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, scm_t_bits val0)
  74 {
  75   return scm_make_foreign_object_n (type, 1, &val0);
  76 }
  77
  78 SCM
  79 scm_make_foreign_object_2 (SCM type, scm_t_bits val0, scm_t_bits val1)
  80 {
  81   scm_t_bits vals[2] = { val0, val1 };
  82
  83   return scm_make_foreign_object_n (type, 2, vals);
  84 }
  85
  86 SCM
  87 scm_make_foreign_object_3 (SCM type, scm_t_bits val0, scm_t_bits val1,
  88                            scm_t_bits val2)
  89 {
  90   scm_t_bits vals[3] = { val0, val1, val2 };
  91
  92   return scm_make_foreign_object_n (type, 3, vals);
  93 }
  94
  95 SCM
  96 scm_make_foreign_object_n (SCM type, size_t n, scm_t_bits vals[])
  97 #define FUNC_NAME "make-foreign-object"
  98 {
  99   SCM obj;
 100   SCM layout;
 101   size_t i;
 102   const char *layout_chars;
 103
 104   SCM_VALIDATE_VTABLE (SCM_ARG1, type);
 105
 106   layout = SCM_VTABLE_LAYOUT (type);
 107
 108   if (scm_i_symbol_length (layout) / 2 < n)
 109     scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
 110
 111   layout_chars = scm_i_symbol_chars (layout);
 112   for (i = 0; i < n; i++)
 113     if (layout_chars[i * 2] != 'u')
 114       scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
 115
 116   obj = scm_c_make_structv (type, 0, 0, NULL);
 117
 118   for (i = 0; i < n; i++)
 119     SCM_STRUCT_DATA_SET (obj, i, vals[i]);
 120
 121   return obj;
 122 }
 123 #undef FUNC_NAME
 124
 125 scm_t_bits
 126 scm_foreign_object_ref (SCM obj, size_t n)
 127 #define FUNC_NAME "foreign-object-ref"
 128 {
 129   SCM layout;
 130
 131   SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
 132
 133   layout = SCM_STRUCT_LAYOUT (obj);
 134   if (scm_i_symbol_length (layout) / 2 < n)
 135     scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
 136
 137   if (scm_i_symbol_ref (layout, n * 2) != 'u')
 138     scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
 139
 140   return SCM_STRUCT_DATA_REF (obj, n);
 141 }
 142 #undef FUNC_NAME
 143
 144 void
 145 scm_foreign_object_set_x (SCM obj, size_t n, scm_t_bits val)
 146 #define FUNC_NAME "foreign-object-set!"
 147 {
 148   SCM layout;
 149
 150   SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
 151
 152   layout = SCM_STRUCT_LAYOUT (obj);
 153   if (scm_i_symbol_length (layout) / 2 < n)
 154     scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
 155
 156   if (scm_i_symbol_ref (layout, n * 2) != 'u')
 157     scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
 158
 159   SCM_STRUCT_DATA_SET (obj, n, val);
 160 }
 161 #undef FUNC_NAME
 162
 163 static void
 164 invoke_finalizer (void *obj, void *data)
 165 {
 166   scm_call_1 (PTR2SCM (data), PTR2SCM (obj));
 167 }
 168
 169 static SCM
 170 sys_add_finalizer_x (SCM obj, SCM finalizer)
 171 #define FUNC_NAME "%add-finalizer!"
 172 {
 173   SCM_VALIDATE_PROC (SCM_ARG2, finalizer);
 174
 175   scm_i_add_finalizer (SCM2PTR (obj), invoke_finalizer, SCM2PTR (finalizer));
 176
 177   return SCM_UNSPECIFIED;
 178 }
 179 #undef FUNC_NAME
 180
 181 static void
 182 scm_init_foreign_object (void)
 183 {
 184   scm_c_define_gsubr ("%add-finalizer!", 2, 0, 0,
 185                       (scm_t_subr) sys_add_finalizer_x);
 186 }
 187
 188 void
 189 scm_register_foreign_object (void)
 190 {
 191   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
 192                             "scm_init_foreign_object",
 193                             (scm_t_extension_init_func)scm_init_foreign_object,
 194                             NULL);
 195 }