libguile/foreign-object.c

   1 /* Copyright (C) 2014 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
  20 \f
  21 #ifdef HAVE_CONFIG_H
  22 #  include <config.h>
  23 #endif
  24
  25 #include "libguile/_scm.h"
  26 #include "libguile/goops.h"
  27 #include "libguile/foreign-object.h"
  28
  29
  30 \f
  31
  32 static SCM make_fobj_type_var;
  33
  34 static void
  35 init_make_fobj_type_var (void)
  36 {
  37   make_fobj_type_var = scm_c_private_lookup ("system foreign-object",
  38                                              "make-foreign-object-type");
  39 }
  40
  41 SCM
  42 scm_make_foreign_object_type (SCM name, SCM slot_names,
  43                               scm_t_struct_finalize finalizer)
  44 {
  45   SCM type;
  46
  47   static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
  48   scm_i_pthread_once (&once, init_make_fobj_type_var);
  49
  50   type = scm_call_2 (scm_variable_ref (make_fobj_type_var), name, slot_names);
  51
  52   if (finalizer)
  53     SCM_SET_VTABLE_INSTANCE_FINALIZER (type, finalizer);
  54
  55   return type;
  56 }
  57
  58 void
  59 scm_assert_foreign_object_type (SCM type, SCM val)
  60 {
  61   if (!SCM_IS_A_P (val, type))
  62     scm_error (scm_arg_type_key, NULL, "Wrong type (expecting ~A): ~S",
  63                scm_list_2 (scm_class_name (type), val), scm_list_1 (val));
  64 }
  65
  66 SCM
  67 scm_make_foreign_object_0 (SCM type)
  68 {
  69   return scm_make_foreign_object_n (type, 0, NULL);
  70 }
  71
  72 SCM
  73 scm_make_foreign_object_1 (SCM type, void *val0)
  74 {
  75   return scm_make_foreign_object_n (type, 1, &val0);
  76 }
  77
  78 SCM
  79 scm_make_foreign_object_2 (SCM type, void *val0, void *val1)
  80 {
  81   void *vals[2];
  82
  83   vals[0] = val0;
  84   vals[1] = val1;
  85
  86   return scm_make_foreign_object_n (type, 2, vals);
  87 }
  88
  89 SCM
  90 scm_make_foreign_object_3 (SCM type, void *val0, void *val1, void *val2)
  91 {
  92   void *vals[3];
  93
  94   vals[0] = val0;
  95   vals[1] = val1;
  96   vals[2] = val2;
  97
  98   return scm_make_foreign_object_n (type, 3, vals);
  99 }
 100
 101 SCM
 102 scm_make_foreign_object_n (SCM type, size_t n, void *vals[])
 103 #define FUNC_NAME "make-foreign-object"
 104 {
 105   SCM obj;
 106   SCM layout;
 107   size_t i;
 108   const char *layout_chars;
 109
 110   SCM_VALIDATE_VTABLE (SCM_ARG1, type);
 111
 112   layout = SCM_VTABLE_LAYOUT (type);
 113
 114   if (scm_i_symbol_length (layout) / 2 < n)
 115     scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
 116
 117   layout_chars = scm_i_symbol_chars (layout);
 118   for (i = 0; i < n; i++)
 119     if (layout_chars[i * 2] != 'u')
 120       scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
 121
 122   obj = scm_c_make_structv (type, 0, 0, NULL);
 123
 124   for (i = 0; i < n; i++)
 125     SCM_STRUCT_DATA_SET (obj, i, (scm_t_bits) vals[i]);
 126
 127   return obj;
 128 }
 129 #undef FUNC_NAME
 130
 131 scm_t_bits
 132 scm_foreign_object_unsigned_ref (SCM obj, size_t n)
 133 #define FUNC_NAME "foreign-object-ref"
 134 {
 135   SCM layout;
 136
 137   SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
 138
 139   layout = SCM_STRUCT_LAYOUT (obj);
 140   if (scm_i_symbol_length (layout) / 2 < n)
 141     scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
 142
 143   if (scm_i_symbol_ref (layout, n * 2) != 'u')
 144     scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
 145
 146   return SCM_STRUCT_DATA_REF (obj, n);
 147 }
 148 #undef FUNC_NAME
 149
 150 void
 151 scm_foreign_object_unsigned_set_x (SCM obj, size_t n, scm_t_bits val)
 152 #define FUNC_NAME "foreign-object-set!"
 153 {
 154   SCM layout;
 155
 156   SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
 157
 158   layout = SCM_STRUCT_LAYOUT (obj);
 159   if (scm_i_symbol_length (layout) / 2 < n)
 160     scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
 161
 162   if (scm_i_symbol_ref (layout, n * 2) != 'u')
 163     scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
 164
 165   SCM_STRUCT_DATA_SET (obj, n, val);
 166 }
 167 #undef FUNC_NAME
 168
 169 scm_t_signed_bits
 170 scm_foreign_object_signed_ref (SCM obj, size_t n)
 171 {
 172   scm_t_bits bits = scm_foreign_object_unsigned_ref (obj, n);
 173   return (scm_t_signed_bits) bits;
 174 }
 175
 176 void
 177 scm_foreign_object_signed_set_x (SCM obj, size_t n, scm_t_signed_bits val)
 178 {
 179   scm_t_bits bits = (scm_t_bits) val;
 180   scm_foreign_object_unsigned_set_x (obj, n, bits);
 181 }
 182
 183 void*
 184 scm_foreign_object_ref (SCM obj, size_t n)
 185 {
 186   scm_t_bits bits = scm_foreign_object_unsigned_ref (obj, n);
 187   return (void *) bits;
 188 }
 189
 190 void
 191 scm_foreign_object_set_x (SCM obj, size_t n, void *val)
 192 {
 193   scm_t_bits bits = (scm_t_bits) val;
 194   scm_foreign_object_unsigned_set_x (obj, n, bits);
 195 }
 196
 197 static void
 198 invoke_finalizer (void *obj, void *data)
 199 {
 200   scm_call_1 (PTR2SCM (data), PTR2SCM (obj));
 201 }
 202
 203 static SCM
 204 sys_add_finalizer_x (SCM obj, SCM finalizer)
 205 #define FUNC_NAME "%add-finalizer!"
 206 {
 207   SCM_VALIDATE_PROC (SCM_ARG2, finalizer);
 208
 209   scm_i_add_finalizer (SCM2PTR (obj), invoke_finalizer, SCM2PTR (finalizer));
 210
 211   return SCM_UNSPECIFIED;
 212 }
 213 #undef FUNC_NAME
 214
 215 static void
 216 scm_init_foreign_object (void)
 217 {
 218   scm_c_define_gsubr ("%add-finalizer!", 2, 0, 0,
 219                       (scm_t_subr) sys_add_finalizer_x);
 220 }
 221
 222 void
 223 scm_register_foreign_object (void)
 224 {
 225   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
 226                             "scm_init_foreign_object",
 227                             (scm_t_extension_init_func)scm_init_foreign_object,
 228                             NULL);
 229 }