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