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_1 (SCM type
, scm_t_bits val0
)
69 return scm_make_foreign_object_n (type
, 1, &val0
);
73 scm_make_foreign_object_2 (SCM type
, scm_t_bits val0
, scm_t_bits val1
)
75 scm_t_bits vals
[2] = { val0
, val1
};
77 return scm_make_foreign_object_n (type
, 2, vals
);
81 scm_make_foreign_object_3 (SCM type
, scm_t_bits val0
, scm_t_bits val1
,
84 scm_t_bits vals
[3] = { val0
, val1
, val2
};
86 return scm_make_foreign_object_n (type
, 3, vals
);
90 scm_make_foreign_object_n (SCM type
, size_t n
, scm_t_bits vals
[])
91 #define FUNC_NAME "make-foreign-object"
97 SCM_VALIDATE_VTABLE (SCM_ARG1
, type
);
99 layout
= SCM_VTABLE_LAYOUT (type
);
101 if (scm_i_symbol_length (layout
) / 2 < n
)
102 scm_out_of_range (FUNC_NAME
, scm_from_size_t (n
));
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");
108 obj
= scm_c_make_structv (type
, 0, 0, NULL
);
110 for (i
= 0; i
< n
; i
++)
111 SCM_STRUCT_DATA_SET (obj
, i
, vals
[i
]);
118 scm_foreign_object_ref (SCM obj
, size_t n
)
119 #define FUNC_NAME "foreign-object-ref"
123 SCM_VALIDATE_STRUCT (SCM_ARG1
, obj
);
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
));
129 if (scm_i_symbol_ref (layout
, n
* 2) != 'u')
130 scm_wrong_type_arg_msg (FUNC_NAME
, 0, layout
, "'u' field");
132 return SCM_STRUCT_DATA_REF (obj
, n
);
137 scm_foreign_object_set_x (SCM obj
, size_t n
, scm_t_bits val
)
138 #define FUNC_NAME "foreign-object-set!"
142 SCM_VALIDATE_STRUCT (SCM_ARG1
, obj
);
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
));
148 if (scm_i_symbol_ref (layout
, n
* 2) != 'u')
149 scm_wrong_type_arg_msg (FUNC_NAME
, 0, layout
, "'u' field");
151 SCM_STRUCT_DATA_SET (obj
, n
, val
);
156 invoke_finalizer (void *obj
, void *data
)
158 scm_call_1 (PTR2SCM (data
), PTR2SCM (obj
));
162 sys_add_finalizer_x (SCM obj
, SCM finalizer
)
163 #define FUNC_NAME "%add-finalizer!"
165 SCM_VALIDATE_PROC (SCM_ARG2
, finalizer
);
167 scm_i_add_finalizer (SCM2PTR (obj
), invoke_finalizer
, SCM2PTR (finalizer
));
169 return SCM_UNSPECIFIED
;
174 scm_init_foreign_object (void)
176 scm_c_define_gsubr ("%add-finalizer!", 2, 0, 0,
177 (scm_t_subr
) sys_add_finalizer_x
);
181 scm_register_foreign_object (void)
183 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
184 "scm_init_foreign_object",
185 (scm_t_extension_init_func
)scm_init_foreign_object
,