Commit | Line | Data |
---|---|---|
e2c2a699 AW |
1 | /* Copyright (C) 2010 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 | #if HAVE_CONFIG_H | |
20 | # include <config.h> | |
21 | #endif | |
22 | ||
23 | #include <string.h> | |
24 | #include "_scm.h" | |
25 | #include "foreign.h" | |
26 | ||
27 | \f | |
28 | ||
29 | static size_t | |
30 | sizeof_type (scm_t_foreign_type type) | |
31 | { | |
32 | switch (type) | |
33 | { | |
34 | case SCM_FOREIGN_TYPE_VOID: abort (); | |
35 | case SCM_FOREIGN_TYPE_FLOAT: return sizeof(float); | |
36 | case SCM_FOREIGN_TYPE_DOUBLE: return sizeof(double); | |
37 | case SCM_FOREIGN_TYPE_UINT8: return sizeof(scm_t_uint8); | |
38 | case SCM_FOREIGN_TYPE_INT8: return sizeof(scm_t_int8); | |
39 | case SCM_FOREIGN_TYPE_UINT16: return sizeof(scm_t_uint16); | |
40 | case SCM_FOREIGN_TYPE_INT16: return sizeof(scm_t_int16); | |
41 | case SCM_FOREIGN_TYPE_UINT32: return sizeof(scm_t_uint32); | |
42 | case SCM_FOREIGN_TYPE_INT32: return sizeof(scm_t_int32); | |
43 | case SCM_FOREIGN_TYPE_UINT64: return sizeof(scm_t_uint64); | |
44 | case SCM_FOREIGN_TYPE_INT64: return sizeof(scm_t_int64); | |
45 | case SCM_FOREIGN_TYPE_STRUCT: abort (); | |
46 | case SCM_FOREIGN_TYPE_POINTER: return sizeof(void*); | |
47 | default: abort (); | |
48 | } | |
49 | } | |
50 | ||
51 | ||
52 | static void | |
53 | foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data) | |
54 | { | |
55 | scm_t_foreign_finalizer finalizer = data; | |
56 | finalizer (SCM_FOREIGN_OBJECT (PTR2SCM (ptr), void*)); | |
57 | } | |
58 | ||
59 | SCM | |
60 | scm_c_from_foreign (scm_t_foreign_type type, void *val, size_t size, | |
61 | scm_t_foreign_finalizer finalizer) | |
62 | { | |
63 | void *ret; | |
64 | if (!size) | |
65 | size = sizeof_type (type); | |
66 | ||
67 | ret = scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2 + size, "foreign"); | |
68 | SCM_SET_CELL_WORD_0 (PTR2SCM (ret), scm_tc7_foreign | (type<<8)); | |
69 | ||
70 | /* set SCM_FOREIGN_OBJECT to point to the third word of the object, which will | |
71 | be 8-byte aligned. Then copy *val into that space. */ | |
72 | SCM_SET_CELL_WORD_1 (PTR2SCM (ret), | |
73 | (scm_t_bits)SCM_CELL_OBJECT_LOC (PTR2SCM (ret), 2)); | |
74 | memcpy (SCM_FOREIGN_OBJECT (PTR2SCM (ret), void), val, size); | |
75 | ||
76 | if (finalizer) | |
77 | { | |
78 | /* Register a finalizer for the newly created instance. */ | |
79 | GC_finalization_proc prev_finalizer; | |
80 | GC_PTR prev_finalizer_data; | |
81 | GC_REGISTER_FINALIZER_NO_ORDER (ret, | |
82 | foreign_finalizer_trampoline, | |
83 | finalizer, | |
84 | &prev_finalizer, | |
85 | &prev_finalizer_data); | |
86 | } | |
87 | ||
88 | return PTR2SCM (ret); | |
89 | } | |
90 | ||
91 | SCM | |
92 | scm_c_take_foreign (scm_t_foreign_type type, void *val, | |
93 | scm_t_foreign_finalizer finalizer) | |
94 | { | |
95 | void *ret; | |
96 | ||
97 | ret = scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2, "foreign"); | |
98 | SCM_SET_CELL_WORD_0 (PTR2SCM (ret), scm_tc7_foreign | (type<<8)); | |
99 | /* Set SCM_FOREIGN_OBJECT to the given pointer. */ | |
100 | SCM_SET_CELL_WORD_1 (PTR2SCM (ret), (scm_t_bits)val); | |
101 | ||
102 | if (finalizer) | |
103 | { | |
104 | /* Register a finalizer for the newly created instance. */ | |
105 | GC_finalization_proc prev_finalizer; | |
106 | GC_PTR prev_finalizer_data; | |
107 | GC_REGISTER_FINALIZER_NO_ORDER (ret, | |
108 | foreign_finalizer_trampoline, | |
109 | finalizer, | |
110 | &prev_finalizer, | |
111 | &prev_finalizer_data); | |
112 | } | |
113 | ||
114 | return PTR2SCM (ret); | |
115 | } | |
116 | ||
117 | SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0, | |
118 | (SCM foreign), | |
119 | "Reference the foreign value wrapped by @var{foreign}.\n\n" | |
120 | "Note that only \"simple\" types may be referenced by this\n" | |
121 | "function. See @code{foreign-struct-ref} or @code{foreign-pointer-ref}\n" | |
122 | "for structs or pointers, respectively.") | |
123 | #define FUNC_NAME s_scm_foreign_ref | |
124 | { | |
125 | SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign); | |
126 | ||
127 | switch (SCM_FOREIGN_TYPE (foreign)) | |
128 | { | |
129 | case SCM_FOREIGN_TYPE_FLOAT: | |
130 | return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, float)); | |
131 | case SCM_FOREIGN_TYPE_DOUBLE: | |
132 | return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, double)); | |
133 | case SCM_FOREIGN_TYPE_UINT8: | |
134 | return scm_from_uint8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint8)); | |
135 | case SCM_FOREIGN_TYPE_INT8: | |
136 | return scm_from_int8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int8)); | |
137 | case SCM_FOREIGN_TYPE_UINT16: | |
138 | return scm_from_uint16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint16)); | |
139 | case SCM_FOREIGN_TYPE_INT16: | |
140 | return scm_from_int16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int16)); | |
141 | case SCM_FOREIGN_TYPE_UINT32: | |
142 | return scm_from_uint32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint32)); | |
143 | case SCM_FOREIGN_TYPE_INT32: | |
144 | return scm_from_int32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int32)); | |
145 | case SCM_FOREIGN_TYPE_UINT64: | |
146 | return scm_from_uint64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint64)); | |
147 | case SCM_FOREIGN_TYPE_INT64: | |
148 | return scm_from_int64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int64)); | |
149 | case SCM_FOREIGN_TYPE_VOID: | |
150 | case SCM_FOREIGN_TYPE_STRUCT: | |
151 | case SCM_FOREIGN_TYPE_POINTER: | |
152 | default: | |
153 | /* other cases should have been caught by the FOREIGN_SIMPLE check */ | |
154 | abort (); | |
155 | } | |
156 | } | |
157 | #undef FUNC_NAME | |
158 | ||
159 | SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 0, 0, | |
160 | (SCM foreign, SCM val), | |
161 | "Set the foreign value wrapped by @var{foreign}.\n\n" | |
162 | "Note that only \"simple\" types may be set by this function.\n" | |
163 | "See @code{foreign-struct-ref} or @code{foreign-pointer-ref} for\n" | |
164 | "structs or pointers, respectively.") | |
165 | #define FUNC_NAME s_scm_foreign_set_x | |
166 | { | |
167 | SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign); | |
168 | ||
169 | switch (SCM_FOREIGN_TYPE (foreign)) | |
170 | { | |
171 | case SCM_FOREIGN_TYPE_FLOAT: | |
172 | SCM_FOREIGN_OBJECT_SET (foreign, float, scm_to_double (val)); | |
173 | break; | |
174 | case SCM_FOREIGN_TYPE_DOUBLE: | |
175 | SCM_FOREIGN_OBJECT_SET (foreign, double, scm_to_double (val)); | |
176 | break; | |
177 | case SCM_FOREIGN_TYPE_UINT8: | |
178 | SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint8, scm_to_uint8 (val)); | |
179 | break; | |
180 | case SCM_FOREIGN_TYPE_INT8: | |
181 | SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int8, scm_to_int8 (val)); | |
182 | break; | |
183 | case SCM_FOREIGN_TYPE_UINT16: | |
184 | SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint16, scm_to_uint16 (val)); | |
185 | break; | |
186 | case SCM_FOREIGN_TYPE_INT16: | |
187 | SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int16, scm_to_int16 (val)); | |
188 | break; | |
189 | case SCM_FOREIGN_TYPE_UINT32: | |
190 | SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint32, scm_to_uint32 (val)); | |
191 | break; | |
192 | case SCM_FOREIGN_TYPE_INT32: | |
193 | SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int32, scm_to_int32 (val)); | |
194 | break; | |
195 | case SCM_FOREIGN_TYPE_UINT64: | |
196 | SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint64, scm_to_uint64 (val)); | |
197 | break; | |
198 | case SCM_FOREIGN_TYPE_INT64: | |
199 | SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int64, scm_to_int64 (val)); | |
200 | break; | |
201 | case SCM_FOREIGN_TYPE_VOID: | |
202 | case SCM_FOREIGN_TYPE_STRUCT: | |
203 | case SCM_FOREIGN_TYPE_POINTER: | |
204 | default: | |
205 | /* other cases should have been caught by the FOREIGN_SIMPLE check */ | |
206 | abort (); | |
207 | } | |
208 | return SCM_UNSPECIFIED; | |
209 | } | |
210 | #undef FUNC_NAME | |
211 | ||
212 | void | |
213 | scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate) | |
214 | { | |
215 | scm_puts ("#<foreign ", port); | |
216 | switch (SCM_FOREIGN_TYPE (foreign)) | |
217 | { | |
218 | case SCM_FOREIGN_TYPE_VOID: | |
219 | abort (); | |
220 | case SCM_FOREIGN_TYPE_FLOAT: | |
221 | scm_puts ("float ", port); | |
222 | scm_display (scm_foreign_ref (foreign), port); | |
223 | break; | |
224 | case SCM_FOREIGN_TYPE_DOUBLE: | |
225 | scm_puts ("double ", port); | |
226 | scm_display (scm_foreign_ref (foreign), port); | |
227 | break; | |
228 | case SCM_FOREIGN_TYPE_UINT8: | |
229 | scm_puts ("uint8 ", port); | |
230 | scm_display (scm_foreign_ref (foreign), port); | |
231 | break; | |
232 | case SCM_FOREIGN_TYPE_INT8: | |
233 | scm_puts ("int8 ", port); | |
234 | scm_display (scm_foreign_ref (foreign), port); | |
235 | break; | |
236 | case SCM_FOREIGN_TYPE_UINT16: | |
237 | scm_puts ("uint16 ", port); | |
238 | scm_display (scm_foreign_ref (foreign), port); | |
239 | break; | |
240 | case SCM_FOREIGN_TYPE_INT16: | |
241 | scm_puts ("int16 ", port); | |
242 | scm_display (scm_foreign_ref (foreign), port); | |
243 | break; | |
244 | case SCM_FOREIGN_TYPE_UINT32: | |
245 | scm_puts ("uint32 ", port); | |
246 | scm_display (scm_foreign_ref (foreign), port); | |
247 | break; | |
248 | case SCM_FOREIGN_TYPE_INT32: | |
249 | scm_puts ("int32 ", port); | |
250 | scm_display (scm_foreign_ref (foreign), port); | |
251 | break; | |
252 | case SCM_FOREIGN_TYPE_UINT64: | |
253 | scm_puts ("uint64 ", port); | |
254 | scm_display (scm_foreign_ref (foreign), port); | |
255 | break; | |
256 | case SCM_FOREIGN_TYPE_INT64: | |
257 | scm_puts ("int64 ", port); | |
258 | scm_display (scm_foreign_ref (foreign), port); | |
259 | break; | |
260 | case SCM_FOREIGN_TYPE_STRUCT: | |
261 | scm_puts ("struct at 0x", port); | |
262 | scm_uintprint (SCM_CELL_WORD_1 (foreign), 16, port); | |
263 | break; | |
264 | case SCM_FOREIGN_TYPE_POINTER: | |
265 | scm_puts ("pointer 0x", port); | |
266 | scm_uintprint (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_bits), 16, port); | |
267 | break; | |
268 | default: | |
269 | abort (); | |
270 | } | |
271 | scm_putc ('>', port); | |
272 | } | |
273 | ||
274 | \f | |
275 | ||
276 | void | |
277 | scm_init_foreign (void) | |
278 | { | |
279 | #ifndef SCM_MAGIC_SNARFER | |
280 | #include "libguile/foreign.x" | |
281 | #endif | |
282 | } | |
283 | ||
284 | /* | |
285 | Local Variables: | |
286 | c-file-style: "gnu" | |
287 | End: | |
288 | */ |