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