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 "_scm.h"
  25 #include "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   void *ret;
  64   if (!size)
  65     size = sizeof_type (type);
  66
  67   ret = scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2 + size, "foreign");
  68   SCM_SET_CELL_WORD_0 (PTR2SCM (ret), scm_tc7_foreign | (type<<8));
  69
  70   /* set SCM_FOREIGN_OBJECT to point to the third word of the object, which will
  71      be 8-byte aligned. Then copy *val into that space. */
  72   SCM_SET_CELL_WORD_1 (PTR2SCM (ret),
  73                        (scm_t_bits)SCM_CELL_OBJECT_LOC (PTR2SCM (ret), 2));
  74   memcpy (SCM_FOREIGN_OBJECT (PTR2SCM (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 (ret,
  82                                       foreign_finalizer_trampoline,
  83                                       finalizer,
  84                                       &prev_finalizer,
  85                                       &prev_finalizer_data);
  86     }
  87
  88   return PTR2SCM (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   void *ret;
  96
  97   ret = scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2, "foreign");
  98   SCM_SET_CELL_WORD_0 (PTR2SCM (ret), scm_tc7_foreign | (type<<8));
  99   /* Set SCM_FOREIGN_OBJECT to the given pointer. */
 100   SCM_SET_CELL_WORD_1 (PTR2SCM (ret), (scm_t_bits)val);
 101
 102   if (finalizer)
 103     {
 104       /* Register a finalizer for the newly created instance.  */
 105       GC_finalization_proc prev_finalizer;
 106       GC_PTR prev_finalizer_data;
 107       GC_REGISTER_FINALIZER_NO_ORDER (ret,
 108                                       foreign_finalizer_trampoline,
 109                                       finalizer,
 110                                       &prev_finalizer,
 111                                       &prev_finalizer_data);
 112     }
 113
 114   return PTR2SCM (ret);
 115 }
 116
 117 SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0,
 118             (SCM foreign),
 119             "Reference the foreign value wrapped by @var{foreign}.\n\n"
 120             "Note that only \"simple\" types may be referenced by this\n"
 121             "function. See @code{foreign-struct-ref} or @code{foreign-pointer-ref}\n"
 122             "for structs or pointers, respectively.")
 123 #define FUNC_NAME s_scm_foreign_ref
 124 {
 125   SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign);
 126
 127   switch (SCM_FOREIGN_TYPE (foreign))
 128     {
 129     case SCM_FOREIGN_TYPE_FLOAT:
 130       return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, float));
 131     case SCM_FOREIGN_TYPE_DOUBLE:
 132       return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, double));
 133     case SCM_FOREIGN_TYPE_UINT8:
 134       return scm_from_uint8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint8));
 135     case SCM_FOREIGN_TYPE_INT8:
 136       return scm_from_int8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int8));
 137     case SCM_FOREIGN_TYPE_UINT16:
 138       return scm_from_uint16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint16));
 139     case SCM_FOREIGN_TYPE_INT16:
 140       return scm_from_int16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int16));
 141     case SCM_FOREIGN_TYPE_UINT32:
 142       return scm_from_uint32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint32));
 143     case SCM_FOREIGN_TYPE_INT32:
 144       return scm_from_int32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int32));
 145     case SCM_FOREIGN_TYPE_UINT64:
 146       return scm_from_uint64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint64));
 147     case SCM_FOREIGN_TYPE_INT64:
 148       return scm_from_int64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int64));
 149     case SCM_FOREIGN_TYPE_VOID:
 150     case SCM_FOREIGN_TYPE_STRUCT:
 151     case SCM_FOREIGN_TYPE_POINTER:
 152     default:
 153       /* other cases should have been caught by the FOREIGN_SIMPLE check */
 154       abort ();
 155     }
 156 }
 157 #undef FUNC_NAME
 158
 159 SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 0, 0,
 160             (SCM foreign, SCM val),
 161             "Set the foreign value wrapped by @var{foreign}.\n\n"
 162             "Note that only \"simple\" types may be set by this function.\n"
 163             "See @code{foreign-struct-ref} or @code{foreign-pointer-ref} for\n"
 164             "structs or pointers, respectively.")
 165 #define FUNC_NAME s_scm_foreign_set_x
 166 {
 167   SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign);
 168
 169   switch (SCM_FOREIGN_TYPE (foreign))
 170     {
 171     case SCM_FOREIGN_TYPE_FLOAT:
 172       SCM_FOREIGN_OBJECT_SET (foreign, float, scm_to_double (val));
 173       break;
 174     case SCM_FOREIGN_TYPE_DOUBLE:
 175       SCM_FOREIGN_OBJECT_SET (foreign, double, scm_to_double (val));
 176       break;
 177     case SCM_FOREIGN_TYPE_UINT8:
 178       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint8, scm_to_uint8 (val));
 179       break;
 180     case SCM_FOREIGN_TYPE_INT8:
 181       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int8, scm_to_int8 (val));
 182       break;
 183     case SCM_FOREIGN_TYPE_UINT16:
 184       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint16, scm_to_uint16 (val));
 185       break;
 186     case SCM_FOREIGN_TYPE_INT16:
 187       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int16, scm_to_int16 (val));
 188       break;
 189     case SCM_FOREIGN_TYPE_UINT32:
 190       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint32, scm_to_uint32 (val));
 191       break;
 192     case SCM_FOREIGN_TYPE_INT32:
 193       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int32, scm_to_int32 (val));
 194       break;
 195     case SCM_FOREIGN_TYPE_UINT64:
 196       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint64, scm_to_uint64 (val));
 197       break;
 198     case SCM_FOREIGN_TYPE_INT64:
 199       SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int64, scm_to_int64 (val));
 200       break;
 201     case SCM_FOREIGN_TYPE_VOID:
 202     case SCM_FOREIGN_TYPE_STRUCT:
 203     case SCM_FOREIGN_TYPE_POINTER:
 204     default:
 205       /* other cases should have been caught by the FOREIGN_SIMPLE check */
 206       abort ();
 207     }
 208   return SCM_UNSPECIFIED;
 209 }
 210 #undef FUNC_NAME
 211
 212 void
 213 scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate)
 214 {
 215   scm_puts ("#<foreign ", port);
 216   switch (SCM_FOREIGN_TYPE (foreign))
 217     {
 218     case SCM_FOREIGN_TYPE_VOID:
 219       abort ();
 220     case SCM_FOREIGN_TYPE_FLOAT:
 221       scm_puts ("float ", port);
 222       scm_display (scm_foreign_ref (foreign), port);
 223       break;
 224     case SCM_FOREIGN_TYPE_DOUBLE:
 225       scm_puts ("double ", port);
 226       scm_display (scm_foreign_ref (foreign), port);
 227       break;
 228     case SCM_FOREIGN_TYPE_UINT8:
 229       scm_puts ("uint8 ", port);
 230       scm_display (scm_foreign_ref (foreign), port);
 231       break;
 232     case SCM_FOREIGN_TYPE_INT8:
 233       scm_puts ("int8 ", port);
 234       scm_display (scm_foreign_ref (foreign), port);
 235       break;
 236     case SCM_FOREIGN_TYPE_UINT16:
 237       scm_puts ("uint16 ", port);
 238       scm_display (scm_foreign_ref (foreign), port);
 239       break;
 240     case SCM_FOREIGN_TYPE_INT16:
 241       scm_puts ("int16 ", port);
 242       scm_display (scm_foreign_ref (foreign), port);
 243       break;
 244     case SCM_FOREIGN_TYPE_UINT32:
 245       scm_puts ("uint32 ", port);
 246       scm_display (scm_foreign_ref (foreign), port);
 247       break;
 248     case SCM_FOREIGN_TYPE_INT32:
 249       scm_puts ("int32 ", port);
 250       scm_display (scm_foreign_ref (foreign), port);
 251       break;
 252     case SCM_FOREIGN_TYPE_UINT64:
 253       scm_puts ("uint64 ", port);
 254       scm_display (scm_foreign_ref (foreign), port);
 255       break;
 256     case SCM_FOREIGN_TYPE_INT64:
 257       scm_puts ("int64 ", port);
 258       scm_display (scm_foreign_ref (foreign), port);
 259       break;
 260     case SCM_FOREIGN_TYPE_STRUCT:
 261       scm_puts ("struct at 0x", port);
 262       scm_uintprint (SCM_CELL_WORD_1 (foreign), 16, port);
 263       break;
 264     case SCM_FOREIGN_TYPE_POINTER:
 265       scm_puts ("pointer 0x", port);
 266       scm_uintprint (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_bits), 16, port);
 267       break;
 268     default:
 269       abort ();
 270     }
 271   scm_putc ('>', port);
 272 }
 273
 274 \f
 275
 276 void
 277 scm_init_foreign (void)
 278 {
 279 #ifndef SCM_MAGIC_SNARFER
 280 #include "libguile/foreign.x"
 281 #endif
 282 }
 283
 284 /*
 285   Local Variables:
 286   c-file-style: "gnu"
 287   End:
 288 */