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