1 /* Copyright (C) 2014 Free Software Foundation, Inc.
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.
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.
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
25 #include "libguile/_scm.h"
26 #include "libguile/goops.h"
27 #include "libguile/foreign-object.h"
32 static SCM make_fobj_type_var
;
35 init_make_fobj_type_var (void)
37 make_fobj_type_var
= scm_c_private_lookup ("system foreign-object",
38 "make-foreign-object-type");
42 scm_make_foreign_object_type (SCM name
, SCM slot_names
,
43 scm_t_struct_finalize finalizer
)
47 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
48 scm_i_pthread_once (&once
, init_make_fobj_type_var
);
50 type
= scm_call_2 (scm_variable_ref (make_fobj_type_var
), name
, slot_names
);
53 SCM_SET_VTABLE_INSTANCE_FINALIZER (type
, finalizer
);
59 scm_assert_foreign_object_type (SCM type
, SCM val
)
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
));
67 scm_make_foreign_object_0 (SCM type
)
69 return scm_make_foreign_object_n (type
, 0, NULL
);
73 scm_make_foreign_object_1 (SCM type
, void *val0
)
75 return scm_make_foreign_object_n (type
, 1, &val0
);
79 scm_make_foreign_object_2 (SCM type
, void *val0
, void *val1
)
86 return scm_make_foreign_object_n (type
, 2, vals
);
90 scm_make_foreign_object_3 (SCM type
, void *val0
, void *val1
, void *val2
)
98 return scm_make_foreign_object_n (type
, 3, vals
);
102 scm_make_foreign_object_n (SCM type
, size_t n
, void *vals
[])
103 #define FUNC_NAME "make-foreign-object"
108 const char *layout_chars
;
110 SCM_VALIDATE_VTABLE (SCM_ARG1
, type
);
112 layout
= SCM_VTABLE_LAYOUT (type
);
114 if (scm_i_symbol_length (layout
) / 2 < n
)
115 scm_out_of_range (FUNC_NAME
, scm_from_size_t (n
));
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");
122 obj
= scm_c_make_structv (type
, 0, 0, NULL
);
124 for (i
= 0; i
< n
; i
++)
125 SCM_STRUCT_DATA_SET (obj
, i
, (scm_t_bits
) vals
[i
]);
132 scm_foreign_object_unsigned_ref (SCM obj
, size_t n
)
133 #define FUNC_NAME "foreign-object-ref"
137 SCM_VALIDATE_STRUCT (SCM_ARG1
, obj
);
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
));
143 if (scm_i_symbol_ref (layout
, n
* 2) != 'u')
144 scm_wrong_type_arg_msg (FUNC_NAME
, 0, layout
, "'u' field");
146 return SCM_STRUCT_DATA_REF (obj
, n
);
151 scm_foreign_object_unsigned_set_x (SCM obj
, size_t n
, scm_t_bits val
)
152 #define FUNC_NAME "foreign-object-set!"
156 SCM_VALIDATE_STRUCT (SCM_ARG1
, obj
);
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
));
162 if (scm_i_symbol_ref (layout
, n
* 2) != 'u')
163 scm_wrong_type_arg_msg (FUNC_NAME
, 0, layout
, "'u' field");
165 SCM_STRUCT_DATA_SET (obj
, n
, val
);
170 scm_foreign_object_signed_ref (SCM obj
, size_t n
)
172 scm_t_bits bits
= scm_foreign_object_unsigned_ref (obj
, n
);
173 return (scm_t_signed_bits
) bits
;
177 scm_foreign_object_signed_set_x (SCM obj
, size_t n
, scm_t_signed_bits val
)
179 scm_t_bits bits
= (scm_t_bits
) val
;
180 scm_foreign_object_unsigned_set_x (obj
, n
, bits
);
184 scm_foreign_object_ref (SCM obj
, size_t n
)
186 scm_t_bits bits
= scm_foreign_object_unsigned_ref (obj
, n
);
187 return (void *) bits
;
191 scm_foreign_object_set_x (SCM obj
, size_t n
, void *val
)
193 scm_t_bits bits
= (scm_t_bits
) val
;
194 scm_foreign_object_unsigned_set_x (obj
, n
, bits
);
198 invoke_finalizer (void *obj
, void *data
)
200 scm_call_1 (PTR2SCM (data
), PTR2SCM (obj
));
204 sys_add_finalizer_x (SCM obj
, SCM finalizer
)
205 #define FUNC_NAME "%add-finalizer!"
207 SCM_VALIDATE_PROC (SCM_ARG2
, finalizer
);
209 scm_i_add_finalizer (SCM2PTR (obj
), invoke_finalizer
, SCM2PTR (finalizer
));
211 return SCM_UNSPECIFIED
;
216 scm_init_foreign_object (void)
218 scm_c_define_gsubr ("%add-finalizer!", 2, 0, 0,
219 (scm_t_subr
) sys_add_finalizer_x
);
223 scm_register_foreign_object (void)
225 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
226 "scm_init_foreign_object",
227 (scm_t_extension_init_func
)scm_init_foreign_object
,