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