HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Update Gnulib; add new modules; remove `round' module.
[bpt/guile.git] / libguile / foreign.c
CommitLineData
f9654187 1/* Copyright (C) 2010, 2011 Free Software Foundation, Inc.
5b46a8c2 2 *
e2c2a699
AW		 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
d8b04f04
AW		 23#include <ffi.h>
24
cdd47ec7 25#include <alloca.h>
d8b04f04 26#include <alignof.h>
e2c2a699 27#include <string.h>
86425e26
LC		 28#include <assert.h>
29
ea7d717b 30#include "libguile/_scm.h"
20aafae2 31#include "libguile/bytevectors.h"
d8b04f04 32#include "libguile/instructions.h"
05e74813 33#include "libguile/threads.h"
ea7d717b 34#include "libguile/foreign.h"
e2c2a699
AW		 35
36\f
37
ab4779ff
AW		 38SCM_SYMBOL (sym_void, "void");
39SCM_SYMBOL (sym_float, "float");
40SCM_SYMBOL (sym_double, "double");
41SCM_SYMBOL (sym_uint8, "uint8");
42SCM_SYMBOL (sym_int8, "int8");
43SCM_SYMBOL (sym_uint16, "uint16");
44SCM_SYMBOL (sym_int16, "int16");
45SCM_SYMBOL (sym_uint32, "uint32");
46SCM_SYMBOL (sym_int32, "int32");
47SCM_SYMBOL (sym_uint64, "uint64");
48SCM_SYMBOL (sym_int64, "int64");
42f7c01e 49SCM_SYMBOL (sym_short, "short");
dd1464bf
LC		 50SCM_SYMBOL (sym_int, "int");
51SCM_SYMBOL (sym_long, "long");
42f7c01e 52SCM_SYMBOL (sym_unsigned_short, "unsigned-short");
dd1464bf
LC		 53SCM_SYMBOL (sym_unsigned_int, "unsigned-int");
54SCM_SYMBOL (sym_unsigned_long, "unsigned-long");
55SCM_SYMBOL (sym_size_t, "size_t");
ab4779ff 56
3435f3c0
AW		 57/* that's for pointers, you know. */
58SCM_SYMBOL (sym_asterisk, "*");
59
54eb59cf 60SCM_SYMBOL (sym_null, "%null-pointer");
01ad5a7b 61SCM_SYMBOL (sym_null_pointer_error, "null-pointer-error");
54eb59cf
LC		 62
63/* The cell representing the null pointer. */
3e5ea35c 64static SCM null_pointer;
3435f3c0 65
d4149a51
LC		 66#if SIZEOF_VOID_P == 4
67# define scm_to_uintptr scm_to_uint32
68# define scm_from_uintptr scm_from_uint32
69#elif SIZEOF_VOID_P == 8
70# define scm_to_uintptr scm_to_uint64
71# define scm_from_uintptr scm_from_uint64
72#else
73# error unsupported pointer size
74#endif
75
76
01ad5a7b
LC		 77/* Raise a null pointer dereference error. */
78static void
79null_pointer_error (const char *func_name)
80{
81 scm_error (sym_null_pointer_error, func_name,
82 "null pointer dereference", SCM_EOL, SCM_EOL);
83}
84
85\f
d8b04f04
AW		 86static SCM cif_to_procedure (SCM cif, SCM func_ptr);
87
88
5b46a8c2 89static SCM pointer_weak_refs = SCM_BOOL_F;
05e74813
AW		 90static scm_i_pthread_mutex_t weak_refs_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
91
20aafae2
AW		 92
93static void
94register_weak_reference (SCM from, SCM to)
95{
05e74813 96 scm_i_pthread_mutex_lock (&weak_refs_lock);
5b46a8c2 97 scm_hashq_set_x (pointer_weak_refs, from, to);
05e74813 98 scm_i_pthread_mutex_unlock (&weak_refs_lock);
20aafae2 99}
d4149a51 100
e2c2a699 101static void
5b46a8c2 102pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
e2c2a699 103{
5b46a8c2
LC		 104 scm_t_pointer_finalizer finalizer = data;
105 finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr)));
e2c2a699
AW		 106}
107
6e097560
LC		 108SCM_DEFINE (scm_pointer_p, "pointer?", 1, 0, 0,
109 (SCM obj),
110 "Return @code{#t} if @var{obj} is a pointer object, "
111 "@code{#f} otherwise.\n")
112#define FUNC_NAME s_scm_pointer_p
113{
114 return scm_from_bool (SCM_POINTER_P (obj));
115}
116#undef FUNC_NAME
117
d4149a51
LC		 118SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 0,
119 (SCM address, SCM finalizer),
120 "Return a foreign pointer object pointing to @var{address}. "
121 "If @var{finalizer} is passed, it should be a pointer to a "
122 "one-argument C function that will be called when the pointer "
123 "object becomes unreachable.")
124#define FUNC_NAME s_scm_make_pointer
125{
126 void *c_finalizer;
127 scm_t_uintptr c_address;
d4149a51
LC		 128
129 c_address = scm_to_uintptr (address);
130 if (SCM_UNBNDP (finalizer))
131 c_finalizer = NULL;
132 else
133 {
5b46a8c2
LC		 134 SCM_VALIDATE_POINTER (2, finalizer);
135 c_finalizer = SCM_POINTER_VALUE (finalizer);
d4149a51
LC		 136 }
137
854aa906 138 return scm_from_pointer ((void *) c_address, c_finalizer);
d4149a51
LC		 139}
140#undef FUNC_NAME
141
e2c2a699 142SCM
5b46a8c2 143scm_from_pointer (void *ptr, scm_t_pointer_finalizer finalizer)
e2c2a699 144{
9fdee5b4 145 SCM ret;
d4149a51 146
854aa906
LC		 147 if (ptr == NULL && finalizer == NULL)
148 ret = null_pointer;
149 else
e2c2a699 150 {
690a0112 151 ret = scm_cell (scm_tc7_pointer, (scm_t_bits) ptr);
854aa906
LC		 152
153 if (finalizer)
154 {
155 /* Register a finalizer for the newly created instance. */
156 GC_finalization_proc prev_finalizer;
157 GC_PTR prev_finalizer_data;
158 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
159 pointer_finalizer_trampoline,
160 finalizer,
161 &prev_finalizer,
162 &prev_finalizer_data);
163 }
e2c2a699
AW		 164 }
165
9fdee5b4 166 return ret;
e2c2a699
AW		 167}
168
5b46a8c2
LC		 169SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0,
170 (SCM pointer),
171 "Return the numerical value of @var{pointer}.")
172#define FUNC_NAME s_scm_pointer_address
e2c2a699 173{
5b46a8c2 174 SCM_VALIDATE_POINTER (1, pointer);
01ad5a7b 175
5b46a8c2 176 return scm_from_uintptr ((scm_t_uintptr) SCM_POINTER_VALUE (pointer));
e2c2a699
AW		 177}
178#undef FUNC_NAME
179
5b46a8c2
LC		 180SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0,
181 (SCM pointer, SCM len, SCM offset, SCM uvec_type),
183a2a22
LC		 182 "Return a bytevector aliasing the @var{len} bytes pointed\n"
183 "to by @var{pointer}.\n\n"
20aafae2
AW		 184 "The user may specify an alternate default interpretation for\n"
185 "the memory by passing the @var{uvec_type} argument, to indicate\n"
186 "that the memory is an array of elements of that type.\n"
187 "@var{uvec_type} should be something that\n"
188 "@code{uniform-vector-element-type} would return, like @code{f32}\n"
189 "or @code{s16}.\n\n"
183a2a22
LC		 190 "When @var{offset} is passed, it specifies the offset in bytes\n"
191 "relative to @var{pointer} of the memory region aliased by the\n"
192 "returned bytevector.")
5b46a8c2 193#define FUNC_NAME s_scm_pointer_to_bytevector
20aafae2
AW		 194{
195 SCM ret;
196 scm_t_int8 *ptr;
197 size_t boffset, blen;
198 scm_t_array_element_type btype;
199
5b46a8c2
LC		 200 SCM_VALIDATE_POINTER (1, pointer);
201 ptr = SCM_POINTER_VALUE (pointer);
54eb59cf
LC		 202
203 if (SCM_UNLIKELY (ptr == NULL))
01ad5a7b 204 null_pointer_error (FUNC_NAME);
54eb59cf 205
20aafae2
AW		 206 if (SCM_UNBNDP (uvec_type))
207 btype = SCM_ARRAY_ELEMENT_TYPE_VU8;
208 else
209 {
210 int i;
211 for (i = 0; i <= SCM_ARRAY_ELEMENT_TYPE_LAST; i++)
212 if (scm_is_eq (uvec_type, scm_i_array_element_types[i]))
213 break;
214 switch (i)
215 {
216 case SCM_ARRAY_ELEMENT_TYPE_VU8:
217 case SCM_ARRAY_ELEMENT_TYPE_U8:
218 case SCM_ARRAY_ELEMENT_TYPE_S8:
219 case SCM_ARRAY_ELEMENT_TYPE_U16:
220 case SCM_ARRAY_ELEMENT_TYPE_S16:
221 case SCM_ARRAY_ELEMENT_TYPE_U32:
222 case SCM_ARRAY_ELEMENT_TYPE_S32:
223 case SCM_ARRAY_ELEMENT_TYPE_U64:
224 case SCM_ARRAY_ELEMENT_TYPE_S64:
225 case SCM_ARRAY_ELEMENT_TYPE_F32:
226 case SCM_ARRAY_ELEMENT_TYPE_F64:
227 case SCM_ARRAY_ELEMENT_TYPE_C32:
228 case SCM_ARRAY_ELEMENT_TYPE_C64:
229 btype = i;
230 break;
231 default:
232 scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec_type,
233 "uniform vector type");
234 }
235 }
d4149a51 236
20aafae2
AW		 237 if (SCM_UNBNDP (offset))
238 boffset = 0;
20aafae2
AW		 239 else
240 boffset = scm_to_size_t (offset);
241
d4149a51 242 blen = scm_to_size_t (len);
20aafae2
AW		 243
244 ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype);
5b46a8c2 245 register_weak_reference (ret, pointer);
20aafae2
AW		 246 return ret;
247}
248#undef FUNC_NAME
249
22697acb
LC		 250SCM_DEFINE (scm_bytevector_to_pointer, "bytevector->pointer", 1, 1, 0,
251 (SCM bv, SCM offset),
5b46a8c2 252 "Return a pointer pointer aliasing the memory pointed to by\n"
22697acb
LC		 253 "@var{bv} or @var{offset} bytes after @var{bv} when @var{offset}\n"
254 "is passed.")
5b46a8c2 255#define FUNC_NAME s_scm_bytevector_to_pointer
20aafae2
AW		 256{
257 SCM ret;
258 scm_t_int8 *ptr;
22697acb 259 size_t boffset;
20aafae2
AW		 260
261 SCM_VALIDATE_BYTEVECTOR (1, bv);
262 ptr = SCM_BYTEVECTOR_CONTENTS (bv);
22697acb 263
20aafae2
AW		 264 if (SCM_UNBNDP (offset))
265 boffset = 0;
266 else
267 boffset = scm_to_unsigned_integer (offset, 0,
268 SCM_BYTEVECTOR_LENGTH (bv) - 1);
269
5b46a8c2 270 ret = scm_from_pointer (ptr + boffset, NULL);
20aafae2
AW		 271 register_weak_reference (ret, bv);
272 return ret;
273}
274#undef FUNC_NAME
275
5b46a8c2
LC		 276SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0,
277 (SCM pointer, SCM finalizer),
3435f3c0 278 "Arrange for the C procedure wrapped by @var{finalizer} to be\n"
5b46a8c2 279 "called on the pointer wrapped by @var{pointer} when @var{pointer}\n"
3435f3c0
AW		 280 "becomes unreachable. Note: the C procedure should not call into\n"
281 "Scheme. If you need a Scheme finalizer, use guardians.")
5b46a8c2 282#define FUNC_NAME s_scm_set_pointer_finalizer_x
3435f3c0
AW		 283{
284 void *c_finalizer;
285 GC_finalization_proc prev_finalizer;
286 GC_PTR prev_finalizer_data;
287
5b46a8c2
LC		 288 SCM_VALIDATE_POINTER (1, pointer);
289 SCM_VALIDATE_POINTER (2, finalizer);
d4149a51 290
5b46a8c2 291 c_finalizer = SCM_POINTER_VALUE (finalizer);
3435f3c0 292
5b46a8c2 293 SCM_SET_CELL_WORD_0 (pointer, SCM_CELL_WORD_0 (pointer) | (1 << 16UL));
3435f3c0 294
5b46a8c2
LC		 295 GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer),
296 pointer_finalizer_trampoline,
3435f3c0
AW		 297 c_finalizer,
298 &prev_finalizer,
299 &prev_finalizer_data);
300
301 return SCM_UNSPECIFIED;
302}
303#undef FUNC_NAME
304
e2c2a699 305void
5b46a8c2 306scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate)
e2c2a699 307{
e5f7f675
AW		 308 scm_puts ("#<pointer 0x", port);
309 scm_uintprint (scm_to_uintptr (scm_pointer_address (pointer)), 16, port);
e2c2a699
AW		 310 scm_putc ('>', port);
311}
312
313\f
fa2a89a6
LC		 314/* Non-primitive helpers functions. These procedures could be
315 implemented in terms of the primitives above but would be inefficient
316 (heap allocation overhead, Scheme/C round trips, etc.) */
317
318SCM_DEFINE (scm_dereference_pointer, "dereference-pointer", 1, 0, 0,
319 (SCM pointer),
320 "Assuming @var{pointer} points to a memory region that\n"
321 "holds a pointer, return this pointer.")
322#define FUNC_NAME s_scm_dereference_pointer
323{
324 SCM_VALIDATE_POINTER (1, pointer);
325
326 return scm_from_pointer (* (void **) SCM_POINTER_VALUE (pointer), NULL);
327}
328#undef FUNC_NAME
329
330SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 0, 0,
331 (SCM string),
332 "Return a foreign pointer to a nul-terminated copy of\n"
333 "@var{string} in the current locale encoding. The C\n"
334 "string is freed when the returned foreign pointer\n"
335 "becomes unreachable.\n\n"
336 "This is the Scheme equivalent of @code{scm_to_locale_string}.")
337#define FUNC_NAME s_scm_string_to_pointer
338{
339 SCM_VALIDATE_STRING (1, string);
340
341 /* XXX: Finalizers slow down libgc; they could be avoided if
342 `scm_to_string' & co. were able to use libgc-allocated memory. */
343
344 return scm_from_pointer (scm_to_locale_string (string), free);
345}
346#undef FUNC_NAME
347
348SCM_DEFINE (scm_pointer_to_string, "pointer->string", 1, 0, 0,
349 (SCM pointer),
350 "Return the string representing the C nul-terminated string\n"
351 "pointed to by @var{pointer}. The C string is assumed to be\n"
352 "in the current locale encoding.\n\n"
353 "This is the Scheme equivalent of @code{scm_from_locale_string}.")
354#define FUNC_NAME s_scm_pointer_to_string
355{
356 SCM_VALIDATE_POINTER (1, pointer);
357
358 return scm_from_locale_string (SCM_POINTER_VALUE (pointer));
359}
360#undef FUNC_NAME
361
362\f
e2c2a699 363
b9264dc5
AW		 364SCM_DEFINE (scm_alignof, "alignof", 1, 0, 0, (SCM type),
365 "Return the alignment of @var{type}, in bytes.\n\n"
366 "@var{type} should be a valid C type, like @code{int}.\n"
367 "Alternately @var{type} may be the symbol @code{*}, in which\n"
368 "case the alignment of a pointer is returned. @var{type} may\n"
369 "also be a list of types, in which case the alignment of a\n"
370 "@code{struct} with ABI-conventional packing is returned.")
9a396cbd
AW		 371#define FUNC_NAME s_scm_alignof
372{
373 if (SCM_I_INUMP (type))
374 {
375 switch (SCM_I_INUM (type))
376 {
377 case SCM_FOREIGN_TYPE_FLOAT:
378 return scm_from_size_t (alignof (float));
379 case SCM_FOREIGN_TYPE_DOUBLE:
380 return scm_from_size_t (alignof (double));
381 case SCM_FOREIGN_TYPE_UINT8:
382 return scm_from_size_t (alignof (scm_t_uint8));
383 case SCM_FOREIGN_TYPE_INT8:
384 return scm_from_size_t (alignof (scm_t_int8));
385 case SCM_FOREIGN_TYPE_UINT16:
386 return scm_from_size_t (alignof (scm_t_uint16));
387 case SCM_FOREIGN_TYPE_INT16:
388 return scm_from_size_t (alignof (scm_t_int16));
389 case SCM_FOREIGN_TYPE_UINT32:
390 return scm_from_size_t (alignof (scm_t_uint32));
391 case SCM_FOREIGN_TYPE_INT32:
392 return scm_from_size_t (alignof (scm_t_int32));
393 case SCM_FOREIGN_TYPE_UINT64:
394 return scm_from_size_t (alignof (scm_t_uint64));
395 case SCM_FOREIGN_TYPE_INT64:
396 return scm_from_size_t (alignof (scm_t_int64));
397 default:
398 scm_wrong_type_arg (FUNC_NAME, 1, type);
399 }
400 }
3435f3c0
AW		 401 else if (scm_is_eq (type, sym_asterisk))
402 /* a pointer */
403 return scm_from_size_t (alignof (void*));
9a396cbd
AW		 404 else if (scm_is_pair (type))
405 /* a struct, yo */
406 return scm_alignof (scm_car (type));
407 else
408 scm_wrong_type_arg (FUNC_NAME, 1, type);
409}
410#undef FUNC_NAME
411
b9264dc5
AW		 412SCM_DEFINE (scm_sizeof, "sizeof", 1, 0, 0, (SCM type),
413 "Return the size of @var{type}, in bytes.\n\n"
414 "@var{type} should be a valid C type, like @code{int}.\n"
415 "Alternately @var{type} may be the symbol @code{*}, in which\n"
416 "case the size of a pointer is returned. @var{type} may also\n"
417 "be a list of types, in which case the size of a @code{struct}\n"
418 "with ABI-conventional packing is returned.")
9a396cbd
AW		 419#define FUNC_NAME s_scm_sizeof
420{
421 if (SCM_I_INUMP (type))
422 {
423 switch (SCM_I_INUM (type))
424 {
425 case SCM_FOREIGN_TYPE_FLOAT:
426 return scm_from_size_t (sizeof (float));
427 case SCM_FOREIGN_TYPE_DOUBLE:
428 return scm_from_size_t (sizeof (double));
429 case SCM_FOREIGN_TYPE_UINT8:
430 return scm_from_size_t (sizeof (scm_t_uint8));
431 case SCM_FOREIGN_TYPE_INT8:
432 return scm_from_size_t (sizeof (scm_t_int8));
433 case SCM_FOREIGN_TYPE_UINT16:
434 return scm_from_size_t (sizeof (scm_t_uint16));
435 case SCM_FOREIGN_TYPE_INT16:
436 return scm_from_size_t (sizeof (scm_t_int16));
437 case SCM_FOREIGN_TYPE_UINT32:
438 return scm_from_size_t (sizeof (scm_t_uint32));
439 case SCM_FOREIGN_TYPE_INT32:
440 return scm_from_size_t (sizeof (scm_t_int32));
441 case SCM_FOREIGN_TYPE_UINT64:
442 return scm_from_size_t (sizeof (scm_t_uint64));
443 case SCM_FOREIGN_TYPE_INT64:
444 return scm_from_size_t (sizeof (scm_t_int64));
445 default:
446 scm_wrong_type_arg (FUNC_NAME, 1, type);
447 }
448 }
3435f3c0
AW		 449 else if (scm_is_eq (type, sym_asterisk))
450 /* a pointer */
451 return scm_from_size_t (sizeof (void*));
9a396cbd
AW		 452 else if (scm_is_pair (type))
453 {
454 /* a struct */
455 size_t off = 0;
456 while (scm_is_pair (type))
457 {
458 off = ROUND_UP (off, scm_to_size_t (scm_alignof (scm_car (type))));
459 off += scm_to_size_t (scm_sizeof (scm_car (type)));
460 type = scm_cdr (type);
461 }
462 return scm_from_size_t (off);
463 }
464 else
465 scm_wrong_type_arg (FUNC_NAME, 1, type);
466}
467#undef FUNC_NAME
468
469
d8b04f04
AW		 470/* return 1 on success, 0 on failure */
471static int
472parse_ffi_type (SCM type, int return_p, long *n_structs, long *n_struct_elts)
473{
474 if (SCM_I_INUMP (type))
475 {
476 if ((SCM_I_INUM (type) < 0 )
477 || (SCM_I_INUM (type) > SCM_FOREIGN_TYPE_LAST))
478 return 0;
479 else if (SCM_I_INUM (type) == SCM_FOREIGN_TYPE_VOID && !return_p)
480 return 0;
481 else
482 return 1;
483 }
3435f3c0
AW		 484 else if (scm_is_eq (type, sym_asterisk))
485 /* a pointer */
486 return 1;
d8b04f04
AW		 487 else
488 {
489 long len;
490
491 len = scm_ilength (type);
492 if (len < 1)
493 return 0;
494 while (len--)
495 {
496 if (!parse_ffi_type (scm_car (type), 0, n_structs, n_struct_elts))
497 return 0;
498 (*n_struct_elts)++;
499 type = scm_cdr (type);
500 }
501 (*n_structs)++;
502 return 1;
503 }
504}
505
506static void
507fill_ffi_type (SCM type, ffi_type *ftype, ffi_type ***type_ptrs,
508 ffi_type **types)
509{
510 if (SCM_I_INUMP (type))
511 {
512 switch (SCM_I_INUM (type))
513 {
514 case SCM_FOREIGN_TYPE_FLOAT:
515 *ftype = ffi_type_float;
516 return;
517 case SCM_FOREIGN_TYPE_DOUBLE:
518 *ftype = ffi_type_double;
519 return;
520 case SCM_FOREIGN_TYPE_UINT8:
521 *ftype = ffi_type_uint8;
522 return;
523 case SCM_FOREIGN_TYPE_INT8:
524 *ftype = ffi_type_sint8;
525 return;
526 case SCM_FOREIGN_TYPE_UINT16:
527 *ftype = ffi_type_uint16;
528 return;
529 case SCM_FOREIGN_TYPE_INT16:
530 *ftype = ffi_type_sint16;
531 return;
532 case SCM_FOREIGN_TYPE_UINT32:
533 *ftype = ffi_type_uint32;
534 return;
535 case SCM_FOREIGN_TYPE_INT32:
536 *ftype = ffi_type_sint32;
537 return;
538 case SCM_FOREIGN_TYPE_UINT64:
539 *ftype = ffi_type_uint64;
540 return;
541 case SCM_FOREIGN_TYPE_INT64:
542 *ftype = ffi_type_sint64;
543 return;
544 case SCM_FOREIGN_TYPE_VOID:
545 *ftype = ffi_type_void;
546 return;
547 default:
2ee07358 548 scm_wrong_type_arg_msg ("pointer->procedure", 0, type,
75383ddb 549 "foreign type");
d8b04f04
AW		 550 }
551 }
3435f3c0
AW		 552 else if (scm_is_eq (type, sym_asterisk))
553 /* a pointer */
554 {
555 *ftype = ffi_type_pointer;
556 return;
557 }
d8b04f04
AW		 558 else
559 {
560 long i, len;
561
562 len = scm_ilength (type);
563
564 ftype->size = 0;
565 ftype->alignment = 0;
566 ftype->type = FFI_TYPE_STRUCT;
567 ftype->elements = *type_ptrs;
568 *type_ptrs += len + 1;
569
570 for (i = 0; i < len; i++)
571 {
9a396cbd
AW		 572 ftype->elements[i] = *types;
573 *types += 1;
d8b04f04
AW		 574 fill_ffi_type (scm_car (type), ftype->elements[i],
575 type_ptrs, types);
576 type = scm_cdr (type);
577 }
578 ftype->elements[i] = NULL;
579 }
580}
33186356
LC		 581
582/* Return a "cif" (call interface) for the given RETURN_TYPE and
583 ARG_TYPES. */
584static ffi_cif *
585make_cif (SCM return_type, SCM arg_types, const char *caller)
586#define FUNC_NAME caller
d8b04f04 587{
33186356 588 SCM walk;
d8b04f04
AW		 589 long i, nargs, n_structs, n_struct_elts;
590 size_t cif_len;
591 char *mem;
592 ffi_cif *cif;
593 ffi_type **type_ptrs;
594 ffi_type *types;
5b46a8c2 595
d8b04f04
AW		 596 nargs = scm_ilength (arg_types);
597 SCM_ASSERT (nargs >= 0, arg_types, 3, FUNC_NAME);
598 /* fixme: assert nargs < 1<<32 */
599 n_structs = n_struct_elts = 0;
600
601 /* For want of talloc, we're going to have to do this in two passes: first we
602 figure out how much memory is needed for all types, then we allocate the
603 cif and the types all in one block. */
604 if (!parse_ffi_type (return_type, 1, &n_structs, &n_struct_elts))
605 scm_wrong_type_arg (FUNC_NAME, 1, return_type);
606 for (walk = arg_types; scm_is_pair (walk); walk = scm_cdr (walk))
607 if (!parse_ffi_type (scm_car (walk), 0, &n_structs, &n_struct_elts))
608 scm_wrong_type_arg (FUNC_NAME, 3, scm_car (walk));
33186356 609
d8b04f04
AW		 610 /* the memory: with space for the cif itself */
611 cif_len = sizeof (ffi_cif);
612
613 /* then ffi_type pointers: one for each arg, one for each struct
614 element, and one for each struct (for null-termination) */
615 cif_len = (ROUND_UP (cif_len, alignof(void*))
33186356
LC		 616 + (nargs + n_structs + n_struct_elts)*sizeof(void*));
617
d8b04f04
AW		 618 /* then the ffi_type structs themselves, one per arg and struct element, and
619 one for the return val */
620 cif_len = (ROUND_UP (cif_len, alignof(ffi_type))
33186356 621 + (nargs + n_struct_elts + 1)*sizeof(ffi_type));
087aa6aa
LC		 622
623 mem = scm_gc_malloc_pointerless (cif_len, "foreign");
3ef6650d
AW		 624 /* ensure all the memory is initialized, even the holes */
625 memset (mem, 0, cif_len);
087aa6aa
LC		 626 cif = (ffi_cif *) mem;
627
d8b04f04
AW		 628 /* reuse cif_len to walk through the mem */
629 cif_len = ROUND_UP (sizeof (ffi_cif), alignof(void*));
630 type_ptrs = (ffi_type**)(mem + cif_len);
631 cif_len = ROUND_UP (cif_len
33186356
LC		 632 + (nargs + n_structs + n_struct_elts)*sizeof(void*),
633 alignof(ffi_type));
d8b04f04 634 types = (ffi_type*)(mem + cif_len);
33186356 635
d8b04f04
AW		 636 /* whew. now knit the pointers together. */
637 cif->rtype = types++;
638 fill_ffi_type (return_type, cif->rtype, &type_ptrs, &types);
639 cif->arg_types = type_ptrs;
640 type_ptrs += nargs;
641 for (walk = arg_types, i = 0; scm_is_pair (walk); walk = scm_cdr (walk), i++)
642 {
643 cif->arg_types[i] = types++;
644 fill_ffi_type (scm_car (walk), cif->arg_types[i], &type_ptrs, &types);
645 }
646
647 /* round out the cif, and we're done. */
648 cif->abi = FFI_DEFAULT_ABI;
649 cif->nargs = nargs;
650 cif->bytes = 0;
651 cif->flags = 0;
33186356 652
d8b04f04 653 if (FFI_OK != ffi_prep_cif (cif, FFI_DEFAULT_ABI, cif->nargs, cif->rtype,
33186356
LC		 654 cif->arg_types))
655 SCM_MISC_ERROR ("ffi_prep_cif failed", SCM_EOL);
656
657 return cif;
658}
659#undef FUNC_NAME
660
2ee07358 661SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0,
33186356
LC		 662 (SCM return_type, SCM func_ptr, SCM arg_types),
663 "Make a foreign function.\n\n"
664 "Given the foreign void pointer @var{func_ptr}, its argument and\n"
665 "return types @var{arg_types} and @var{return_type}, return a\n"
666 "procedure that will pass arguments to the foreign function\n"
667 "and return appropriate values.\n\n"
668 "@var{arg_types} should be a list of foreign types.\n"
669 "@code{return_type} should be a foreign type.")
2ee07358 670#define FUNC_NAME s_scm_pointer_to_procedure
33186356
LC		 671{
672 ffi_cif *cif;
673
674 SCM_VALIDATE_POINTER (2, func_ptr);
d8b04f04 675
33186356
LC		 676 cif = make_cif (return_type, arg_types, FUNC_NAME);
677
678 return cif_to_procedure (scm_from_pointer (cif, NULL), func_ptr);
d8b04f04
AW		 679}
680#undef FUNC_NAME
681
682\f
683
684/* Pre-generate trampolines for less than 10 arguments. */
685
686#ifdef WORDS_BIGENDIAN
687#define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40
688#define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
689#else
690#define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
691#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
692#endif
693
694#define CODE(nreq) \
695 OBJCODE_HEADER, \
696 /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \
697 /* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function pointer */ \
698 /* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well) */ \
699 /* 7 */ scm_op_nop, \
700 /* 8 */ META (3, 7, nreq)
701
702#define META(start, end, nreq) \
703 META_HEADER, \
704 /* 0 */ scm_op_make_eol, /* bindings */ \
705 /* 1 */ scm_op_make_eol, /* sources */ \
706 /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
707 /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \
708 /* 8 */ scm_op_list, 0, 3, /* make a list of those 3 vals */ \
709 /* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
710 /* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
711 /* 22 */ scm_op_object_ref, 1, /* the name from the object table */ \
712 /* 24 */ scm_op_cons, /* make a pair for the properties */ \
713 /* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
714 /* 28 */ scm_op_return, /* and return */ \
715 /* 29 */ scm_op_nop, scm_op_nop, scm_op_nop \
716 /* 32 */
717
718static const struct
719{
720 scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
721 const scm_t_uint8 bytes[10 * (sizeof (struct scm_objcode) + 8
722 + sizeof (struct scm_objcode) + 32)];
723} raw_bytecode = {
724 0,
725 {
726 CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
727 CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
728 }
729};
730
731#undef CODE
732#undef META
733#undef OBJCODE_HEADER
734#undef META_HEADER
735
736/*
737 (defun generate-objcode-cells (n)
738 "Generate objcode cells for up to N arguments"
739 (interactive "p")
740 (let ((i 0))
741 (while (< i n)
742 (insert
743 (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
744 (* (+ 4 4 8 4 4 32) i)))
745 (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
746 (setq i (1+ i)))))
747*/
748#define STATIC_OBJCODE_TAG \
f9654187 749 SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
d8b04f04
AW		 750
751static const struct
752{
753 scm_t_uint64 dummy; /* alignment */
754 scm_t_cell cells[10 * 2]; /* 10 double cells */
755} objcode_cells = {
756 0,
757 /* C-u 1 0 M-x generate-objcode-cells RET */
758 {
759 { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
760 { SCM_BOOL_F, SCM_PACK (0) },
761 { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 56) },
762 { SCM_BOOL_F, SCM_PACK (0) },
763 { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 112) },
764 { SCM_BOOL_F, SCM_PACK (0) },
765 { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 168) },
766 { SCM_BOOL_F, SCM_PACK (0) },
767 { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 224) },
768 { SCM_BOOL_F, SCM_PACK (0) },
769 { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 280) },
770 { SCM_BOOL_F, SCM_PACK (0) },
771 { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 336) },
772 { SCM_BOOL_F, SCM_PACK (0) },
773 { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 392) },
774 { SCM_BOOL_F, SCM_PACK (0) },
775 { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
776 { SCM_BOOL_F, SCM_PACK (0) },
777 { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 504) },
778 { SCM_BOOL_F, SCM_PACK (0) }
779 }
780};
781
782static const SCM objcode_trampolines[10] = {
783 SCM_PACK (objcode_cells.cells+0),
784 SCM_PACK (objcode_cells.cells+2),
785 SCM_PACK (objcode_cells.cells+4),
786 SCM_PACK (objcode_cells.cells+6),
787 SCM_PACK (objcode_cells.cells+8),
788 SCM_PACK (objcode_cells.cells+10),
789 SCM_PACK (objcode_cells.cells+12),
790 SCM_PACK (objcode_cells.cells+14),
791 SCM_PACK (objcode_cells.cells+16),
792 SCM_PACK (objcode_cells.cells+18),
793};
794
795static SCM
796cif_to_procedure (SCM cif, SCM func_ptr)
797{
d4149a51
LC		 798 ffi_cif *c_cif;
799 unsigned int nargs;
d8b04f04 800 SCM objcode, table, ret;
d4149a51 801
5b46a8c2 802 c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
d4149a51
LC		 803 nargs = c_cif->nargs;
804
d8b04f04
AW		 805 if (nargs < 10)
806 objcode = objcode_trampolines[nargs];
807 else
75383ddb
AW		 808 scm_misc_error ("make-foreign-function", "args >= 10 currently unimplemented",
809 SCM_EOL);
d8b04f04
AW		 810
811 table = scm_c_make_vector (2, SCM_UNDEFINED);
812 SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr));
813 SCM_SIMPLE_VECTOR_SET (table, 1, SCM_BOOL_F); /* name */
814 ret = scm_make_program (objcode, table, SCM_BOOL_F);
815
816 return ret;
817}
818
165a8643 819/* Set *LOC to the foreign representation of X with TYPE. */
4d9130a5 820static void
165a8643 821unpack (const ffi_type *type, void *loc, SCM x)
9970cf67 822#define FUNC_NAME "scm_i_foreign_call"
4d9130a5
AW		 823{
824 switch (type->type)
825 {
826 case FFI_TYPE_FLOAT:
165a8643 827 *(float *) loc = scm_to_double (x);
4d9130a5
AW		 828 break;
829 case FFI_TYPE_DOUBLE:
165a8643 830 *(double *) loc = scm_to_double (x);
4d9130a5
AW		 831 break;
832 case FFI_TYPE_UINT8:
165a8643 833 *(scm_t_uint8 *) loc = scm_to_uint8 (x);
4d9130a5
AW		 834 break;
835 case FFI_TYPE_SINT8:
165a8643 836 *(scm_t_int8 *) loc = scm_to_int8 (x);
4d9130a5
AW		 837 break;
838 case FFI_TYPE_UINT16:
165a8643 839 *(scm_t_uint16 *) loc = scm_to_uint16 (x);
4d9130a5
AW		 840 break;
841 case FFI_TYPE_SINT16:
165a8643 842 *(scm_t_int16 *) loc = scm_to_int16 (x);
4d9130a5
AW		 843 break;
844 case FFI_TYPE_UINT32:
165a8643 845 *(scm_t_uint32 *) loc = scm_to_uint32 (x);
4d9130a5
AW		 846 break;
847 case FFI_TYPE_SINT32:
165a8643 848 *(scm_t_int32 *) loc = scm_to_int32 (x);
4d9130a5
AW		 849 break;
850 case FFI_TYPE_UINT64:
165a8643 851 *(scm_t_uint64 *) loc = scm_to_uint64 (x);
4d9130a5
AW		 852 break;
853 case FFI_TYPE_SINT64:
165a8643 854 *(scm_t_int64 *) loc = scm_to_int64 (x);
4d9130a5
AW		 855 break;
856 case FFI_TYPE_STRUCT:
9970cf67 857 SCM_VALIDATE_POINTER (1, x);
5b46a8c2 858 memcpy (loc, SCM_POINTER_VALUE (x), type->size);
4d9130a5
AW		 859 break;
860 case FFI_TYPE_POINTER:
9970cf67 861 SCM_VALIDATE_POINTER (1, x);
5b46a8c2 862 *(void **) loc = SCM_POINTER_VALUE (x);
4d9130a5
AW		 863 break;
864 default:
865 abort ();
866 }
867}
9970cf67 868#undef FUNC_NAME
4d9130a5 869
165a8643 870/* Return a Scheme representation of the foreign value at LOC of type TYPE. */
4d9130a5 871static SCM
165a8643 872pack (const ffi_type * type, const void *loc)
4d9130a5
AW		 873{
874 switch (type->type)
875 {
876 case FFI_TYPE_VOID:
877 return SCM_UNSPECIFIED;
878 case FFI_TYPE_FLOAT:
165a8643 879 return scm_from_double (*(float *) loc);
4d9130a5 880 case FFI_TYPE_DOUBLE:
165a8643 881 return scm_from_double (*(double *) loc);
4d9130a5 882 case FFI_TYPE_UINT8:
165a8643 883 return scm_from_uint8 (*(scm_t_uint8 *) loc);
4d9130a5 884 case FFI_TYPE_SINT8:
165a8643 885 return scm_from_int8 (*(scm_t_int8 *) loc);
4d9130a5 886 case FFI_TYPE_UINT16:
165a8643 887 return scm_from_uint16 (*(scm_t_uint16 *) loc);
4d9130a5 888 case FFI_TYPE_SINT16:
165a8643 889 return scm_from_int16 (*(scm_t_int16 *) loc);
4d9130a5 890 case FFI_TYPE_UINT32:
165a8643 891 return scm_from_uint32 (*(scm_t_uint32 *) loc);
4d9130a5 892 case FFI_TYPE_SINT32:
165a8643 893 return scm_from_int32 (*(scm_t_int32 *) loc);
4d9130a5 894 case FFI_TYPE_UINT64:
165a8643 895 return scm_from_uint64 (*(scm_t_uint64 *) loc);
4d9130a5 896 case FFI_TYPE_SINT64:
165a8643 897 return scm_from_int64 (*(scm_t_int64 *) loc);
4d9130a5
AW		 898 case FFI_TYPE_STRUCT:
899 {
165a8643
LC		 900 void *mem = scm_gc_malloc_pointerless (type->size, "foreign");
901 memcpy (mem, loc, type->size);
5b46a8c2 902 return scm_from_pointer (mem, NULL);
4d9130a5
AW		 903 }
904 case FFI_TYPE_POINTER:
5b46a8c2 905 return scm_from_pointer (*(void **) loc, NULL);
4d9130a5
AW		 906 default:
907 abort ();
908 }
909}
910
165a8643 911
4d9130a5 912SCM
165a8643 913scm_i_foreign_call (SCM foreign, const SCM *argv)
4d9130a5
AW		 914{
915 /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
916 objtable. */
917 ffi_cif *cif;
b577bc90 918 void (*func) (void);
4d9130a5
AW		 919 scm_t_uint8 *data;
920 void *rvalue;
921 void **args;
922 unsigned i;
a2c69049 923 size_t arg_size;
4d9130a5
AW		 924 scm_t_ptrdiff off;
925
5b46a8c2
LC		 926 cif = SCM_POINTER_VALUE (SCM_CAR (foreign));
927 func = SCM_POINTER_VALUE (SCM_CDR (foreign));
a2c69049
LC		 928
929 /* Argument pointers. */
b577bc90 930 args = alloca (sizeof (void *) * cif->nargs);
a2c69049 931
86425e26
LC		 932 /* Compute the worst-case amount of memory needed to store all the argument
933 values. Note: as of libffi 3.0.9 `cif->bytes' is undocumented and is zero,
934 so it can't be used for that purpose. */
935 for (i = 0, arg_size = 0; i < cif->nargs; i++)
936 arg_size += cif->arg_types[i]->size + cif->arg_types[i]->alignment - 1;
a2c69049
LC		 937
938 /* Space for argument values, followed by return value. */
86425e26
LC		 939 data = alloca (arg_size + cif->rtype->size
940 + max (sizeof (void *), cif->rtype->alignment));
a2c69049 941
165a8643
LC		 942 /* Unpack ARGV to native values, setting ARGV pointers. */
943 for (i = 0, off = 0;
944 i < cif->nargs;
86425e26
LC		 945 off = (scm_t_uint8 *) args[i] - data + cif->arg_types[i]->size,
946 i++)
4d9130a5 947 {
86425e26
LC		 948 /* Suitably align the storage area for argument I. */
949 args[i] = (void *) ROUND_UP ((scm_t_uintptr) data + off,
950 cif->arg_types[i]->alignment);
951 assert ((scm_t_uintptr) args[i] % cif->arg_types[i]->alignment == 0);
4d9130a5 952 unpack (cif->arg_types[i], args[i], argv[i]);
4d9130a5 953 }
165a8643 954
86425e26
LC		 955 /* Prepare space for the return value. On some platforms, such as
956 `armv5tel-*-linux-gnueabi', the return value has to be at least
957 word-aligned, even if its type doesn't have any alignment requirement as is
958 the case with `char'. */
959 rvalue = (void *) ROUND_UP ((scm_t_uintptr) data + off,
960 max (sizeof (void *), cif->rtype->alignment));
4d9130a5
AW		 961
962 /* off we go! */
963 ffi_call (cif, func, rvalue, args);
964
965 return pack (cif->rtype, rvalue);
966}
967
d8b04f04 968\f
33186356
LC		 969/* Function pointers aka. "callbacks" or "closures". */
970
971#ifdef FFI_CLOSURES
972
973/* Trampoline to invoke a libffi closure that wraps a Scheme
974 procedure. */
975static void
976invoke_closure (ffi_cif *cif, void *ret, void **args, void *data)
977{
978 size_t i;
979 SCM proc, *argv, result;
980
981 proc = PTR2SCM (data);
982
983 argv = alloca (cif->nargs * sizeof (*argv));
984
985 /* Pack ARGS to SCM values, setting ARGV pointers. */
986 for (i = 0; i < cif->nargs; i++)
987 argv[i] = pack (cif->arg_types[i], args[i]);
988
989 result = scm_call_n (proc, argv, cif->nargs);
990
991 unpack (cif->rtype, ret, result);
992}
993
994SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
995 (SCM return_type, SCM proc, SCM arg_types),
996 "Return a pointer to a C function of type @var{return-type}\n"
997 "taking arguments of types @var{arg-types} (a list) and\n"
998 "behaving as a proxy to procedure @var{proc}. Thus\n"
999 "@var{proc}'s arity, supported argument types, and return\n"
1000 "type should match @var{return-type} and @var{arg-types}.\n")
1001#define FUNC_NAME s_scm_procedure_to_pointer
1002{
1003 SCM pointer;
1004 ffi_cif *cif;
1005 ffi_status err;
1006 void *closure, *executable;
1007
1008 cif = make_cif (return_type, arg_types, FUNC_NAME);
1009
1010 closure = ffi_closure_alloc (sizeof (ffi_closure), &executable);
1011 err = ffi_prep_closure_loc ((ffi_closure *) closure, cif,
1012 invoke_closure, SCM2PTR (proc),
1013 executable);
1014 if (err != FFI_OK)
1015 {
1016 ffi_closure_free (closure);
1017 SCM_MISC_ERROR ("`ffi_prep_closure_loc' failed", SCM_EOL);
1018 }
1019
1020 if (closure == executable)
1021 pointer = scm_from_pointer (executable, ffi_closure_free);
1022 else
1023 {
1024 /* CLOSURE needs to be freed eventually. However, since
1025 `GC_all_interior_pointers' is disabled, we can't just register
1026 a finalizer for CLOSURE. Instead, we create a pointer object
1027 for CLOSURE, with a finalizer, and register it as a weak
1028 reference of POINTER. */
1029 SCM friend;
1030
1031 pointer = scm_from_pointer (executable, NULL);
1032 friend = scm_from_pointer (closure, ffi_closure_free);
1033
1034 register_weak_reference (pointer, friend);
1035 }
1036
1037 return pointer;
1038}
1039#undef FUNC_NAME
1040
1041#endif /* FFI_CLOSURES */
1042
1043\f
d8b04f04 1044
ab4779ff 1045static void
e2c2a699
AW		 1046scm_init_foreign (void)
1047{
1048#ifndef SCM_MAGIC_SNARFER
1049#include "libguile/foreign.x"
1050#endif
ab4779ff
AW		 1051 scm_define (sym_void, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID));
1052 scm_define (sym_float, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT));
1053 scm_define (sym_double, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE));
1054 scm_define (sym_uint8, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8));
1055 scm_define (sym_int8, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8));
1056 scm_define (sym_uint16, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16));
1057 scm_define (sym_int16, scm_from_uint8 (SCM_FOREIGN_TYPE_INT16));
1058 scm_define (sym_uint32, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32));
1059 scm_define (sym_int32, scm_from_uint8 (SCM_FOREIGN_TYPE_INT32));
1060 scm_define (sym_uint64, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64));
1061 scm_define (sym_int64, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64));
dd1464bf 1062
42f7c01e
LC		 1063 scm_define (sym_short,
1064#if SIZEOF_SHORT == 8
1065 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
1066#elif SIZEOF_SHORT == 4
1067 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
1068#elif SIZEOF_SHORT == 2
1069 scm_from_uint8 (SCM_FOREIGN_TYPE_INT16)
1070#else
1071# error unsupported sizeof (short)
1072#endif
1073 );
1074
1075 scm_define (sym_unsigned_short,
1076#if SIZEOF_SHORT == 8
1077 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64)
1078#elif SIZEOF_SHORT == 4
1079 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
1080#elif SIZEOF_SHORT == 2
1081 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16)
1082#else
1083# error unsupported sizeof (short)
1084#endif
1085 );
1086
dd1464bf
LC		 1087 scm_define (sym_int,
1088#if SIZEOF_INT == 8
1089 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
1090#elif SIZEOF_INT == 4
1091 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
1092#else
1093# error unsupported sizeof (int)
1094#endif
1095 );
1096
1097 scm_define (sym_unsigned_int,
1098#if SIZEOF_UNSIGNED_INT == 8
1099 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64)
1100#elif SIZEOF_UNSIGNED_INT == 4
1101 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
1102#else
1103# error unsupported sizeof (unsigned int)
1104#endif
1105 );
1106
1107 scm_define (sym_long,
1108#if SIZEOF_LONG == 8
1109 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
1110#elif SIZEOF_LONG == 4
1111 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
1112#else
1113# error unsupported sizeof (long)
1114#endif
1115 );
1116
1117 scm_define (sym_unsigned_long,
1118#if SIZEOF_UNSIGNED_LONG == 8
1119 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64)
1120#elif SIZEOF_UNSIGNED_LONG == 4
1121 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
1122#else
1123# error unsupported sizeof (unsigned long)
1124#endif
1125 );
1126
1127 scm_define (sym_size_t,
1128#if SIZEOF_SIZE_T == 8
1129 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64)
1130#elif SIZEOF_SIZE_T == 4
1131 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
1132#else
1133# error unsupported sizeof (size_t)
1134#endif
1135 );
54eb59cf 1136
5b46a8c2 1137 null_pointer = scm_cell (scm_tc7_pointer, 0);
3e5ea35c 1138 scm_define (sym_null, null_pointer);
ab4779ff
AW		 1139}
1140
1141void
1142scm_register_foreign (void)
1143{
44602b08
AW		 1144 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
1145 "scm_init_foreign",
ab4779ff
AW		 1146 (scm_t_extension_init_func)scm_init_foreign,
1147 NULL);
5b46a8c2 1148 pointer_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
e2c2a699
AW		 1149}
1150
1151/*
1152 Local Variables:
1153 c-file-style: "gnu"
1154 End:
1155*/
Unnamed repository; edit this file 'description' to name the repository.