1 /* Copyright (C) 2010, 2011, 2012, 2013 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
30 #include "libguile/_scm.h"
31 #include "libguile/bytevectors.h"
32 #include "libguile/instructions.h"
33 #include "libguile/threads.h"
34 #include "libguile/foreign.h"
38 SCM_SYMBOL (sym_void
, "void");
39 SCM_SYMBOL (sym_float
, "float");
40 SCM_SYMBOL (sym_double
, "double");
41 SCM_SYMBOL (sym_uint8
, "uint8");
42 SCM_SYMBOL (sym_int8
, "int8");
43 SCM_SYMBOL (sym_uint16
, "uint16");
44 SCM_SYMBOL (sym_int16
, "int16");
45 SCM_SYMBOL (sym_uint32
, "uint32");
46 SCM_SYMBOL (sym_int32
, "int32");
47 SCM_SYMBOL (sym_uint64
, "uint64");
48 SCM_SYMBOL (sym_int64
, "int64");
49 SCM_SYMBOL (sym_short
, "short");
50 SCM_SYMBOL (sym_int
, "int");
51 SCM_SYMBOL (sym_long
, "long");
52 SCM_SYMBOL (sym_unsigned_short
, "unsigned-short");
53 SCM_SYMBOL (sym_unsigned_int
, "unsigned-int");
54 SCM_SYMBOL (sym_unsigned_long
, "unsigned-long");
55 SCM_SYMBOL (sym_size_t
, "size_t");
56 SCM_SYMBOL (sym_ssize_t
, "ssize_t");
57 SCM_SYMBOL (sym_ptrdiff_t
, "ptrdiff_t");
59 /* that's for pointers, you know. */
60 SCM_SYMBOL (sym_asterisk
, "*");
62 SCM_SYMBOL (sym_null
, "%null-pointer");
63 SCM_SYMBOL (sym_null_pointer_error
, "null-pointer-error");
65 /* The cell representing the null pointer. */
66 static SCM null_pointer
;
68 #if SIZEOF_VOID_P == 4
69 # define scm_to_uintptr scm_to_uint32
70 # define scm_from_uintptr scm_from_uint32
71 #elif SIZEOF_VOID_P == 8
72 # define scm_to_uintptr scm_to_uint64
73 # define scm_from_uintptr scm_from_uint64
75 # error unsupported pointer size
79 /* Raise a null pointer dereference error. */
81 null_pointer_error (const char *func_name
)
83 scm_error (sym_null_pointer_error
, func_name
,
84 "null pointer dereference", SCM_EOL
, SCM_EOL
);
88 static SCM
cif_to_procedure (SCM cif
, SCM func_ptr
);
91 static SCM pointer_weak_refs
= SCM_BOOL_F
;
92 static scm_i_pthread_mutex_t weak_refs_lock
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
96 register_weak_reference (SCM from
, SCM to
)
98 scm_i_pthread_mutex_lock (&weak_refs_lock
);
99 scm_hashq_set_x (pointer_weak_refs
, from
, to
);
100 scm_i_pthread_mutex_unlock (&weak_refs_lock
);
104 pointer_finalizer_trampoline (void *ptr
, void *data
)
106 scm_t_pointer_finalizer finalizer
= data
;
107 finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr
)));
110 SCM_DEFINE (scm_pointer_p
, "pointer?", 1, 0, 0,
112 "Return @code{#t} if @var{obj} is a pointer object, "
113 "@code{#f} otherwise.\n")
114 #define FUNC_NAME s_scm_pointer_p
116 return scm_from_bool (SCM_POINTER_P (obj
));
120 SCM_DEFINE (scm_make_pointer
, "make-pointer", 1, 1, 0,
121 (SCM address
, SCM finalizer
),
122 "Return a foreign pointer object pointing to @var{address}. "
123 "If @var{finalizer} is passed, it should be a pointer to a "
124 "one-argument C function that will be called when the pointer "
125 "object becomes unreachable.")
126 #define FUNC_NAME s_scm_make_pointer
129 scm_t_uintptr c_address
;
131 c_address
= scm_to_uintptr (address
);
132 if (SCM_UNBNDP (finalizer
))
136 SCM_VALIDATE_POINTER (2, finalizer
);
137 c_finalizer
= SCM_POINTER_VALUE (finalizer
);
140 return scm_from_pointer ((void *) c_address
, c_finalizer
);
145 scm_to_pointer (SCM pointer
)
146 #define FUNC_NAME "scm_to_pointer"
148 SCM_VALIDATE_POINTER (1, pointer
);
149 return SCM_POINTER_VALUE (pointer
);
154 scm_from_pointer (void *ptr
, scm_t_pointer_finalizer finalizer
)
158 if (ptr
== NULL
&& finalizer
== NULL
)
162 ret
= scm_cell (scm_tc7_pointer
, (scm_t_bits
) ptr
);
165 scm_i_set_finalizer (SCM2PTR (ret
), pointer_finalizer_trampoline
,
172 SCM_DEFINE (scm_pointer_address
, "pointer-address", 1, 0, 0,
174 "Return the numerical value of @var{pointer}.")
175 #define FUNC_NAME s_scm_pointer_address
177 SCM_VALIDATE_POINTER (1, pointer
);
179 return scm_from_uintptr ((scm_t_uintptr
) SCM_POINTER_VALUE (pointer
));
183 SCM_DEFINE (scm_pointer_to_scm
, "pointer->scm", 1, 0, 0,
185 "Unsafely cast @var{pointer} to a Scheme object.\n"
186 "Cross your fingers!")
187 #define FUNC_NAME s_scm_pointer_to_scm
189 SCM_VALIDATE_POINTER (1, pointer
);
191 return SCM_PACK ((scm_t_bits
) SCM_POINTER_VALUE (pointer
));
195 SCM_DEFINE (scm_scm_to_pointer
, "scm->pointer", 1, 0, 0,
197 "Return a foreign pointer object with the @code{object-address}\n"
199 #define FUNC_NAME s_scm_scm_to_pointer
203 ret
= scm_from_pointer ((void*) SCM_UNPACK (scm
), NULL
);
205 register_weak_reference (ret
, scm
);
211 SCM_DEFINE (scm_pointer_to_bytevector
, "pointer->bytevector", 2, 2, 0,
212 (SCM pointer
, SCM len
, SCM offset
, SCM uvec_type
),
213 "Return a bytevector aliasing the @var{len} bytes pointed\n"
214 "to by @var{pointer}.\n\n"
215 "The user may specify an alternate default interpretation for\n"
216 "the memory by passing the @var{uvec_type} argument, to indicate\n"
217 "that the memory is an array of elements of that type.\n"
218 "@var{uvec_type} should be something that\n"
219 "@code{uniform-vector-element-type} would return, like @code{f32}\n"
221 "When @var{offset} is passed, it specifies the offset in bytes\n"
222 "relative to @var{pointer} of the memory region aliased by the\n"
223 "returned bytevector.")
224 #define FUNC_NAME s_scm_pointer_to_bytevector
228 size_t boffset
, blen
;
229 scm_t_array_element_type btype
;
231 SCM_VALIDATE_POINTER (1, pointer
);
232 ptr
= SCM_POINTER_VALUE (pointer
);
234 if (SCM_UNLIKELY (ptr
== NULL
))
235 null_pointer_error (FUNC_NAME
);
237 if (SCM_UNBNDP (uvec_type
))
238 btype
= SCM_ARRAY_ELEMENT_TYPE_VU8
;
242 for (i
= 0; i
<= SCM_ARRAY_ELEMENT_TYPE_LAST
; i
++)
243 if (scm_is_eq (uvec_type
, scm_i_array_element_types
[i
]))
247 case SCM_ARRAY_ELEMENT_TYPE_VU8
:
248 case SCM_ARRAY_ELEMENT_TYPE_U8
:
249 case SCM_ARRAY_ELEMENT_TYPE_S8
:
250 case SCM_ARRAY_ELEMENT_TYPE_U16
:
251 case SCM_ARRAY_ELEMENT_TYPE_S16
:
252 case SCM_ARRAY_ELEMENT_TYPE_U32
:
253 case SCM_ARRAY_ELEMENT_TYPE_S32
:
254 case SCM_ARRAY_ELEMENT_TYPE_U64
:
255 case SCM_ARRAY_ELEMENT_TYPE_S64
:
256 case SCM_ARRAY_ELEMENT_TYPE_F32
:
257 case SCM_ARRAY_ELEMENT_TYPE_F64
:
258 case SCM_ARRAY_ELEMENT_TYPE_C32
:
259 case SCM_ARRAY_ELEMENT_TYPE_C64
:
263 scm_wrong_type_arg_msg (FUNC_NAME
, SCM_ARG1
, uvec_type
,
264 "uniform vector type");
268 if (SCM_UNBNDP (offset
))
271 boffset
= scm_to_size_t (offset
);
273 blen
= scm_to_size_t (len
);
275 ret
= scm_c_take_typed_bytevector ((signed char *) ptr
+ boffset
,
277 register_weak_reference (ret
, pointer
);
282 SCM_DEFINE (scm_bytevector_to_pointer
, "bytevector->pointer", 1, 1, 0,
283 (SCM bv
, SCM offset
),
284 "Return a pointer pointer aliasing the memory pointed to by\n"
285 "@var{bv} or @var{offset} bytes after @var{bv} when @var{offset}\n"
287 #define FUNC_NAME s_scm_bytevector_to_pointer
293 SCM_VALIDATE_BYTEVECTOR (1, bv
);
294 ptr
= SCM_BYTEVECTOR_CONTENTS (bv
);
296 if (SCM_UNBNDP (offset
))
299 boffset
= scm_to_unsigned_integer (offset
, 0,
300 SCM_BYTEVECTOR_LENGTH (bv
) - 1);
302 ret
= scm_from_pointer (ptr
+ boffset
, NULL
);
303 register_weak_reference (ret
, bv
);
308 SCM_DEFINE (scm_set_pointer_finalizer_x
, "set-pointer-finalizer!", 2, 0, 0,
309 (SCM pointer
, SCM finalizer
),
310 "Arrange for the C procedure wrapped by @var{finalizer} to be\n"
311 "called on the pointer wrapped by @var{pointer} when @var{pointer}\n"
312 "becomes unreachable. Note: the C procedure should not call into\n"
313 "Scheme. If you need a Scheme finalizer, use guardians.")
314 #define FUNC_NAME s_scm_set_pointer_finalizer_x
316 SCM_VALIDATE_POINTER (1, pointer
);
317 SCM_VALIDATE_POINTER (2, finalizer
);
319 scm_i_add_finalizer (SCM2PTR (pointer
), pointer_finalizer_trampoline
,
320 SCM_POINTER_VALUE (finalizer
));
322 return SCM_UNSPECIFIED
;
327 scm_i_pointer_print (SCM pointer
, SCM port
, scm_print_state
*pstate
)
329 scm_puts ("#<pointer 0x", port
);
330 scm_uintprint (scm_to_uintptr (scm_pointer_address (pointer
)), 16, port
);
331 scm_putc ('>', port
);
335 /* Non-primitive helpers functions. These procedures could be
336 implemented in terms of the primitives above but would be inefficient
337 (heap allocation overhead, Scheme/C round trips, etc.) */
339 SCM_DEFINE (scm_dereference_pointer
, "dereference-pointer", 1, 0, 0,
341 "Assuming @var{pointer} points to a memory region that\n"
342 "holds a pointer, return this pointer.")
343 #define FUNC_NAME s_scm_dereference_pointer
347 SCM_VALIDATE_POINTER (1, pointer
);
349 ptr
= SCM_POINTER_VALUE (pointer
);
350 if (SCM_UNLIKELY (ptr
== NULL
))
351 null_pointer_error (FUNC_NAME
);
353 return scm_from_pointer (*ptr
, NULL
);
357 SCM_DEFINE (scm_string_to_pointer
, "string->pointer", 1, 1, 0,
358 (SCM string
, SCM encoding
),
359 "Return a foreign pointer to a nul-terminated copy of\n"
360 "@var{string} in the given @var{encoding}, defaulting to\n"
361 "the current locale encoding. The C string is freed when\n"
362 "the returned foreign pointer becomes unreachable.\n\n"
363 "This is the Scheme equivalent of @code{scm_to_stringn}.")
364 #define FUNC_NAME s_scm_string_to_pointer
366 SCM_VALIDATE_STRING (1, string
);
368 /* XXX: Finalizers slow down libgc; they could be avoided if
369 `scm_to_string' & co. were able to use libgc-allocated memory. */
371 if (SCM_UNBNDP (encoding
))
372 return scm_from_pointer (scm_to_locale_string (string
), free
);
378 SCM_VALIDATE_STRING (2, encoding
);
380 enc
= scm_to_locale_string (encoding
);
381 scm_dynwind_begin (0);
382 scm_dynwind_free (enc
);
384 ret
= scm_from_pointer
385 (scm_to_stringn (string
, NULL
, enc
,
386 scm_i_default_port_conversion_handler ()),
396 SCM_DEFINE (scm_pointer_to_string
, "pointer->string", 1, 2, 0,
397 (SCM pointer
, SCM length
, SCM encoding
),
398 "Return the string representing the C string pointed to by\n"
399 "@var{pointer}. If @var{length} is omitted or @code{-1}, the\n"
400 "string is assumed to be nul-terminated. Otherwise\n"
401 "@var{length} is the number of bytes in memory pointed to by\n"
402 "@var{pointer}. The C string is assumed to be in the given\n"
403 "@var{encoding}, defaulting to the current locale encoding.\n\n"
404 "This is the Scheme equivalent of @code{scm_from_stringn}.")
405 #define FUNC_NAME s_scm_pointer_to_string
409 SCM_VALIDATE_POINTER (1, pointer
);
411 if (SCM_UNBNDP (length
)
412 || scm_is_true (scm_eqv_p (length
, scm_from_int (-1))))
415 len
= scm_to_size_t (length
);
417 if (SCM_UNBNDP (encoding
))
418 return scm_from_locale_stringn (SCM_POINTER_VALUE (pointer
), len
);
424 SCM_VALIDATE_STRING (3, encoding
);
426 enc
= scm_to_locale_string (encoding
);
427 scm_dynwind_begin (0);
428 scm_dynwind_free (enc
);
430 ret
= scm_from_stringn (SCM_POINTER_VALUE (pointer
), len
, enc
,
431 scm_i_default_port_conversion_handler ());
442 SCM_DEFINE (scm_alignof
, "alignof", 1, 0, 0, (SCM type
),
443 "Return the alignment of @var{type}, in bytes.\n\n"
444 "@var{type} should be a valid C type, like @code{int}.\n"
445 "Alternately @var{type} may be the symbol @code{*}, in which\n"
446 "case the alignment of a pointer is returned. @var{type} may\n"
447 "also be a list of types, in which case the alignment of a\n"
448 "@code{struct} with ABI-conventional packing is returned.")
449 #define FUNC_NAME s_scm_alignof
451 if (SCM_I_INUMP (type
))
453 switch (SCM_I_INUM (type
))
455 case SCM_FOREIGN_TYPE_FLOAT
:
456 return scm_from_size_t (alignof_type (float));
457 case SCM_FOREIGN_TYPE_DOUBLE
:
458 return scm_from_size_t (alignof_type (double));
459 case SCM_FOREIGN_TYPE_UINT8
:
460 return scm_from_size_t (alignof_type (scm_t_uint8
));
461 case SCM_FOREIGN_TYPE_INT8
:
462 return scm_from_size_t (alignof_type (scm_t_int8
));
463 case SCM_FOREIGN_TYPE_UINT16
:
464 return scm_from_size_t (alignof_type (scm_t_uint16
));
465 case SCM_FOREIGN_TYPE_INT16
:
466 return scm_from_size_t (alignof_type (scm_t_int16
));
467 case SCM_FOREIGN_TYPE_UINT32
:
468 return scm_from_size_t (alignof_type (scm_t_uint32
));
469 case SCM_FOREIGN_TYPE_INT32
:
470 return scm_from_size_t (alignof_type (scm_t_int32
));
471 case SCM_FOREIGN_TYPE_UINT64
:
472 return scm_from_size_t (alignof_type (scm_t_uint64
));
473 case SCM_FOREIGN_TYPE_INT64
:
474 return scm_from_size_t (alignof_type (scm_t_int64
));
476 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
479 else if (scm_is_eq (type
, sym_asterisk
))
481 return scm_from_size_t (alignof_type (void*));
482 else if (scm_is_pair (type
))
484 /* TYPE is a structure. Section 3-3 of the i386, x86_64, PowerPC,
485 and SPARC P.S. of the System V ABI all say: "Aggregates
486 (structures and arrays) and unions assume the alignment of
487 their most strictly aligned component." */
490 for (max
= 0; scm_is_pair (type
); type
= SCM_CDR (type
))
494 align
= scm_to_size_t (scm_alignof (SCM_CAR (type
)));
499 return scm_from_size_t (max
);
502 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
506 SCM_DEFINE (scm_sizeof
, "sizeof", 1, 0, 0, (SCM type
),
507 "Return the size of @var{type}, in bytes.\n\n"
508 "@var{type} should be a valid C type, like @code{int}.\n"
509 "Alternately @var{type} may be the symbol @code{*}, in which\n"
510 "case the size of a pointer is returned. @var{type} may also\n"
511 "be a list of types, in which case the size of a @code{struct}\n"
512 "with ABI-conventional packing is returned.")
513 #define FUNC_NAME s_scm_sizeof
515 if (SCM_I_INUMP (type
))
517 switch (SCM_I_INUM (type
))
519 case SCM_FOREIGN_TYPE_FLOAT
:
520 return scm_from_size_t (sizeof (float));
521 case SCM_FOREIGN_TYPE_DOUBLE
:
522 return scm_from_size_t (sizeof (double));
523 case SCM_FOREIGN_TYPE_UINT8
:
524 return scm_from_size_t (sizeof (scm_t_uint8
));
525 case SCM_FOREIGN_TYPE_INT8
:
526 return scm_from_size_t (sizeof (scm_t_int8
));
527 case SCM_FOREIGN_TYPE_UINT16
:
528 return scm_from_size_t (sizeof (scm_t_uint16
));
529 case SCM_FOREIGN_TYPE_INT16
:
530 return scm_from_size_t (sizeof (scm_t_int16
));
531 case SCM_FOREIGN_TYPE_UINT32
:
532 return scm_from_size_t (sizeof (scm_t_uint32
));
533 case SCM_FOREIGN_TYPE_INT32
:
534 return scm_from_size_t (sizeof (scm_t_int32
));
535 case SCM_FOREIGN_TYPE_UINT64
:
536 return scm_from_size_t (sizeof (scm_t_uint64
));
537 case SCM_FOREIGN_TYPE_INT64
:
538 return scm_from_size_t (sizeof (scm_t_int64
));
540 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
543 else if (scm_is_eq (type
, sym_asterisk
))
545 return scm_from_size_t (sizeof (void*));
546 else if (scm_is_pair (type
))
550 while (scm_is_pair (type
))
552 off
= ROUND_UP (off
, scm_to_size_t (scm_alignof (scm_car (type
))));
553 off
+= scm_to_size_t (scm_sizeof (scm_car (type
)));
554 type
= scm_cdr (type
);
556 return scm_from_size_t (off
);
559 scm_wrong_type_arg (FUNC_NAME
, 1, type
);
564 /* return 1 on success, 0 on failure */
566 parse_ffi_type (SCM type
, int return_p
, long *n_structs
, long *n_struct_elts
)
568 if (SCM_I_INUMP (type
))
570 if ((SCM_I_INUM (type
) < 0 )
571 || (SCM_I_INUM (type
) > SCM_FOREIGN_TYPE_LAST
))
573 else if (SCM_I_INUM (type
) == SCM_FOREIGN_TYPE_VOID
&& !return_p
)
578 else if (scm_is_eq (type
, sym_asterisk
))
585 len
= scm_ilength (type
);
590 if (!parse_ffi_type (scm_car (type
), 0, n_structs
, n_struct_elts
))
593 type
= scm_cdr (type
);
601 fill_ffi_type (SCM type
, ffi_type
*ftype
, ffi_type
***type_ptrs
,
604 if (SCM_I_INUMP (type
))
606 switch (SCM_I_INUM (type
))
608 case SCM_FOREIGN_TYPE_FLOAT
:
609 *ftype
= ffi_type_float
;
611 case SCM_FOREIGN_TYPE_DOUBLE
:
612 *ftype
= ffi_type_double
;
614 case SCM_FOREIGN_TYPE_UINT8
:
615 *ftype
= ffi_type_uint8
;
617 case SCM_FOREIGN_TYPE_INT8
:
618 *ftype
= ffi_type_sint8
;
620 case SCM_FOREIGN_TYPE_UINT16
:
621 *ftype
= ffi_type_uint16
;
623 case SCM_FOREIGN_TYPE_INT16
:
624 *ftype
= ffi_type_sint16
;
626 case SCM_FOREIGN_TYPE_UINT32
:
627 *ftype
= ffi_type_uint32
;
629 case SCM_FOREIGN_TYPE_INT32
:
630 *ftype
= ffi_type_sint32
;
632 case SCM_FOREIGN_TYPE_UINT64
:
633 *ftype
= ffi_type_uint64
;
635 case SCM_FOREIGN_TYPE_INT64
:
636 *ftype
= ffi_type_sint64
;
638 case SCM_FOREIGN_TYPE_VOID
:
639 *ftype
= ffi_type_void
;
642 scm_wrong_type_arg_msg ("pointer->procedure", 0, type
,
646 else if (scm_is_eq (type
, sym_asterisk
))
649 *ftype
= ffi_type_pointer
;
656 len
= scm_ilength (type
);
659 ftype
->alignment
= 0;
660 ftype
->type
= FFI_TYPE_STRUCT
;
661 ftype
->elements
= *type_ptrs
;
662 *type_ptrs
+= len
+ 1;
664 for (i
= 0; i
< len
; i
++)
666 ftype
->elements
[i
] = *types
;
668 fill_ffi_type (scm_car (type
), ftype
->elements
[i
],
670 type
= scm_cdr (type
);
672 ftype
->elements
[i
] = NULL
;
676 /* Return a "cif" (call interface) for the given RETURN_TYPE and
679 make_cif (SCM return_type
, SCM arg_types
, const char *caller
)
680 #define FUNC_NAME caller
683 long i
, nargs
, n_structs
, n_struct_elts
;
687 ffi_type
**type_ptrs
;
690 nargs
= scm_ilength (arg_types
);
691 SCM_ASSERT (nargs
>= 0, arg_types
, 3, FUNC_NAME
);
692 /* fixme: assert nargs < 1<<32 */
693 n_structs
= n_struct_elts
= 0;
695 /* For want of talloc, we're going to have to do this in two passes: first we
696 figure out how much memory is needed for all types, then we allocate the
697 cif and the types all in one block. */
698 if (!parse_ffi_type (return_type
, 1, &n_structs
, &n_struct_elts
))
699 scm_wrong_type_arg (FUNC_NAME
, 1, return_type
);
700 for (walk
= arg_types
; scm_is_pair (walk
); walk
= scm_cdr (walk
))
701 if (!parse_ffi_type (scm_car (walk
), 0, &n_structs
, &n_struct_elts
))
702 scm_wrong_type_arg (FUNC_NAME
, 3, scm_car (walk
));
704 /* the memory: with space for the cif itself */
705 cif_len
= sizeof (ffi_cif
);
707 /* then ffi_type pointers: one for each arg, one for each struct
708 element, and one for each struct (for null-termination) */
709 cif_len
= (ROUND_UP (cif_len
, alignof_type (void *))
710 + (nargs
+ n_structs
+ n_struct_elts
)*sizeof(void*));
712 /* then the ffi_type structs themselves, one per arg and struct element, and
713 one for the return val */
714 cif_len
= (ROUND_UP (cif_len
, alignof_type (ffi_type
))
715 + (nargs
+ n_struct_elts
+ 1)*sizeof(ffi_type
));
717 mem
= scm_gc_malloc_pointerless (cif_len
, "foreign");
718 /* ensure all the memory is initialized, even the holes */
719 memset (mem
, 0, cif_len
);
720 cif
= (ffi_cif
*) mem
;
722 /* reuse cif_len to walk through the mem */
723 cif_len
= ROUND_UP (sizeof (ffi_cif
), alignof_type (void *));
724 type_ptrs
= (ffi_type
**)(mem
+ cif_len
);
725 cif_len
= ROUND_UP (cif_len
726 + (nargs
+ n_structs
+ n_struct_elts
)*sizeof(void*),
727 alignof_type (ffi_type
));
728 types
= (ffi_type
*)(mem
+ cif_len
);
730 /* whew. now knit the pointers together. */
731 cif
->rtype
= types
++;
732 fill_ffi_type (return_type
, cif
->rtype
, &type_ptrs
, &types
);
733 cif
->arg_types
= type_ptrs
;
735 for (walk
= arg_types
, i
= 0; scm_is_pair (walk
); walk
= scm_cdr (walk
), i
++)
737 cif
->arg_types
[i
] = types
++;
738 fill_ffi_type (scm_car (walk
), cif
->arg_types
[i
], &type_ptrs
, &types
);
741 /* round out the cif, and we're done. */
742 cif
->abi
= FFI_DEFAULT_ABI
;
747 if (FFI_OK
!= ffi_prep_cif (cif
, FFI_DEFAULT_ABI
, cif
->nargs
, cif
->rtype
,
749 SCM_MISC_ERROR ("ffi_prep_cif failed", SCM_EOL
);
755 SCM_DEFINE (scm_pointer_to_procedure
, "pointer->procedure", 3, 0, 0,
756 (SCM return_type
, SCM func_ptr
, SCM arg_types
),
757 "Make a foreign function.\n\n"
758 "Given the foreign void pointer @var{func_ptr}, its argument and\n"
759 "return types @var{arg_types} and @var{return_type}, return a\n"
760 "procedure that will pass arguments to the foreign function\n"
761 "and return appropriate values.\n\n"
762 "@var{arg_types} should be a list of foreign types.\n"
763 "@code{return_type} should be a foreign type.")
764 #define FUNC_NAME s_scm_pointer_to_procedure
768 SCM_VALIDATE_POINTER (2, func_ptr
);
770 cif
= make_cif (return_type
, arg_types
, FUNC_NAME
);
772 return cif_to_procedure (scm_from_pointer (cif
, NULL
), func_ptr
);
778 /* Pre-generate trampolines for less than 10 arguments. */
780 #ifdef WORDS_BIGENDIAN
781 #define OBJCODE_HEADER(M) M (0), M (0), M (0), M (8), M (0), M (0), M (0), M (40)
782 #define META_HEADER(M) M (0), M (0), M (0), M (32), M (0), M (0), M (0), M (0)
784 #define OBJCODE_HEADER(M) M (8), M (0), M (0), M (0), M (40), M (0), M (0), M (0)
785 #define META_HEADER(M) M (32), M (0), M (0), M (0), M (0), M (0), M (0), M (0)
788 #define GEN_CODE(M, nreq) \
789 OBJCODE_HEADER (M), \
790 /* 0 */ M (scm_op_assert_nargs_ee), M (0), M (nreq), /* assert number of args */ \
791 /* 3 */ M (scm_op_object_ref), M (0), /* push the pair with the cif and the function pointer */ \
792 /* 5 */ M (scm_op_foreign_call), M (nreq), /* and call (will return value as well) */ \
793 /* 7 */ M (scm_op_nop), \
794 /* 8 */ META (M, 3, 7, nreq)
796 #define META(M, start, end, nreq) \
798 /* 0 */ M (scm_op_make_eol), /* bindings */ \
799 /* 1 */ M (scm_op_make_eol), /* sources */ \
800 /* 2 */ M (scm_op_make_int8), M (start), M (scm_op_make_int8), M (end), /* arity: from ip N to ip N */ \
801 /* 6 */ M (scm_op_make_int8), M (nreq), /* the arity is N required args */ \
802 /* 8 */ M (scm_op_list), M (0), M (3), /* make a list of those 3 vals */ \
803 /* 11 */ M (scm_op_list), M (0), M (1), /* and the arities will be a list of that one list */ \
804 /* 14 */ M (scm_op_load_symbol), M (0), M (0), M (4), M ('n'), M ('a'), M ('M'), M ('e'), /* `name' */ \
805 /* 22 */ M (scm_op_object_ref), M (1), /* the name from the object table */ \
806 /* 24 */ M (scm_op_cons), /* make a pair for the properties */ \
807 /* 25 */ M (scm_op_list), M (0), M (4), /* pack bindings, sources, and arities into list */ \
808 /* 28 */ M (scm_op_return), /* and return */ \
809 /* 29 */ M (scm_op_nop), M (scm_op_nop), M (scm_op_nop) \
812 #define M_STATIC(x) (x)
813 #define CODE(nreq) GEN_CODE (M_STATIC, nreq)
817 scm_t_uint64 dummy
; /* ensure 8-byte alignment; perhaps there's a better way */
818 const scm_t_uint8 bytes
[10 * (sizeof (struct scm_objcode
) + 8
819 + sizeof (struct scm_objcode
) + 32)];
823 CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
824 CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
829 make_objcode_trampoline (unsigned int nargs
)
831 const int size
= sizeof (struct scm_objcode
) + 8
832 + sizeof (struct scm_objcode
) + 32;
833 SCM bytecode
= scm_c_make_bytevector (size
);
834 scm_t_uint8
*bytes
= (scm_t_uint8
*) SCM_BYTEVECTOR_CONTENTS (bytecode
);
837 #define M_DYNAMIC(x) (bytes[i++] = (x))
838 GEN_CODE (M_DYNAMIC
, nargs
);
842 scm_syserror ("make_objcode_trampoline");
843 return scm_bytecode_to_native_objcode (bytecode
);
850 #undef OBJCODE_HEADER
854 (defun generate-objcode-cells (n)
855 "Generate objcode cells for up to N arguments"
860 (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
861 (* (+ 4 4 8 4 4 32) i)))
862 (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
865 #define STATIC_OBJCODE_TAG \
866 SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
870 scm_t_uint64 dummy
; /* alignment */
871 scm_t_cell cells
[10 * 2]; /* 10 double cells */
874 /* C-u 1 0 M-x generate-objcode-cells RET */
876 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 0) },
877 { SCM_BOOL_F
, SCM_PACK (0) },
878 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 56) },
879 { SCM_BOOL_F
, SCM_PACK (0) },
880 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 112) },
881 { SCM_BOOL_F
, SCM_PACK (0) },
882 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 168) },
883 { SCM_BOOL_F
, SCM_PACK (0) },
884 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 224) },
885 { SCM_BOOL_F
, SCM_PACK (0) },
886 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 280) },
887 { SCM_BOOL_F
, SCM_PACK (0) },
888 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 336) },
889 { SCM_BOOL_F
, SCM_PACK (0) },
890 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 392) },
891 { SCM_BOOL_F
, SCM_PACK (0) },
892 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 448) },
893 { SCM_BOOL_F
, SCM_PACK (0) },
894 { STATIC_OBJCODE_TAG
, SCM_PACK (raw_bytecode
.bytes
+ 504) },
895 { SCM_BOOL_F
, SCM_PACK (0) }
899 static const SCM objcode_trampolines
[10] = {
900 SCM_PACK (objcode_cells
.cells
+0),
901 SCM_PACK (objcode_cells
.cells
+2),
902 SCM_PACK (objcode_cells
.cells
+4),
903 SCM_PACK (objcode_cells
.cells
+6),
904 SCM_PACK (objcode_cells
.cells
+8),
905 SCM_PACK (objcode_cells
.cells
+10),
906 SCM_PACK (objcode_cells
.cells
+12),
907 SCM_PACK (objcode_cells
.cells
+14),
908 SCM_PACK (objcode_cells
.cells
+16),
909 SCM_PACK (objcode_cells
.cells
+18),
912 static SCM large_objcode_trampolines
= SCM_UNDEFINED
;
913 static scm_i_pthread_mutex_t large_objcode_trampolines_mutex
=
914 SCM_I_PTHREAD_MUTEX_INITIALIZER
;
917 get_objcode_trampoline (unsigned int nargs
)
922 objcode
= objcode_trampolines
[nargs
];
923 else if (nargs
< 128)
925 scm_i_scm_pthread_mutex_lock (&large_objcode_trampolines_mutex
);
926 if (SCM_UNBNDP (large_objcode_trampolines
))
927 large_objcode_trampolines
= scm_c_make_vector (128, SCM_UNDEFINED
);
928 objcode
= scm_c_vector_ref (large_objcode_trampolines
, nargs
);
929 if (SCM_UNBNDP (objcode
))
930 scm_c_vector_set_x (large_objcode_trampolines
, nargs
,
931 objcode
= make_objcode_trampoline (nargs
));
932 scm_i_pthread_mutex_unlock (&large_objcode_trampolines_mutex
);
935 scm_misc_error ("make-foreign-function", "args >= 128 currently unimplemented",
942 cif_to_procedure (SCM cif
, SCM func_ptr
)
945 SCM objcode
, table
, ret
;
947 c_cif
= (ffi_cif
*) SCM_POINTER_VALUE (cif
);
948 objcode
= get_objcode_trampoline (c_cif
->nargs
);
950 table
= scm_c_make_vector (2, SCM_UNDEFINED
);
951 SCM_SIMPLE_VECTOR_SET (table
, 0, scm_cons (cif
, func_ptr
));
952 SCM_SIMPLE_VECTOR_SET (table
, 1, SCM_BOOL_F
); /* name */
953 ret
= scm_make_program (objcode
, table
, SCM_BOOL_F
);
958 /* Set *LOC to the foreign representation of X with TYPE. */
960 unpack (const ffi_type
*type
, void *loc
, SCM x
, int return_value_p
)
961 #define FUNC_NAME "scm_i_foreign_call"
966 *(float *) loc
= scm_to_double (x
);
968 case FFI_TYPE_DOUBLE
:
969 *(double *) loc
= scm_to_double (x
);
972 /* For integer return values smaller than `int', libffi expects the
973 result in an `ffi_arg'-long buffer. */
977 *(ffi_arg
*) loc
= scm_to_uint8 (x
);
979 *(scm_t_uint8
*) loc
= scm_to_uint8 (x
);
983 *(ffi_arg
*) loc
= scm_to_int8 (x
);
985 *(scm_t_int8
*) loc
= scm_to_int8 (x
);
987 case FFI_TYPE_UINT16
:
989 *(ffi_arg
*) loc
= scm_to_uint16 (x
);
991 *(scm_t_uint16
*) loc
= scm_to_uint16 (x
);
993 case FFI_TYPE_SINT16
:
995 *(ffi_arg
*) loc
= scm_to_int16 (x
);
997 *(scm_t_int16
*) loc
= scm_to_int16 (x
);
999 case FFI_TYPE_UINT32
:
1001 *(ffi_arg
*) loc
= scm_to_uint32 (x
);
1003 *(scm_t_uint32
*) loc
= scm_to_uint32 (x
);
1005 case FFI_TYPE_SINT32
:
1007 *(ffi_arg
*) loc
= scm_to_int32 (x
);
1009 *(scm_t_int32
*) loc
= scm_to_int32 (x
);
1011 case FFI_TYPE_UINT64
:
1012 *(scm_t_uint64
*) loc
= scm_to_uint64 (x
);
1014 case FFI_TYPE_SINT64
:
1015 *(scm_t_int64
*) loc
= scm_to_int64 (x
);
1017 case FFI_TYPE_STRUCT
:
1018 SCM_VALIDATE_POINTER (1, x
);
1019 memcpy (loc
, SCM_POINTER_VALUE (x
), type
->size
);
1021 case FFI_TYPE_POINTER
:
1022 SCM_VALIDATE_POINTER (1, x
);
1023 *(void **) loc
= SCM_POINTER_VALUE (x
);
1034 /* Return a Scheme representation of the foreign value at LOC of type
1035 TYPE. When RETURN_VALUE_P is true, LOC is assumed to point to a
1036 return value buffer; otherwise LOC is assumed to point to an
1039 pack (const ffi_type
* type
, const void *loc
, int return_value_p
)
1044 return SCM_UNSPECIFIED
;
1045 case FFI_TYPE_FLOAT
:
1046 return scm_from_double (*(float *) loc
);
1047 case FFI_TYPE_DOUBLE
:
1048 return scm_from_double (*(double *) loc
);
1050 /* For integer return values smaller than `int', libffi stores the
1051 result in an `ffi_arg'-long buffer, of which only the
1052 significant bits must be kept---hence the pair of casts below.
1053 See <http://thread.gmane.org/gmane.comp.lib.ffi.general/406>
1056 case FFI_TYPE_UINT8
:
1058 return scm_from_uint8 ((scm_t_uint8
) *(ffi_arg
*) loc
);
1060 return scm_from_uint8 (* (scm_t_uint8
*) loc
);
1061 case FFI_TYPE_SINT8
:
1063 return scm_from_int8 ((scm_t_int8
) *(ffi_arg
*) loc
);
1065 return scm_from_int8 (* (scm_t_int8
*) loc
);
1066 case FFI_TYPE_UINT16
:
1068 return scm_from_uint16 ((scm_t_uint16
) *(ffi_arg
*) loc
);
1070 return scm_from_uint16 (* (scm_t_uint16
*) loc
);
1071 case FFI_TYPE_SINT16
:
1073 return scm_from_int16 ((scm_t_int16
) *(ffi_arg
*) loc
);
1075 return scm_from_int16 (* (scm_t_int16
*) loc
);
1076 case FFI_TYPE_UINT32
:
1078 return scm_from_uint32 ((scm_t_uint32
) *(ffi_arg
*) loc
);
1080 return scm_from_uint32 (* (scm_t_uint32
*) loc
);
1081 case FFI_TYPE_SINT32
:
1083 return scm_from_int32 ((scm_t_int32
) *(ffi_arg
*) loc
);
1085 return scm_from_int32 (* (scm_t_int32
*) loc
);
1086 case FFI_TYPE_UINT64
:
1087 return scm_from_uint64 (*(scm_t_uint64
*) loc
);
1088 case FFI_TYPE_SINT64
:
1089 return scm_from_int64 (*(scm_t_int64
*) loc
);
1091 case FFI_TYPE_STRUCT
:
1093 void *mem
= scm_gc_malloc_pointerless (type
->size
, "foreign");
1094 memcpy (mem
, loc
, type
->size
);
1095 return scm_from_pointer (mem
, NULL
);
1097 case FFI_TYPE_POINTER
:
1098 return scm_from_pointer (*(void **) loc
, NULL
);
1106 scm_i_foreign_call (SCM foreign
, const SCM
*argv
)
1108 /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
1111 void (*func
) (void);
1119 cif
= SCM_POINTER_VALUE (SCM_CAR (foreign
));
1120 func
= SCM_POINTER_VALUE (SCM_CDR (foreign
));
1122 /* Argument pointers. */
1123 args
= alloca (sizeof (void *) * cif
->nargs
);
1125 /* Compute the worst-case amount of memory needed to store all the argument
1126 values. Note: as of libffi 3.0.9 `cif->bytes' is undocumented and is zero,
1127 so it can't be used for that purpose. */
1128 for (i
= 0, arg_size
= 0; i
< cif
->nargs
; i
++)
1129 arg_size
+= cif
->arg_types
[i
]->size
+ cif
->arg_types
[i
]->alignment
- 1;
1131 /* Space for argument values, followed by return value. */
1132 data
= alloca (arg_size
+ cif
->rtype
->size
1133 + max (sizeof (void *), cif
->rtype
->alignment
));
1135 /* Unpack ARGV to native values, setting ARGV pointers. */
1136 for (i
= 0, off
= 0;
1138 off
= (scm_t_uint8
*) args
[i
] - data
+ cif
->arg_types
[i
]->size
,
1141 /* Suitably align the storage area for argument I. */
1142 args
[i
] = (void *) ROUND_UP ((scm_t_uintptr
) data
+ off
,
1143 cif
->arg_types
[i
]->alignment
);
1144 assert ((scm_t_uintptr
) args
[i
] % cif
->arg_types
[i
]->alignment
== 0);
1145 unpack (cif
->arg_types
[i
], args
[i
], argv
[i
], 0);
1148 /* Prepare space for the return value. On some platforms, such as
1149 `armv5tel-*-linux-gnueabi', the return value has to be at least
1150 word-aligned, even if its type doesn't have any alignment requirement as is
1151 the case with `char'. */
1152 rvalue
= (void *) ROUND_UP ((scm_t_uintptr
) data
+ off
,
1153 max (sizeof (void *), cif
->rtype
->alignment
));
1156 ffi_call (cif
, func
, rvalue
, args
);
1158 return pack (cif
->rtype
, rvalue
, 1);
1162 /* Function pointers aka. "callbacks" or "closures". */
1166 /* Trampoline to invoke a libffi closure that wraps a Scheme
1169 invoke_closure (ffi_cif
*cif
, void *ret
, void **args
, void *data
)
1172 SCM proc
, *argv
, result
;
1174 proc
= PTR2SCM (data
);
1176 argv
= alloca (cif
->nargs
* sizeof (*argv
));
1178 /* Pack ARGS to SCM values, setting ARGV pointers. */
1179 for (i
= 0; i
< cif
->nargs
; i
++)
1180 argv
[i
] = pack (cif
->arg_types
[i
], args
[i
], 0);
1182 result
= scm_call_n (proc
, argv
, cif
->nargs
);
1184 unpack (cif
->rtype
, ret
, result
, 1);
1187 SCM_DEFINE (scm_procedure_to_pointer
, "procedure->pointer", 3, 0, 0,
1188 (SCM return_type
, SCM proc
, SCM arg_types
),
1189 "Return a pointer to a C function of type @var{return_type}\n"
1190 "taking arguments of types @var{arg_types} (a list) and\n"
1191 "behaving as a proxy to procedure @var{proc}. Thus\n"
1192 "@var{proc}'s arity, supported argument types, and return\n"
1193 "type should match @var{return_type} and @var{arg_types}.\n")
1194 #define FUNC_NAME s_scm_procedure_to_pointer
1196 SCM cif_pointer
, pointer
;
1199 void *closure
, *executable
;
1201 cif
= make_cif (return_type
, arg_types
, FUNC_NAME
);
1203 closure
= ffi_closure_alloc (sizeof (ffi_closure
), &executable
);
1204 err
= ffi_prep_closure_loc ((ffi_closure
*) closure
, cif
,
1205 invoke_closure
, SCM2PTR (proc
),
1209 ffi_closure_free (closure
);
1210 SCM_MISC_ERROR ("`ffi_prep_closure_loc' failed", SCM_EOL
);
1213 /* CIF points to GC-managed memory and it should remain as long as
1214 POINTER (see below) is live. Wrap it in a Scheme pointer to then
1215 hold a weak reference on it. */
1216 cif_pointer
= scm_from_pointer (cif
, NULL
);
1218 if (closure
== executable
)
1220 pointer
= scm_from_pointer (executable
, ffi_closure_free
);
1221 register_weak_reference (pointer
,
1222 scm_list_2 (proc
, cif_pointer
));
1226 /* CLOSURE needs to be freed eventually. However, since
1227 `GC_all_interior_pointers' is disabled, we can't just register
1228 a finalizer for CLOSURE. Instead, we create a pointer object
1229 for CLOSURE, with a finalizer, and register it as a weak
1230 reference of POINTER. */
1233 pointer
= scm_from_pointer (executable
, NULL
);
1234 friend = scm_from_pointer (closure
, ffi_closure_free
);
1236 register_weak_reference (pointer
,
1237 scm_list_3 (proc
, cif_pointer
, friend));
1244 #endif /* FFI_CLOSURES */
1249 scm_init_foreign (void)
1251 #ifndef SCM_MAGIC_SNARFER
1252 #include "libguile/foreign.x"
1254 scm_define (sym_void
, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID
));
1255 scm_define (sym_float
, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT
));
1256 scm_define (sym_double
, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE
));
1257 scm_define (sym_uint8
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8
));
1258 scm_define (sym_int8
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8
));
1259 scm_define (sym_uint16
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16
));
1260 scm_define (sym_int16
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT16
));
1261 scm_define (sym_uint32
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
));
1262 scm_define (sym_int32
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
));
1263 scm_define (sym_uint64
, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
));
1264 scm_define (sym_int64
, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
));
1266 scm_define (sym_short
,
1267 #if SIZEOF_SHORT == 8
1268 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1269 #elif SIZEOF_SHORT == 4
1270 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1271 #elif SIZEOF_SHORT == 2
1272 scm_from_uint8 (SCM_FOREIGN_TYPE_INT16
)
1274 # error unsupported sizeof (short)
1278 scm_define (sym_unsigned_short
,
1279 #if SIZEOF_SHORT == 8
1280 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1281 #elif SIZEOF_SHORT == 4
1282 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1283 #elif SIZEOF_SHORT == 2
1284 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16
)
1286 # error unsupported sizeof (short)
1290 scm_define (sym_int
,
1292 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1293 #elif SIZEOF_INT == 4
1294 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1296 # error unsupported sizeof (int)
1300 scm_define (sym_unsigned_int
,
1301 #if SIZEOF_UNSIGNED_INT == 8
1302 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1303 #elif SIZEOF_UNSIGNED_INT == 4
1304 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1306 # error unsupported sizeof (unsigned int)
1310 scm_define (sym_long
,
1311 #if SIZEOF_LONG == 8
1312 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1313 #elif SIZEOF_LONG == 4
1314 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1316 # error unsupported sizeof (long)
1320 scm_define (sym_unsigned_long
,
1321 #if SIZEOF_UNSIGNED_LONG == 8
1322 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1323 #elif SIZEOF_UNSIGNED_LONG == 4
1324 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1326 # error unsupported sizeof (unsigned long)
1330 scm_define (sym_size_t
,
1331 #if SIZEOF_SIZE_T == 8
1332 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64
)
1333 #elif SIZEOF_SIZE_T == 4
1334 scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32
)
1336 # error unsupported sizeof (size_t)
1340 scm_define (sym_ssize_t
,
1341 #if SIZEOF_SIZE_T == 8
1342 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1343 #elif SIZEOF_SIZE_T == 4
1344 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1346 # error unsupported sizeof (ssize_t)
1350 scm_define (sym_ptrdiff_t
,
1351 #if SCM_SIZEOF_SCM_T_PTRDIFF == 8
1352 scm_from_uint8 (SCM_FOREIGN_TYPE_INT64
)
1353 #elif SCM_SIZEOF_SCM_T_PTRDIFF == 4
1354 scm_from_uint8 (SCM_FOREIGN_TYPE_INT32
)
1356 # error unsupported sizeof (scm_t_ptrdiff)
1360 null_pointer
= scm_cell (scm_tc7_pointer
, 0);
1361 scm_define (sym_null
, null_pointer
);
1365 scm_register_foreign (void)
1367 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1369 (scm_t_extension_init_func
)scm_init_foreign
,
1371 pointer_weak_refs
= scm_make_weak_key_hash_table (SCM_UNDEFINED
);