libguile/foreign.c

   1 /* Copyright (C) 2010  Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 #if HAVE_CONFIG_H
  20 #  include <config.h>
  21 #endif
  22
  23 #include <string.h>
  24 #include "libguile/_scm.h"
  25 #include "libguile/foreign.h"
  26
  27 \f
  28
  29 static size_t
  30 sizeof_type (scm_t_foreign_type type)
  31 {
  32   switch (type)
  33     {
  34     case SCM_FOREIGN_TYPE_VOID:    abort ();
  35     case SCM_FOREIGN_TYPE_FLOAT:   return sizeof(float);
  36     case SCM_FOREIGN_TYPE_DOUBLE:  return sizeof(double);
  37     case SCM_FOREIGN_TYPE_UINT8:   return sizeof(scm_t_uint8);
  38     case SCM_FOREIGN_TYPE_INT8:    return sizeof(scm_t_int8);
  39     case SCM_FOREIGN_TYPE_UINT16:  return sizeof(scm_t_uint16);
  40     case SCM_FOREIGN_TYPE_INT16:   return sizeof(scm_t_int16);
  41     case SCM_FOREIGN_TYPE_UINT32:  return sizeof(scm_t_uint32);
  42     case SCM_FOREIGN_TYPE_INT32:   return sizeof(scm_t_int32);
  43     case SCM_FOREIGN_TYPE_UINT64:  return sizeof(scm_t_uint64);
  44     case SCM_FOREIGN_TYPE_INT64:   return sizeof(scm_t_int64);
  45     case SCM_FOREIGN_TYPE_STRUCT:  abort ();
  46     case SCM_FOREIGN_TYPE_POINTER: return sizeof(void*);
  47     default:                       abort ();
  48     }
  49 }
  50
  51
  52 static void
  53 foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
  54 {
  55   scm_t_foreign_finalizer finalizer = data;
  56   finalizer (SCM_FOREIGN_OBJECT (PTR2SCM (ptr), void*));
  57 }
  58
  59 SCM
  60 scm_c_from_foreign (scm_t_foreign_type type, void *val, size_t size,
  61                     scm_t_foreign_finalizer finalizer)
  62 {
  63   SCM ret;
  64   if (!size)
  65     size = sizeof_type (type);
  66
  67   ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2 + size,
  68                                             "foreign"));
  69   SCM_SET_CELL_WORD_0 (ret, (scm_t_bits)(scm_tc7_foreign | (type<<8)));
  70
  71   /* set SCM_FOREIGN_OBJECT to point to the third word of the object, which will
  72      be 8-byte aligned. Then copy *val into that space. */
  73   SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
  74   memcpy (SCM_FOREIGN_OBJECT (ret, void), val, size);
  75
  76   if (finalizer)
  77     {
  78       /* Register a finalizer for the newly created instance.  */
  79       GC_finalization_proc prev_finalizer;
  80       GC_PTR prev_finalizer_data;
  81       GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
  82                                       foreign_finalizer_trampoline,
  83                                       finalizer,
  84                                       &prev_finalizer,
  85                                       &prev_finalizer_data);
  86     }
  87
  88   return ret;
  89 }
  90
  91 SCM
  92 scm_c_take_foreign (scm_t_foreign_type type, void *val,
  93                     scm_t_foreign_finalizer finalizer)
  94 {
  95   SCM ret;
  96
  97   ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2,
  98                                             "foreign"));
  99   SCM_SET_CELL_WORD_0 (ret, (scm_t_bits)(scm_tc7_foreign | (type<<8)));
 100   /* Set SCM_FOREIGN_OBJECT to the given pointer. */
 101   SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)val);
 102
 103   if (finalizer)
 104     {
 105       /* Register a finalizer for the newly created instance.  */
 106       GC_finalization_proc prev_finalizer;
 107       GC_PTR prev_finalizer_data;
 108       GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
 109                                       foreign_finalizer_trampoline,
 110                                       finalizer,
 111                                       &prev_finalizer,
 112                                       &prev_finalizer_data);
 113     }
 114
 115   return ret;
 116 }
 117
 118 SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0,
 119             (SCM foreign),
 120             "Reference the foreign value wrapped by @var{foreign}.\n\n"
 121             "Note that only \"simple\" types may be referenced by this\n"
 122             "function. See @code{foreign-struct-ref} or @code{foreign-pointer-ref}\n"
 123             "for structs or pointers, respectively.")
 124 #define FUNC_NAME s_scm_foreign_ref
 125 {
 126   SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign);
 127
 128   switch (SCM_FOREIGN_TYPE (foreign))
 129     {
 130     case SCM_FOREIGN_TYPE_FLOAT:
 131       return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, float));
 132     case SCM_FOREIGN_TYPE_DOUBLE:
 133       return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, double));
 134     case SCM_FOREIGN_TYPE_UINT8:
 135       return scm_from_uint8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint8));
 136     case SCM_FOREIGN_TYPE_INT8:
 137       return scm_from_int8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int8));
 138     case SCM_FOREIGN_TYPE_UINT16:
 139       return scm_from_uint16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint16));
 140     case SCM_FOREIGN_TYPE_INT16:
 141       return scm_from_int16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int16));
 142     case SCM_FOREIGN_TYPE_UINT32:
 143       return scm_from_uint32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint32));
 144     case SCM_FOREIGN_TYPE_INT32:
 145       return scm_from_int32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int32));
 146     case SCM_FOREIGN_TYPE_UINT64:
 147       return scm_from_uint64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint64));
 148     case SCM_FOREIGN_TYPE_INT64:
 149       return scm_from_int64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int64));
 150     case SCM_FOREIGN_TYPE_VOID:
 151     case SCM_FOREIGN_TYPE_STRUCT:
 152     case SCM_FOREIGN_TYPE_POINTER:
 153     default:
 154       /* other cases should have been caught by the FOREIGN_SIMPLE check */
 155       abort ();
 156     }
 157 }
 158 #undef FUNC_NAME
 159
 160 SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 0, 0,
 161             (SCM foreign, SCM val),
 162             "Set the foreign value wrapped by @var{foreign}.\n\n"
 163             "Note that only \"simple\" types may be set by this function.\n"
 164             "See @code{foreign-struct-ref} or @code{foreign-pointer-ref} for\n"
 165             "structs or pointers, respectively.")
 166 #define FUNC_NAME s_scm_foreign_set_x
 167 {
 168   SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign);
 169
 170   switch (SCM_FOREIGN_TYPE (foreign))
 171     {
 172     case SCM_FOREIGN_TYPE_FLOAT:
 173       SCM_FOREIGN_OBJECT_SET (foreign, float, scm_to_double (val));
 174       break;
 175     case SCM_FOREIGN_TYPE_DOUBLE:
 176       SCM_FOREIGN_OBJECT_SET (foreign, double, scm_to_double (val));
 177       break;
 178     case SCM_FOREIGN_TYPE_UINT8:
 179       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint8, scm_to_uint8 (val));
 180       break;
 181     case SCM_FOREIGN_TYPE_INT8:
 182       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int8, scm_to_int8 (val));
 183       break;
 184     case SCM_FOREIGN_TYPE_UINT16:
 185       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint16, scm_to_uint16 (val));
 186       break;
 187     case SCM_FOREIGN_TYPE_INT16:
 188       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int16, scm_to_int16 (val));
 189       break;
 190     case SCM_FOREIGN_TYPE_UINT32:
 191       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint32, scm_to_uint32 (val));
 192       break;
 193     case SCM_FOREIGN_TYPE_INT32:
 194       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int32, scm_to_int32 (val));
 195       break;
 196     case SCM_FOREIGN_TYPE_UINT64:
 197       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint64, scm_to_uint64 (val));
 198       break;
 199     case SCM_FOREIGN_TYPE_INT64:
 200       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int64, scm_to_int64 (val));
 201       break;
 202     case SCM_FOREIGN_TYPE_VOID:
 203     case SCM_FOREIGN_TYPE_STRUCT:
 204     case SCM_FOREIGN_TYPE_POINTER:
 205     default:
 206       /* other cases should have been caught by the FOREIGN_SIMPLE check */
 207       abort ();
 208     }
 209   return SCM_UNSPECIFIED;
 210 }
 211 #undef FUNC_NAME
 212
 213 void
 214 scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate)
 215 {
 216   scm_puts ("#<foreign ", port);
 217   switch (SCM_FOREIGN_TYPE (foreign))
 218     {
 219     case SCM_FOREIGN_TYPE_VOID:
 220       abort ();
 221     case SCM_FOREIGN_TYPE_FLOAT:
 222       scm_puts ("float ", port);
 223       scm_display (scm_foreign_ref (foreign), port);
 224       break;
 225     case SCM_FOREIGN_TYPE_DOUBLE:
 226       scm_puts ("double ", port);
 227       scm_display (scm_foreign_ref (foreign), port);
 228       break;
 229     case SCM_FOREIGN_TYPE_UINT8:
 230       scm_puts ("uint8 ", port);
 231       scm_display (scm_foreign_ref (foreign), port);
 232       break;
 233     case SCM_FOREIGN_TYPE_INT8:
 234       scm_puts ("int8 ", port);
 235       scm_display (scm_foreign_ref (foreign), port);
 236       break;
 237     case SCM_FOREIGN_TYPE_UINT16:
 238       scm_puts ("uint16 ", port);
 239       scm_display (scm_foreign_ref (foreign), port);
 240       break;
 241     case SCM_FOREIGN_TYPE_INT16:
 242       scm_puts ("int16 ", port);
 243       scm_display (scm_foreign_ref (foreign), port);
 244       break;
 245     case SCM_FOREIGN_TYPE_UINT32:
 246       scm_puts ("uint32 ", port);
 247       scm_display (scm_foreign_ref (foreign), port);
 248       break;
 249     case SCM_FOREIGN_TYPE_INT32:
 250       scm_puts ("int32 ", port);
 251       scm_display (scm_foreign_ref (foreign), port);
 252       break;
 253     case SCM_FOREIGN_TYPE_UINT64:
 254       scm_puts ("uint64 ", port);
 255       scm_display (scm_foreign_ref (foreign), port);
 256       break;
 257     case SCM_FOREIGN_TYPE_INT64:
 258       scm_puts ("int64 ", port);
 259       scm_display (scm_foreign_ref (foreign), port);
 260       break;
 261     case SCM_FOREIGN_TYPE_STRUCT:
 262       scm_puts ("struct at 0x", port);
 263       scm_uintprint (SCM_CELL_WORD_1 (foreign), 16, port);
 264       break;
 265     case SCM_FOREIGN_TYPE_POINTER:
 266       scm_puts ("pointer 0x", port);
 267       scm_uintprint (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_bits), 16, port);
 268       break;
 269     default:
 270       abort ();
 271     }
 272   scm_putc ('>', port);
 273 }
 274
 275 \f
 276
 277 void
 278 scm_init_foreign (void)
 279 {
 280 #ifndef SCM_MAGIC_SNARFER
 281 #include "libguile/foreign.x"
 282 #endif
 283 }
 284
 285 /*
 286   Local Variables:
 287   c-file-style: "gnu"
 288   End:
 289 */