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 SCM_SYMBOL (sym_void, "void");
  30 SCM_SYMBOL (sym_float, "float");
  31 SCM_SYMBOL (sym_double, "double");
  32 SCM_SYMBOL (sym_uint8, "uint8");
  33 SCM_SYMBOL (sym_int8, "int8");
  34 SCM_SYMBOL (sym_uint16, "uint16");
  35 SCM_SYMBOL (sym_int16, "int16");
  36 SCM_SYMBOL (sym_uint32, "uint32");
  37 SCM_SYMBOL (sym_int32, "int32");
  38 SCM_SYMBOL (sym_uint64, "uint64");
  39 SCM_SYMBOL (sym_int64, "int64");
  40
  41 static void
  42 foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
  43 {
  44   scm_t_foreign_finalizer finalizer = data;
  45   finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr), void));
  46 }
  47
  48 SCM
  49 scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len,
  50                           scm_t_foreign_finalizer finalizer)
  51 {
  52   SCM ret;
  53   scm_t_bits word0;
  54
  55   word0 = (scm_t_bits)(scm_tc7_foreign | (type<<8)
  56                        | (finalizer ? (1<<16) : 0) | (len<<17));
  57   if (SCM_UNLIKELY ((word0 >> 16) != len))
  58     scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len));
  59
  60   ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2,
  61                                             "foreign"));
  62   SCM_SET_CELL_WORD_0 (ret, word0);
  63   SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)ptr);
  64
  65   if (finalizer)
  66     {
  67       /* Register a finalizer for the newly created instance.  */
  68       GC_finalization_proc prev_finalizer;
  69       GC_PTR prev_finalizer_data;
  70       GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
  71                                       foreign_finalizer_trampoline,
  72                                       finalizer,
  73                                       &prev_finalizer,
  74                                       &prev_finalizer_data);
  75     }
  76
  77   return ret;
  78 }
  79
  80 static void
  81 keepalive (GC_PTR obj, GC_PTR data)
  82 {
  83 }
  84
  85 SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 3, 0,
  86             (SCM foreign, SCM type, SCM offset, SCM len),
  87             "Reference the foreign value wrapped by @var{foreign}.\n\n"
  88             "The value will be referenced according to its type.\n"
  89             "If and only if the type of the foreign value is @code{void},\n"
  90             "this function accepts optional @var{type} and @var{offset}\n"
  91             "arguments, indicating that the pointer wrapped by\n"
  92             "@var{foreign} should be incremented by @var{offset} bytes,\n"
  93             "and treated as a pointer to a value of the given @var{type}.\n"
  94             "@var{offset} defaults to 0.\n\n"
  95             "If @var{type} itself is @code{void}, @var{len} will be used\n"
  96             "to specify the size of the resulting @code{void} pointer.")
  97 #define FUNC_NAME s_scm_foreign_ref
  98 {
  99   scm_t_foreign_type ftype;
 100   scm_t_uint8 *ptr;
 101
 102   SCM_VALIDATE_FOREIGN (1, foreign);
 103   ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
 104
 105   ftype = SCM_FOREIGN_TYPE (foreign);
 106   if (ftype == SCM_FOREIGN_TYPE_VOID)
 107     {
 108       if (SCM_UNBNDP (type))
 109         scm_error_num_args_subr (FUNC_NAME);
 110       ftype = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
 111       if (!SCM_UNBNDP (offset))
 112         ptr += scm_to_ssize_t (offset);
 113     }
 114   else
 115     {
 116       if (!SCM_UNBNDP (type))
 117         scm_error_num_args_subr (FUNC_NAME);
 118     }
 119
 120   /* FIXME: is there a window in which we can see ptr but not foreign? */
 121   switch (ftype)
 122     {
 123     case SCM_FOREIGN_TYPE_FLOAT:
 124       return scm_from_double (*(float*)ptr);
 125     case SCM_FOREIGN_TYPE_DOUBLE:
 126       return scm_from_double (*(double*)ptr);
 127     case SCM_FOREIGN_TYPE_UINT8:
 128       return scm_from_uint8 (*(scm_t_uint8*)ptr);
 129     case SCM_FOREIGN_TYPE_INT8:
 130       return scm_from_int8 (*(scm_t_int8*)ptr);
 131     case SCM_FOREIGN_TYPE_UINT16:
 132       return scm_from_uint16 (*(scm_t_uint16*)ptr);
 133     case SCM_FOREIGN_TYPE_INT16:
 134       return scm_from_int16 (*(scm_t_int16*)ptr);
 135     case SCM_FOREIGN_TYPE_UINT32:
 136       return scm_from_uint32 (*(scm_t_uint32*)ptr);
 137     case SCM_FOREIGN_TYPE_INT32:
 138       return scm_from_int32 (*(scm_t_int32*)ptr);
 139     case SCM_FOREIGN_TYPE_UINT64:
 140       return scm_from_uint64 (*(scm_t_uint64*)ptr);
 141     case SCM_FOREIGN_TYPE_INT64:
 142       return scm_from_int64 (*(scm_t_int64*)ptr);
 143     case SCM_FOREIGN_TYPE_VOID:
 144       /* seems we're making a new pointer, woo */
 145       {
 146         GC_finalization_proc prev_finalizer;
 147         GC_PTR prev_finalizer_data;
 148         SCM ret = scm_take_foreign_pointer
 149           (ftype, ptr, SCM_UNBNDP (len) ? 0 : scm_to_size_t (len), NULL);
 150         /* while the kid is alive, keep the parent alive */
 151         if (SCM_FOREIGN_HAS_FINALIZER (foreign))
 152           GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret), keepalive, foreign,
 153                                           &prev_finalizer, &prev_finalizer_data);
 154         return ret;
 155       }
 156     default:
 157       abort ();
 158     }
 159 }
 160 #undef FUNC_NAME
 161
 162 SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 2, 0,
 163             (SCM foreign, SCM val, SCM type, SCM offset),
 164             "Set the foreign value wrapped by @var{foreign}.\n\n"
 165             "The value will be set according to its type.\n"
 166             "If and only if the type of the foreign value is @code{void},\n"
 167             "this function accepts optional @var{type} and @var{offset}\n"
 168             "arguments, indicating that the pointer wrapped by\n"
 169             "@var{foreign} should be incremented by @var{offset} bytes,\n"
 170             "and treated as a pointer to a value of the given @var{type}.\n"
 171             "@var{offset} defaults to 0.")
 172 #define FUNC_NAME s_scm_foreign_set_x
 173 {
 174   scm_t_foreign_type ftype;
 175   scm_t_uint8 *ptr;
 176
 177   SCM_VALIDATE_FOREIGN (1, foreign);
 178   ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
 179
 180   ftype = SCM_FOREIGN_TYPE (foreign);
 181   if (ftype == SCM_FOREIGN_TYPE_VOID)
 182     {
 183       if (SCM_UNBNDP (type))
 184         scm_error_num_args_subr (FUNC_NAME);
 185       ftype = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
 186       if (!SCM_UNBNDP (offset))
 187         ptr += scm_to_ssize_t (offset);
 188     }
 189   else
 190     {
 191       if (!SCM_UNBNDP (type))
 192         scm_error_num_args_subr (FUNC_NAME);
 193     }
 194
 195   /* FIXME: is there a window in which we can see ptr but not foreign? */
 196   switch (ftype)
 197     {
 198     case SCM_FOREIGN_TYPE_FLOAT:
 199       *(float*)ptr = scm_to_double (val);
 200       break;
 201     case SCM_FOREIGN_TYPE_DOUBLE:
 202       *(double*)ptr = scm_to_double (val);
 203       break;
 204     case SCM_FOREIGN_TYPE_UINT8:
 205       *(scm_t_uint8*)ptr = scm_to_uint8 (val);
 206       break;
 207     case SCM_FOREIGN_TYPE_INT8:
 208       *(scm_t_int8*)ptr = scm_to_int8 (val);
 209       break;
 210     case SCM_FOREIGN_TYPE_UINT16:
 211       *(scm_t_uint16*)ptr = scm_to_uint16 (val);
 212       break;
 213     case SCM_FOREIGN_TYPE_INT16:
 214       *(scm_t_int16*)ptr = scm_to_int16 (val);
 215       break;
 216     case SCM_FOREIGN_TYPE_UINT32:
 217       *(scm_t_uint32*)ptr = scm_to_uint32 (val);
 218       break;
 219     case SCM_FOREIGN_TYPE_INT32:
 220       *(scm_t_int32*)ptr = scm_to_int32 (val);
 221       break;
 222     case SCM_FOREIGN_TYPE_UINT64:
 223       *(scm_t_uint64*)ptr = scm_to_uint64 (val);
 224       break;
 225     case SCM_FOREIGN_TYPE_INT64:
 226       *(scm_t_int64*)ptr = scm_to_int64 (val);
 227       break;
 228     case SCM_FOREIGN_TYPE_VOID:
 229       SCM_VALIDATE_FOREIGN (2, val);
 230       if (SCM_FOREIGN_HAS_FINALIZER (val))
 231         /* setting a pointer inside one foreign value to the pointer of another?
 232            that is asking for trouble */
 233         scm_wrong_type_arg_msg (FUNC_NAME, 2, val,
 234                                 "foreign value without finalizer");
 235       *(void**)ptr = SCM_FOREIGN_POINTER (val, void*);
 236       break;
 237     default:
 238       abort ();
 239     }
 240
 241   return SCM_UNSPECIFIED;
 242 }
 243 #undef FUNC_NAME
 244
 245 void
 246 scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate)
 247 {
 248   scm_puts ("#<foreign ", port);
 249   switch (SCM_FOREIGN_TYPE (foreign))
 250     {
 251     case SCM_FOREIGN_TYPE_FLOAT:
 252       scm_puts ("float ", port);
 253       scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
 254                                     SCM_UNDEFINED),
 255                    port);
 256       break;
 257     case SCM_FOREIGN_TYPE_DOUBLE:
 258       scm_puts ("double ", port);
 259       scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
 260                                     SCM_UNDEFINED),
 261                    port);
 262       break;
 263     case SCM_FOREIGN_TYPE_UINT8:
 264       scm_puts ("uint8 ", port);
 265       scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
 266                                     SCM_UNDEFINED),
 267                    port);
 268       break;
 269     case SCM_FOREIGN_TYPE_INT8:
 270       scm_puts ("int8 ", port);
 271       scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
 272                                     SCM_UNDEFINED),
 273                    port);
 274       break;
 275     case SCM_FOREIGN_TYPE_UINT16:
 276       scm_puts ("uint16 ", port);
 277       scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
 278                                     SCM_UNDEFINED),
 279                    port);
 280       break;
 281     case SCM_FOREIGN_TYPE_INT16:
 282       scm_puts ("int16 ", port);
 283       scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
 284                                     SCM_UNDEFINED),
 285                    port);
 286       break;
 287     case SCM_FOREIGN_TYPE_UINT32:
 288       scm_puts ("uint32 ", port);
 289       scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
 290                                     SCM_UNDEFINED),
 291                    port);
 292       break;
 293     case SCM_FOREIGN_TYPE_INT32:
 294       scm_puts ("int32 ", port);
 295       scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
 296                                     SCM_UNDEFINED),
 297                    port);
 298       break;
 299     case SCM_FOREIGN_TYPE_UINT64:
 300       scm_puts ("uint64 ", port);
 301       scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
 302                                     SCM_UNDEFINED),
 303                    port);
 304       break;
 305     case SCM_FOREIGN_TYPE_INT64:
 306       scm_puts ("int64 ", port);
 307       scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
 308                                     SCM_UNDEFINED),
 309                    port);
 310       break;
 311     case SCM_FOREIGN_TYPE_VOID:
 312       scm_puts ("pointer 0x", port);
 313       scm_uintprint ((scm_t_bits)SCM_FOREIGN_POINTER (foreign, void), 16, port);
 314       break;
 315     default:
 316       abort ();
 317     }
 318   scm_putc ('>', port);
 319 }
 320
 321 \f
 322
 323 static void
 324 scm_init_foreign (void)
 325 {
 326 #ifndef SCM_MAGIC_SNARFER
 327 #include "libguile/foreign.x"
 328 #endif
 329   scm_define (sym_void, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID));
 330   scm_define (sym_float, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT));
 331   scm_define (sym_double, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE));
 332   scm_define (sym_uint8, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8));
 333   scm_define (sym_int8, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8));
 334   scm_define (sym_uint16, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16));
 335   scm_define (sym_int16, scm_from_uint8 (SCM_FOREIGN_TYPE_INT16));
 336   scm_define (sym_uint32, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32));
 337   scm_define (sym_int32, scm_from_uint8 (SCM_FOREIGN_TYPE_INT32));
 338   scm_define (sym_uint64, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64));
 339   scm_define (sym_int64, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64));
 340 }
 341
 342 void
 343 scm_register_foreign (void)
 344 {
 345   scm_c_register_extension ("libguile", "scm_init_foreign",
 346                             (scm_t_extension_init_func)scm_init_foreign,
 347                             NULL);
 348 }
 349
 350 /*
 351   Local Variables:
 352   c-file-style: "gnu"
 353   End:
 354 */