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