1 /* Foreign language interface for CLISP
2 * Marcus Daniels 8.4.1994
3 * Bruno Haible 1995-2005, 2016-2018
4 * Sam Steingold 2000-2011, 2017
5 */
6
7 #include "lispbibl.c"
8 #include "arilev0.c" /* for mulu32_unchecked */
9 #undef valid
10
11 #ifdef DYNAMIC_FFI
12
13 BEGIN_DECLS
14 #include <avcall.h> /* Low level support for call-out */
15 #include <callback.h> /* Low level support for call-in */
16 END_DECLS
17
18 /* Convert a void* to a callback_t.
19 Note that this type only exists in libffcall >= 2.0. */
20 #if LIBFFCALL_VERSION >= 0x0200
21 #define cast_to_callback_t(address) (callback_t)(address)
22 #else
23 #define cast_to_callback_t(address) (address)
24 #endif
25
26
27 /* =================== Basic properties of foreign types =================== */
28
29 /* A foreign value descriptor describes an item of foreign data.
30 <c-type> ::=
31 <simple-c-type> as described in impnotes.html#dffi
32 c-pointer
33 c-string
34 #(c-struct name options slots constructor <c-type>*)
35 #(c-union alternatives <c-type>*)
36 #(c-array <c-type> number*)
37 #(c-array-max <c-type> number)
38 #(c-function <c-type> #({<c-type> flags}*) flags)
39 #(c-ptr <c-type>)
40 #(c-ptr-null <c-type>)
41 #(c-array-ptr <c-type>) */
42
43 #define C_STRUCT_SLOTS 3
44 #define C_STRUCT_CONSTRUCTOR (C_STRUCT_SLOTS+1)
45 #define C_STRUCT_C_TYPE_START (C_STRUCT_CONSTRUCTOR+1)
46
47 #define C_UNION_ALT 1
48 #define C_UNION_C_TYPE_START (C_UNION_ALT+1)
49
50
51 /* Error message. */
error_foreign_type(object fvd)52 local _Noreturn void error_foreign_type (object fvd) {
53 dynamic_bind(S(print_circle),T); /* bind *PRINT-CIRCLE* to T */
54 pushSTACK(fvd); pushSTACK(TheSubr(subr_self)->name);
55 error(error_condition,GETTEXT("~S: illegal foreign data type ~S"));
56 }
57
58
59 #if (long_bitsize<64) && !defined(HAVE_LONG_LONG_INT)
60 /* use long long type with ffcall when possible, otherwise pass
61 64-bit integers as structs. Note that long long is incompatible
62 with struct passing/returning with gcc/i386/Linux, whereas struct
63 passing was tested compatible with MSVC6' __int64 type. */
64 #if BIG_ENDIAN_P
65 typedef struct { uint32 hi; uint32 lo; } struct_uint64;
66 typedef struct { sint32 hi; uint32 lo; } struct_sint64;
67 #else
68 typedef struct { uint32 lo; uint32 hi; } struct_uint64;
69 typedef struct { uint32 lo; sint32 hi; } struct_sint64;
70 #endif
71 #else
72 #define struct_uint64 uint64
73 #define struct_sint64 sint64
74 #endif
75
76 /* Size, Alignment, Splittable -- layout of the foreign data */
77 struct foreign_layout {
78 uintL size; /* size (in bytes) of the type */
79 uintL alignment; /* alignment (in bytes) of the type */
80 bool splittable; /* splittable flag, if a struct/union/array type */
81 };
82
83
84 /* Compute the size and alignment of foreign data.
85 foreign_layout(fvd, struct foreign_layout *data);
86 > fvd: foreign value descriptor
87 < data: foreign layout */
88 local void foreign_layout (object fvd, struct foreign_layout *data);
89 /* `struct_alignment' is what gcc calls STRUCTURE_SIZE_BOUNDARY/8.
90 It is = 1 on most machines, but = 2 on M68K and = 4 on ARM. */
91 #ifdef __cplusplus
92 struct trivial_struct { char slot1; };
93 static const uintL struct_alignment = sizeof(struct trivial_struct);
94 #else
95 #define struct_alignment sizeof(struct { char slot1; })
96 #endif
foreign_layout(object fvd,struct foreign_layout * data)97 local void foreign_layout (object fvd, struct foreign_layout *data)
98 {
99 check_SP();
100 if (symbolp(fvd)) {
101 if (eq(fvd,S(nil))) {
102 data->size = 0; data->alignment = 1;
103 data->splittable = true; return;
104 } else if (eq(fvd,S(boolean))) {
105 data->size = sizeof(int); data->alignment = alignof(int);
106 data->splittable = true; return;
107 } else if (eq(fvd,S(character))) {
108 data->size = sizeof(unsigned char);
109 data->alignment = alignof(unsigned char);
110 data->splittable = true; return;
111 } else if (eq(fvd,S(char)) || eq(fvd,S(sint8))) {
112 data->size = sizeof(sint8); data->alignment = alignof(sint8);
113 data->splittable = true; return;
114 } else if (eq(fvd,S(uchar)) || eq(fvd,S(uint8))) {
115 data->size = sizeof(uint8); data->alignment = alignof(uint8);
116 data->splittable = true; return;
117 } else if (eq(fvd,S(short)) || eq(fvd,S(sint16))) {
118 data->size = sizeof(sint16); data->alignment = alignof(sint16);
119 data->splittable = true; return;
120 } else if (eq(fvd,S(ushort)) || eq(fvd,S(uint16))) {
121 data->size = sizeof(uint16); data->alignment = alignof(uint16);
122 data->splittable = true; return;
123 } else if (eq(fvd,S(sint32))) {
124 data->size = sizeof(sint32); data->alignment = alignof(sint32);
125 data->splittable = true; return;
126 } else if (eq(fvd,S(uint32))) {
127 data->size = sizeof(uint32); data->alignment = alignof(uint32);
128 data->splittable = true; return;
129 } else if (eq(fvd,S(sint64))) {
130 #if (long_bitsize<64) && !defined(HAVE_LONG_LONG_INT)
131 data->size = sizeof(struct_sint64);
132 data->alignment = alignof(struct_sint64);
133 data->splittable = av_word_splittable_2(sint32,sint32); /* always true */
134 #else
135 data->size = sizeof(sint64); data->alignment = alignof(sint64);
136 data->splittable = av_word_splittable_1(sint64); /* always true */
137 #endif
138 return;
139 } else if (eq(fvd,S(uint64))) {
140 #if (long_bitsize<64) && !defined(HAVE_LONG_LONG_INT)
141 data->size = sizeof(struct_uint64);
142 data->alignment = alignof(struct_uint64);
143 data->splittable = av_word_splittable_2(uint32,uint32); /* always true */
144 #else
145 data->size = sizeof(uint64); data->alignment = alignof(uint64);
146 data->splittable = av_word_splittable_1(uint64); /* always true */
147 #endif
148 return;
149 } else if (eq(fvd,S(int))) {
150 data->size = sizeof(int); data->alignment = alignof(int);
151 data->splittable = true; return;
152 } else if (eq(fvd,S(uint))) {
153 data->size = sizeof(unsigned int);
154 data->alignment = alignof(unsigned int);
155 data->splittable = true; return;
156 } else if (eq(fvd,S(long))) {
157 data->size = sizeof(long); data->alignment = alignof(long);
158 data->splittable = true; return;
159 } else if (eq(fvd,S(ulong))) {
160 data->size = sizeof(unsigned long);
161 data->alignment = alignof(unsigned long);
162 data->splittable = true; return;
163 } else if (eq(fvd,S(single_float))) {
164 data->size = sizeof(float); data->alignment = alignof(float);
165 data->splittable = (sizeof(float) <= sizeof(long)); return;
166 } else if (eq(fvd,S(double_float))) {
167 data->size = sizeof(double); data->alignment = alignof(double);
168 data->splittable = (sizeof(double) <= sizeof(long)); return;
169 } else if (eq(fvd,S(c_pointer))) {
170 data->size = sizeof(void*); data->alignment = alignof(void*);
171 data->splittable = true; return;
172 } else if (eq(fvd,S(c_string))) {
173 data->size = sizeof(char*); data->alignment = alignof(char*);
174 data->splittable = true; return;
175 }
176 } else if (simple_vector_p(fvd)) {
177 var uintL fvdlen = Svector_length(fvd);
178 if (fvdlen > 0) {
179 var object fvdtype = TheSvector(fvd)->data[0];
180 if (eq(fvdtype,S(c_struct)) && (fvdlen >= C_STRUCT_C_TYPE_START)) {
181 var uintL cumul_size = 0;
182 var uintL cumul_alignment = struct_alignment;
183 var bool cumul_splittable = true;
184 var uintL i;
185 for (i = C_STRUCT_C_TYPE_START; i < fvdlen; i++) {
186 foreign_layout(TheSvector(fvd)->data[i],data);
187 /* We assume all alignments are of the form 2^k. */
188 cumul_size += (-cumul_size) & (data->alignment-1);
189 /* cumul_splittable = cumul_splittable AND
190 (cumul_size..cumul_size+data->size-1) fits in a word; */
191 if (floor(cumul_size,sizeof(long)) <
192 floor(cumul_size+data->size-1,sizeof(long)))
193 cumul_splittable = false;
194 cumul_size += data->size;
195 /* cumul_alignment = lcm(cumul_alignment,data->alignment); */
196 if (data->alignment > cumul_alignment)
197 cumul_alignment = data->alignment;
198 }
199 cumul_size += (-cumul_size) & (cumul_alignment-1);
200 data->size = cumul_size; data->alignment = cumul_alignment;
201 data->splittable = cumul_splittable;
202 return;
203 } else if (eq(fvdtype,S(c_union)) && (fvdlen > 1)) {
204 var uintL cumul_size = 0;
205 var uintL cumul_alignment = struct_alignment;
206 var bool cumul_splittable = false;
207 var uintL i;
208 for (i = 2; i < fvdlen; i++) {
209 foreign_layout(TheSvector(fvd)->data[i],data);
210 /* We assume all alignments are of the form 2^k.
211 cumul_size = max(cumul_size,data->size); */
212 if (data->size > cumul_size)
213 cumul_size = data->size;
214 /* cumul_alignment = lcm(cumul_alignment,data->alignment); */
215 if (data->alignment > cumul_alignment)
216 cumul_alignment = data->alignment;
217 /* cumul_splittable = cumul_splittable OR data->splittable; */
218 if (data->splittable)
219 cumul_splittable = true;
220 }
221 data->size = cumul_size; data->alignment = cumul_alignment;
222 data->splittable = cumul_splittable;
223 return;
224 } else if ((eq(fvdtype,S(c_array)) && (fvdlen > 1))
225 || (eq(fvdtype,S(c_array_max)) && (fvdlen == 3))) {
226 var uintL i;
227 foreign_layout(TheSvector(fvd)->data[1],data);
228 for (i = 2; i < fvdlen; i++) {
229 var object dim = TheSvector(fvd)->data[i];
230 if (!uint32_p(dim))
231 error_foreign_type(fvd);
232 data->size = data->size * I_to_uint32(dim);
233 }
234 data->splittable = (data->size <= sizeof(long));
235 return;
236 } else if (eq(fvdtype,S(c_function)) && (fvdlen == 4)) {
237 data->size = sizeof(void*); data->alignment = alignof(void*);
238 data->splittable = true; return;
239 } else if ((eq(fvdtype,S(c_ptr)) || eq(fvdtype,S(c_ptr_null))
240 || eq(fvdtype,S(c_pointer)) || eq(fvdtype,S(c_array_ptr)))
241 && (fvdlen == 2)) {
242 data->size = sizeof(void*); data->alignment = alignof(void*);
243 data->splittable = true; return;
244 }
245 }
246 } else {
247 var object inttype = gethash(fvd,O(foreign_inttype_table),false);
248 if (!eq(inttype,nullobj)) {
249 foreign_layout(inttype,data);
250 return;
251 }
252 }
253 error_foreign_type(fvd);
254 }
255
256 /* compute the size of the foreign data
257 < fvd: foreign value descriptor
258 > size: the size of the foreign data */
foreign_size(object fvd)259 local inline uintL foreign_size (object fvd) {
260 var struct foreign_layout sas;
261 foreign_layout(fvd,&sas);
262 return sas.size;
263 }
264
265 LISPFUNN(sizeof,1)
266 { /* (FFI::%SIZEOF c-type) returns the size and alignment of a C type,
267 measured in bytes. */
268 var object fvd = popSTACK();
269 var struct foreign_layout sas;
270 foreign_layout(fvd,&sas);
271 VALUES2(UL_to_I(sas.size),fixnum(sas.alignment));
272 }
273
274 LISPFUNN(bitsizeof,1)
275 { /* (FFI::%BITSIZEOF c-type) returns the size and alignment of a C type,
276 measured in bits. */
277 var object fvd = popSTACK();
278 var struct foreign_layout sas;
279 foreign_layout(fvd,&sas);
280 VALUES2(UL_to_I(8*sas.size),fixnum(8*sas.alignment));
281 }
282
check_fvar_alignment(object fvar,uintL alignment)283 static void check_fvar_alignment (object fvar, uintL alignment) {
284 if (((uintP)Faddress_value(TheFvariable(fvar)->fv_address) & (alignment-1))) {
285 pushSTACK(fvar); pushSTACK(TheSubr(subr_self)->name);
286 error(error_condition,GETTEXT("~S: foreign variable ~S does not have the required alignment"));
287 }
288 }
289
290
291 /* =================== Foreign pointer, foreign address =================== */
292
293 /* complain about non-foreign object */
error_foreign_object(object arg)294 local _Noreturn void error_foreign_object (object arg) {
295 pushSTACK(arg); pushSTACK(TheSubr(subr_self)->name);
296 error(error_condition,GETTEXT("~S: argument is not a foreign object: ~S"));
297 }
298
299 /* foreign address vs foreign pointer
300 - foreign pointers are available even when FFI is not
301 (used by berkeley-db and new-clx modules)
302 - foreign addresses can share the base which enables controlling validity
303 of resources (see impnotes.html#ex-dffi-validity)
304
305 Historically, the heavy weight foreign address objects come from Amiga:
306 A library entry point is a known (negative) offset towards the library
307 base pointer -- much like today's COM objects or vtables. */
308
309 /* Allocate a foreign address.
310 make_faddress(base,offset)
311 > base: base address
312 > offset: offset relative to the base address
313 < result: Lisp object
314 can trigger GC */
make_faddress(object base,uintP offset)315 modexp maygc object make_faddress (object base, uintP offset)
316 {
317 pushSTACK(base);
318 var object result = allocate_faddress();
319 TheFaddress(result)->fa_base = popSTACK(); /* base */
320 TheFaddress(result)->fa_offset = offset;
321 return result;
322 }
323
324 /* return the foreign address of the foreign object
325 can trigger GC -- only when allocate_p is TRUE */
foreign_address(object obj,bool allocate_p)326 local /*maygc*/ object foreign_address (object obj, bool allocate_p)
327 {
328 GCTRIGGER_IF(allocate_p,GCTRIGGER1(obj));
329 if (orecordp(obj)) {
330 switch (Record_type(obj)) {
331 case Rectype_Fpointer:
332 if (allocate_p) return make_faddress(obj,0);
333 pushSTACK(S(foreign_variable));
334 pushSTACK(S(foreign_function));
335 pushSTACK(S(foreign_address));
336 pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
337 error(error_condition,
338 GETTEXT("~S: argument ~S should be a ~S, ~S or ~S"));
339 case Rectype_Faddress:
340 return obj;
341 case Rectype_Fvariable:
342 return TheFvariable(obj)->fv_address;
343 case Rectype_Ffunction:
344 return TheFfunction(obj)->ff_address;
345 }
346 }
347 error_foreign_object(obj);
348 }
349
350 /* return the foreign pointer of the foreign object
351 or nullobj if the argument is not a foreign object */
foreign_pointer(object obj)352 local object foreign_pointer (object obj)
353 {
354 if (orecordp(obj)) {
355 switch (Record_type(obj)) {
356 case Rectype_Fpointer:
357 return obj;
358 case Rectype_Fvariable:
359 obj = TheFvariable(obj)->fv_address;
360 goto foreign_address;
361 case Rectype_Ffunction:
362 obj = TheFfunction(obj)->ff_address;
363 case Rectype_Faddress: foreign_address:
364 return TheFaddress(obj)->fa_base;
365 }
366 }
367 return nullobj; /* non-foreign object */
368 }
369
370 /* return the foreign pointer of the foreign object
371 and signal an error if the argument is not a foreign object */
foreign_pointer_strict(object obj)372 local object foreign_pointer_strict (object obj)
373 {
374 var object fp = foreign_pointer(obj);
375 if (eq(fp,nullobj)) error_foreign_object(obj);
376 return fp;
377 }
378
379 /* (FFI:VALIDP foreign-entity) tests whether a foreign entity
380 is still valid or refers to an invalid foreign pointer. */
381 LISPFUNNR(validp,1) {
382 var object fp = foreign_pointer(popSTACK());
383 VALUES_IF(eq(fp,nullobj) || fp_validp(TheFpointer(fp)));
384 }
385 LISPFUNN(set_validp,2)
386 { /* (setf (validp f-ent) new-value) */
387 var bool new_value = !nullp(popSTACK());
388 var object arg = popSTACK();
389 var object fp = foreign_pointer(arg);
390 if (eq(fp,nullobj)) /* permit new_value=true ? */
391 error_foreign_object(arg);
392 if (fp_validp(TheFpointer(fp))) {
393 if (!new_value) {
394 if (eq(fp,O(fp_zero))) {
395 pushSTACK(TheSubr(subr_self)->name);
396 error(error_condition,GETTEXT("~S: must not invalidate the sole FFI session pointer"));
397 }
398 mark_fp_invalid(TheFpointer(fp));
399 }
400 } else if (new_value) {
401 pushSTACK(fp); pushSTACK(TheSubr(subr_self)->name);
402 error(error_condition,GETTEXT("~S: cannot resurrect the zombie ~S"));
403 }
404 VALUES_IF(new_value);
405 }
406
407 /* FOREIGN-POINTER of this foreign entity */
408 LISPFUNNR(foreign_pointer,1)
409 { VALUES1(foreign_pointer_strict(popSTACK())); }
410
411 /* (FFI:SET-FOREIGN-POINTER foreign-entity other-entity)
412 returns foreign-entity modified to share pointer-base with other entity */
413 LISPFUNN(set_foreign_pointer,2)
414 {
415 /* TODO? restart that allows all of (OR (EQL :COPY) FOREIGN-xyz) */
416 var object address = check_faddress_valid(foreign_address(STACK_1,false));
417 var object new_fp = STACK_0;
418 STACK_0 = address;
419 /* Stack layout: f-entity f-entity-address. */
420 if (eq(new_fp,S(Kcopy))) {
421 var object fp = TheFaddress(address)->fa_base;
422 new_fp = allocate_fpointer(Fpointer_value(fp));
423 } else {
424 /* extract other entity's FOREIGN-POINTER */
425 new_fp = foreign_pointer_strict(new_fp);
426 var sintP offset =
427 (uintP)Faddress_value(address) - (uintP)Fpointer_value(new_fp);
428 TheFaddress(address)->fa_offset = offset;
429 }
430 TheFaddress(STACK_0)->fa_base = new_fp;
431 VALUES1(STACK_1); skipSTACK(2);
432 }
433
434 /* (FFI:UNSIGNED-FOREIGN-ADDRESS integer)
435 makes a FOREIGN-ADDRESS object out of an unsigned integer */
436 LISPFUNNR(unsigned_foreign_address,1) {
437 VALUES1(make_faddress(O(fp_zero),I_to_ulong(popSTACK())));
438 }
439
440 /* (FFI:FOREIGN-ADDRESS-UNSIGNED foreign-address)
441 returns the unsigned integer value of the FOREIGN-ADDRESS */
442 LISPFUNNR(foreign_address_unsigned,1) {
443 var object arg = popSTACK();
444 /* arg --> address */
445 if (fvariablep(arg)) arg = TheFvariable(arg)->fv_address;
446 else if (ffunctionp(arg)) arg = TheFfunction(arg)->ff_address;
447 /* address --> integer */
448 if (faddressp(arg)) value1 = ulong_to_I((uintP)Faddress_value(arg));
449 else if (fpointerp(arg)) value1 = ulong_to_I((uintP)Fpointer_value(arg));
450 else error_foreign_object(arg);
451 mv_count = 1;
452 }
453
454 /* (FFI:FOREIGN-ADDRESS foreign-entity) creates or extracts FOREIGN-ADDRESS
455 out of a FOREIGN-* object. Useful with C-POINTER type declaration. */
456 LISPFUNNR(foreign_address,1)
457 { VALUES1(foreign_address(popSTACK(),true)); }
458
459
460 /* =========================== Foreign libraries =========================== */
461
462 #if defined(WIN32_NATIVE) || defined(HAVE_DLOPEN)
463
464 #if defined(HAVE_DLFCN_H)
465 #include <dlfcn.h>
466 #endif
467
468 #if defined(HAVE_DLERROR)
469 /* return the string object for dlerror() value */
dlerror_string(void)470 local object dlerror_string (void)
471 {
472 var const char* errmesg;
473 begin_system_call(); errmesg = dlerror(); end_system_call();
474 return safe_to_string(errmesg);
475 }
476 #endif
477
478 #if defined(HAVE_DLADDR)
479 LISPFUNN(foreign_pointer_info,1) {
480 var object arg = foreign_address(popSTACK(),true);
481 var void *addr = Fpointer_value(arg);
482 var Dl_info dli;
483 var int status;
484 begin_system_call(); status = dladdr(addr,&dli); end_system_call();
485 if (status == 0) { /* failed */
486 #if defined(HAVE_DLERROR)
487 pushSTACK(dlerror_string());
488 #endif
489 pushSTACK(arg); pushSTACK(TheSubr(subr_self)->name);
490 #if defined(HAVE_DLERROR)
491 error(error_condition,GETTEXT("~S(~S): dladdr() failed: ~S"));
492 #else
493 error(error_condition,GETTEXT("~S(~S): dladdr() failed"));
494 #endif
495 } else {
496 pushSTACK(safe_to_string(dli.dli_fname));
497 pushSTACK(allocate_fpointer(dli.dli_fbase));
498 pushSTACK(safe_to_string(dli.dli_sname));
499 pushSTACK(allocate_fpointer((void*)dli.dli_saddr));
500 STACK_to_mv(4);
501 }
502 }
503 #endif
504
505 /* Open a library with the given name
506 name: pointer to a Lisp string (corrected on error) or :DEFAULT or :NEXT
507 returns a dlopen() handle to the DLL
508 can trigger GC -- only on error */
open_library(gcv_object_t * name)509 local maygc void * open_library (gcv_object_t* name)
510 {
511 var void * handle;
512 open_library_restart:
513 if (eq(*name,S(Kdefault))) {
514 #if defined(RTLD_DEFAULT)
515 return RTLD_DEFAULT;
516 #else /* known to work on WIN32, FreeBSD, MacOSX */
517 return NULL;
518 #endif
519 }
520 if (eq(*name,S(Knext))) {
521 #if defined(RTLD_NEXT)
522 return RTLD_NEXT;
523 #else
524 pushSTACK(NIL); /* no PLACE */
525 pushSTACK(S(Knext));
526 pushSTACK(TheSubr(subr_self)->name);
527 check_value(error_condition,GETTEXT("~S: ~S is not supported on this platform."));
528 *name = value1;
529 goto open_library_restart;
530 #endif
531 }
532 with_string_0(*name = check_string(*name),O(misc_encoding),libname, {
533 begin_blocking_system_call();
534 handle = libopen(libname);
535 end_blocking_system_call();
536 });
537 if (handle == NULL) {
538 pushSTACK(NIL); /* no PLACE */
539 pushSTACK(*name);
540 #if defined(HAVE_DLERROR)
541 pushSTACK(STACK_0);
542 STACK_1 = dlerror_string();
543 #endif
544 pushSTACK(TheSubr(subr_self)->name);
545 #if defined(HAVE_DLERROR)
546 check_value(error_condition,GETTEXT("~S: Cannot open library ~S: ~S"));
547 #else
548 check_value(error_condition,GETTEXT("~S: Cannot open library ~S"));
549 #endif
550 *name = value1;
551 goto open_library_restart;
552 }
553 return handle;
554 }
555
556 /* close the fpointer to a library */
close_library(object fp)557 local void close_library (object fp) {
558 var void * libaddr = (TheFpointer(fp)->fp_pointer);
559 begin_system_call();
560 #if defined(WIN32_NATIVE)
561 FreeLibrary((HMODULE)libaddr);
562 #else
563 dlclose(libaddr);
564 #endif
565 end_system_call();
566 mark_fp_invalid(TheFpointer(fp));
567 }
568
569 /* find versioned symbol in the dynamic library.
570 If this functionality is not supported, then the symbol
571 is not found, even if the name does exist in the library. */
find_name_version(void * handle,const char * name,const char * ver)572 local void *find_name_version (void *handle, const char *name,
573 const char *ver) {
574 var void *ret = NULL;
575 #ifdef HAVE_DLVSYM
576 ret = dlvsym(handle,name,ver);
577 #else
578 unused(handle); unused(name); unused(ver);
579 #endif
580 return ret;
581 }
582
583 /* return the object handle
584 > library - library specifier (lib addr obj...)
585 > name - object name (string)
586 < address - the foreign library handle (in the C sense)
587 can trigger GC */
object_handle(object library,object name,object version)588 local maygc void* object_handle (object library, object name, object version) {
589 var void * address;
590 if (nullp(version)) {
591 with_string_0(name,O(foreign_encoding),namez, {
592 begin_system_call();
593 address = find_name(TheFpointer(Car(Cdr(library)))->fp_pointer, namez);
594 end_system_call();
595 });
596 } else {
597 with_string_0(name,O(foreign_encoding),namez, {
598 with_string_0(version,O(foreign_encoding),verz, {
599 begin_system_call();
600 address = find_name_version(TheFpointer(Car(Cdr(library)))->fp_pointer,
601 namez, verz);
602 end_system_call();
603 });
604 });
605 }
606 if (address == NULL) {
607 var uintC argcount = 6;
608 var gcv_object_t *cfs;
609 var gcv_object_t *efs;
610 pushSTACK(NIL); cfs=&STACK_0; /* continue-format-string */
611 pushSTACK(S(error)); /* error type */
612 pushSTACK(NIL); efs=&STACK_0; /* error-format-string */
613 pushSTACK(TheSubr(subr_self)->name); pushSTACK(name);
614 if (!nullp(version)) {
615 pushSTACK(version); argcount++;
616 }
617 pushSTACK(Car(library));
618 *efs = nullp(version)
619 ? CLSTEXT("~S: no dynamic object named ~S in library ~S")
620 : CLSTEXT("~S: no dynamic object named ~S (version ~S) in library ~S");
621 *cfs = CLSTEXT("Skip foreign object creation");
622 funcall(L(cerror_of_type),argcount);
623 }
624 return address;
625 }
626
627 /* O(foreign_libraries) is an alist of all open foreign library specifiers.
628 a library specifier is a list (library-name fpointer object1 object2 ...) */
629
630 /* find the library in O(foreign_libraries):
631 (ASSOC name O(foreign_libraries) :TEST (FUNCTION EQUAL))
632 > name: the name of the library
633 < library specifier (library fpointer deps object1 object2 ...) or NIL */
find_library_by_name(object name)634 local object find_library_by_name (object name) {
635 var object alist = O(foreign_libraries);
636 while (consp(alist)) {
637 if (equal(name,Car(Car(alist))))
638 return Car(alist);
639 alist = Cdr(alist);
640 }
641 return NIL;
642 }
643 /* find the library in O(foreign_libraries):
644 (FIND address O(foreign_libraries) :KEY (FUNCTION SECOND))
645 > addr: the address of the library
646 < library specifier (library fpointer object1 object2 ...) or NIL */
find_library_by_address(object addr)647 local object find_library_by_address (object addr) {
648 var object alist = O(foreign_libraries);
649 while (consp(alist)) {
650 if (eq(addr,Car(Cdr(Car(alist)))))
651 return Car(alist);
652 alist = Cdr(alist);
653 }
654 return NIL;
655 }
656
657 /* update the DLL pointer and all related objects: re-open the library,
658 and update the base fp_pointer of fpointer-library-handle and all objects in
659 lib_spec = (library-name fpointer-library-handle deps object1 object2 ...)
660 can trigger GC -- only on error in open_library() or object_handle() */
update_library(object lib_spec)661 local maygc void update_library (object lib_spec) {
662 pushSTACK(lib_spec);
663 var gcv_object_t *lib_spec_ = &STACK_0;
664 /* update dependencies */
665 for (pushSTACK(Car(Cdr(Cdr(*lib_spec_)))); consp(STACK_0);
666 STACK_0 = Cdr(STACK_0))
667 /* dependencies are strings */
668 update_library(find_library_by_name(Car(STACK_0)));
669 skipSTACK(1);
670 /* open the library */
671 pushSTACK(Car(*lib_spec_));
672 var void *lib_handle = open_library(&STACK_0);
673 Car(*lib_spec_) = popSTACK();
674 pushSTACK(Car(Cdr(*lib_spec_))); /* library address - Fpointer */
675 var gcv_object_t *lib_addr_ = &STACK_0; /* presumably invalid */
676 TheFpointer(*lib_addr_)->fp_pointer = lib_handle;
677 mark_fp_valid(TheFpointer(*lib_addr_));
678 /* update objects */
679 pushSTACK(NIL);
680 var gcv_object_t *fa_ = &STACK_0; /* place to keep foreign address */
681 pushSTACK(Cdr(Cdr(*lib_spec_))); /* library list */
682 while (consp(Cdr(STACK_0))) {
683 var object fo = Car(Cdr(STACK_0)); /* foreign object */
684 *fa_ = foreign_address(fo,false); /* its foreign address */
685 var object fn; /* its name */
686 var object ve; /* its version */
687 switch (Record_type(fo)) {
688 case Rectype_Fvariable:
689 fn = TheFvariable(fo)->fv_name;
690 ve = TheFvariable(fo)->fv_version;
691 break;
692 case Rectype_Ffunction:
693 fn = TheFfunction(fo)->ff_name;
694 ve = TheFfunction(fo)->ff_version;
695 break;
696 default: NOTREACHED;
697 }
698 ASSERT(eq(TheFaddress(*fa_)->fa_base,*lib_addr_));
699 var void* handle = object_handle(*lib_spec_,fn,ve);
700 if (handle) { /* found -- fix Faddress */
701 TheFaddress(*fa_)->fa_offset = (sintP)handle - (sintP)lib_handle;
702 STACK_0 = Cdr(STACK_0);
703 } else { /* not found - drop object */
704 Cdr(STACK_0) = Cdr(Cdr(STACK_0));
705 var object fp = allocate_fpointer((void*)0);
706 TheFaddress(*fa_)->fa_base = fp;
707 mark_fp_invalid(TheFpointer(TheFaddress(*fa_)->fa_base));
708 }
709 }
710 skipSTACK(4); /* drop lib_spec, library list & lib_addr */
711 }
712
713 /* Check a foreign library argument: an address or a string
714 > obj ----- library name (will be opened) or address (will be updated)
715 < Return the library specifier (name fpointer object...)
716 if obj was the name, it is checked and updated by open_library
717 can trigger GC */
check_library(gcv_object_t * obj)718 local maygc object check_library (gcv_object_t *obj) {
719 var object lib_spec = (fpointerp(*obj) ? find_library_by_address(*obj)
720 : stringp(*obj) ? find_library_by_name(*obj) : NIL);
721 if (nullp(lib_spec)) { /* open new */
722 pushSTACK(*obj);
723 pushSTACK(allocate_fpointer(open_library(obj)));
724 pushSTACK(NIL); /* dependencies */
725 lib_spec = allocate_cons();
726 Cdr(lib_spec) = O(foreign_libraries);
727 O(foreign_libraries) = lib_spec;
728 Car(O(foreign_libraries)) = lib_spec = listof(3);
729 return lib_spec;
730 } else { /* lib_spec = (library-name library-addr deps obj1 obj2 ...) */
731 if (!fp_validp(TheFpointer(Car(Cdr(lib_spec))))) {
732 /* Library already existed in a previous Lisp session.
733 Update the address, and make it valid. */
734 pushSTACK(lib_spec); /* save */
735 update_library(lib_spec);
736 lib_spec = popSTACK(); /* restore */
737 }
738 return lib_spec;
739 }
740 }
741
742 /* (FFI:OPEN-FOREIGN-LIBRARY name &require dependencies)
743 returns a foreign library specifier (fpointer). */
744 LISPFUN(open_foreign_library,seclass_read,1,0,norest,key,1,(kw(require))) {
745 /* open the dependencies */
746 for (pushSTACK(STACK_0); consp(STACK_0); STACK_0 = Cdr(STACK_0)) {
747 pushSTACK(Car(STACK_0));
748 check_library(&STACK_0);
749 var object tmp = popSTACK(); Car(STACK_1) = tmp;
750 }
751 var object lib_spec = check_library(&STACK_2);
752 Car(Cdr(Cdr(lib_spec))) = STACK_1; /* save dependencies */
753 VALUES1(Car(Cdr(lib_spec)));
754 skipSTACK(3); /* name, dependencies, tail */
755 }
756
757 /* (FFI:CLOSE-FOREIGN-LIBRARY name) */
758 LISPFUNN(close_foreign_library,1) {
759 var object lib_cons = find_library_by_name(popSTACK());
760 if (consp(lib_cons)) {
761 var object library = Car(Cdr(lib_cons));
762 if (fp_validp(TheFpointer(library)))
763 close_library(library);
764 value1 = library;
765 } else
766 value1 = NIL;
767 mv_count = 1;
768 }
769
770 /* Try to make a Foreign-Pointer valid again, returning the argument.
771 validate_fpointer(obj);
772 can trigger GC */
validate_fpointer(object obj)773 local maygc object validate_fpointer (object obj)
774 { /* If the foreign pointer belongs to a foreign library from a previous
775 session, we reopen the library. */
776 pushSTACK(obj);
777 pushSTACK(O(foreign_libraries));
778 while (consp(STACK_0)) {
779 var object lib_spec = Car(STACK_0); STACK_0 = Cdr(STACK_0);
780 if (eq(Car(Cdr(lib_spec)),STACK_1)) {
781 update_library(lib_spec);
782 skipSTACK(1); return popSTACK();
783 }
784 }
785 skipSTACK(1); /* drop tail */
786 return check_fpointer(popSTACK()/*obj*/,false);
787 }
788
789 /* return the foreign address of the foreign object named 'name'
790 > library - foreign library specifier (name fpointer obj...)
791 > name - string (C name)
792 > offset - integer or NIL, if supplied, name is ignored
793 can trigger GC */
object_address(object library,object name,object version,object offset)794 local maygc object object_address (object library, object name,
795 object version, object offset)
796 { var object lib_addr = Car(Cdr(library));
797 var sintP result_offset;
798 if (nullp(offset)) {
799 pushSTACK(lib_addr);
800 var void* name_handle = object_handle(library,name,version);
801 lib_addr = popSTACK();
802 if (NULL == name_handle) return nullobj;
803 result_offset =
804 (sintP)name_handle - (sintP)TheFpointer(lib_addr)->fp_pointer;
805 } else {
806 result_offset = (sintP)I_to_sint32(offset);
807 }
808 return make_faddress(lib_addr,result_offset);
809 }
810
811 /* add foreign object obj to the lib_spec (name addr obj1 ...)
812 can trigger GC */
push_foreign_object(object obj,object lib_spec)813 local maygc void push_foreign_object (object obj, object lib_spec) {
814 pushSTACK(obj); pushSTACK(lib_spec);
815 var object new_cons = allocate_cons();
816 lib_spec = popSTACK();
817 Car(new_cons) = popSTACK()/*obj*/; Cdr(new_cons) = Cdr(Cdr(Cdr(lib_spec)));
818 Cdr(Cdr(Cdr(lib_spec))) = new_cons;
819 }
820
821 /* UP: check foreign_library_* arguments and create the foreign object
822 > name - object name (pre-checked)
823 > library - library name --> library specifier
824 > version - object version (checked here)
825 > offset - address offset in the library or NIL
826 < new object address
827 can trigger GC */
foreign_library_check(gcv_object_t * name,gcv_object_t * library,gcv_object_t * version,gcv_object_t * offset)828 local maygc object foreign_library_check
829 (gcv_object_t *name, gcv_object_t *library,
830 gcv_object_t *version, gcv_object_t *offset) {
831 *library = check_library(library);
832 if (!nullp(*offset)) *offset = check_sint32(*offset);
833 if (!nullp(*version)) *version = coerce_ss(*version);
834 return object_address(*library,*name,*version,*offset);
835 }
836 #define push_foreign_library_object(n,l,v,o) \
837 pushSTACK(foreign_library_check(n,l,v,o)); \
838 if (eq(nullobj,STACK_0)) { /* not found and ignored */ \
839 skipSTACK(1); return NIL; \
840 }
841
842 /* UP: find and allocate a foreign variable in a dynamic library
843 > name - variable C name (string - prechecked)
844 > library - library C name (string - checked here)
845 > version - object version (NIL or string - checked here)
846 > offset - address offset in the library or NIL
847 > fvd - function type
848 can trigger GC */
foreign_library_variable(gcv_object_t * name,gcv_object_t * fvd,gcv_object_t * library,gcv_object_t * version,gcv_object_t * offset)849 local maygc object foreign_library_variable (
850 gcv_object_t *name, gcv_object_t* fvd,
851 gcv_object_t *library, gcv_object_t *version, gcv_object_t *offset) {
852 push_foreign_library_object(name,library,version,offset);
853 var struct foreign_layout sas;
854 foreign_layout(*fvd,&sas);
855 var uintL size = sas.size;
856 var uintL alignment = sas.alignment;
857 var object fvar = allocate_fvariable();
858 TheFvariable(fvar)->fv_name = *name;
859 TheFvariable(fvar)->fv_version = *version;
860 TheFvariable(fvar)->fv_address = STACK_0;
861 TheFvariable(fvar)->fv_size = fixnum(size);
862 TheFvariable(fvar)->fv_type = *fvd;
863 check_fvar_alignment(fvar,alignment);
864 STACK_0 = fvar; /* save */
865 push_foreign_object(fvar,*library);
866 return popSTACK(); /* fvar */
867 }
868
869 /* UP: find and allocate a foreign function in a dynamic library
870 > name - function C name (string - prechecked)
871 > fvd - function type (already checked)
872 > properties - function properties
873 > library - library C name (string - checked here)
874 > version - object version (NIL or string - checked here)
875 > offset - address offset in the library or NIL
876 can trigger GC */
foreign_library_function(gcv_object_t * name,gcv_object_t * fvd,gcv_object_t * properties,gcv_object_t * library,gcv_object_t * version,gcv_object_t * offset)877 local maygc object foreign_library_function (
878 gcv_object_t *name, gcv_object_t *fvd, gcv_object_t *properties,
879 gcv_object_t *library, gcv_object_t *version, gcv_object_t *offset) {
880 push_foreign_library_object(name,library,version,offset);
881 var object ffun = allocate_ffunction();
882 TheFfunction(ffun)->ff_name = *name;
883 TheFfunction(ffun)->ff_version = *version;
884 TheFfunction(ffun)->ff_address = STACK_0;
885 TheFfunction(ffun)->ff_resulttype = TheSvector(*fvd)->data[1];
886 TheFfunction(ffun)->ff_argtypes = TheSvector(*fvd)->data[2];
887 TheFfunction(ffun)->ff_flags = TheSvector(*fvd)->data[3];
888 TheFfunction(ffun)->ff_properties = *properties;
889 STACK_0 = ffun; /* save */
890 push_foreign_object(ffun,*library);
891 return popSTACK(); /* ffun */
892 }
893
894 #else /* not WIN32_NATIVE || HAVE_DLOPEN */
895
896 /* Try to make a Foreign-Pointer valid again.
897 validate_fpointer(obj); */
validate_fpointer(object obj)898 local inline object validate_fpointer (object obj)
899 { /* Can't do anything. */
900 return check_fpointer(obj,false);
901 }
902
903 /* error-message about lack of dlsym */
error_no_dlsym(object name,object library)904 local _Noreturn void error_no_dlsym (object name, object library) {
905 pushSTACK(library); pushSTACK(name);
906 pushSTACK(TheSubr(subr_self)->name);
907 error(error_condition,GETTEXT("~S: cannot find ~S in ~S due to lack of dlsym() on this platform"));
908 }
909
910 /* stubs signalling errors */
foreign_library_function(gcv_object_t * name,gcv_object_t * fvd,gcv_object_t * properties,gcv_object_t * library,gcv_object_t * version,gcv_object_t * offset)911 local maygc object foreign_library_function (
912 gcv_object_t *name, gcv_object_t *fvd, gcv_object_t *properties,
913 gcv_object_t *library, gcv_object_t *version, gcv_object_t *offset)
914 {
915 error_no_dlsym(*name,*library);
916 }
foreign_library_variable(gcv_object_t * name,gcv_object_t * fvd,gcv_object_t * library,gcv_object_t * version,gcv_object_t * offset)917 local maygc object foreign_library_variable (
918 gcv_object_t *name, gcv_object_t* fvd,
919 gcv_object_t *library, gcv_object_t *version, gcv_object_t *offset)
920 {
921 error_no_dlsym(*name,*library);
922 }
923
924 #endif
925
926
927 /* ===================== Registry of foreign variables ===================== */
928
929 /* Registers a foreign variable.
930 register_foreign_variable(address,name,flags,size);
931 > address: address of a variable in memory
932 > name: its name
933 > flags: fv_readonly for read-only variables
934 > size: its size in bytes
935 can trigger GC */
register_foreign_variable(void * address,const char * name_asciz,uintBWL flags,uintL size)936 modexp maygc void register_foreign_variable
937 (void* address, const char * name_asciz, uintBWL flags, uintL size) {
938 var object name = asciz_to_string(name_asciz,O(internal_encoding));
939 var object obj = gethash(name,O(foreign_variable_table),false);
940 if (!eq(obj,nullobj)) {
941 obj = TheFvariable(obj)->fv_address;
942 obj = TheFaddress(obj)->fa_base;
943 if (fp_validp(TheFpointer(obj))) {
944 pushSTACK(name);
945 error(error_condition,GETTEXT("Foreign variable ~S already exists"));
946 } else {
947 /* Variable already existed in a previous Lisp session.
948 Update the address, and make it and any of its subvariables valid. */
949 TheFpointer(obj)->fp_pointer = address;
950 mark_fp_valid(TheFpointer(obj));
951 }
952 } else {
953 pushSTACK(name);
954 pushSTACK(make_faddress(allocate_fpointer(address),0));
955 obj = allocate_fvariable();
956 TheFvariable(obj)->fv_address = popSTACK();
957 TheFvariable(obj)->fv_name = name = popSTACK();
958 TheFvariable(obj)->fv_size = fixnum(size);
959 record_flags_replace(TheFvariable(obj), flags);
960 shifthash(O(foreign_variable_table),name,obj,true);
961 }
962 }
963
964
965 /* ===================== Registry of foreign functions ===================== */
966
967 /* Registers a foreign function.
968 register_foreign_function(address,name,flags);
969 > address: address of the function in memory
970 > name: its name
971 > flags: its language and parameter passing convention
972 can trigger GC */
register_foreign_function(void * address,const char * name_asciz,uintWL flags)973 modexp maygc void register_foreign_function
974 (void* address, const char * name_asciz, uintWL flags) {
975 var object name = asciz_to_string(name_asciz,O(internal_encoding));
976 var object obj = gethash(name,O(foreign_function_table),false);
977 if (!eq(obj,nullobj)) {
978 obj = TheFfunction(obj)->ff_address;
979 obj = TheFaddress(obj)->fa_base;
980 if (fp_validp(TheFpointer(obj))) {
981 pushSTACK(name);
982 error(error_condition,GETTEXT("Foreign function ~S already exists"));
983 } else {
984 /* Function already existed in a previous Lisp session.
985 Update the address, and make it valid. */
986 TheFpointer(obj)->fp_pointer = address;
987 mark_fp_valid(TheFpointer(obj));
988 }
989 } else {
990 pushSTACK(name);
991 pushSTACK(make_faddress(allocate_fpointer(address),0));
992 obj = allocate_ffunction();
993 TheFfunction(obj)->ff_address = popSTACK();
994 TheFfunction(obj)->ff_name = name = popSTACK();
995 TheFfunction(obj)->ff_flags = fixnum(flags);
996 shifthash(O(foreign_function_table),name,obj,true);
997 }
998 }
999
1000
1001 /* =============== Registry and utilities for foreign types =============== */
1002
1003 /* determine the integer type that corresponds to the given type */
parse_foreign_inttype(uintL size,bool signed_p)1004 local object parse_foreign_inttype (uintL size, bool signed_p) {
1005 switch (size) {
1006 case 1: return signed_p ? S(sint8) : S(uint8);
1007 case 2: return signed_p ? S(sint16) : S(uint16);
1008 case 4: return signed_p ? S(sint32) : S(uint32);
1009 case 8: return signed_p ? S(sint64) : S(uint64);
1010 }
1011 pushSTACK(fixnum(size));
1012 error(error_condition,GETTEXT("No foreign int type of size ~S"));
1013 }
1014
1015 /* Registers a foreign type.
1016 register_foreign_type (const char * name_asciz, uintL size, uintL alignment)
1017 > name_asciz: C type name
1018 > size : sizeof(name_asciz)
1019 > alignment : alignof(name_asciz)
1020 can trigger GC */
register_foreign_inttype(const char * name_asciz,uintL size,bool signed_p)1021 modexp maygc void register_foreign_inttype
1022 (const char * name_asciz, uintL size, bool signed_p) {
1023 var object name = asciz_to_string(name_asciz,O(internal_encoding));
1024 var object obj = gethash(name,O(foreign_inttype_table),false);
1025 var object inttype = parse_foreign_inttype(size, signed_p);
1026 if (!eq(obj,nullobj)) {
1027 if (!eq(inttype,obj)) {
1028 pushSTACK(inttype); pushSTACK(obj); pushSTACK(name);
1029 error(error_condition,GETTEXT("Cannot redefine foreign type ~S from ~S to ~S"));
1030 }
1031 } else shifthash(O(foreign_inttype_table),name,inttype,true);
1032 }
1033
1034 LISPFUNNF(parse_foreign_inttype,2) { /* "size_t" --> FFI:UINT64 */
1035 var bool errorp = !nullp(STACK_0);
1036 var object inttype = gethash(STACK_1,O(foreign_inttype_table),false);
1037 if (eq(inttype,nullobj)) {
1038 if (errorp)
1039 error(error_condition,GETTEXT("No foreign int type named ~S"));
1040 else
1041 inttype = Fixnum_0; /* no such type */
1042 }
1043 VALUES1(inttype);
1044 skipSTACK(2);
1045 }
1046
1047 /* Error message. */
error_convert(object fvd,object obj)1048 local _Noreturn void error_convert (object fvd, object obj) {
1049 dynamic_bind(S(print_circle),T); /* bind *PRINT-CIRCLE* to T */
1050 pushSTACK(fvd); pushSTACK(obj);
1051 pushSTACK(TheSubr(subr_self)->name);
1052 error(error_condition,GETTEXT("~S: ~S cannot be converted to the foreign type ~S"));
1053 }
1054
1055 #if !defined(HAVE_LONG_LONG_INT)
1056 /* Error message. */
error_64bit(object fvd)1057 local _Noreturn void error_64bit (object fvd) {
1058 dynamic_bind(S(print_circle),T); /* bind *PRINT-CIRCLE* to T */
1059 pushSTACK(fvd); pushSTACK(TheSubr(subr_self)->name);
1060 error(error_condition,GETTEXT("~S: 64 bit integers are not supported on this platform and with this C compiler: ~S"));
1061 }
1062 #endif
1063
1064 /* check that fvd is a valid foreign function type specification
1065 can trigger GC */
check_foreign_function_type(object fvd)1066 local maygc object check_foreign_function_type (object fvd) {
1067 while (!(simple_vector_p(fvd)
1068 && (Svector_length(fvd) == 4)
1069 && eq(TheSvector(fvd)->data[0],S(c_function))
1070 && simple_vector_p(TheSvector(fvd)->data[2]))) {
1071 dynamic_bind(S(print_circle),T); /* bind *PRINT-CIRCLE* to T */
1072 pushSTACK(NIL); /* no PLACE */
1073 pushSTACK(fvd); pushSTACK(TheSubr(subr_self)->name);
1074 check_value(error_condition,GETTEXT("~S: illegal foreign function type ~S"));
1075 fvd = value1;
1076 }
1077 return fvd;
1078 }
1079
1080 /* Comparison of two fvd's.
1081 According to the ANSI C rules, two "c-struct"s are only equivalent if they
1082 come from the same declaration. Same for "c-union"s.
1083 "c-array"s, "c-ptr", "c-ptr-null" are compared recursively. Same for
1084 "c-function". */
1085 local bool equal_fvd (object fvd1, object fvd2);
1086 /* As an exception to strict type and prototype checking,
1087 C-POINTER matches any C-PTR, C-PTR-NULL, C-ARRAY-PTR and C-FUNCTION type. */
1088 local bool equalp_fvd (object fvd1, object fvd2);
1089 /* Comparison of two argument type vectors. */
1090 local bool equal_argfvds (object argfvds1, object argfvds2);
1091
equal_fvd(object fvd1,object fvd2)1092 local bool equal_fvd (object fvd1, object fvd2)
1093 {
1094 check_SP();
1095 recurse:
1096 if (eq(fvd1,fvd2))
1097 return true;
1098 if (simple_vector_p(fvd1) && simple_vector_p(fvd2))
1099 if (Svector_length(fvd1) == Svector_length(fvd2)) {
1100 var uintL len = Svector_length(fvd1);
1101 if (len > 0) {
1102 if (eq(TheSvector(fvd1)->data[0],TheSvector(fvd2)->data[0])) {
1103 var object obj;
1104 obj = TheSvector(fvd1)->data[0];
1105 if ((len >= 2) && (eq(obj,S(c_array)) || eq(obj,S(c_array_max))
1106 || eq(obj,S(c_ptr)) || eq(obj,S(c_ptr_null))
1107 || eq(obj,S(c_pointer))
1108 || eq(obj,S(c_array_ptr)))) {
1109 var uintL i;
1110 for (i = 2; i < len; i++)
1111 if (!eql(TheSvector(fvd1)->data[i],TheSvector(fvd2)->data[i]))
1112 return false;
1113 fvd1 = TheSvector(fvd1)->data[1];
1114 fvd2 = TheSvector(fvd2)->data[1];
1115 goto recurse;
1116 } else if ((len == 4) && eq(obj,S(c_function))) {
1117 if (!equal_fvd(TheSvector(fvd1)->data[1],
1118 TheSvector(fvd2)->data[1]))
1119 return false;
1120 if (!equal_argfvds(TheSvector(fvd1)->data[2],
1121 TheSvector(fvd2)->data[2]))
1122 return false;
1123 if (!eql(TheSvector(fvd1)->data[3],TheSvector(fvd2)->data[3]))
1124 return false;
1125 return true;
1126 }
1127 }
1128 }
1129 }
1130 return false;
1131 }
1132
equal_argfvds(object argfvds1,object argfvds2)1133 local bool equal_argfvds (object argfvds1, object argfvds2)
1134 {
1135 ASSERT(simple_vector_p(argfvds1) && simple_vector_p(argfvds2));
1136 var uintL len = Svector_length(argfvds1);
1137 if (!(len == Svector_length(argfvds2)))
1138 return false;
1139 while (len > 0) {
1140 len--;
1141 if (!equal_fvd(TheSvector(argfvds1)->data[len],
1142 TheSvector(argfvds2)->data[len]))
1143 return false;
1144 }
1145 return true;
1146 }
1147
equalp_fvd(object fvd1,object fvd2)1148 local bool equalp_fvd (object fvd1, object fvd2)
1149 {
1150 if (eq(fvd1,fvd2))
1151 return true;
1152 if (eq(fvd1,S(c_pointer))
1153 && simple_vector_p(fvd2) && (Svector_length(fvd2) > 0)) {
1154 var object fvd2type = TheSvector(fvd2)->data[0];
1155 if (eq(fvd2type,S(c_ptr)) || eq(fvd2type,S(c_ptr_null))
1156 || eq(fvd2type,S(c_pointer)) || eq(fvd2type,S(c_array_ptr))
1157 || eq(fvd2type,S(c_function)))
1158 return true;
1159 }
1160 if (eq(fvd2,S(c_pointer))
1161 && simple_vector_p(fvd1) && (Svector_length(fvd1) > 0)) {
1162 var object fvd1type = TheSvector(fvd1)->data[0];
1163 if (eq(fvd1type,S(c_ptr)) || eq(fvd1type,S(c_ptr_null))
1164 || eq(fvd1type,S(c_pointer)) || eq(fvd1type,S(c_array_ptr))
1165 || eq(fvd1type,S(c_function)))
1166 return true;
1167 }
1168 return equal_fvd(fvd1,fvd2);
1169 }
1170
1171
1172 /* ================ Conversion between Lisp data and C data ================ */
1173
1174 /* When a Lisp function is converted to a C function, it has to be stored in
1175 a table of call-back functions. (Because we can't give away pointers to
1176 Lisp objects for GC reasons.)
1177 There is a two-way correspondence:
1178
1179 hash table, alist
1180 Lisp function ------------------> index array
1181 Lisp function <------------------ index -----------------> trampoline
1182 array <-----------------
1183 trampoline_data()
1184
1185 The index also has a reference count attached, in order to not generate
1186 several trampolines for different conversions of the same Lisp function.
1187
1188 O(foreign_callin_table) is a hash table.
1189 O(foreign_callin_vector) is an extendable vector of size 3*n+1, of triples
1190 #(... lisp-function foreign-function reference-count ...).
1191 3*index-2 3*index-1 3*index
1192 (The foreign-function itself contains the trampoline address.)
1193 Free triples are linked together to a free list like this:
1194 #(... nil nil next-index ...)
1195 3*index-2 3*index-1 3*index */
1196
1197 local void callback (void* data, va_alist args);
1198
1199 /* check whether the given Ffunction matches the given calling convention */
check_cc_match(object fun,object resulttype,object argtypes,object flags)1200 local void check_cc_match (object fun, object resulttype,
1201 object argtypes, object flags) {
1202 if (!(equal_fvd(resulttype,TheFfunction(fun)->ff_resulttype)
1203 && equal_argfvds(argtypes,TheFfunction(fun)->ff_argtypes)
1204 && eq(flags,TheFfunction(fun)->ff_flags))) {
1205 pushSTACK(fun);
1206 error(error_condition,GETTEXT("~S cannot be converted to a foreign function with another calling convention."));
1207 }
1208 }
1209
1210 /* Convert a Lisp function to a C function.
1211 convert_function_to_foreign(address,resulttype,argtypes,flags)
1212 The real C function address is
1213 Faddress_value(TheFfunction(result)->ff_address).
1214 can trigger GC */
convert_function_to_foreign(object fun,object resulttype,object argtypes,object flags)1215 local maygc object convert_function_to_foreign (object fun, object resulttype,
1216 object argtypes, object flags) {
1217 /* Convert to a function: */
1218 if (!functionp(fun)) {
1219 pushSTACK(resulttype); pushSTACK(argtypes); pushSTACK(flags);
1220 with_saved_back_trace_subr(L(coerce),STACK STACKop -2,-1,
1221 { fun = coerce_function(fun); });
1222 flags = popSTACK(); argtypes = popSTACK(); resulttype = popSTACK();
1223 }
1224 /* If it is already a foreign function, return it immediately: */
1225 if (ffunctionp(fun)) {
1226 check_cc_match(fun, resulttype, argtypes, flags);
1227 return fun;
1228 }
1229 { /* Look it up in the hash table, alist: */
1230 var object alist = gethash(fun,O(foreign_callin_table),false);
1231 if (!eq(alist,nullobj)) {
1232 while (consp(alist)) {
1233 var object acons = Car(alist);
1234 alist = Cdr(alist);
1235 if (equal_fvd(resulttype,Car(acons))
1236 && equal_argfvds(argtypes,Car(Cdr(acons)))
1237 && eq(flags,Car(Cdr(Cdr(acons))))) {
1238 var uintV f_index = posfixnum_to_V(Cdr(Cdr(Cdr(acons))));
1239 var gcv_object_t* triple = &TheSvector(TheIarray(O(foreign_callin_vector))->data)->data[3*f_index-2];
1240 var object ffun = triple[1];
1241 ASSERT(equal_fvd(resulttype,TheFfunction(ffun)->ff_resulttype));
1242 ASSERT(equal_argfvds(argtypes,TheFfunction(ffun)->ff_argtypes));
1243 ASSERT(eq(flags,TheFfunction(ffun)->ff_flags));
1244 var object faddress = TheFfunction(ffun)->ff_address;
1245 if (fp_validp(TheFpointer(TheFaddress(faddress)->fa_base))) {
1246 triple[2] = fixnum_inc(triple[2],1); /* increment reference count */
1247 } else { /* callback from a previous session -- renew */
1248 triple[2] = Fixnum_1; /* reset reference count */
1249 begin_system_call();
1250 TheFaddress(faddress)->fa_offset =
1251 (uintP)alloc_callback(&callback,(void*)(uintP)f_index);
1252 end_system_call();
1253 TheFaddress(faddress)->fa_base = O(fp_zero);
1254 }
1255 return ffun;
1256 }
1257 }
1258 }
1259 }
1260 /* Not already in the hash table -> allocate new: */
1261 pushSTACK(fun);
1262 pushSTACK(NIL);
1263 pushSTACK(resulttype);
1264 pushSTACK(argtypes);
1265 pushSTACK(flags);
1266 { /* First grab an index. */
1267 var uintV f_index = posfixnum_to_V(TheSvector(TheIarray(O(foreign_callin_vector))->data)->data[0]);
1268 if (f_index != 0) { /* remove first index from the free list */
1269 var object dv = TheIarray(O(foreign_callin_vector))->data;
1270 TheSvector(dv)->data[0] = TheSvector(dv)->data[3*f_index];
1271 } else { /* free list exhausted */
1272 var uintC i = 3;
1273 while (i--) {
1274 pushSTACK(NIL); pushSTACK(O(foreign_callin_vector));
1275 funcall(L(vector_push_extend),2);
1276 }
1277 f_index = floor(vector_length(O(foreign_callin_vector)),3);
1278 }
1279 { /* Next allocate the trampoline. */
1280 begin_system_call();
1281 var void* trampoline =
1282 (void*)alloc_callback(&callback,(void*)(uintP)f_index);
1283 end_system_call();
1284 pushSTACK(make_faddress(O(fp_zero),(uintP)trampoline));
1285 /* Now allocate the foreign-function. */
1286 var object obj = allocate_ffunction();
1287 TheFfunction(obj)->ff_name = NIL;
1288 TheFfunction(obj)->ff_address = popSTACK();
1289 TheFfunction(obj)->ff_resulttype = STACK_2;
1290 TheFfunction(obj)->ff_argtypes = STACK_1;
1291 TheFfunction(obj)->ff_flags = STACK_0;
1292 STACK_3 = obj;
1293 }
1294 pushSTACK(fixnum(f_index)); funcall(L(liststar),4); pushSTACK(value1);
1295 /* Stack layout: fun, obj, acons. */
1296 { /* Put it into the hash table. */
1297 var object new_cons = allocate_cons();
1298 Car(new_cons) = popSTACK();
1299 var object alist = gethash(STACK_1,O(foreign_callin_table),false);
1300 if (eq(alist,nullobj))
1301 alist = NIL;
1302 Cdr(new_cons) = alist;
1303 shifthash(O(foreign_callin_table),STACK_1,new_cons,true);
1304 }
1305 /* Put it into the vector. */
1306 var gcv_object_t* triple = &TheSvector(TheIarray(O(foreign_callin_vector))->data)->data[3*f_index-2];
1307 triple[1] = popSTACK(); /* obj */
1308 triple[0] = popSTACK(); /* fun */
1309 triple[2] = Fixnum_1; /* refcount := 1 */
1310 return triple[1];
1311 }
1312 }
1313
1314 /* Undoes the allocation effect of convert_function_to_foreign(). */
free_foreign_callin(void * address)1315 local void free_foreign_callin (void* address)
1316 {
1317 begin_system_call();
1318 if (is_callback(address) /* safety check */
1319 && (callback_address(cast_to_callback_t(address)) == &callback)) {
1320 var uintL cb_data = (uintL)(uintP)callback_data(cast_to_callback_t(address));
1321 end_system_call();
1322 var object dv = TheIarray(O(foreign_callin_vector))->data;
1323 var gcv_object_t* triple = &TheSvector(dv)->data[3*cb_data-2];
1324 if (!nullp(triple[1])) { /* safety check */
1325 triple[2] = fixnum_inc(triple[2],-1); /* decrement reference count */
1326 if (eq(triple[2],Fixnum_0)) {
1327 var object fun = triple[0];
1328 var object ffun = triple[1];
1329 /* clear vector entry, put index=cb_data onto free list: */
1330 triple[0] = NIL; triple[1] = NIL;
1331 triple[2] = TheSvector(dv)->data[0];
1332 TheSvector(dv)->data[0] = fixnum(cb_data);
1333 { /* remove from hash table entry: */
1334 var object alist = gethash(fun,O(foreign_callin_table),false);
1335 if (!eq(alist,nullobj)) { /* safety check */
1336 /* see list.d:deleteq() */
1337 var object alist1 = alist;
1338 var object alist2 = alist;
1339 while (consp(alist2)) {
1340 if (eq(Cdr(Cdr(Cdr(Car(alist2)))),fixnum(cb_data))) {
1341 if (eq(alist2,alist)) {
1342 alist2 = alist1 = Cdr(alist2);
1343 shifthash(O(foreign_callin_table),fun,alist2,false);
1344 } else
1345 Cdr(alist1) = alist2 = Cdr(alist2);
1346 } else {
1347 alist1 = alist2; alist2 = Cdr(alist2);
1348 }
1349 }
1350 }
1351 }
1352 var object faddress = TheFfunction(ffun)->ff_address;
1353 if (fp_validp(TheFpointer(TheFaddress(faddress)->fa_base))) {
1354 /* free the trampoline: */
1355 begin_system_call();
1356 free_callback((__TR_function)Faddress_value(faddress));
1357 end_system_call();
1358 }
1359 }
1360 }
1361 } else {
1362 end_system_call();
1363 }
1364 }
1365
1366 /* Convert a C function to a Lisp foreign function.
1367 convert_function_from_foreign(address,resulttype,argtypes,flags) */
convert_function_from_foreign(void * address,object resulttype,object argtypes,object flags)1368 local object convert_function_from_foreign (void* address, object resulttype,
1369 object argtypes, object flags) {
1370 begin_system_call();
1371 if (is_callback(address) /* safety check */
1372 && (callback_address(cast_to_callback_t(address)) == &callback)) {
1373 var uintL cb_data = (uintL)(uintP)callback_data(cast_to_callback_t(address));
1374 end_system_call();
1375 var gcv_object_t* triple = &TheSvector(TheIarray(O(foreign_callin_vector))->data)->data[3*cb_data-2];
1376 var object ffun = triple[1];
1377 check_cc_match(ffun,resulttype,argtypes,flags);
1378 return ffun;
1379 } else {
1380 end_system_call();
1381 }
1382 pushSTACK(argtypes);
1383 pushSTACK(resulttype);
1384 pushSTACK(make_faddress(O(fp_zero),(uintP)address));
1385 var object obj = allocate_ffunction();
1386 TheFfunction(obj)->ff_name = NIL;
1387 TheFfunction(obj)->ff_address = popSTACK();
1388 TheFfunction(obj)->ff_resulttype = popSTACK();
1389 TheFfunction(obj)->ff_argtypes = popSTACK();
1390 TheFfunction(obj)->ff_flags = flags;
1391 return obj;
1392 }
1393
1394 /* ensure that the Faddress is valid
1395 < fa: foreign address
1396 can trigger GC */
check_faddress_valid(object fa)1397 global maygc object check_faddress_valid (object fa) {
1398 var object fp = TheFaddress(fa)->fa_base;
1399 if (!fp_validp(TheFpointer(fp))) {
1400 pushSTACK(fa); /* save */
1401 check_fpointer(validate_fpointer(fp),false);
1402 fa = popSTACK(); /* restore */
1403 }
1404 return fa;
1405 }
1406
1407 /* (FFI:FOREIGN-FUNCTION address c-type &key name) constructor */
1408 LISPFUN(foreign_function,seclass_read,2,0,norest,key,1,(kw(name)) )
1409 {
1410 STACK_1 = check_foreign_function_type(STACK_1);
1411 foreign_function_restart:
1412 var object fa = STACK_2;
1413 if (ffunctionp(fa)) {
1414 if (missingp(STACK_0))
1415 STACK_0 = TheFfunction(fa)->ff_name;
1416 fa = TheFfunction(fa)->ff_address;
1417 }
1418 /* If you believe objects of type foreign-variable should be accepted,
1419 * then you probably missed an indirection. */
1420 if (!faddressp(fa)) {
1421 pushSTACK(NIL); /* no PLACE */
1422 pushSTACK(fa); /* TYPE-ERROR slot DATUM */
1423 pushSTACK(O(type_foreign_function)); /* TYPE-ERROR slot EXPECTED-TYPE */
1424 pushSTACK(STACK_0); pushSTACK(fa);
1425 pushSTACK(TheSubr(subr_self)->name);
1426 check_value(type_error,GETTEXT("~S: ~S is not of type ~S"));
1427 STACK_2 = value1;
1428 goto foreign_function_restart;
1429 }
1430 fa = check_faddress_valid(fa);
1431 var object fvd = STACK_1;
1432 var object ff = convert_function_from_foreign(Faddress_value(fa),
1433 TheSvector(fvd)->data[1],
1434 TheSvector(fvd)->data[2],
1435 TheSvector(fvd)->data[3]);
1436 /* TODO need to visit callback interaction */
1437 if (nullp(TheFfunction(ff)->ff_name) && !missingp(STACK_0)) {
1438 pushSTACK(ff);
1439 STACK_1 = coerce_ss(STACK_1);
1440 ff = popSTACK();
1441 TheFfunction(ff)->ff_name = STACK_0;
1442 }
1443 VALUES1(ff); skipSTACK(3);
1444 }
1445
1446
1447 /* Zero a block of memory. */
blockzero(void * ptr,unsigned long size)1448 local void blockzero (void* ptr, unsigned long size)
1449 {
1450 if (size > 0) {
1451 if ((size % sizeof(long)) || ((uintP)ptr % sizeof(long))) {
1452 var char* p = (char*)ptr;
1453 do { *p++ = 0;
1454 } while (--size > 0);
1455 } else {
1456 var long* p = (long*)ptr;
1457 do { *p++ = 0;
1458 } while ((size -= sizeof(long)) > 0);
1459 }
1460 }
1461 }
1462
1463 /* Test a block of memory for zero. */
blockzerop(const void * ptr,unsigned long size)1464 local bool blockzerop (const void* ptr, unsigned long size)
1465 {
1466 if ((size % sizeof(long)) || ((uintP)ptr % sizeof(long))) {
1467 var const char* p = (const char*)ptr;
1468 do { if (*p++ != 0) return false;
1469 } while (--size > 0);
1470 return true;
1471 } else {
1472 var const long* p = (const long*)ptr;
1473 do { if (*p++ != 0) return false;
1474 } while ((size -= sizeof(long)) > 0);
1475 return true;
1476 }
1477 }
1478
1479 /* Convert foreign data to Lisp data.
1480 can trigger GC */
1481 global maygc object convert_from_foreign (object fvd, const void* data);
1482 /* Allocate an array corresponding to a foreign array.
1483 can trigger GC */
convert_from_foreign_array_alloc(object dims,object eltype)1484 local maygc object convert_from_foreign_array_alloc (object dims, object eltype)
1485 {
1486 var uintL argcount = 1;
1487 pushSTACK(dims);
1488 if (symbolp(eltype)) {
1489 if (eq(eltype,S(character))) {
1490 pushSTACK(S(Kelement_type)); pushSTACK(S(character));
1491 argcount += 2;
1492 } else if (eq(eltype,S(uint8))) {
1493 pushSTACK(S(Kelement_type)); pushSTACK(O(type_uint8));
1494 argcount += 2;
1495 }
1496 #if 0
1497 else if (eq(eltype,S(sint8))) {
1498 pushSTACK(S(Kelement_type)); pushSTACK(O(type_sint8));
1499 argcount += 2;
1500 }
1501 #endif
1502 else if (eq(eltype,S(uint16))) {
1503 pushSTACK(S(Kelement_type)); pushSTACK(O(type_uint16));
1504 argcount += 2;
1505 }
1506 #if 0
1507 else if (eq(eltype,S(sint16))) {
1508 pushSTACK(S(Kelement_type)); pushSTACK(O(type_sint16));
1509 argcount += 2;
1510 }
1511 #endif
1512 else if (eq(eltype,S(uint32))) {
1513 pushSTACK(S(Kelement_type)); pushSTACK(O(type_uint32));
1514 argcount += 2;
1515 }
1516 #if 0
1517 else if (eq(eltype,S(sint32))) {
1518 pushSTACK(S(Kelement_type)); pushSTACK(O(type_sint32));
1519 argcount += 2;
1520 }
1521 #endif
1522 }
1523 funcall(L(make_array),argcount);
1524 return value1;
1525 }
1526 /* Fill a specialized Lisp array with foreign data.
1527 Return the (possibly reallocated) array. */
convert_from_foreign_array_fill(object eltype,uintL size,object array,const void * data)1528 local object convert_from_foreign_array_fill (object eltype, uintL size,
1529 object array, const void* data)
1530 {
1531 if (eq(eltype,S(character))) {
1532 if (size > 0) {
1533 var const uintB* ptr1 = (const uintB*)data;
1534 #ifdef ENABLE_UNICODE
1535 pushSTACK(array);
1536 var object encoding = O(foreign_8bit_encoding);
1537 ASSERT(Encoding_mblen(encoding)(encoding,ptr1,ptr1+size) == size);
1538 var DYNAMIC_ARRAY(tmpbuf,chart,size);
1539 var chart* ptr2 = &tmpbuf[0];
1540 Encoding_mbstowcs(encoding)(encoding,nullobj,&ptr1,ptr1+size,&ptr2,
1541 ptr2+size);
1542 ASSERT(ptr1 == (const uintB*)data+size);
1543 sstring_store_array(array,0,&tmpbuf[0],size);
1544 FREE_DYNAMIC_ARRAY(tmpbuf);
1545 array = popSTACK();
1546 sstring_un_realloc(array);
1547 #else
1548 var chart* ptr2 = &TheSnstring(array)->data[0];
1549 do { *ptr2++ = as_chart(*ptr1++); } while(--size);
1550 #endif
1551 }
1552 } else if (eq(eltype,S(uint8))) {
1553 if (size > 0) {
1554 var const uint8* ptr1 = (const uint8*)data;
1555 var uint8* ptr2 = (uint8*)&TheSbvector(array)->data[0];
1556 do { *ptr2++ = *ptr1++; } while(--size);
1557 }
1558 }
1559 #if 0
1560 else if (eq(eltype,S(sint8))) {
1561 if (size > 0) {
1562 var const sint8* ptr1 = (const sint8*)data;
1563 var sint8* ptr2 = (sint8*)&TheSbvector(array)->data[0];
1564 do { *ptr2++ = *ptr1++; } while(--size);
1565 }
1566 }
1567 #endif
1568 else if (eq(eltype,S(uint16))) {
1569 if (size > 0) {
1570 var const uint16* ptr1 = (const uint16*)data;
1571 var uint16* ptr2 = (uint16*)&TheSbvector(array)->data[0];
1572 do { *ptr2++ = *ptr1++; } while(--size);
1573 }
1574 }
1575 #if 0
1576 else if (eq(eltype,S(sint16))) {
1577 if (size > 0) {
1578 var const sint16* ptr1 = (const sint16*)data;
1579 var sint16* ptr2 = (sint16*)&TheSbvector(array)->data[0];
1580 do { *ptr2++ = *ptr1++; } while(--size);
1581 }
1582 }
1583 #endif
1584 else if (eq(eltype,S(uint32))) {
1585 if (size > 0) {
1586 var const uint32* ptr1 = (const uint32*)data;
1587 var uint32* ptr2 = (uint32*)&TheSbvector(array)->data[0];
1588 do { *ptr2++ = *ptr1++; } while(--size);
1589 }
1590 }
1591 #if 0
1592 else if (eq(eltype,S(sint32))) {
1593 if (size > 0) {
1594 var const sint32* ptr1 = (const sint32*)data;
1595 var sint32* ptr2 = (sint32*)&TheSbvector(array)->data[0];
1596 do { *ptr2++ = *ptr1++; } while(--size);
1597 }
1598 }
1599 #endif
1600 else
1601 NOTREACHED;
1602 return array;
1603 }
1604 /* Error message */
error_eltype_zero_size(object fvd)1605 local _Noreturn void error_eltype_zero_size (object fvd) {
1606 pushSTACK(fvd);
1607 pushSTACK(TheSubr(subr_self)->name);
1608 error(error_condition,GETTEXT("~S: element type has size 0: ~S"));
1609 }
convert_from_foreign(object fvd,const void * data)1610 modexp maygc object convert_from_foreign (object fvd, const void* data)
1611 { /* keep in sync with foreign1.lisp:convert-from-foreign */
1612 check_SP();
1613 check_STACK();
1614 if (NULL == data) {
1615 pushSTACK(fvd); pushSTACK(TheSubr(subr_self)->name);
1616 error(error_condition,GETTEXT("~S: trying to read an object of type ~S from NULL address"));
1617 }
1618 if (symbolp(fvd)) {
1619 if (eq(fvd,S(nil)))
1620 /* If we are presented the empty type, we take it as "ignore"
1621 and return NIL. */
1622 return NIL;
1623 else if (eq(fvd,S(boolean))) {
1624 var const int* pdata = (const int*)data;
1625 return (*pdata ? T : NIL);
1626 } else if (eq(fvd,S(character))) {
1627 var const uintB* pdata = (const unsigned char *)data;
1628 var chart ch;
1629 #ifdef ENABLE_UNICODE
1630 var object encoding = O(foreign_8bit_encoding);
1631 var chart chbuf[1];
1632 var const uintB* ptr1 = pdata;
1633 var chart* ptr2 = &chbuf[0];
1634 Encoding_mbstowcs(encoding)(encoding,nullobj,&ptr1,ptr1+1,&ptr2,ptr2+1);
1635 ASSERT(ptr2 == &chbuf[1]);
1636 ch = chbuf[0];
1637 #else
1638 ch = as_chart(*pdata);
1639 #endif
1640 return code_char(ch);
1641 } else if (eq(fvd,S(char)) || eq(fvd,S(sint8))) {
1642 var const sint8* pdata = (const sint8*)data;
1643 return sint8_to_I(*pdata);
1644 } else if (eq(fvd,S(uchar)) || eq(fvd,S(uint8))) {
1645 var const uint8* pdata = (const uint8*)data;
1646 return uint8_to_I(*pdata);
1647 } else if (eq(fvd,S(short)) || eq(fvd,S(sint16))) {
1648 var const sint16* pdata = (const sint16*)data;
1649 return sint16_to_I(*pdata);
1650 } else if (eq(fvd,S(ushort)) || eq(fvd,S(uint16))) {
1651 var const uint16* pdata = (const uint16*)data;
1652 return uint16_to_I(*pdata);
1653 } else if (eq(fvd,S(sint32))) {
1654 var const sint32* pdata = (const sint32*)data;
1655 return sint32_to_I(*pdata);
1656 } else if (eq(fvd,S(uint32))) {
1657 var const uint32* pdata = (const uint32*)data;
1658 return uint32_to_I(*pdata);
1659 } else if (eq(fvd,S(sint64))) {
1660 var const struct_sint64* pdata = (const struct_sint64*)data;
1661 #if (long_bitsize<64) && !defined(HAVE_LONG_LONG_INT)
1662 return L2_to_I(pdata->hi,pdata->lo);
1663 #else
1664 return sint64_to_I(*pdata);
1665 #endif
1666 } else if (eq(fvd,S(uint64))) {
1667 var const struct_uint64* pdata = (const struct_uint64*)data;
1668 #if (long_bitsize<64) && !defined(HAVE_LONG_LONG_INT)
1669 return UL2_to_I(pdata->hi,pdata->lo);
1670 #else
1671 return uint64_to_I(*pdata);
1672 #endif
1673 } else if (eq(fvd,S(int))) {
1674 var const int* pdata = (const int*)data;
1675 return sint_to_I(*pdata);
1676 } else if (eq(fvd,S(uint))) {
1677 var const unsigned int * pdata = (const unsigned int *)data;
1678 return uint_to_I(*pdata);
1679 } else if (eq(fvd,S(long))) {
1680 var const long* pdata = (const long*)data;
1681 return slong_to_I(*pdata);
1682 } else if (eq(fvd,S(ulong))) {
1683 var const unsigned long * pdata = (const unsigned long *)data;
1684 return ulong_to_I(*pdata);
1685 } else if (eq(fvd,S(single_float))) {
1686 var const ffloatjanus* pdata = (const ffloatjanus*) data;
1687 return c_float_to_FF(pdata);
1688 } else if (eq(fvd,S(double_float))) {
1689 var const dfloatjanus* pdata = (const dfloatjanus*) data;
1690 return c_double_to_DF(pdata);
1691 } else if (eq(fvd,S(c_pointer))) {
1692 var const uintP address = (uintP)(*(void* const *) data);
1693 return address==0 ? NIL : make_faddress(O(fp_zero),address);
1694 } else if (eq(fvd,S(c_string))) {
1695 var const char * asciz = *(const char * const *) data;
1696 return asciz==NULL ? NIL : asciz_to_string(asciz,O(foreign_encoding));
1697 }
1698 } else if (simple_vector_p(fvd)) {
1699 var uintL fvdlen = Svector_length(fvd);
1700 if (fvdlen > 0) {
1701 var object fvdtype = TheSvector(fvd)->data[0];
1702 if (eq(fvdtype,S(c_struct)) && (fvdlen >= C_STRUCT_C_TYPE_START)) {
1703 pushSTACK(fvd);
1704 {
1705 var gcv_object_t* fvd_ = &STACK_0;
1706 var uintL cumul_size = 0;
1707 var uintL cumul_alignment = struct_alignment;
1708 var uintL i;
1709 for (i = C_STRUCT_C_TYPE_START; i < fvdlen; i++) {
1710 var object fvdi = TheSvector(*fvd_)->data[i];
1711 var struct foreign_layout sas;
1712 foreign_layout(fvdi,&sas);
1713 /* We assume all alignments are of the form 2^k. */
1714 cumul_size += (-cumul_size) & (sas.alignment-1);
1715 var const void* pdata = (const char*)data + cumul_size;
1716 cumul_size += sas.size;
1717 /* cumul_alignment = lcm(cumul_alignment,sas.alignment); */
1718 if (sas.alignment > cumul_alignment)
1719 cumul_alignment = sas.alignment;
1720 /* Now we are finished with sas.size and sas.alignment.
1721 Convert the structure slot: */
1722 fvdi = convert_from_foreign(fvdi,pdata);
1723 pushSTACK(fvdi);
1724 }
1725 /* Call the constructor. */
1726 funcall(TheSvector(*fvd_)->data[C_STRUCT_CONSTRUCTOR],
1727 fvdlen-C_STRUCT_C_TYPE_START);
1728 }
1729 skipSTACK(1);
1730 return value1;
1731 } else if (eq(fvdtype,S(c_union)) && (fvdlen > 1)) {
1732 /* Use the union's first component. */
1733 return convert_from_foreign(fvdlen > 2 ? (object)TheSvector(fvd)->data[2] : NIL, data);
1734 } else if (eq(fvdtype,S(c_array)) && (fvdlen > 1)) {
1735 if (fvdlen == 3 && eq(TheSvector(fvd)->data[1],S(character))) {
1736 /* 1-dimensional array of CHARACTER. */
1737 var uintL dim1 = I_to_UL(TheSvector(fvd)->data[2]);
1738 #ifdef ENABLE_UNICODE
1739 var object encoding = O(foreign_encoding);
1740 var uintL clen =
1741 Encoding_mblen(encoding)(encoding,
1742 (const uintB*)data,(const uintB*)data+dim1);
1743 #else
1744 var uintL clen = dim1;
1745 #endif
1746 check_stringsize(clen);
1747 var object string = allocate_string(clen);
1748 if (clen > 0) {
1749 var chart* cptr = &TheSnstring(string)->data[0];
1750 var const uintB* bptr = (const uintB*)data;
1751 #ifdef ENABLE_UNICODE
1752 var const uintB* bendptr = bptr+dim1;
1753 encoding = O(foreign_encoding);
1754 var chart* cendptr = cptr+clen;
1755 Encoding_mbstowcs(encoding)(encoding,nullobj,&bptr,bendptr,&cptr,cendptr);
1756 ASSERT(cptr == cendptr);
1757 #else
1758 do { *cptr++ = as_chart(*bptr++); } while(--clen);
1759 #endif
1760 }
1761 return string;
1762 }
1763 pushSTACK(fvd);
1764 /* Allocate the resulting array: (MAKE-ARRAY dims :element-type ...) */
1765 var object dims = Cdr(Cdr((coerce_sequence(fvd,S(list),true),value1)));
1766 var object array = convert_from_foreign_array_alloc(dims,TheSvector(STACK_0)->data[1]);
1767 /* Fill the resulting array.
1768 Only a single loop is needed since C and Lisp both store the
1769 elements in row-major order. */
1770 {
1771 var object eltype = TheSvector(STACK_0)->data[1];
1772 var uintL eltype_size = foreign_size(eltype);
1773 STACK_0 = eltype;
1774 var uintL size = array_total_size(array);
1775 pushSTACK(array);
1776 if (!vectorp(array))
1777 array = TheIarray(array)->data; /* fetch the data vector */
1778 if (!simple_vector_p(array)) {
1779 /* Fill specialized array. */
1780 var object reallocated_array =
1781 convert_from_foreign_array_fill(eltype,size,array,data);
1782 array = STACK_0;
1783 if (vectorp(array))
1784 STACK_0 = reallocated_array;
1785 else
1786 TheIarray(array)->data = reallocated_array;
1787 } else {
1788 /* Fill general array.
1789 SYS::ROW-MAJOR-STORE is equivalent to SETF SVREF here. */
1790 pushSTACK(array);
1791 {
1792 var const char* pdata = (const char*)data;
1793 var uintL i;
1794 for (i = 0; i < size; i++, pdata += eltype_size) {
1795 /* pdata = (const char*)data + i*eltype_size */
1796 var object el = convert_from_foreign(STACK_2,(const void*)pdata);
1797 TheSvector(STACK_0)->data[i] = el;
1798 }
1799 }
1800 skipSTACK(1);
1801 }
1802 array = popSTACK();
1803 }
1804 skipSTACK(1);
1805 return array;
1806 } else if (eq(fvdtype,S(c_array_max)) && (fvdlen == 3)) {
1807 var object eltype = TheSvector(fvd)->data[1];
1808 var uintL eltype_size = foreign_size(eltype);
1809 if (eltype_size == 0) error_eltype_zero_size(fvd);
1810 /* Determine length of array: */
1811 var uintL len = 0;
1812 {
1813 var uintL maxdim = I_to_UL(TheSvector(fvd)->data[2]);
1814 var const void* ptr = data;
1815 while (!((len == maxdim) || blockzerop(ptr,eltype_size))) {
1816 ptr = (const void*)((uintP)ptr + eltype_size);
1817 len++;
1818 }
1819 }
1820 if (eq(eltype,S(character))) {
1821 /* 1-dimensional array of CHARACTER. */
1822 #ifdef ENABLE_UNICODE
1823 var object encoding = O(foreign_encoding);
1824 var uintL clen =
1825 Encoding_mblen(encoding)(encoding,
1826 (const uintB*)data,(const uintB*)data+len);
1827 #else
1828 var uintL clen = len;
1829 #endif
1830 check_stringsize(clen);
1831 var object string = allocate_string(clen);
1832 if (clen > 0) {
1833 var chart* cptr = &TheSnstring(string)->data[0];
1834 var const uintB* bptr = (const uintB*)data;
1835 #ifdef ENABLE_UNICODE
1836 var const uintB* bendptr = bptr+len;
1837 encoding = O(foreign_encoding);
1838 var chart* cendptr = cptr+clen;
1839 Encoding_mbstowcs(encoding)(encoding,nullobj,&bptr,bendptr,&cptr,cendptr);
1840 ASSERT(cptr == cendptr);
1841 #else
1842 do { *cptr++ = as_chart(*bptr++); } while(--clen);
1843 #endif
1844 }
1845 return string;
1846 }
1847 pushSTACK(eltype);
1848 /* Allocate the resulting array: */
1849 var object array = convert_from_foreign_array_alloc(UL_to_I(len),eltype);
1850 /* Fill the resulting array. */
1851 if (!simple_vector_p(array)) { /* Fill specialized array. */
1852 array = convert_from_foreign_array_fill(STACK_0,len,array,data);
1853 } else { /* Fill general array, using SYS::SVSTORE. */
1854 pushSTACK(array);
1855 {
1856 var const char* pdata = (const char*)data;
1857 var uintL i;
1858 for (i = 0; i < len; i++, pdata += eltype_size) {
1859 /* pdata = (const char*)data + i*eltype_size */
1860 pushSTACK(STACK_0); /* array */
1861 pushSTACK(fixnum(i));
1862 pushSTACK(convert_from_foreign(STACK_(1+2),(const void*)pdata));
1863 funcall(L(svstore),3);
1864 }
1865 }
1866 array = popSTACK();
1867 }
1868 skipSTACK(1);
1869 return array;
1870 } else if (eq(fvdtype,S(c_function)) && (fvdlen == 4)) {
1871 if (*(void* const*)data == NULL)
1872 return NIL;
1873 else
1874 return convert_function_from_foreign(*(void* const*)data,
1875 TheSvector(fvd)->data[1],
1876 TheSvector(fvd)->data[2],
1877 TheSvector(fvd)->data[3]);
1878 } else if ((eq(fvdtype,S(c_ptr)) || eq(fvdtype,S(c_ptr_null)))
1879 && (fvdlen == 2)) {
1880 if (*(void* const*)data == NULL)
1881 return NIL;
1882 else
1883 return convert_from_foreign(TheSvector(fvd)->data[1],
1884 *(void* const*)data);
1885 } else if (eq(fvdtype,S(c_pointer)) && (fvdlen == 2)) {
1886 if (*(void* const*)data == NULL)
1887 return NIL;
1888 else {
1889 var const uintP address = (uintP)(*(void* const *) data);
1890 pushSTACK(TheSvector(fvd)->data[1]);
1891 pushSTACK(make_faddress(O(fp_zero),address));
1892 var object fvar = allocate_fvariable();
1893 record_flags_replace(TheFvariable(fvar), 0);
1894 TheFvariable(fvar)->fv_name = NIL; /* no name known */
1895 TheFvariable(fvar)->fv_address = popSTACK();
1896 fvd = popSTACK();
1897 TheFvariable(fvar)->fv_size = fixnum(foreign_size(fvd));
1898 TheFvariable(fvar)->fv_type = fvd;
1899 return fvar;
1900 }
1901 } else if (eq(fvdtype,S(c_array_ptr)) && (fvdlen == 2)) {
1902 if (*(void* const*)data == NULL)
1903 return NIL;
1904 else {
1905 var object eltype = TheSvector(fvd)->data[1];
1906 var uintL eltype_size = foreign_size(eltype);
1907 if (eltype_size == 0) error_eltype_zero_size(fvd);
1908 /* Determine length of array: */
1909 var uintL len = 0;
1910 {
1911 var const void* ptr = *(const void* const*)data;
1912 while (!blockzerop(ptr,eltype_size)) {
1913 ptr = (const void*)((uintP)ptr + eltype_size);
1914 len++;
1915 }
1916 }
1917 if (eq(eltype,S(character))) {
1918 /* 1-dimensional array of CHARACTER. */
1919 #ifdef ENABLE_UNICODE
1920 var object encoding = O(foreign_encoding);
1921 var uintL clen =
1922 Encoding_mblen(encoding)(encoding,
1923 *(const uintB**)data,*(const uintB**)data+len);
1924 #else
1925 var uintL clen = len;
1926 #endif
1927 check_stringsize(clen);
1928 var object string = allocate_string(clen);
1929 if (clen > 0) {
1930 var chart* cptr = &TheSnstring(string)->data[0];
1931 var const uintB* bptr = *(const uintB**)data;
1932 #ifdef ENABLE_UNICODE
1933 var const uintB* bendptr = bptr+len;
1934 encoding = O(foreign_encoding);
1935 var chart* cendptr = cptr+clen;
1936 Encoding_mbstowcs(encoding)(encoding,nullobj,&bptr,bendptr,&cptr,cendptr);
1937 ASSERT(cptr == cendptr);
1938 #else
1939 do { *cptr++ = as_chart(*bptr++); } while(--clen);
1940 #endif
1941 }
1942 return string;
1943 }
1944 pushSTACK(eltype);
1945 /* Allocate Lisp array: */
1946 pushSTACK(allocate_vector(len));
1947 /* Fill Lisp array: */
1948 {
1949 var const void* ptr = *(const void* const*)data;
1950 var uintL i;
1951 for (i = 0; i < len; i++) {
1952 var object obj = convert_from_foreign(STACK_1,ptr);
1953 TheSvector(STACK_0)->data[i] = obj;
1954 ptr = (const void*)((uintP)ptr + eltype_size);
1955 }
1956 }
1957 var object result = STACK_0;
1958 skipSTACK(2);
1959 return result;
1960 }
1961 }
1962 }
1963 } else {
1964 var object inttype = gethash(fvd,O(foreign_inttype_table),false);
1965 if (!eq(inttype,nullobj))
1966 return convert_from_foreign(inttype,data);
1967 }
1968 error_foreign_type(fvd);
1969 }
1970
1971 /* Test whether a foreign type contained C-PTRs (recursively). */
foreign_with_pointers_p(object fvd)1972 local bool foreign_with_pointers_p (object fvd)
1973 {
1974 check_SP();
1975 if (symbolp(fvd)) {
1976 if (eq(fvd,S(c_string)))
1977 return true;
1978 return false;
1979 } else if (stringp(fvd)) {
1980 return false; /* inttype */
1981 } else if (simple_vector_p(fvd)) {
1982 var uintL fvdlen = Svector_length(fvd);
1983 if (fvdlen > 0) {
1984 var object fvdtype = TheSvector(fvd)->data[0];
1985 if (eq(fvdtype,S(c_struct)) && (fvdlen >= C_STRUCT_C_TYPE_START)) {
1986 var uintL i;
1987 for (i = C_STRUCT_C_TYPE_START; i < fvdlen; i++)
1988 if (foreign_with_pointers_p(TheSvector(fvd)->data[i]))
1989 return true;
1990 return false;
1991 } else if (eq(fvdtype,S(c_union)) && (fvdlen > 1)) {
1992 /* Use the union's first component. */
1993 return foreign_with_pointers_p(fvdlen > 2 ? (object)TheSvector(fvd)->data[2] : NIL);
1994 } else if ((eq(fvdtype,S(c_array)) && (fvdlen > 1))
1995 || (eq(fvdtype,S(c_array_max)) && (fvdlen == 3))) {
1996 var uintL i;
1997 for (i = 2; i < fvdlen; i++)
1998 if (eq(TheSvector(fvd)->data[i],Fixnum_0))
1999 return false;
2000 return foreign_with_pointers_p(TheSvector(fvd)->data[1]);
2001 } else if (eq(fvdtype,S(c_function)) && (fvdlen == 4)) {
2002 return true;
2003 } else if ((eq(fvdtype,S(c_ptr)) || eq(fvdtype,S(c_ptr_null))
2004 || eq(fvdtype,S(c_array_ptr))) && (fvdlen == 2)) {
2005 return true;
2006 } else if (eq(fvdtype,S(c_pointer)) && (fvdlen == 2)) {
2007 return false;
2008 }
2009 }
2010 }
2011 error_foreign_type(fvd);
2012 }
2013
2014 struct walk_foreign {
2015 bool null_terminates;
2016 /* what's the meaning of fvd here?? */
2017 void (*pre_hook) (object fvd, void** pdata, struct walk_foreign *walk);
2018 void (*post_hook) (object fvd, void** pdata, struct walk_foreign *walk);
2019 void (*function_hook) (object fvd, void** pdata, struct walk_foreign *walk);
2020 };
2021
2022 /* Walk foreign data, giving special attention to the pointers. */
walk_foreign_pointers(object fvd,void * data,struct walk_foreign * walk)2023 local void walk_foreign_pointers (object fvd, void* data,
2024 struct walk_foreign *walk)
2025 {
2026 if (!foreign_with_pointers_p(fvd))
2027 return;
2028 check_SP();
2029 if (symbolp(fvd)) {
2030 if (eq(fvd,S(c_string))) {
2031 if (walk->null_terminates) {
2032 /* NULL pointers stop the recursion */
2033 if (*(void**)data == NULL)
2034 return;
2035 }
2036 (*walk->pre_hook)(fvd,(void**)data,walk);
2037 (*walk->post_hook)(fvd,(void**)data,walk);
2038 return;
2039 }
2040 } else if (simple_vector_p(fvd)) {
2041 var uintL fvdlen = Svector_length(fvd);
2042 if (fvdlen > 0) {
2043 var object fvdtype = TheSvector(fvd)->data[0];
2044 if (eq(fvdtype,S(c_struct)) && (fvdlen >= C_STRUCT_C_TYPE_START)) {
2045 var uintL cumul_size = 0;
2046 var uintL cumul_alignment = struct_alignment;
2047 var uintL i;
2048 for (i = C_STRUCT_C_TYPE_START; i < fvdlen; i++) {
2049 var object fvdi = TheSvector(fvd)->data[i];
2050 var struct foreign_layout sas;
2051 foreign_layout(fvdi,&sas);
2052 /* We assume all alignments are of the form 2^k. */
2053 cumul_size += (-cumul_size) & (sas.alignment-1);
2054 var void* pdata = (char*)data + cumul_size;
2055 cumul_size += sas.size;
2056 /* cumul_alignment = lcm(cumul_alignment,sas.alignment); */
2057 if (sas.alignment > cumul_alignment)
2058 cumul_alignment = sas.alignment;
2059 /* Now we are finished with sas.size and sas.alignment.
2060 Descend into the structure slot: */
2061 walk_foreign_pointers(fvdi,pdata,walk);
2062 }
2063 return;
2064 } else if (eq(fvdtype,S(c_union)) && (fvdlen > 1)) {
2065 /* Use the union's first component. */
2066 if (fvdlen > 2)
2067 walk_foreign_pointers(TheSvector(fvd)->data[2],data,walk);
2068 return;
2069 } else if (eq(fvdtype,S(c_array)) && (fvdlen > 1)) {
2070 var object eltype = TheSvector(fvd)->data[1];
2071 var uintL eltype_size = foreign_size(eltype);
2072 var uintL size = 1;
2073 {
2074 var uintL i;
2075 for (i = 2; i < fvdlen; i++) {
2076 var object dim = TheSvector(fvd)->data[i];
2077 if (!uint32_p(dim))
2078 error_foreign_type(fvd);
2079 size *= I_to_uint32(dim);
2080 }
2081 }
2082 {
2083 var uintL i;
2084 var char* pdata = (char*)data;
2085 for (i = 0; i < size; i++, pdata += eltype_size) {
2086 /* pdata = (char*)data + i*eltype_size */
2087 walk_foreign_pointers(eltype,pdata,walk);
2088 }
2089 }
2090 return;
2091 } else if (eq(fvdtype,S(c_array_max)) && (fvdlen == 3)) {
2092 var object eltype = TheSvector(fvd)->data[1];
2093 var uintL eltype_size = foreign_size(eltype);
2094 if (eltype_size == 0) error_eltype_zero_size(fvd);
2095 {
2096 var uintL maxdim = I_to_UL(TheSvector(fvd)->data[2]);
2097 var uintL len = 0;
2098 var void* ptr = data;
2099 while (!((len == maxdim) || blockzerop(ptr,eltype_size))) {
2100 walk_foreign_pointers(eltype,ptr,walk);
2101 ptr = (void*)((uintP)ptr + eltype_size);
2102 len++;
2103 }
2104 }
2105 return;
2106 } else if (eq(fvdtype,S(c_function)) && (fvdlen == 4)) {
2107 if (walk->null_terminates) {
2108 /* NULL pointers stop the recursion */
2109 if (*(void**)data == NULL)
2110 return;
2111 }
2112 (*walk->function_hook)(fvd,(void**)data,walk);
2113 return;
2114 } else if ((eq(fvdtype,S(c_ptr)) || eq(fvdtype,S(c_ptr_null)))
2115 && (fvdlen == 2)) {
2116 if (walk->null_terminates || eq(fvdtype,S(c_ptr_null))) {
2117 /* NULL pointers stop the recursion */
2118 if (*(void**)data == NULL)
2119 return;
2120 }
2121 fvd = TheSvector(fvd)->data[1];
2122 (*walk->pre_hook)(fvd,(void**)data,walk);
2123 walk_foreign_pointers(fvd,*(void**)data,walk);
2124 (*walk->post_hook)(fvd,(void**)data,walk);
2125 return;
2126 } else if (eq(fvdtype,S(c_array_ptr)) && (fvdlen == 2)) {
2127 if (walk->null_terminates) {
2128 /* NULL pointers stop the recursion */
2129 if (*(void**)data == NULL)
2130 return;
2131 }
2132 var object elfvd = TheSvector(fvd)->data[1];
2133 (*walk->pre_hook)(elfvd,(void**)data,walk);
2134 {
2135 var uintL eltype_size = foreign_size(elfvd);
2136 if (eltype_size == 0) error_eltype_zero_size(fvd);
2137 var void* ptr = *(void**)data;
2138 while (!blockzerop(ptr,eltype_size)) {
2139 walk_foreign_pointers(elfvd,ptr,walk);
2140 ptr = (void*)((uintP)ptr + eltype_size);
2141 }
2142 }
2143 (*walk->post_hook)(elfvd,(void**)data,walk);
2144 return;
2145 }
2146 }
2147 }
2148 error_foreign_type(fvd);
2149 }
2150
2151 /* Free the storage used by foreign data. */
2152 global void free_foreign (object fvd, void* data);
free_walk_pre(object fvd,void ** pdata,struct walk_foreign * walk)2153 local void free_walk_pre (object fvd, void** pdata, struct walk_foreign *walk)
2154 {
2155 unused(fvd); unused(pdata); unused(walk);
2156 }
free_walk_post(object fvd,void ** pdata,struct walk_foreign * walk)2157 local void free_walk_post (object fvd, void** pdata, struct walk_foreign *walk)
2158 {
2159 unused(fvd); unused(walk);
2160 begin_system_call();
2161 free(*pdata);
2162 end_system_call();
2163 *pdata = NULL; /* for safety */
2164 }
free_walk_function(object fvd,void ** pdata,struct walk_foreign * walk)2165 local void free_walk_function (object fvd, void** pdata,
2166 struct walk_foreign *walk)
2167 {
2168 unused(fvd); unused(walk);
2169 free_foreign_callin(*pdata);
2170 *pdata = NULL; /* for safety */
2171 }
free_foreign(object fvd,void * data)2172 global void free_foreign (object fvd, void* data)
2173 {
2174 struct walk_foreign walk
2175 = { true, &free_walk_pre, &free_walk_post, &free_walk_function };
2176 walk_foreign_pointers(fvd,data,&walk);
2177 }
2178
2179 /* Some flags and hooks that direct the walk: */
2180 struct walk_lisp {
2181 uintL counter;
2182 uintL alignment;
2183 bool nil_terminates;
2184 void (*pre_hook) (object fvd, object obj, struct walk_lisp *walk);
2185 void (*post_hook) (object fvd, object obj, struct walk_lisp *walk);
2186 void (*function_hook) (object fvd, object obj, struct walk_lisp *walk);
2187 };
2188
2189 /* Walk Lisp data, giving special attention to the pointers.
2190 can trigger GC */
walk_lisp_pointers(object fvd,object obj,struct walk_lisp * walk)2191 local maygc void walk_lisp_pointers (object fvd, object obj,
2192 struct walk_lisp *walk) {
2193 if (!foreign_with_pointers_p(fvd))
2194 return;
2195 check_SP();
2196 check_STACK();
2197 if (symbolp(fvd)) {
2198 if (eq(fvd,S(c_string))) {
2199 if (walk->nil_terminates) {
2200 /* NIL pointers stop the recursion */
2201 if (nullp(obj))
2202 return;
2203 }
2204 if (!stringp(obj)) goto bad_obj;
2205 (*walk->pre_hook)(fvd,obj,walk);
2206 (*walk->post_hook)(fvd,obj,walk);
2207 return;
2208 }
2209 } else if (simple_vector_p(fvd)) {
2210 var uintL fvdlen = Svector_length(fvd);
2211 if (fvdlen > 0) {
2212 var object fvdtype = TheSvector(fvd)->data[0];
2213 if (eq(fvdtype,S(c_struct)) && (fvdlen >= C_STRUCT_C_TYPE_START)) {
2214 var object slots = TheSvector(fvd)->data[C_STRUCT_SLOTS];
2215 var object constructor = TheSvector(fvd)->data[C_STRUCT_CONSTRUCTOR];
2216 if (!(simple_vector_p(slots)
2217 && (Svector_length(slots)==fvdlen-C_STRUCT_C_TYPE_START)))
2218 error_foreign_type(fvd);
2219 if (eq(constructor,L(vector))) {
2220 if (!(simple_vector_p(obj)
2221 && (Svector_length(obj)==fvdlen-C_STRUCT_C_TYPE_START)))
2222 goto bad_obj;
2223 } else if (eq(constructor,L(list))) {
2224 } else {
2225 if (!(structurep(obj) || instancep(obj)))
2226 goto bad_obj;
2227 }
2228 pushSTACK(constructor);
2229 pushSTACK(slots);
2230 pushSTACK(fvd);
2231 pushSTACK(obj);
2232 var uintL cumul_size = 0;
2233 var uintL cumul_alignment = struct_alignment;
2234 var uintL i;
2235 for (i = C_STRUCT_C_TYPE_START; i < fvdlen; i++) {
2236 var object obji;
2237 if (eq(STACK_3,L(vector))) {
2238 obji = TheSvector(STACK_0)->data[i-C_STRUCT_C_TYPE_START];
2239 } else if (eq(STACK_3,L(list))) {
2240 obji = STACK_0;
2241 if (atomp(obji)) goto bad_obj;
2242 STACK_0 = Cdr(obji); obji = Car(obji);
2243 } else { /* simple_vector_p(slots)
2244 && (Svector_length(slots)==fvdlen-C_STRUCT_C_TYPE_START) */
2245 pushSTACK(STACK_0);
2246 pushSTACK(TheSvector(STACK_(2+1))->data[i-C_STRUCT_C_TYPE_START]);
2247 funcall(L(slot_value),2); obji = value1;
2248 }
2249 var object fvdi = TheSvector(STACK_1)->data[i];
2250 var struct foreign_layout sas;
2251 foreign_layout(fvdi,&sas);
2252 /* We assume all alignments are of the form 2^k. */
2253 cumul_size += (-cumul_size) & (sas.alignment-1);
2254 cumul_size += sas.size;
2255 /* cumul_alignment = lcm(cumul_alignment,sas.alignment); */
2256 if (sas.alignment > cumul_alignment)
2257 cumul_alignment = sas.alignment;
2258 /* Now we are finished with sas.size and sas.alignment.
2259 Descend into the structure slot: */
2260 walk_lisp_pointers(fvdi,obji,walk);
2261 }
2262 skipSTACK(4);
2263 return;
2264 } else if (eq(fvdtype,S(c_union)) && (fvdlen > 1)) {
2265 /* Use the union's first component. */
2266 if (fvdlen > 2)
2267 walk_lisp_pointers(TheSvector(fvd)->data[2],obj,walk);
2268 return;
2269 } else if (eq(fvdtype,S(c_array)) && (fvdlen > 1)) {
2270 var object eltype = TheSvector(fvd)->data[1];
2271 var uintL size = 1;
2272 var struct foreign_layout sas;
2273 foreign_layout(eltype,&sas);
2274 {
2275 var uintL i;
2276 for (i = 2; i < fvdlen; i++) {
2277 var object dim = TheSvector(fvd)->data[i];
2278 if (!uint32_p(dim))
2279 error_foreign_type(fvd);
2280 size *= I_to_uint32(dim);
2281 }
2282 }
2283 if (!(arrayp(obj) && array_total_size(obj)==size))
2284 goto bad_obj;
2285 pushSTACK(eltype);
2286 pushSTACK(obj);
2287 {
2288 var uintL i;
2289 for (i = 0; i < size; i++) {
2290 pushSTACK(STACK_0); pushSTACK(fixnum(i));
2291 funcall(L(row_major_aref),2);
2292 walk_lisp_pointers(STACK_1,value1,walk);
2293 }
2294 }
2295 skipSTACK(2);
2296 return;
2297 } else if (eq(fvdtype,S(c_array_max)) && (fvdlen == 3)) {
2298 var object eltype = TheSvector(fvd)->data[1];
2299 var uintL maxdim = I_to_UL(TheSvector(fvd)->data[2]);
2300 var struct foreign_layout data;
2301 foreign_layout(eltype,&data);
2302 if (!vectorp(obj))
2303 goto bad_obj;
2304 var uintL len = vector_length(obj);
2305 if (len > maxdim)
2306 len = maxdim;
2307 pushSTACK(eltype);
2308 pushSTACK(obj);
2309 {
2310 var uintL i;
2311 for (i = 0; i < len; i++) {
2312 pushSTACK(STACK_0); pushSTACK(fixnum(i));
2313 funcall(L(aref),2);
2314 walk_lisp_pointers(STACK_1,value1,walk);
2315 }
2316 }
2317 skipSTACK(2);
2318 return;
2319 } else if (eq(fvdtype,S(c_function)) && (fvdlen == 4)) {
2320 (*walk->function_hook)(fvd,obj,walk);
2321 return;
2322 } else if ((eq(fvdtype,S(c_ptr)) || eq(fvdtype,S(c_ptr_null)))
2323 && (fvdlen == 2)) {
2324 if (walk->nil_terminates || eq(fvdtype,S(c_ptr_null))) {
2325 /* NIL pointers stop the recursion */
2326 if (nullp(obj))
2327 return;
2328 }
2329 (*walk->pre_hook)(fvd,obj,walk);
2330 pushSTACK(fvd);
2331 walk_lisp_pointers(TheSvector(fvd)->data[1],obj,walk);
2332 fvd = popSTACK();
2333 (*walk->post_hook)(fvd,obj,walk);
2334 return;
2335 } else if (eq(fvdtype,S(c_array_ptr)) && (fvdlen == 2)) {
2336 if (walk->nil_terminates) {
2337 /* NIL pointers stop the recursion */
2338 if (nullp(obj))
2339 return;
2340 }
2341 if (!vectorp(obj)) goto bad_obj;
2342 (*walk->pre_hook)(fvd,obj,walk);
2343 pushSTACK(fvd);
2344 pushSTACK(TheSvector(fvd)->data[1]); /* eltype */
2345 pushSTACK(obj);
2346 {
2347 var uintL size = vector_length(obj);
2348 var uintL i;
2349 for (i = 0; i < size; i++) {
2350 pushSTACK(STACK_0); pushSTACK(fixnum(i));
2351 funcall(L(aref),2);
2352 walk_lisp_pointers(STACK_1,value1,walk);
2353 }
2354 }
2355 skipSTACK(2);
2356 fvd = popSTACK();
2357 (*walk->post_hook)(fvd,obj,walk);
2358 return;
2359 }
2360 }
2361 }
2362 error_foreign_type(fvd);
2363 bad_obj:
2364 error_convert(fvd,obj);
2365 }
2366
2367 /* Determine amount of additional storage needed
2368 to convert Lisp data to foreign data.
2369 can trigger GC */
2370 local maygc void convert_to_foreign_needs (object fvd, object obj,
2371 struct foreign_layout *sas);
count_walk_pre(object fvd,object obj,struct walk_lisp * walk)2372 local void count_walk_pre (object fvd, object obj, struct walk_lisp *walk)
2373 {
2374 var uintL size;
2375 var uintL alignment;
2376 if (eq(fvd,S(c_string))) {
2377 if (nullp(obj))
2378 size = 0;
2379 else {
2380 ASSERT(stringp(obj));
2381 var uintL len;
2382 var uintL offset;
2383 var object string = unpack_string_ro(obj,&len,&offset);
2384 var const chart* ptr1;
2385 unpack_sstring_alloca(string,len,offset, ptr1=);
2386 var uintL bytelen = cslen(O(foreign_encoding),ptr1,len);
2387 size = bytelen + 1;
2388 }
2389 alignment = 1;
2390 } else {
2391 /* fvd = #(c-ptr ...), #(c-ptr-null ...), #(c-array-ptr ...) */
2392 var object eltype = TheSvector(fvd)->data[1];
2393 var struct foreign_layout sas;
2394 foreign_layout(eltype,&sas);
2395 size = sas.size;
2396 alignment = sas.alignment;
2397 if (eq(TheSvector(fvd)->data[0],S(c_array_ptr))) {
2398 if (eq(eltype,S(character)) && stringp(obj)) {
2399 var uintL clen;
2400 var uintL offset;
2401 var object string = unpack_string_ro(obj,&clen,&offset);
2402 var const chart* ptr1;
2403 unpack_sstring_alloca(string,clen,offset, ptr1=);
2404 var uintL blen = cslen(O(foreign_encoding),ptr1,clen);
2405 size = blen + 1;
2406 } else {
2407 size *= vector_length(obj) + 1;
2408 }
2409 }
2410 }
2411 walk->counter = ((walk->counter + alignment-1) & -alignment) + size;
2412 /* walk->alignment = lcm(walk->alignment,alignment); */
2413 if (alignment > walk->alignment)
2414 walk->alignment = alignment;
2415 }
count_walk_post(object fvd,object obj,struct walk_lisp * walk)2416 local void count_walk_post (object fvd, object obj, struct walk_lisp *walk)
2417 {
2418 unused(fvd); unused(obj); unused(walk);
2419 }
convert_to_foreign_needs(object fvd,object obj,struct foreign_layout * sas)2420 local maygc void convert_to_foreign_needs (object fvd, object obj,
2421 struct foreign_layout *sas)
2422 {
2423 struct walk_lisp walk
2424 = { 0, 1, true, &count_walk_pre, &count_walk_post, &count_walk_post };
2425 walk_lisp_pointers(fvd,obj,&walk);
2426 sas->size = walk.counter; sas->alignment = walk.alignment;
2427 }
2428
2429 /* Convert Lisp data to foreign data.
2430 Storage is allocated through converter_malloc().
2431 Only the toplevel storage must already exist; its address is given.
2432 can trigger GC */
convert_to_foreign(object fvd,object obj,void * data,converter_malloc_t * converter_malloc,void ** state)2433 modexp maygc void convert_to_foreign
2434 (object fvd, object obj, void* data, converter_malloc_t *converter_malloc,
2435 void** state) { /* keep in sync with foreign1.lisp:convert-to-foreign */
2436 check_SP();
2437 check_STACK();
2438 if (NULL == data) {
2439 pushSTACK(fvd); pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
2440 error(error_condition,GETTEXT("~S: trying to write object ~S of type ~S into NULL address"));
2441 }
2442 if (symbolp(fvd)) {
2443 if (eq(fvd,S(c_pointer))) {
2444 if (fvariablep(obj))
2445 obj = TheFvariable(obj)->fv_address;
2446 else if (nullp(obj)) { *(void**)data = NULL; return; }
2447 else if (fpointerp(obj)) {
2448 *(void**)data = Fpointer_value(validate_fpointer(obj)); return;
2449 } else if (!faddressp(obj)) goto bad_obj;
2450 obj = check_faddress_valid(obj);
2451 *(void**)data = Faddress_value(obj);
2452 return;
2453 } else if (eq(fvd,S(c_string))) {
2454 if (nullp(obj)) {
2455 *(char**)data = NULL;
2456 return;
2457 }
2458 if (!stringp(obj)) goto bad_obj;
2459 var uintL len;
2460 var uintL offset;
2461 var object string = unpack_string_ro(obj,&len,&offset);
2462 var const chart* ptr1;
2463 unpack_sstring_alloca(string,len,offset, ptr1=);
2464 var uintL bytelen = cslen(O(foreign_encoding),ptr1,len);
2465 /* bytelen is the same as computed earlier in count_walk_pre. */
2466 var char* asciz =
2467 (char*)converter_malloc(*(char**)data,bytelen+1,1,state);
2468 cstombs(O(foreign_encoding),ptr1,len,(uintB*)asciz,bytelen);
2469 asciz[bytelen] = '\0';
2470 *(char**)data = asciz;
2471 return;
2472 } else if (eq(fvd,S(char)) || eq(fvd,S(sint8))) {
2473 var sint8* pdata = (sint8*)data;
2474 if (!sint8_p(obj)) goto bad_obj;
2475 *pdata = I_to_sint8(obj);
2476 return;
2477 } else if (eq(fvd,S(uchar)) || eq(fvd,S(uint8))) {
2478 var uint8* pdata = (uint8*)data;
2479 if (!uint8_p(obj)) goto bad_obj;
2480 *pdata = I_to_uint8(obj);
2481 return;
2482 } else if (eq(fvd,S(short)) || eq(fvd,S(sint16))) {
2483 var sint16* pdata = (sint16*)data;
2484 if (!sint16_p(obj)) goto bad_obj;
2485 *pdata = I_to_sint16(obj);
2486 return;
2487 } else if (eq(fvd,S(ushort)) || eq(fvd,S(uint16))) {
2488 var uint16* pdata = (uint16*)data;
2489 if (!uint16_p(obj)) goto bad_obj;
2490 *pdata = I_to_uint16(obj);
2491 return;
2492 } else if (eq(fvd,S(sint32))) {
2493 var sint32* pdata = (sint32*)data;
2494 if (!sint32_p(obj)) goto bad_obj;
2495 *pdata = I_to_sint32(obj);
2496 return;
2497 } else if (eq(fvd,S(uint32))) {
2498 var uint32* pdata = (uint32*)data;
2499 if (!uint32_p(obj)) goto bad_obj;
2500 *pdata = I_to_uint32(obj);
2501 return;
2502 }
2503 #ifdef HAVE_LONG_LONG_INT
2504 else if (eq(fvd,S(sint64))) {
2505 var struct_sint64* pdata = (struct_sint64*)data;
2506 if (!sint64_p(obj)) goto bad_obj;
2507 var sint64 val = I_to_sint64(obj);
2508 #if (long_bitsize<64) && !defined(HAVE_LONG_LONG_INT)
2509 pdata->hi = (sint32)(val>>32); pdata->lo = (uint32)val;
2510 #else
2511 *pdata = val;
2512 #endif
2513 return;
2514 } else if (eq(fvd,S(uint64))) {
2515 var struct_uint64* pdata = (struct_uint64*)data;
2516 if (!uint64_p(obj)) goto bad_obj;
2517 var uint64 val = I_to_uint64(obj);
2518 #if (long_bitsize<64) && !defined(HAVE_LONG_LONG_INT)
2519 pdata->hi = (uint32)(val>>32); pdata->lo = (uint32)val;
2520 #else
2521 *pdata = val;
2522 #endif
2523 return;
2524 }
2525 #else
2526 else if (eq(fvd,S(sint64)) || eq(fvd,S(uint64))) {
2527 error_64bit(fvd);
2528 }
2529 #endif
2530 else if (eq(fvd,S(int))) {
2531 var int* pdata = (int*)data;
2532 if (!sint_p(obj)) goto bad_obj;
2533 *pdata = I_to_sint(obj);
2534 return;
2535 } else if (eq(fvd,S(uint))) {
2536 var unsigned int * pdata = (unsigned int *)data;
2537 if (!uint_p(obj)) goto bad_obj;
2538 *pdata = I_to_uint(obj);
2539 return;
2540 } else if (eq(fvd,S(long))) {
2541 var long* pdata = (long*)data;
2542 if (!slong_p(obj)) goto bad_obj;
2543 *pdata = I_to_slong(obj);
2544 return;
2545 } else if (eq(fvd,S(ulong))) {
2546 var unsigned long * pdata = (unsigned long *)data;
2547 if (!ulong_p(obj)) goto bad_obj;
2548 *pdata = I_to_ulong(obj);
2549 return;
2550 } else if (eq(fvd,S(single_float))) {
2551 if (!single_float_p(obj)) obj = coerce_float(obj,S(single_float));
2552 FF_to_c_float(obj,(ffloatjanus*)data);
2553 return;
2554 } else if (eq(fvd,S(double_float))) {
2555 if (!double_float_p(obj)) obj = coerce_float(obj,S(double_float));
2556 DF_to_c_double(obj,(dfloatjanus*)data);
2557 return;
2558 } else if (eq(fvd,S(boolean))) {
2559 var int* pdata = (int*)data;
2560 if (nullp(obj))
2561 *pdata = 0;
2562 else if (eq(obj,T))
2563 *pdata = 1;
2564 else
2565 goto bad_obj;
2566 return;
2567 } else if (eq(fvd,S(character))) {
2568 var uintB* pdata = (unsigned char *)data;
2569 if (!charp(obj)) goto bad_obj;
2570 var chart ch = char_code(obj);
2571 #ifdef ENABLE_UNICODE
2572 ASSERT(cslen(O(foreign_8bit_encoding),&ch,1) == 1);
2573 cstombs(O(foreign_8bit_encoding),&ch,1,pdata,1);
2574 #else
2575 *pdata = as_cint(ch);
2576 #endif
2577 return;
2578 } else if (eq(fvd,S(nil)))
2579 /* If we are presented the empty type, we take it as "ignore". */
2580 return;
2581 } else if (simple_vector_p(fvd)) {
2582 var uintL fvdlen = Svector_length(fvd);
2583 if (fvdlen > 0) {
2584 var object fvdtype = TheSvector(fvd)->data[0];
2585 if (eq(fvdtype,S(c_struct)) && (fvdlen >= C_STRUCT_C_TYPE_START)) {
2586 var object slots = TheSvector(fvd)->data[C_STRUCT_SLOTS];
2587 var object constructor = TheSvector(fvd)->data[C_STRUCT_CONSTRUCTOR];
2588 if (!(simple_vector_p(slots)
2589 && (Svector_length(slots)==fvdlen-C_STRUCT_C_TYPE_START)))
2590 error_foreign_type(fvd);
2591 if (eq(constructor,L(vector))) {
2592 if (!(simple_vector_p(obj)
2593 && (Svector_length(obj)==fvdlen-C_STRUCT_C_TYPE_START)))
2594 goto bad_obj;
2595 } else if (eq(constructor,L(list))) {
2596 } else {
2597 if (!(structurep(obj) || instancep(obj)))
2598 goto bad_obj;
2599 }
2600 pushSTACK(constructor);
2601 pushSTACK(slots);
2602 pushSTACK(fvd);
2603 pushSTACK(obj);
2604 var uintL cumul_size = 0;
2605 var uintL cumul_alignment = struct_alignment;
2606 var uintL i;
2607 for (i = C_STRUCT_C_TYPE_START; i < fvdlen; i++) {
2608 var object obji;
2609 if (eq(STACK_3,L(vector))) {
2610 obji = TheSvector(STACK_0)->data[i-C_STRUCT_C_TYPE_START];
2611 } else if (eq(STACK_3,L(list))) {
2612 obji = STACK_0;
2613 if (atomp(obji)) goto bad_obj;
2614 STACK_0 = Cdr(obji); obji = Car(obji);
2615 } else { /* simple_vector_p(slots)
2616 && (Svector_length(slots)==fvdlen-C_STRUCT_C_TYPE_START) */
2617 pushSTACK(STACK_0);
2618 pushSTACK(TheSvector(STACK_(2+1))->data[i-C_STRUCT_C_TYPE_START]);
2619 funcall(L(slot_value),2); obji = value1;
2620 }
2621 var object fvdi = TheSvector(STACK_1)->data[i];
2622 var struct foreign_layout sas;
2623 foreign_layout(fvdi,&sas);
2624 /* We assume all alignments are of the form 2^k. */
2625 cumul_size += (-cumul_size) & (sas.alignment-1);
2626 var void* pdata = (char*)data + cumul_size;
2627 cumul_size += sas.size;
2628 /* cumul_alignment = lcm(cumul_alignment,sas.alignment); */
2629 if (sas.alignment > cumul_alignment)
2630 cumul_alignment = sas.alignment;
2631 /* Now we are finished with sas.size and sas.alignment.
2632 Descend into the structure slot: */
2633 convert_to_foreign(fvdi,obji,pdata,converter_malloc,state);
2634 }
2635 skipSTACK(4);
2636 return;
2637 } else if (eq(fvdtype,S(c_union)) && (fvdlen > 1)) {
2638 /* Use the union's first component. */
2639 convert_to_foreign(fvdlen > 2 ? (object)TheSvector(fvd)->data[2] : NIL,
2640 obj,data,converter_malloc,state);
2641 return;
2642 } else if (eq(fvdtype,S(c_array)) && (fvdlen > 1)) {
2643 var object eltype = TheSvector(fvd)->data[1];
2644 if (fvdlen == 3 && eq(eltype,S(character)) && stringp(obj)) {
2645 /* 1-dimensional array of CHARACTER. */
2646 var uintL clen;
2647 var uintL offset;
2648 var object string = unpack_string_ro(obj,&clen,&offset);
2649 var const chart* ptr1;
2650 unpack_sstring_alloca(string,clen,offset, ptr1=);
2651 var uintL blen = cslen(O(foreign_encoding),ptr1,clen);
2652 if (blen != I_to_UL(TheSvector(fvd)->data[2]))
2653 goto bad_obj;
2654 cstombs(O(foreign_encoding),ptr1,clen,(uintB*)data,blen);
2655 return;
2656 }
2657 var uintL eltype_size = foreign_size(eltype);
2658 var uintL size = 1;
2659 {
2660 var uintL i;
2661 for (i = 2; i < fvdlen; i++) {
2662 var object dim = TheSvector(fvd)->data[i];
2663 if (!uint32_p(dim))
2664 error_foreign_type(fvd);
2665 size *= I_to_uint32(dim);
2666 }
2667 }
2668 if (!(arrayp(obj) && array_total_size(obj)==size))
2669 goto bad_obj;
2670 if (eq(eltype,S(character)) && stringp(obj)) {
2671 var uintL len;
2672 var uintL offset;
2673 var object string = unpack_string_ro(obj,&len,&offset);
2674 var const chart* ptr1;
2675 unpack_sstring_alloca(string,len,offset, ptr1=);
2676 ASSERT(cslen(O(foreign_8bit_encoding),ptr1,len) == len);
2677 cstombs(O(foreign_8bit_encoding),ptr1,len,(uintB*)data,len);
2678 } else if (eq(eltype,S(uint8)) && bit_vector_p(Atype_8Bit,obj)) {
2679 if (size > 0) {
2680 var uintL offset = 0;
2681 obj = array_displace_check(obj,size,&offset);
2682 var const uint8* ptr1 = &TheSbvector(obj)->data[offset];
2683 var uint8* ptr2 = (uint8*)data;
2684 var uintL count = size;
2685 do { *ptr2++ = *ptr1++; } while(--count);
2686 }
2687 } else if (eq(eltype,S(uint16)) && bit_vector_p(Atype_16Bit,obj)) {
2688 if (size > 0) {
2689 var uintL offset = 0;
2690 obj = array_displace_check(obj,size,&offset);
2691 var const uint16* ptr1 =
2692 (uint16*)&TheSbvector(obj)->data[2*offset];
2693 var uint16* ptr2 = (uint16*)data;
2694 var uintL count = size;
2695 do { *ptr2++ = *ptr1++; } while(--count);
2696 }
2697 } else if (eq(eltype,S(uint32)) && bit_vector_p(Atype_32Bit,obj)) {
2698 if (size > 0) {
2699 var uintL offset = 0;
2700 obj = array_displace_check(obj,size,&offset);
2701 var const uint32* ptr1 =
2702 (uint32*)&TheSbvector(obj)->data[4*offset];
2703 var uint32* ptr2 = (uint32*)data;
2704 var uintL count = size;
2705 do { *ptr2++ = *ptr1++; } while(--count);
2706 }
2707 } else {
2708 pushSTACK(eltype);
2709 pushSTACK(obj);
2710 {
2711 var uintL i;
2712 var char* pdata = (char*)data;
2713 for (i = 0; i < size; i++, pdata += eltype_size) {
2714 /* pdata = (char*)data + i*eltype_size */
2715 pushSTACK(STACK_0); pushSTACK(fixnum(i));
2716 funcall(L(row_major_aref),2);
2717 convert_to_foreign(STACK_1,value1,pdata,converter_malloc,state);
2718 }
2719 }
2720 skipSTACK(2);
2721 }
2722 return;
2723 } else if (eq(fvdtype,S(c_array_max)) && (fvdlen == 3)) {
2724 var object eltype = TheSvector(fvd)->data[1];
2725 var uintL maxdim = I_to_UL(TheSvector(fvd)->data[2]);
2726 if (eq(eltype,S(character)) && stringp(obj)) {
2727 /* 1-dimensional array of CHARACTER. */
2728 var uintL clen;
2729 var uintL offset;
2730 var object string = unpack_string_ro(obj,&clen,&offset);
2731 var const chart* ptr1;
2732 unpack_sstring_alloca(string,clen,offset, ptr1=);
2733 var uintL blen = cslen(O(foreign_encoding),ptr1,clen);
2734 if (blen > maxdim)
2735 blen = maxdim;
2736 var uintB* ptr2 = (uintB*)data;
2737 #ifdef ENABLE_UNICODE
2738 var object encoding = O(foreign_encoding);
2739 Encoding_wcstombs(encoding)(encoding,nullobj,&ptr1,ptr1+clen,&ptr2,ptr2+blen);
2740 #else
2741 begin_system_call(); memcpy(ptr2,ptr1,blen); end_system_call();
2742 ptr2 += blen;
2743 #endif
2744 if (ptr2 < (uintB*)data+maxdim)
2745 *ptr2 = '\0';
2746 return;
2747 }
2748 var uintL eltype_size = foreign_size(eltype);
2749 if (!vectorp(obj))
2750 goto bad_obj;
2751 var uintL len = vector_length(obj);
2752 if (len > maxdim)
2753 len = maxdim;
2754 if (eq(eltype,S(uint8)) && bit_vector_p(Atype_8Bit,obj)) {
2755 var uint8* ptr2 = (uint8*)data;
2756 if (len > 0) {
2757 var uintL offset = 0;
2758 obj = array_displace_check(obj,len,&offset);
2759 var const uint8* ptr1 = &TheSbvector(obj)->data[offset];
2760 var uintL count = len;
2761 do { *ptr2++ = *ptr1++; } while(--count);
2762 }
2763 if (len < maxdim)
2764 *ptr2 = 0;
2765 } else if (eq(eltype,S(uint16)) && bit_vector_p(Atype_16Bit,obj)) {
2766 var uint16* ptr2 = (uint16*)data;
2767 if (len > 0) {
2768 var uintL offset = 0;
2769 obj = array_displace_check(obj,len,&offset);
2770 var const uint16* ptr1 =
2771 (uint16*)&TheSbvector(obj)->data[2*offset];
2772 var uintL count = len;
2773 do { *ptr2++ = *ptr1++; } while(--count);
2774 }
2775 if (len < maxdim)
2776 *ptr2 = 0;
2777 } else if (eq(eltype,S(uint32)) && bit_vector_p(Atype_32Bit,obj)) {
2778 var uint32* ptr2 = (uint32*)data;
2779 if (len > 0) {
2780 var uintL offset = 0;
2781 obj = array_displace_check(obj,len,&offset);
2782 var const uint32* ptr1 =
2783 (uint32*)&TheSbvector(obj)->data[4*offset];
2784 var uintL count = len;
2785 do { *ptr2++ = *ptr1++; } while(--count);
2786 }
2787 if (len < maxdim)
2788 *ptr2 = 0;
2789 } else {
2790 pushSTACK(eltype);
2791 pushSTACK(obj);
2792 {
2793 var uintL i;
2794 var char* pdata = (char*)data;
2795 for (i = 0; i < len; i++, pdata += eltype_size) {
2796 /* pdata = (char*)data + i*eltype_size */
2797 pushSTACK(STACK_0); pushSTACK(fixnum(i));
2798 funcall(L(aref),2);
2799 convert_to_foreign(STACK_1,value1,pdata,converter_malloc,state);
2800 }
2801 if (len < maxdim)
2802 blockzero(pdata,eltype_size);
2803 }
2804 skipSTACK(2);
2805 }
2806 return;
2807 } else if (eq(fvdtype,S(c_function)) && (fvdlen == 4)) {
2808 if (nullp(obj)) {
2809 *(void**)data = NULL;
2810 } else {
2811 var object ffun =
2812 convert_function_to_foreign(obj,
2813 TheSvector(fvd)->data[1],
2814 TheSvector(fvd)->data[2],
2815 TheSvector(fvd)->data[3]);
2816 /* known to be valid! */
2817 *(void**)data = Faddress_value(TheFfunction(ffun)->ff_address);
2818 }
2819 return;
2820 } else if ((eq(fvdtype,S(c_ptr)) || eq(fvdtype,S(c_ptr_null)))
2821 && (fvdlen == 2)) {
2822 if (nullp(obj) && eq(fvdtype,S(c_ptr_null))) {
2823 *(void**)data = NULL;
2824 return;
2825 }
2826 fvd = TheSvector(fvd)->data[1];
2827 var struct foreign_layout sas;
2828 foreign_layout(fvd,&sas);
2829 var void* p =
2830 converter_malloc(*(void**)data,sas.size,sas.alignment,state);
2831 *(void**)data = p;
2832 convert_to_foreign(fvd,obj,p,converter_malloc,state);
2833 return;
2834 } else if (eq(fvdtype,S(c_pointer)) && (fvdlen == 2)) {
2835 if (faddressp(obj)) {
2836 obj = check_faddress_valid(obj);
2837 *(void**)data = Faddress_value(obj);
2838 return;
2839 } else if (fvariablep(obj)) {
2840 fvd = TheSvector(fvd)->data[1];
2841 if (equal_fvd(fvd,TheFvariable(obj)->fv_type)) {
2842 obj = TheFvariable(obj)->fv_address;
2843 obj = check_faddress_valid(obj);
2844 *(void**)data = Faddress_value(obj);
2845 return;
2846 } else goto bad_obj;
2847 } else if (nullp(obj)) { *(void**)data = NULL; return; }
2848 else goto bad_obj;
2849 } else if (eq(fvdtype,S(c_array_ptr)) && (fvdlen == 2)) {
2850 if (nullp(obj)) {
2851 *(void**)data = NULL;
2852 return;
2853 }
2854 var object eltype = TheSvector(fvd)->data[1];
2855 if (eq(eltype,S(character)) && stringp(obj)) {
2856 /* 1-dimensional array of CHARACTER. */
2857 var uintL clen;
2858 var uintL offset;
2859 var object string = unpack_string_ro(obj,&clen,&offset);
2860 var const chart* ptr1;
2861 unpack_sstring_alloca(string,clen,offset, ptr1=);
2862 var uintL blen = cslen(O(foreign_encoding),ptr1,clen);
2863 var void* p = converter_malloc(*(void**)data,blen+1,1,state);
2864 *(void**)data = p;
2865 cstombs(O(foreign_encoding),ptr1,clen,(uintB*)p,blen);
2866 ((uintB*)p)[blen] = '\0';
2867 return;
2868 }
2869 if (!vectorp(obj)) goto bad_obj;
2870 var uintL len = vector_length(obj);
2871 var struct foreign_layout sas;
2872 foreign_layout(eltype,&sas);
2873 var uintL eltype_size = sas.size;
2874 var void* p = converter_malloc(*(void**)data,(len+1)*eltype_size,
2875 sas.alignment,state);
2876 *(void**)data = p;
2877 pushSTACK(eltype);
2878 pushSTACK(obj);
2879 {
2880 var uintL i;
2881 for (i = 0; i < len; i++, p = (void*)((char*)p + eltype_size)) {
2882 pushSTACK(STACK_0); pushSTACK(fixnum(i));
2883 funcall(L(aref),2);
2884 convert_to_foreign(STACK_1,value1,p,converter_malloc,state);
2885 }
2886 }
2887 skipSTACK(2);
2888 blockzero(p,eltype_size);
2889 return;
2890 }
2891 }
2892 } else {
2893 var object inttype = gethash(fvd,O(foreign_inttype_table),false);
2894 if (!eq(inttype,nullobj)) {
2895 convert_to_foreign(inttype,obj,data,converter_malloc,state);
2896 return;
2897 }
2898 }
2899 error_foreign_type(fvd);
2900 bad_obj:
2901 error_convert(fvd,obj);
2902 }
2903
2904 /* Convert Lisp data to foreign data.
2905 The foreign data has dynamic extent.
2906 1. convert_to_foreign_need(fvd,obj);
2907 2. make room according to sas.size and sas.alignment,
2908 set allocaing_room_pointer.
2909 3. convert_to_foreign(fvd,obj,data,room_pointer,&allocaing,
2910 &allocaing_room_pointer);
2911 can trigger GC */
allocaing(void * old_data,uintL size,uintL alignment,void ** allocaing_room_pointer)2912 local void* allocaing (void* old_data, uintL size, uintL alignment,
2913 void** allocaing_room_pointer) {
2914 unused(old_data);
2915 *allocaing_room_pointer = (void*)(((uintP)*allocaing_room_pointer
2916 + alignment-1) & -(long)alignment);
2917 var void* result = *allocaing_room_pointer;
2918 *allocaing_room_pointer = (void*)((uintP)*allocaing_room_pointer + size);
2919 return result;
2920 }
2921
2922 /* Convert Lisp data to foreign data.
2923 The foreign data is allocated through malloc() and has more than dynamic
2924 extent. (Not exactly indefinite extent: It is deallocated the next time
2925 free_foreign() is called on it.)
2926 can trigger GC */
mallocing(void * old_data,uintL size,uintL alignment,void ** state)2927 modexp void* mallocing (void* old_data, uintL size, uintL alignment,
2928 void** state)
2929 {
2930 unused(old_data); unused(alignment); unused(state);
2931 return clisp_malloc(size);
2932 }
2933
2934 /* Convert Lisp data to foreign data.
2935 The foreign data storage is reused.
2936 DANGEROUS, especially for type C-STRING !!
2937 Also beware against NULL pointers! They are not treated specially.
2938 can trigger GC */
nomalloc(void * old_data,uintL size,uintL alignment,void ** state)2939 modexp void* nomalloc (void* old_data, uintL size, uintL alignment,
2940 void** state)
2941 {
2942 unused(size); unused(alignment); unused(state);
2943 return old_data;
2944 }
2945
2946
2947 /* ====================== Accessing foreign variables ====================== */
2948
2949 /* Error messages. */
error_foreign_variable(object obj)2950 local _Noreturn void error_foreign_variable (object obj) {
2951 pushSTACK(NIL); /* no PLACE */
2952 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
2953 pushSTACK(S(foreign_variable)); /* TYPE-ERROR slot EXPECTED-TYPE */
2954 pushSTACK(STACK_0); pushSTACK(obj);
2955 pushSTACK(TheSubr(subr_self)->name);
2956 error(type_error,GETTEXT("~S: ~S is not of type ~S"));
2957 }
error_variable_no_fvd(object obj)2958 local _Noreturn void error_variable_no_fvd (object obj) {
2959 pushSTACK(obj);
2960 pushSTACK(TheSubr(subr_self)->name);
2961 error(error_condition,GETTEXT("~S: foreign variable with unknown type, missing DEF-C-VAR: ~S"));
2962 }
2963
2964 /* UP: looks up a foreign variable, given its Lisp name.
2965 > name -- lisp name
2966 > fvd --- FFI type
2967 can trigger GC */
lookup_foreign_variable(gcv_object_t * name,gcv_object_t * fvd)2968 local maygc object lookup_foreign_variable
2969 (gcv_object_t *name, gcv_object_t *fvd) {
2970 var object fvar = gethash(*name,O(foreign_variable_table),false);
2971 if (eq(fvar,nullobj)) {
2972 pushSTACK(NIL); /* 4 continue-format-string */
2973 pushSTACK(S(error)); /* 3 error type */
2974 pushSTACK(NIL); /* 2 error-format-string */
2975 pushSTACK(S(find_foreign_variable)); /* 1 */
2976 pushSTACK(*name); /* 0 */
2977 STACK_2 = CLSTEXT("~S: foreign variable ~S does not exist");
2978 STACK_4 = CLSTEXT("Skip foreign variable creation");
2979 funcall(L(cerror_of_type),5);
2980 return NIL;
2981 }
2982 /* The first lookup_foreign_variable determines the variable's type. */
2983 if (nullp(TheFvariable(fvar)->fv_type)) {
2984 var struct foreign_layout sas;
2985 foreign_layout(*fvd,&sas);
2986 var object fa = TheFvariable(fvar)->fv_address;
2987 pushSTACK(fvar); fa = check_faddress_valid(fa); fvar = popSTACK();
2988 if (!((posfixnum_to_V(TheFvariable(fvar)->fv_size) == sas.size)
2989 && (((long)Faddress_value(fa) & (sas.alignment-1)) == 0))) {
2990 pushSTACK(fvar);
2991 pushSTACK(TheSubr(subr_self)->name);
2992 error(error_condition,GETTEXT("~S: foreign variable ~S does not have the required size or alignment"));
2993 }
2994 TheFvariable(fvar)->fv_type = *fvd;
2995 } else if (!equal_fvd(TheFvariable(fvar)->fv_type,*fvd)) {
2996 /* Subsequent lookup_foreign_variable calls only compare the type. */
2997 if (!equalp_fvd(TheFvariable(fvar)->fv_type,*fvd)) {
2998 dynamic_bind(S(print_circle),T); /* bind *PRINT-CIRCLE* to T */
2999 pushSTACK(*fvd);
3000 pushSTACK(TheFvariable(fvar)->fv_type);
3001 pushSTACK(fvar);
3002 pushSTACK(TheSubr(subr_self)->name);
3003 error(error_condition,GETTEXT("~S: type specifications for foreign variable ~S conflict: ~S and ~S"));
3004 }
3005 /* If the types are not exactly the same but still compatible,
3006 allocate a new foreign variable with the given fvd. */
3007 pushSTACK(fvar);
3008 var object new_fvar = allocate_fvariable();
3009 fvar = popSTACK();
3010 record_flags_replace(TheFvariable(new_fvar),
3011 record_flags(TheFvariable(fvar)));
3012 TheFvariable(new_fvar)->fv_name = TheFvariable(fvar)->fv_name;
3013 TheFvariable(new_fvar)->fv_address = TheFvariable(fvar)->fv_address;
3014 TheFvariable(new_fvar)->fv_size = TheFvariable(fvar)->fv_size;
3015 TheFvariable(new_fvar)->fv_type = *fvd;
3016 fvar = new_fvar;
3017 }
3018 return fvar;
3019 }
3020
error_version_nonlibrary(object name,object version)3021 local _Noreturn void error_version_nonlibrary (object name, object version) {
3022 pushSTACK(version); pushSTACK(name), pushSTACK(TheSubr(subr_self)->name);
3023 error(error_condition,
3024 GETTEXT("~S(~S): version ~S without library does not make sense"));
3025 }
3026
3027 /* (FFI::FIND-FOREIGN-VARIABLE foreign-variable-name foreign-type
3028 foreign-library version foreign-offset) */
3029 LISPFUNN(find_foreign_variable,5) {
3030 STACK_4 = coerce_ss(STACK_4); /* name */
3031 if (nullp(STACK_2)) { /* library */
3032 if (!nullp(STACK_1)) /* version */
3033 error_version_nonlibrary(STACK_4,STACK_1);
3034 VALUES1(lookup_foreign_variable(&STACK_4,&STACK_3));
3035 } else VALUES1(foreign_library_variable(&STACK_4,&STACK_3,&STACK_2,
3036 &STACK_1,&STACK_0));
3037 skipSTACK(5);
3038 }
3039
3040 /* (FFI:FOREIGN-VARIABLE address c-type &key name) constructor */
3041 LISPFUN(foreign_variable,seclass_read,2,0,norest,key,1,(kw(name)) )
3042 {
3043 foreign_variable_restart:
3044 var object fa = STACK_2;
3045 if (fvariablep(fa))
3046 { fa = TheFvariable(fa)->fv_address; }
3047 /* If you believe objects of type foreign-function should be accepted,
3048 * then you probably missed an indirection. */
3049 if (!faddressp(fa)) {
3050 pushSTACK(NIL); /* no PLACE */
3051 pushSTACK(fa); /* TYPE-ERROR slot DATUM */
3052 pushSTACK(O(type_foreign_variable)); /* TYPE-ERROR slot EXPECTED-TYPE */
3053 pushSTACK(STACK_0); pushSTACK(fa);
3054 pushSTACK(TheSubr(subr_self)->name);
3055 check_value(type_error,GETTEXT("~S: ~S is not of type ~S"));
3056 STACK_2 = value1;
3057 goto foreign_variable_restart;
3058 }
3059 fa = check_faddress_valid(fa);
3060 if (!missingp(STACK_0)) STACK_0 = coerce_ss(STACK_0);
3061 var object fvar = allocate_fvariable();
3062 var object fvd = STACK_1;
3063 var struct foreign_layout sas;
3064 foreign_layout(fvd,&sas);
3065 TheFvariable(fvar)->fv_size = fixnum(sas.size);
3066 TheFvariable(fvar)->fv_type = fvd;
3067 TheFvariable(fvar)->fv_name = (boundp(STACK_0) ? (object)STACK_0 : NIL);
3068 if (fvariablep(STACK_2)) {
3069 var object old_fvar = STACK_2;
3070 TheFvariable(fvar)->fv_address = TheFvariable(old_fvar)->fv_address;
3071 record_flags_replace(TheFvariable(fvar),
3072 record_flags(TheFvariable(old_fvar)));
3073
3074 if (nullp(TheFvariable(fvar)->fv_name)) {
3075 TheFvariable(fvar)->fv_name = TheFvariable(old_fvar)->fv_name;
3076 }
3077 } else {
3078 TheFvariable(fvar)->fv_address = STACK_2;
3079 record_flags_replace(TheFvariable(fvar), 0);
3080 }
3081 check_fvar_alignment(fvar,sas.alignment);
3082 VALUES1(fvar); skipSTACK(3);
3083 }
3084
3085 /* (FFI::FOREIGN-VALUE foreign-variable)
3086 returns the value of the foreign variable as a Lisp data structure. */
3087 LISPFUNN(foreign_value,1)
3088 {
3089 var object fvar = STACK_0;
3090 if (!fvariablep(fvar)) error_foreign_variable(fvar);
3091 var object fa = TheFvariable(fvar)->fv_address;
3092 fa = check_faddress_valid(fa); fvar = STACK_0;
3093 var void* address = Faddress_value(fa);
3094 var object fvd = TheFvariable(fvar)->fv_type;
3095 if (nullp(fvd)) error_variable_no_fvd(fvar);
3096 VALUES1(convert_from_foreign(fvd,address)); skipSTACK(1);
3097 }
3098
3099 /* (FFI::SET-FOREIGN-VALUE foreign-variable new-value)
3100 sets the value of the foreign variable. */
3101 LISPFUNN(set_foreign_value,2)
3102 {
3103 var object fvar = STACK_1;
3104 if (!fvariablep(fvar)) error_foreign_variable(fvar);
3105 var object fa = TheFvariable(fvar)->fv_address;
3106 fa = check_faddress_valid(fa); fvar = STACK_1;
3107 var void* address = Faddress_value(fa);
3108 var object fvd = TheFvariable(fvar)->fv_type;
3109 if (nullp(fvd)) error_variable_no_fvd(fvar);
3110 if (record_flags(TheFvariable(fvar)) & fv_readonly) {
3111 pushSTACK(fvar);
3112 pushSTACK(TheSubr(subr_self)->name);
3113 error(error_condition,GETTEXT("~S: foreign variable ~S may not be modified"));
3114 }
3115 if (record_flags(TheFvariable(fvar)) & fv_malloc) {
3116 /* Protect this using a semaphore??
3117 Free old value: */
3118 free_foreign(fvd,address);
3119 /* Put in new value: */
3120 convert_to_foreign(fvd,STACK_0,address,&mallocing,NULL);
3121 } else {
3122 /* Protect this using a semaphore??
3123 Put in new value, reusing the old value's storage: */
3124 convert_to_foreign(fvd,STACK_0,address,&nomalloc,NULL);
3125 }
3126 VALUES1(STACK_0);
3127 skipSTACK(2);
3128 }
3129
3130 LISPFUNN(foreign_type,1)
3131 { /* (FFI::FOREIGN-TYPE foreign-variable) */
3132 var object fvar = popSTACK();
3133 if (!fvariablep(fvar))
3134 error_foreign_variable(fvar);
3135 if (nullp((value1 = TheFvariable(fvar)->fv_type)))
3136 error_variable_no_fvd(fvar);
3137 mv_count=1;
3138 }
3139
3140 /* (FFI::%ELEMENT foreign-array-variable {index}*)
3141 returns a foreign variable, corresponding to the specified array element. */
3142 LISPFUN(element,seclass_default,1,0,rest,nokey,0,NIL)
3143 {
3144 var object fvar = Before(rest_args_pointer);
3145 /* Check that fvar is a foreign variable: */
3146 if (!fvariablep(fvar))
3147 error_foreign_variable(fvar);
3148 /* Check that fvar is a foreign array: */
3149 var object fvd = TheFvariable(fvar)->fv_type;
3150 var uintL fvdlen;
3151 if (!(simple_vector_p(fvd)
3152 && ((fvdlen = Svector_length(fvd)) > 1)
3153 && (eq(TheSvector(fvd)->data[0],S(c_array))
3154 || eq(TheSvector(fvd)->data[0],S(c_array_max))))) {
3155 dynamic_bind(S(print_circle),T); /* bind *PRINT-CIRCLE* to T */
3156 pushSTACK(fvd);
3157 pushSTACK(fvar);
3158 pushSTACK(S(element));
3159 error(error_condition,GETTEXT("~S: foreign variable ~S of type ~S is not an array"));
3160 }
3161 /* Check the subscript count: */
3162 if (!(argcount == fvdlen-2)) {
3163 pushSTACK(fixnum(fvdlen-2));
3164 pushSTACK(fvar);
3165 pushSTACK(fixnum(argcount));
3166 pushSTACK(S(element));
3167 error(error_condition,GETTEXT("~S: got ~S subscripts, but ~S has rank ~S"));
3168 }
3169 /* Check the subscripts: */
3170 var uintL row_major_index = 0;
3171 if (argcount > 0) {
3172 var gcv_object_t* args_pointer = rest_args_pointer;
3173 var gcv_object_t* dimptr = &TheSvector(fvd)->data[2];
3174 var uintC count = argcount;
3175 do {
3176 var object subscriptobj = NEXT(args_pointer);
3177 if (!posfixnump(subscriptobj)) {
3178 var object list = listof(argcount);
3179 /* STACK_0 is fvar now. */
3180 pushSTACK(list);
3181 pushSTACK(S(element));
3182 error(error_condition,GETTEXT("~S: subscripts ~S for ~S are not of type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))"));
3183 }
3184 var uintV subscript = posfixnum_to_V(subscriptobj);
3185 var uintL dim = I_to_uint32(*dimptr);
3186 if (!(subscript<dim)) {
3187 var object list = listof(argcount);
3188 /* STACK_0 is fvar now. */
3189 pushSTACK(list);
3190 pushSTACK(S(element));
3191 error(error_condition,GETTEXT("~S: subscripts ~S for ~S are out of range"));
3192 }
3193 /* Compute row_major_index := row_major_index*dim+subscript: */
3194 row_major_index = mulu32_unchecked(row_major_index,dim)+subscript;
3195 dimptr++;
3196 } while (--count);
3197 }
3198 set_args_end_pointer(rest_args_pointer);
3199 fvd = TheSvector(fvd)->data[1]; /* the element's foreign type */
3200 pushSTACK(fvd);
3201 var uintL size = foreign_size(fvd); /* the element's size */
3202 pushSTACK(make_faddress(TheFaddress(TheFvariable(fvar)->fv_address)->fa_base,
3203 TheFaddress(TheFvariable(fvar)->fv_address)->fa_offset
3204 + row_major_index * size));
3205 var object new_fvar = allocate_fvariable();
3206 fvar = STACK_2;
3207 record_flags_replace(TheFvariable(new_fvar), record_flags(TheFvariable(fvar)));
3208 TheFvariable(new_fvar)->fv_name = NIL; /* no name known */
3209 TheFvariable(new_fvar)->fv_address = popSTACK();
3210 TheFvariable(new_fvar)->fv_size = fixnum(size);
3211 TheFvariable(new_fvar)->fv_type = popSTACK();
3212 VALUES1(new_fvar);
3213 skipSTACK(1);
3214 }
3215
3216 /* (FFI::%DEREF foreign-pointer-variable)
3217 returns a foreign variable, corresponding to what the specified pointer
3218 points to. */
3219 LISPFUNN(deref,1)
3220 {
3221 var object fvar = STACK_0;
3222 /* Check that fvar is a foreign variable: */
3223 if (!fvariablep(fvar)) error_foreign_variable(fvar);
3224 /* Check that fvar is a foreign pointer: */
3225 var object fvd = TheFvariable(fvar)->fv_type;
3226 if (!(simple_vector_p(fvd)
3227 && (Svector_length(fvd) == 2)
3228 && (eq(TheSvector(fvd)->data[0],S(c_ptr))
3229 || eq(TheSvector(fvd)->data[0],S(c_ptr_null))
3230 || eq(TheSvector(fvd)->data[0],S(c_pointer))))) {
3231 dynamic_bind(S(print_circle),T); /* bind *PRINT-CIRCLE* to T */
3232 pushSTACK(fvd);
3233 pushSTACK(fvar);
3234 pushSTACK(S(element));
3235 error(error_condition,GETTEXT("~S: foreign variable ~S of type ~S is not a pointer"));
3236 }
3237 fvd = TheSvector(fvd)->data[1]; /* the target's foreign type */
3238 pushSTACK(fvd);
3239 var uintL size = foreign_size(fvd); /* the target's size */
3240 var object fa = TheFvariable(fvar)->fv_address;
3241 fa = check_faddress_valid(fa);
3242 /* Actually dereference the pointer: */
3243 var void* address = *(void**)Faddress_value(fa);
3244 if (address == NULL) {
3245 /* Don't mess with NULL pointers, return NIL instead. */
3246 VALUES1(NIL); skipSTACK(2);
3247 } else {
3248 pushSTACK(make_faddress(O(fp_zero),(uintP)address));
3249 var object new_fvar = allocate_fvariable();
3250 fvar = STACK_2;
3251 record_flags_replace(TheFvariable(new_fvar),
3252 record_flags(TheFvariable(fvar)));
3253 TheFvariable(new_fvar)->fv_name = NIL; /* no name known */
3254 TheFvariable(new_fvar)->fv_address = popSTACK();
3255 TheFvariable(new_fvar)->fv_size = fixnum(size);
3256 TheFvariable(new_fvar)->fv_type = popSTACK();
3257 VALUES1(new_fvar);
3258 skipSTACK(1);
3259 }
3260 }
3261
3262 /* (FFI::%SLOT foreign-struct/union-variable slot-name)
3263 returns a foreign variable, corresponding to the specified struct slot or
3264 union alternative. */
3265 LISPFUNN(slot,2)
3266 {
3267 var object fvar = STACK_1;
3268 var object slot = STACK_0;
3269 /* Check that fvar is a foreign variable: */
3270 if (!fvariablep(fvar))
3271 error_foreign_variable(fvar);
3272 /* Check that fvar is a foreign struct or a foreign union: */
3273 var object fvd = TheFvariable(fvar)->fv_type;
3274 var uintL fvdlen;
3275 var struct foreign_layout sas;
3276 if (simple_vector_p(fvd) && ((fvdlen = Svector_length(fvd)) > 0)) {
3277 if (eq(TheSvector(fvd)->data[0],S(c_struct))
3278 && (fvdlen >= C_STRUCT_C_TYPE_START)) {
3279 var object slots = TheSvector(fvd)->data[C_STRUCT_SLOTS];
3280 if (!(simple_vector_p(slots)
3281 && (Svector_length(slots)==fvdlen-C_STRUCT_C_TYPE_START)))
3282 error_foreign_type(fvd);
3283 var uintL cumul_size = 0;
3284 var uintL i;
3285 for (i = C_STRUCT_C_TYPE_START; i < fvdlen; i++) {
3286 var object fvdi = TheSvector(fvd)->data[i];
3287 foreign_layout(fvdi,&sas);
3288 /* We assume all alignments are of the form 2^k. */
3289 cumul_size += (-cumul_size) & (sas.alignment-1);
3290 if (eq(TheSvector(slots)->data[i-C_STRUCT_C_TYPE_START],slot)) {
3291 pushSTACK(fvdi); goto found_struct_slot;
3292 }
3293 cumul_size += sas.size;
3294 }
3295 goto bad_slot;
3296 found_struct_slot: {
3297 var uintL size = sas.size;
3298 pushSTACK(make_faddress(TheFaddress(TheFvariable(fvar)->fv_address)->fa_base,
3299 TheFaddress(TheFvariable(fvar)->fv_address)->fa_offset
3300 + cumul_size));
3301 var object new_fvar = allocate_fvariable();
3302 fvar = STACK_3;
3303 record_flags_replace(TheFvariable(new_fvar), record_flags(TheFvariable(fvar)));
3304 TheFvariable(new_fvar)->fv_name = NIL; /* no name known */
3305 TheFvariable(new_fvar)->fv_address = popSTACK();
3306 TheFvariable(new_fvar)->fv_size = fixnum(size);
3307 TheFvariable(new_fvar)->fv_type = popSTACK();
3308 VALUES1(new_fvar);
3309 skipSTACK(2);
3310 return;
3311 }
3312 }
3313 if (eq(TheSvector(fvd)->data[0],S(c_union)) && (fvdlen > 1)) {
3314 var object slots = TheSvector(fvd)->data[1];
3315 if (!(simple_vector_p(slots) && (Svector_length(slots)==fvdlen-2)))
3316 error_foreign_type(fvd);
3317 var uintL i;
3318 for (i = 2; i < fvdlen; i++) {
3319 if (eq(TheSvector(slots)->data[i-2],slot))
3320 goto found_union_slot;
3321 }
3322 goto bad_slot;
3323 found_union_slot:
3324 pushSTACK(TheSvector(fvd)->data[i]);
3325 var object new_fvar = allocate_fvariable();
3326 fvd = popSTACK(); /* the alternative's type */
3327 fvar = STACK_1;
3328 record_flags_replace(TheFvariable(new_fvar),
3329 record_flags(TheFvariable(fvar)));
3330 TheFvariable(new_fvar)->fv_name = NIL; /* no name known */
3331 TheFvariable(new_fvar)->fv_address = TheFvariable(fvar)->fv_address;
3332 TheFvariable(new_fvar)->fv_size = fixnum(foreign_size(fvd));
3333 TheFvariable(new_fvar)->fv_type = fvd;
3334 VALUES1(new_fvar);
3335 skipSTACK(2);
3336 return;
3337 }
3338 }
3339 dynamic_bind(S(print_circle),T); /* bind *PRINT-CIRCLE* to T */
3340 pushSTACK(fvd);
3341 pushSTACK(fvar);
3342 pushSTACK(S(slot));
3343 error(error_condition,GETTEXT("~S: foreign variable ~S of type ~S is not a struct or union"));
3344 bad_slot:
3345 dynamic_bind(S(print_circle),T); /* bind *PRINT-CIRCLE* to T */
3346 pushSTACK(slot);
3347 pushSTACK(fvd);
3348 pushSTACK(fvar);
3349 pushSTACK(S(slot));
3350 error(error_condition,GETTEXT("~S: foreign variable ~S of type ~S has no component with name ~S"));
3351 }
3352
3353 /* (FFI::%CAST foreign-variable c-type)
3354 returns a foreign variable, referring to the same memory locations, but of
3355 the given c-type. */
3356 LISPFUNN(cast,2)
3357 {
3358 var object fvar = STACK_1;
3359 if (!fvariablep(fvar))
3360 error_foreign_variable(fvar);
3361 var object fvd = TheFvariable(fvar)->fv_type;
3362 if (nullp(fvd))
3363 error_variable_no_fvd(fvar);
3364 /* The old and the new type must have the same size. */
3365 if (!eq(TheFvariable(fvar)->fv_size,fixnum(foreign_size(STACK_0))))
3366 error_convert(STACK_0,fvar);
3367 /* Allocate a new foreign variable. */
3368 var object new_fvar = allocate_fvariable();
3369 fvar = STACK_1;
3370 record_flags_replace(TheFvariable(new_fvar),
3371 record_flags(TheFvariable(fvar)));
3372 TheFvariable(new_fvar)->fv_name = TheFvariable(fvar)->fv_name;
3373 TheFvariable(new_fvar)->fv_address = TheFvariable(fvar)->fv_address;
3374 TheFvariable(new_fvar)->fv_size = TheFvariable(fvar)->fv_size;
3375 TheFvariable(new_fvar)->fv_type = STACK_0;
3376 VALUES1(new_fvar);
3377 skipSTACK(2);
3378 }
3379
3380 /* (FFI::%OFFSET foreign-variable offset c-type)
3381 returns a foreign variable, referring to (memory-location + offset),
3382 of the given c-type.
3383 This is lower-level than FFI::%SLOT and more general than FFI::%CAST.
3384 It allows dynamic resizing of arrays,
3385 e.g. (C-ARRAY uint8 <N>) to (C-ARRAY uint8 <M>). */
3386 LISPFUNN(offset,3) {
3387 var object fvar = STACK_2;
3388 if (!fvariablep(fvar))
3389 error_foreign_variable(fvar);
3390 {
3391 var object fvd = TheFvariable(fvar)->fv_type;
3392 if (nullp(fvd))
3393 error_variable_no_fvd(fvar);
3394 }
3395 STACK_1 = check_sint32(STACK_1);
3396 var struct foreign_layout sas;
3397 foreign_layout(STACK_0,&sas);
3398 fvar = STACK_2;
3399 var uintL size = sas.size;
3400 var uintL alignment = sas.alignment;
3401 { /* Allocate a new foreign address. */
3402 var object fvaddr = TheFvariable(fvar)->fv_address;
3403 fvaddr = make_faddress(TheFaddress(fvaddr)->fa_base,
3404 TheFaddress(fvaddr)->fa_offset
3405 + (sintP)I_to_sint32(STACK_1));
3406 pushSTACK(fvaddr);
3407 }
3408 /* Allocate a new foreign variable. */
3409 var object new_fvar = allocate_fvariable();
3410 fvar = STACK_(2+1);
3411 record_flags_replace(TheFvariable(new_fvar),
3412 record_flags(TheFvariable(fvar)));
3413 TheFvariable(new_fvar)->fv_name = TheFvariable(fvar)->fv_name;
3414 TheFvariable(new_fvar)->fv_address = STACK_0;
3415 TheFvariable(new_fvar)->fv_size = fixnum(size);
3416 TheFvariable(new_fvar)->fv_type = STACK_(0+1);
3417 check_fvar_alignment(new_fvar,alignment);
3418 VALUES1(new_fvar);
3419 skipSTACK(3+1);
3420 }
3421
3422
3423 /* ================== Low-level, little consing accessors ================== */
3424
3425 /* (FFI:MEMORY-AS address ffi-type &optional byte-offset)
3426 a low-level, little-consing accessor to memory, in effect
3427 similar to (foreign-value (foreign-variable address type)) */
3428 LISPFUN(read_memory_as,seclass_default,2,1,norest,nokey,0,NIL)
3429 {
3430 /* TODO accept foreign_pointer as well, without consing */
3431 /* TODO refuse foreign-function */
3432 var object fp = check_faddress_valid(foreign_address(STACK_2,false));
3433 var void* address = Faddress_value(fp);
3434 if (!missingp(STACK_0)) {
3435 STACK_0 = check_sint32(STACK_0);
3436 address = (void*)((uintP)address + (sintP)I_to_sint32(STACK_0));
3437 }
3438 /* TODO asciz_to_string is not suitable for unicode */
3439 var object item = eq(STACK_1,S(string))
3440 ? asciz_to_string((char*)address,O(foreign_encoding))
3441 : convert_from_foreign(STACK_1,address);
3442 VALUES1(item); skipSTACK(3);
3443 }
3444
3445 /* (FFI::WRITE-MEMORY-AS value address type &optional byte-offset) */
3446 LISPFUN(write_memory_as,seclass_default,3,1,norest,nokey,0,NIL)
3447 {
3448 var object fp = check_faddress_valid(foreign_address(STACK_2,false));
3449 var void* address = Faddress_value(fp);
3450 if (!missingp(STACK_0)) {
3451 STACK_0 = check_sint32(STACK_0);
3452 address = (void*)((uintP)address + (sintP)I_to_sint32(STACK_0));
3453 }
3454 convert_to_foreign(STACK_1,STACK_3,address,&nomalloc,NULL);
3455 VALUES1(STACK_3); skipSTACK(4);
3456 }
3457
3458 /* Stack-allocated objects */
3459
3460 /* (FFI::EXEC-ON-STACK thunk fvd [initarg]) allocates foreign objects
3461 on the C stack and executes (funcall thunk (foreign-variable-on-stack)).
3462 Calling with initarg is radically different than without one.
3463 With an initarg, CLISP allocates an arbitrarily complex structure on the
3464 stack. Without one, all it does is like a single calloc(1,sizeof(fvd))! */
3465 LISPFUN(exec_on_stack,seclass_default,2,1,norest,nokey,0,NIL) {
3466 STACK_2 = check_function(STACK_2);
3467 var bool init = boundp(STACK_0); /* Passing NIL is also an initialization */
3468 var object fvd = STACK_1;
3469 var struct foreign_layout sas;
3470 foreign_layout(fvd,&sas);
3471 /* Room for top-level structure: */
3472 var uintL result_size = sas.size;
3473 var uintL result_alignment = sas.alignment;
3474 var uintL cumul_size = result_size;
3475 var uintL cumul_alignment = result_alignment;
3476 cumul_size += (-cumul_size) & (cumul_alignment-1);
3477 if (init) {
3478 /* Room for pointers in argument: */
3479 convert_to_foreign_needs(fvd,STACK_0,&sas);
3480 fvd = STACK_1;
3481 /* We assume all alignments are of the form 2^k. */
3482 cumul_size += (-cumul_size) & (sas.alignment-1);
3483 cumul_size += sas.size;
3484 /* cumul_alignment = lcm(cumul_alignment,sas.alignment); */
3485 if (sas.alignment > cumul_alignment)
3486 cumul_alignment = sas.alignment;
3487 }
3488 var DYNAMIC_ARRAY(total_room,char,cumul_size+cumul_alignment/*-1*/);
3489 var void* result_address = (void*)((uintP)(total_room+result_alignment-1)
3490 & -(long)result_alignment);
3491 if (init) {
3492 var void* allocaing_room_pointer = (void*)((uintP)result_address + result_size);
3493 convert_to_foreign(fvd,STACK_0,result_address,&allocaing,
3494 &allocaing_room_pointer);
3495 } else {
3496 blockzero(result_address,result_size);
3497 }
3498 STACK_0 = allocate_fpointer(result_address); /* Release initarg early */
3499 pushSTACK(make_faddress(STACK_0,0));
3500 /* Stack layout: thunk fvd fp fa. */
3501 var object fvar = allocate_fvariable();
3502 TheFvariable(fvar)->fv_name = Symbol_name(TheSubr(subr_self)->name);
3503 TheFvariable(fvar)->fv_address = popSTACK();
3504 var object fp_obj = popSTACK();
3505 TheFvariable(fvar)->fv_size = fixnum(result_size);
3506 TheFvariable(fvar)->fv_type = STACK_0;
3507 record_flags_replace(TheFvariable(fvar), 0); /* TODO needed? */
3508 var object thunk = STACK_1;
3509 STACK_1 = fp_obj; skipSTACK(1);
3510 { var gcv_object_t* top_of_frame = STACK;
3511 var sp_jmp_buf returner; /* return point */
3512 finish_entry_frame(UNWIND_PROTECT,returner,, goto clean_up; );
3513 pushSTACK(fvar); funcall(thunk,1); /* protected: (funcall thunk fvar) */
3514 /* normal clean-up: */
3515 skipSTACK(2); /* unwind UNWIND-PROTECT-frame */
3516 fp_obj = popSTACK();
3517 mark_fp_invalid(TheFpointer(fp_obj));
3518 FREE_DYNAMIC_ARRAY(total_room);
3519 return;
3520 clean_up: {
3521 var restartf_t fun = unwind_protect_to_save.fun;
3522 var gcv_object_t* arg = unwind_protect_to_save.upto_frame;
3523 skipSTACK(2); /* unwind UNWIND-PROTECT-frame */
3524 fp_obj = popSTACK();
3525 mark_fp_invalid(TheFpointer(fp_obj));
3526 FREE_DYNAMIC_ARRAY(total_room);
3527 fun(arg); /* jump further */
3528 }
3529 }
3530 /* values, mv_count are set by funcall */
3531 }
3532
3533 /* (FFI::CALL-WITH-FOREIGN-STRING thunk encoding string start end extra-zeroes)
3534 Allocate string on stack, converted according to encoding and
3535 invoke (funcall thunk foreign-address charsize bytesize).
3536 Allows to allocate many zero bytes (like a partially filled buffer) */
3537 LISPFUNN(call_with_foreign_string,6)
3538 {
3539 var uintV zeroes = posfixnum_to_V(check_posfixnum(popSTACK()));
3540 STACK_4 = check_function(STACK_4);
3541 #ifdef ENABLE_UNICODE
3542 STACK_3 = check_encoding(STACK_3,&O(foreign_encoding),false);
3543 #else
3544 STACK_3 = check_encoding(STACK_3,&O(default_file_encoding),false);
3545 #endif
3546 /* Stack layout: ... string start end. - as needed for test_limits
3547 the following code inspired by with_string() and substring(): */
3548 var stringarg arg;
3549 test_string_limits_ro(&arg);
3550 var object data_array = arg.string;
3551 /* Stack: ... thunk encoding. - string, start and end were popped off */
3552 var const chart* srcptr;
3553 unpack_sstring_alloca(data_array,arg.len, arg.offset+arg.index, srcptr=);
3554 var object encoding = STACK_0;
3555 var uintL charsize = arg.len;
3556 var uintL bytesize = cslen(encoding,srcptr,charsize);
3557 var DYNAMIC_ARRAY(stack_data,uintB,bytesize+zeroes);
3558 if (bytesize>0)
3559 cstombs(encoding,srcptr,charsize,&stack_data[0],bytesize);
3560 if (zeroes != 0) { /* add terminating zero bytes */
3561 do { stack_data[bytesize++] = 0; } while (--zeroes > 0);
3562 charsize++;
3563 }
3564 { var object pointer_base = allocate_fpointer((void*)&stack_data[0]);
3565 pushSTACK(pointer_base);
3566 var gcv_object_t* top_of_frame = STACK;
3567 var sp_jmp_buf returner;
3568 finish_entry_frame(UNWIND_PROTECT,returner,, {
3569 /* UNWIND-PROTECT case: (MARK-INVALID-FOREIGN pointer_base) */
3570 var restartf_t fun = unwind_protect_to_save.fun;
3571 var gcv_object_t* upto = unwind_protect_to_save.upto_frame;
3572 skipSTACK(2); /* unwind Unwind-Protect-Frame */
3573 pointer_base = popSTACK();
3574 mark_fp_invalid(TheFpointer(pointer_base));
3575 fun(upto); /* and jump ahead */
3576 NOTREACHED;
3577 });
3578 pushSTACK(make_faddress(pointer_base,0));
3579 pushSTACK(fixnum(charsize));
3580 pushSTACK(fixnum(bytesize));
3581 funcall(STACK_(1+1+2+3),3);
3582 skipSTACK(2); /* unwind UNWIND-PROTECT frame */
3583 pointer_base = popSTACK();
3584 mark_fp_invalid(TheFpointer(pointer_base));
3585 }
3586 FREE_DYNAMIC_ARRAY(stack_data);
3587 skipSTACK(2);
3588 }
3589
3590 /* (FFI:FOREIGN-ALLOCATE c-type &key initial-contents count read-only)
3591 Allocates memory. If initial-contents is set (even NIL), invokes
3592 convert_from_foreign() to allocate an arbitrarily nested structure.
3593 Otherwise performs a single calloc(). */
3594 LISPFUN(foreign_allocate,seclass_default,1,0,norest,key,3,
3595 (kw(initial_contents),kw(count),kw(read_only)))
3596 {
3597 var object arg_fvd = STACK_3;
3598 /* If :COUNT then use c-type (C-ARRAY[-MAX] c-type count) */
3599 if (!missingp(STACK_1)) {
3600 var object array_fvd = allocate_vector(3);
3601 TheSvector(array_fvd)->data[0] =
3602 eq(arg_fvd,S(character)) ? S(c_array_max) : S(c_array);
3603 TheSvector(array_fvd)->data[1] = arg_fvd;
3604 TheSvector(array_fvd)->data[2] = STACK_1; /* count */
3605 STACK_3 = arg_fvd = array_fvd;
3606 }
3607 var struct foreign_layout sas;
3608 foreign_layout(arg_fvd,&sas);
3609 var uintL arg_size = sas.size;
3610 var uintL arg_alignment = sas.alignment;
3611 if (arg_size == 0) { error_eltype_zero_size(arg_fvd); }
3612 /* Perform top-level allocation of sizeof(fvd), sublevel allocations follow */
3613 var void* arg_address = clisp_malloc(arg_size);
3614 blockzero(arg_address,arg_size);
3615 /* Create FOREIGN-VARIABLE now so that it may be used in error message */
3616 pushSTACK(make_faddress(allocate_fpointer(arg_address),0));
3617 var object fvar = allocate_fvariable();
3618 arg_fvd = STACK_(3+1);
3619 TheFvariable(fvar)->fv_name = TheSubr(subr_self)->name;
3620 TheFvariable(fvar)->fv_address = STACK_0;
3621 TheFvariable(fvar)->fv_size = fixnum(arg_size);
3622 TheFvariable(fvar)->fv_type = arg_fvd;
3623 { var bool readonly = !missingp(STACK_1);
3624 record_flags_replace(TheFvariable(fvar), readonly ? fv_readonly : 0);
3625 /* Must not set fv_malloc flag since it applies
3626 to sublevel structures only. */
3627 }
3628 check_fvar_alignment(fvar,arg_alignment);
3629 { /* :INITIAL-CONTENTS NIL also causes an initialization! */
3630 var object initarg = STACK_3;
3631 if (boundp(initarg)) {
3632 STACK_0 = fvar;
3633 convert_to_foreign(arg_fvd,initarg,arg_address,&mallocing,NULL);
3634 /* subr-self name is lost and GC may happen */
3635 fvar = STACK_0;
3636 }
3637 }
3638 /* Must not finalize foreign-pointer since some protocol (witness the
3639 :malloc parameter declaration) may require foreign code to call free()
3640 However, CormanLisp does finalize! */
3641 VALUES1(fvar);
3642 skipSTACK(5);
3643 }
3644
3645 /* (FFI:FOREIGN-FREE foreign &key full)
3646 Deallocate callbacks or memory (even recursively),
3647 depending on argument type. */
3648 LISPFUN(foreign_free,seclass_default,1,0,norest,key,1,(kw(full)))
3649 {
3650 var object obj = popSTACK();
3651 var bool full_recurse = !missingp(obj);
3652 /* TODO? additional arguments [mark-invalid [silent]] */
3653 obj = popSTACK();
3654 if (orecordp(obj)) {
3655 var void* address;
3656 switch (Record_type(obj)) {
3657 case Rectype_Ffunction: { /* Free callback object */
3658 var object addr_obj = TheFfunction(obj)->ff_address;
3659 addr_obj = check_faddress_valid(addr_obj);
3660 address = Faddress_value(addr_obj);
3661 free_foreign_callin(address);
3662 /* make the function invalid */
3663 pushSTACK(addr_obj);
3664 var object fp = allocate_fpointer(address);
3665 TheFaddress(STACK_0)->fa_base = fp;
3666 TheFaddress(STACK_0)->fa_offset = 0;
3667 mark_fp_invalid(TheFpointer(TheFaddress(popSTACK())->fa_base));
3668 VALUES1(NIL);
3669 return;
3670 }
3671 case Rectype_Fvariable: {
3672 var object addr_obj = TheFvariable(obj)->fv_address;
3673 pushSTACK(obj);
3674 addr_obj = check_faddress_valid(addr_obj);
3675 obj = popSTACK();
3676 address = Faddress_value(addr_obj);
3677 if (full_recurse)
3678 free_foreign(TheFvariable(obj)->fv_type,address);
3679 goto free_address;
3680 }
3681 case Rectype_Faddress:
3682 obj = check_faddress_valid(obj);
3683 address = Faddress_value(obj);
3684 if (full_recurse) {
3685 pushSTACK(obj);
3686 pushSTACK(TheSubr(subr_self)->name);
3687 error(error_condition,GETTEXT("~S: ~S has no type, :FULL is illegal"));
3688 }
3689 free_address:
3690 begin_system_call();
3691 free(address);
3692 end_system_call();
3693 VALUES1(NIL);
3694 return;
3695 }
3696 }
3697 error_foreign_object(obj);
3698 }
3699
3700 /* Error messages. */
error_foreign_function(object obj)3701 local _Noreturn void error_foreign_function (object obj) {
3702 pushSTACK(NIL); /* no PLACE */
3703 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
3704 pushSTACK(S(foreign_function)); /* TYPE-ERROR slot EXPECTED-TYPE */
3705 pushSTACK(STACK_0); pushSTACK(obj);
3706 pushSTACK(TheSubr(subr_self)->name);
3707 error(type_error,GETTEXT("~S: ~S is not of type ~S"));
3708 }
error_function_no_fvd(object obj,object caller)3709 local _Noreturn void error_function_no_fvd (object obj, object caller) {
3710 pushSTACK(obj);
3711 pushSTACK(caller);
3712 error(error_condition,GETTEXT("~S: foreign function with unknown calling convention, missing DEF-CALL-OUT: ~S"));
3713 }
3714
3715 /* UP: looks up a foreign function, given its Lisp name.
3716 can trigger GC */
lookup_foreign_function(gcv_object_t * name_,gcv_object_t * fvd_,gcv_object_t * properties_)3717 local maygc object lookup_foreign_function
3718 (gcv_object_t *name_, gcv_object_t *fvd_, gcv_object_t *properties_) {
3719 var object ffun = allocate_ffunction();
3720 var object props = *properties_;
3721 var object fvd = *fvd_;
3722 var object name = *name_;
3723 var object oldffun = gethash(name,O(foreign_function_table),false);
3724 if (eq(oldffun,nullobj)) {
3725 pushSTACK(NIL); /* 4 continue-format-string */
3726 pushSTACK(S(error)); /* 3 error type */
3727 pushSTACK(NIL); /* 2 error-format-string */
3728 pushSTACK(TheSubr(subr_self)->name); /* 1 */
3729 pushSTACK(name); /* 0 */
3730 STACK_2 = CLSTEXT("~S: foreign function ~S does not exist");
3731 STACK_4 = CLSTEXT("Skip foreign function creation");
3732 funcall(L(cerror_of_type),5);
3733 return NIL;
3734 }
3735 if (!eq(TheFfunction(oldffun)->ff_flags,TheSvector(fvd)->data[3])) {
3736 pushSTACK(oldffun);
3737 pushSTACK(TheSubr(subr_self)->name);
3738 error(error_condition,GETTEXT("~S: calling conventions for foreign function ~S conflict"));
3739 }
3740 TheFfunction(ffun)->ff_name = TheFfunction(oldffun)->ff_name;
3741 TheFfunction(ffun)->ff_address = TheFfunction(oldffun)->ff_address;
3742 TheFfunction(ffun)->ff_resulttype = TheSvector(fvd)->data[1];
3743 TheFfunction(ffun)->ff_argtypes = TheSvector(fvd)->data[2];
3744 TheFfunction(ffun)->ff_flags = TheSvector(fvd)->data[3];
3745 TheFfunction(ffun)->ff_properties = props;
3746 return ffun;
3747 }
3748
3749 /* (FFI::FIND-FOREIGN-FUNCTION foreign-function-name foreign-type properties
3750 foreign-library version foreign-offset) */
3751 LISPFUNN(find_foreign_function,6) {
3752 STACK_5 = coerce_ss(STACK_5); /* name */
3753 STACK_4 = check_foreign_function_type(STACK_4); /* type */
3754 if (nullp(STACK_2)) { /* library */
3755 if (!nullp(STACK_1)) /* version */
3756 error_version_nonlibrary(STACK_5,STACK_1);
3757 VALUES1(lookup_foreign_function(&STACK_5,&STACK_4,&STACK_3));
3758 } else VALUES1(foreign_library_function(&STACK_5,&STACK_4,&STACK_3,
3759 &STACK_2,&STACK_1,&STACK_0));
3760 skipSTACK(6);
3761 }
3762
3763
3764 /* ====================== Implementation of CALL-OUTs ====================== */
3765
3766 /* Here is the point where we use the AVCALL package. */
3767
3768 /* Call the appropriate av_start_xxx macro for the result.
3769 do_av_start(flags,result_fvd,&alist,address,result_address,
3770 result_size,result_splittable); */
do_av_start(uintWL flags,object result_fvd,av_alist * alist,void * address,void * result_address,uintL result_size,bool result_splittable)3771 local void do_av_start (uintWL flags, object result_fvd, av_alist *alist,
3772 void *address, void *result_address, uintL result_size,
3773 bool result_splittable)
3774 {
3775 if (symbolp(result_fvd)) {
3776 if (eq(result_fvd,S(nil))) {
3777 av_start_void(*alist,address);
3778 } else if (eq(result_fvd,S(char)) || eq(result_fvd,S(sint8))) {
3779 if (flags & ff_lang_ansi_c) {
3780 av_start_schar(*alist,address,result_address);
3781 } else { /* `signed char' promotes to `int' */
3782 av_start_int(*alist,address,result_address);
3783 }
3784 } else if (eq(result_fvd,S(uchar)) || eq(result_fvd,S(uint8))
3785 || eq(result_fvd,S(character))) {
3786 if (flags & ff_lang_ansi_c) {
3787 av_start_uchar(*alist,address,result_address);
3788 } else { /* `unsigned char' promotes to `unsigned int' */
3789 av_start_uint(*alist,address,result_address);
3790 }
3791 } else if (eq(result_fvd,S(short)) || eq(result_fvd,S(sint16))) {
3792 if (flags & ff_lang_ansi_c) {
3793 av_start_short(*alist,address,result_address);
3794 } else { /* `short' promotes to `int' */
3795 av_start_int(*alist,address,result_address);
3796 }
3797 } else if (eq(result_fvd,S(ushort)) || eq(result_fvd,S(uint16))) {
3798 if (flags & ff_lang_ansi_c) {
3799 av_start_ushort(*alist,address,result_address);
3800 } else { /* `unsigned short' promotes to `unsigned int' */
3801 av_start_uint(*alist,address,result_address);
3802 }
3803 } else if (eq(result_fvd,S(boolean)) || eq(result_fvd,S(int))
3804 #if (int_bitsize==32)
3805 || eq(result_fvd,S(sint32))
3806 #endif
3807 ) {
3808 av_start_int(*alist,address,result_address);
3809 } else if (eq(result_fvd,S(uint))
3810 #if (int_bitsize==32)
3811 || eq(result_fvd,S(uint32))
3812 #endif
3813 ) {
3814 av_start_uint(*alist,address,result_address);
3815 } else if (eq(result_fvd,S(long))
3816 #if (int_bitsize<32) && (long_bitsize==32)
3817 || eq(result_fvd,S(sint32))
3818 #endif
3819 #if (long_bitsize==64)
3820 || eq(result_fvd,S(sint64))
3821 #endif
3822 ) {
3823 av_start_long(*alist,address,result_address);
3824 } else if (eq(result_fvd,S(ulong))
3825 #if (int_bitsize<32) && (long_bitsize==32)
3826 || eq(result_fvd,S(uint32))
3827 #endif
3828 #if (long_bitsize==64)
3829 || eq(result_fvd,S(uint64))
3830 #endif
3831 ) {
3832 av_start_ulong(*alist,address,result_address);
3833 }
3834 #if (long_bitsize<64)
3835 #if defined(HAVE_LONG_LONG_INT)
3836 else if (eq(result_fvd,S(sint64))) {
3837 av_start_longlong(*alist,address,result_address);
3838 } else if (eq(result_fvd,S(uint64))) {
3839 av_start_ulonglong(*alist,address,result_address);
3840 }
3841 #else
3842 else if (eq(result_fvd,S(sint64))) {
3843 av_start_struct(*alist,address,struct_sint64,
3844 av_word_splittable_2(sint32,sint32),result_address);
3845 } else if (eq(result_fvd,S(uint64))) {
3846 av_start_struct(*alist,address,struct_uint64,
3847 av_word_splittable_2(uint32,uint32),result_address);
3848 }
3849 #endif
3850 #endif
3851 else if (eq(result_fvd,S(single_float))) {
3852 if (flags & ff_lang_ansi_c) {
3853 av_start_float(*alist,address,result_address);
3854 } else { /* `float' promotes to `double' */
3855 av_start_double(*alist,address,result_address);
3856 }
3857 } else if (eq(result_fvd,S(double_float))) {
3858 av_start_double(*alist,address,result_address);
3859 } else if (eq(result_fvd,S(c_pointer)) || eq(result_fvd,S(c_string))) {
3860 av_start_ptr(*alist,address,void*,result_address);
3861 } else {
3862 error_foreign_type(result_fvd);
3863 }
3864 } else if (simple_vector_p(result_fvd)) {
3865 var object result_fvdtype = TheSvector(result_fvd)->data[0];
3866 if (eq(result_fvdtype,S(c_struct)) || eq(result_fvdtype,S(c_union))
3867 || eq(result_fvdtype,S(c_array)) || eq(result_fvdtype,S(c_array_max))) {
3868 _av_start_struct(*alist,address,result_size,result_splittable,
3869 result_address);
3870 } else if (eq(result_fvdtype,S(c_function))
3871 || eq(result_fvdtype,S(c_ptr))
3872 || eq(result_fvdtype,S(c_ptr_null))
3873 || eq(result_fvdtype,S(c_pointer))
3874 || eq(result_fvdtype,S(c_array_ptr))) {
3875 av_start_ptr(*alist,address,void*,result_address);
3876 } else {
3877 error_foreign_type(result_fvd);
3878 }
3879 } else {
3880 var object inttype = gethash(result_fvd,O(foreign_inttype_table),false);
3881 if (!eq(inttype,nullobj))
3882 do_av_start (flags, inttype, alist, address, result_address,
3883 result_size, result_splittable);
3884 else error_foreign_type(result_fvd);
3885 }
3886 #if defined(WIN32_NATIVE) || defined(UNIX_CYGWIN)
3887 /* This code does not compile with libffcall >= 2.0 and old C compilers.
3888 So limit it to the platforms where it is needed, namely Windows. */
3889 if (flags & ff_lang_stdcall)
3890 alist->flags |= __AV_STDCALL_CLEANUP;
3891 #endif
3892 }
3893
3894 /* Call the appropriate av_xxx macro for an argument.
3895 do_av_arg(flags,arg_fvd,&alist,arg_address,arg_size,arg_alignment); */
do_av_arg(uintWL flags,object arg_fvd,av_alist * alist,void * arg_address,unsigned long arg_size,unsigned long arg_alignment)3896 local void do_av_arg (uintWL flags, object arg_fvd, av_alist * alist,
3897 void* arg_address, unsigned long arg_size,
3898 unsigned long arg_alignment)
3899 {
3900 if (symbolp(arg_fvd)) {
3901 if (eq(arg_fvd,S(nil))) {
3902 } else if (eq(arg_fvd,S(char)) || eq(arg_fvd,S(sint8))) {
3903 if (flags & ff_lang_ansi_c) {
3904 av_schar(*alist,*(sint8*)arg_address);
3905 } else { /* `signed char' promotes to `int' */
3906 av_int(*alist,*(sint8*)arg_address);
3907 }
3908 } else if (eq(arg_fvd,S(uchar)) || eq(arg_fvd,S(uint8))
3909 || eq(arg_fvd,S(character))) {
3910 if (flags & ff_lang_ansi_c) {
3911 av_uchar(*alist,*(uint8*)arg_address);
3912 } else { /* `unsigned char' promotes to `unsigned int' */
3913 av_uint(*alist,*(uint8*)arg_address);
3914 }
3915 } else if (eq(arg_fvd,S(short)) || eq(arg_fvd,S(sint16))) {
3916 if (flags & ff_lang_ansi_c) {
3917 av_short(*alist,*(sint16*)arg_address);
3918 } else { /* `short' promotes to `int' */
3919 av_int(*alist,*(sint16*)arg_address);
3920 }
3921 } else if (eq(arg_fvd,S(ushort)) || eq(arg_fvd,S(uint16))) {
3922 if (flags & ff_lang_ansi_c) {
3923 av_ushort(*alist,*(uint16*)arg_address);
3924 } else { /* `unsigned short' promotes to `unsigned int' */
3925 av_uint(*alist,*(uint16*)arg_address);
3926 }
3927 } else if (eq(arg_fvd,S(boolean)) || eq(arg_fvd,S(int))
3928 #if (int_bitsize==32)
3929 || eq(arg_fvd,S(sint32))
3930 #endif
3931 ) {
3932 av_int(*alist,*(int*)arg_address);
3933 } else if (eq(arg_fvd,S(uint))
3934 #if (int_bitsize==32)
3935 || eq(arg_fvd,S(uint32))
3936 #endif
3937 ) {
3938 av_uint(*alist,*(unsigned int *)arg_address);
3939 } else if (eq(arg_fvd,S(long))
3940 #if (int_bitsize<32) && (long_bitsize==32)
3941 || eq(arg_fvd,S(sint32))
3942 #endif
3943 #if (long_bitsize==64)
3944 || eq(arg_fvd,S(sint64))
3945 #endif
3946 ) {
3947 av_long(*alist,*(long*)arg_address);
3948 } else if (eq(arg_fvd,S(ulong))
3949 #if (int_bitsize<32) && (long_bitsize==32)
3950 || eq(arg_fvd,S(uint32))
3951 #endif
3952 #if (long_bitsize==64)
3953 || eq(arg_fvd,S(uint64))
3954 #endif
3955 ) {
3956 av_ulong(*alist,*(unsigned long *)arg_address);
3957 }
3958 #if (long_bitsize<64)
3959 #if defined(HAVE_LONG_LONG_INT)
3960 else if (eq(arg_fvd,S(sint64))) {
3961 av_longlong(*alist,*(sint64*)arg_address);
3962 } else if (eq(arg_fvd,S(uint64))) {
3963 av_ulonglong(*alist,*(uint64*)arg_address);
3964 }
3965 #else
3966 else if (eq(arg_fvd,S(sint64))) {
3967 av_struct(*alist,struct_sint64,*(struct_sint64*)arg_address);
3968 } else if (eq(arg_fvd,S(uint64))) {
3969 av_struct(*alist,struct_uint64,*(struct_uint64*)arg_address);
3970 }
3971 #endif
3972 #endif
3973 else if (eq(arg_fvd,S(single_float))) {
3974 if (flags & ff_lang_ansi_c) {
3975 av_float(*alist,*(float*)arg_address);
3976 } else { /* `float' promotes to `double' */
3977 av_double(*alist,*(float*)arg_address);
3978 }
3979 } else if (eq(arg_fvd,S(double_float))) {
3980 av_double(*alist,*(double*)arg_address);
3981 } else if (eq(arg_fvd,S(c_pointer))) {
3982 av_ptr(*alist,void*,*(void**)arg_address);
3983 } else if (eq(arg_fvd,S(c_string))) {
3984 av_ptr(*alist,char*,*(char**)arg_address);
3985 } else {
3986 error_foreign_type(arg_fvd);
3987 }
3988 } else if (simple_vector_p(arg_fvd)) {
3989 var object arg_fvdtype = TheSvector(arg_fvd)->data[0];
3990 if (eq(arg_fvdtype,S(c_struct)) || eq(arg_fvdtype,S(c_union))
3991 || eq(arg_fvdtype,S(c_array)) || eq(arg_fvdtype,S(c_array_max))) {
3992 _av_struct(*alist,arg_size,arg_alignment,arg_address);
3993 } else if (eq(arg_fvdtype,S(c_function))
3994 || eq(arg_fvdtype,S(c_ptr))
3995 || eq(arg_fvdtype,S(c_ptr_null))
3996 || eq(arg_fvdtype,S(c_pointer))
3997 || eq(arg_fvdtype,S(c_array_ptr))) {
3998 av_ptr(*alist,void*,*(void**)arg_address);
3999 } else {
4000 error_foreign_type(arg_fvd);
4001 }
4002 } else {
4003 var object inttype = gethash(arg_fvd,O(foreign_inttype_table),false);
4004 if (!eq(inttype,nullobj))
4005 do_av_arg (flags, inttype, alist, arg_address, arg_size, arg_alignment);
4006 else error_foreign_type(arg_fvd);
4007 }
4008 }
4009
4010 /* (FFI::FOREIGN-CALL-OUT foreign-function . args)
4011 calls a foreign function with Lisp data structures as arguments,
4012 and returns the return value as a Lisp data structure. */
4013 LISPFUN(foreign_call_out,seclass_default,1,0,rest,nokey,0,NIL) {
4014 var object ffun = Before(rest_args_pointer);
4015 if (!ffunctionp(ffun))
4016 error_foreign_function(ffun);
4017 var object argfvds_top = TheFfunction(ffun)->ff_argtypes;
4018 if (!simple_vector_p(argfvds_top))
4019 error_function_no_fvd(ffun,S(foreign_call_out));
4020 var uintWL flags = posfixnum_to_V(TheFfunction(ffun)->ff_flags);
4021 switch (flags & 0x7F00) {
4022 /* For the moment, the only supported languages are "C" and "ANSI C". */
4023 case ff_lang_c:
4024 case ff_lang_ansi_c:
4025 break;
4026 default:
4027 error_function_no_fvd(ffun,S(foreign_call_out));
4028 }
4029 {
4030 var av_alist alist;
4031 var object fa = TheFfunction(ffun)->ff_address;
4032 fa = check_faddress_valid(fa);
4033 ffun = Before(rest_args_pointer);
4034 argfvds_top = TheFfunction(ffun)->ff_argtypes;
4035 var void* address = Faddress_value(fa);
4036 var object result_fvd = TheFfunction(ffun)->ff_resulttype;
4037 /* Allocate space for the result and maybe the args: */
4038 var struct foreign_layout sas;
4039 foreign_layout(result_fvd,&sas);
4040 var uintL result_size = sas.size;
4041 var uintL result_alignment = sas.alignment;
4042 var bool result_splittable = sas.splittable;
4043 var uintL result_totalsize = result_size+result_alignment; /* >= result_size+result_alignment-1, > 0 */
4044 var uintL cumul_alignment = result_alignment;
4045 var uintL cumul_size = result_totalsize;
4046 var uintL allargcount = Svector_length(argfvds_top)/2;
4047 var uintL outargcount = 0;
4048 {
4049 var sintL inargcount = 0;
4050 var uintL i;
4051 for (i = 0; i < allargcount; i++) {
4052 var object argfvds = TheFfunction(Before(rest_args_pointer))->ff_argtypes;
4053 var object arg_fvd = TheSvector(argfvds)->data[2*i];
4054 var uintWL arg_flags = posfixnum_to_V(TheSvector(argfvds)->data[2*i+1]);
4055 if (!(arg_flags & ff_out)) {
4056 inargcount++;
4057 if (inargcount > argcount)
4058 error_too_few_args(S(foreign_call_out),Before(rest_args_pointer),
4059 argcount,inargcount);
4060 }
4061 if (arg_flags & (ff_out | ff_inout)) {
4062 if (!(simple_vector_p(arg_fvd) && (Svector_length(arg_fvd) == 2)
4063 && eq(TheSvector(arg_fvd)->data[0],S(c_ptr))) ) {
4064 dynamic_bind(S(print_circle),T); /* bind *PRINT-CIRCLE* to T */
4065 pushSTACK(arg_fvd);
4066 pushSTACK(S(foreign_call_out));
4067 error(error_condition,GETTEXT("~S: :OUT argument is not a pointer: ~S"));
4068 }
4069 outargcount++;
4070 }
4071 if (arg_flags & ff_alloca) {
4072 var struct foreign_layout sas;
4073 /* Room for arg itself: */
4074 foreign_layout(arg_fvd,&sas);
4075 /* We assume all alignments are of the form 2^k. */
4076 cumul_size += (-cumul_size) & (sas.alignment-1);
4077 cumul_size += sas.size;
4078 /* cumul_alignment = lcm(cumul_alignment,sas.alignment); */
4079 if (sas.alignment > cumul_alignment)
4080 cumul_alignment = sas.alignment;
4081 if (arg_flags & ff_out) {
4082 /* Room for top-level pointer in arg: */
4083 var object argo_fvd = TheSvector(arg_fvd)->data[1];
4084 foreign_layout(argo_fvd,&sas);
4085 /* We assume all alignments are of the form 2^k. */
4086 cumul_size += (-cumul_size) & (sas.alignment-1);
4087 cumul_size += sas.size;
4088 /* cumul_alignment = lcm(cumul_alignment,sas.alignment); */
4089 if (sas.alignment > cumul_alignment)
4090 cumul_alignment = sas.alignment;
4091 } else {
4092 /* Room for pointers in arg: */
4093 var object arg = Before(rest_args_pointer STACKop -inargcount);
4094 pushSTACK(result_fvd); pushSTACK(argfvds); /* save */
4095 convert_to_foreign_needs(arg_fvd,arg,&sas);
4096 argfvds = popSTACK(); result_fvd = popSTACK(); /* restore */
4097 /* We assume all alignments are of the form 2^k. */
4098 cumul_size += (-cumul_size) & (sas.alignment-1);
4099 cumul_size += sas.size;
4100 /* cumul_alignment = lcm(cumul_alignment,sas.alignment); */
4101 if (sas.alignment > cumul_alignment)
4102 cumul_alignment = sas.alignment;
4103 }
4104 }
4105 }
4106 if (argcount != inargcount)
4107 error_too_many_args(S(foreign_call_out),Before(rest_args_pointer),argcount,inargcount);
4108 }
4109 var uintL result_count = 0;
4110 typedef struct { void* address; } result_descr; /* fvd is pushed onto the STACK */
4111 var DYNAMIC_ARRAY(results,result_descr,1+outargcount);
4112 cumul_size += (-cumul_size) & (cumul_alignment-1);
4113 var DYNAMIC_ARRAY(total_room,char,cumul_size+cumul_alignment/*-1*/);
4114 var void* result_address = (void*)((uintP)(total_room+result_alignment-1) & -(long)result_alignment);
4115 var void* allocaing_room_pointer = (void*)((uintP)result_address + result_size);
4116 if (!eq(result_fvd,S(nil))) {
4117 pushSTACK(result_fvd);
4118 results[0].address = result_address;
4119 result_count++;
4120 }
4121 /* Call av_start_xxx: */
4122 begin_system_call();
4123 do_av_start(flags,result_fvd,&alist,address,result_address,result_size,
4124 result_splittable);
4125 end_system_call();
4126 { /* Now pass the arguments. */
4127 var uintL i;
4128 var sintL j;
4129 for (i = 0, j = 0; i < allargcount; i++) {
4130 var object argfvds = TheFfunction(Before(rest_args_pointer))->ff_argtypes;
4131 var object arg_fvd = TheSvector(argfvds)->data[2*i];
4132 var uintWL arg_flags = posfixnum_to_V(TheSvector(argfvds)->data[2*i+1]);
4133 var object arg;
4134 if (arg_flags & ff_out) {
4135 arg = unbound; /* only to avoid uninitialized variable */
4136 } else {
4137 arg = Next(rest_args_pointer STACKop -j); j++;
4138 }
4139 /* Allocate temporary space for the argument: */
4140 var struct foreign_layout sas;
4141 foreign_layout(arg_fvd,&sas);
4142 var uintL arg_size = sas.size;
4143 var uintL arg_alignment = sas.alignment;
4144 if (arg_flags & ff_alloca) {
4145 allocaing_room_pointer =
4146 (void*)(((uintP)allocaing_room_pointer + arg_alignment-1)
4147 & -(long)arg_alignment);
4148 var void* arg_address = allocaing_room_pointer;
4149 allocaing_room_pointer = (void*)((uintP)allocaing_room_pointer
4150 + arg_size);
4151 if (arg_flags & ff_out) {
4152 /* Pass top-level pointer only: */
4153 var object argo_fvd = TheSvector(arg_fvd)->data[1];
4154 foreign_layout(argo_fvd,&sas);
4155 allocaing_room_pointer =
4156 (void*)(((uintP)allocaing_room_pointer + sas.alignment-1)
4157 & -(long)sas.alignment);
4158 *(void**)arg_address = allocaing_room_pointer;
4159 pushSTACK(argo_fvd);
4160 results[result_count].address = allocaing_room_pointer;
4161 result_count++;
4162 /* zero-fill to avoid uninitialized result: */
4163 blockzero(allocaing_room_pointer,sas.size);
4164 allocaing_room_pointer =
4165 (void*)((uintP)allocaing_room_pointer + sas.size);
4166 } else {
4167 /* Convert argument: */
4168 pushSTACK(arg_fvd); /* save */
4169 convert_to_foreign(arg_fvd,arg,arg_address,&allocaing,
4170 &allocaing_room_pointer);
4171 arg_fvd = popSTACK(); /* restore */
4172 if (arg_flags & ff_inout) {
4173 pushSTACK(TheSvector(arg_fvd)->data[1]);
4174 results[result_count].address = *(void**)arg_address;
4175 result_count++;
4176 }
4177 }
4178 /* Call av_xxx: */
4179 begin_system_call();
4180 do_av_arg(flags,arg_fvd,&alist,arg_address,arg_size,arg_alignment);
4181 end_system_call();
4182 } else {
4183 var uintL arg_totalsize = arg_size+arg_alignment; /* >= arg_size+arg_alignment-1, > 0 */
4184 var DYNAMIC_ARRAY(arg_room,char,arg_totalsize);
4185 var void* arg_address = (void*)((uintP)(arg_room+arg_alignment-1)
4186 & -(long)arg_alignment);
4187 if (!(arg_flags & ff_out)) {
4188 /* Convert argument: */
4189 pushSTACK(arg_fvd); /* save */
4190 if (arg_flags & ff_malloc)
4191 convert_to_foreign(arg_fvd,arg,arg_address,&mallocing,NULL);
4192 else
4193 convert_to_foreign(arg_fvd,arg,arg_address,&nomalloc,NULL);
4194 arg_fvd = popSTACK(); /* restore */
4195 if (arg_flags & ff_inout) {
4196 pushSTACK(TheSvector(arg_fvd)->data[1]);
4197 results[result_count].address = *(void**)arg_address;
4198 result_count++;
4199 }
4200 }
4201 /* Call av_xxx: */
4202 begin_system_call();
4203 do_av_arg(flags,arg_fvd,&alist,arg_address,arg_size,arg_alignment);
4204 end_system_call();
4205 FREE_DYNAMIC_ARRAY(arg_room);
4206 }
4207 }
4208 }
4209 if (av_overflown(alist))
4210 /* avcall has limited buffer space
4211 __AV_ALIST_WORDS is only an approximation in number of arguments */
4212 error_too_many_args(S(foreign_call_out),Before(rest_args_pointer),
4213 allargcount,__AV_ALIST_WORDS);
4214 /* Finally call the function. */
4215 begin_blocking_system_call();
4216 av_call(alist);
4217 end_blocking_system_call();
4218 { /* Convert the result(s) back to Lisp. */
4219 var gcv_object_t* resptr = (&STACK_0 STACKop result_count) STACKop -1;
4220 var uintL i;
4221 for (i = 0; i < result_count; i++) {
4222 *resptr = convert_from_foreign(*resptr,results[i].address);
4223 resptr skipSTACKop -1;
4224 }
4225 }
4226 /* Return them as multiple values. */
4227 if (result_count >= mv_limit)
4228 error_mv_toomany(S(foreign_call_out));
4229 STACK_to_mv(result_count);
4230 if (flags & ff_alloca) {
4231 /* The C functions we passed also have dynamic extent. Free them.
4232 Not done now. ?? */
4233 }
4234 if (flags & ff_malloc) {
4235 result_fvd = TheFfunction(Before(rest_args_pointer))->ff_resulttype;
4236 free_foreign(result_fvd,result_address);
4237 }
4238 FREE_DYNAMIC_ARRAY(total_room);
4239 FREE_DYNAMIC_ARRAY(results);
4240 }
4241 set_args_end_pointer(rest_args_pointer STACKop 1); /* STACK cleanup */
4242 }
4243
4244
4245 /* ====================== Implementation of CALL-INs ====================== */
4246
4247 /* Here is the point where we use the VACALL package. */
4248
4249 /* Call the appropriate va_start_xxx macro for the result.
4250 do_va_start(flags,result_fvd,alist,result_size,result_alignment,
4251 result_splittable); */
do_va_start(uintWL flags,object result_fvd,va_alist alist,uintL result_size,uintL result_alignment,bool result_splittable)4252 local void do_va_start (uintWL flags, object result_fvd, va_alist alist,
4253 uintL result_size, uintL result_alignment,
4254 bool result_splittable)
4255 {
4256 if (symbolp(result_fvd)) {
4257 if (eq(result_fvd,S(nil))) {
4258 va_start_void(alist);
4259 } else if (eq(result_fvd,S(char)) || eq(result_fvd,S(sint8))) {
4260 if (flags & ff_lang_ansi_c) {
4261 va_start_schar(alist);
4262 } else { /* `signed char' promotes to `int' */
4263 va_start_int(alist);
4264 }
4265 } else if (eq(result_fvd,S(uchar)) || eq(result_fvd,S(uint8))
4266 || eq(result_fvd,S(character))) {
4267 if (flags & ff_lang_ansi_c) {
4268 va_start_uchar(alist);
4269 } else { /* `unsigned char' promotes to `unsigned int' */
4270 va_start_uint(alist);
4271 }
4272 } else if (eq(result_fvd,S(short)) || eq(result_fvd,S(sint16))) {
4273 if (flags & ff_lang_ansi_c) {
4274 va_start_short(alist);
4275 } else { /* `short' promotes to `int' */
4276 va_start_int(alist);
4277 }
4278 } else if (eq(result_fvd,S(ushort)) || eq(result_fvd,S(uint16))) {
4279 if (flags & ff_lang_ansi_c) {
4280 va_start_ushort(alist);
4281 } else { /* `unsigned short' promotes to `unsigned int' */
4282 va_start_uint(alist);
4283 }
4284 } else if (eq(result_fvd,S(boolean)) || eq(result_fvd,S(int))
4285 #if (int_bitsize==32)
4286 || eq(result_fvd,S(sint32))
4287 #endif
4288 ) {
4289 va_start_int(alist);
4290 } else if (eq(result_fvd,S(uint))
4291 #if (int_bitsize==32)
4292 || eq(result_fvd,S(uint32))
4293 #endif
4294 ) {
4295 va_start_uint(alist);
4296 } else if (eq(result_fvd,S(long))
4297 #if (int_bitsize<32) && (long_bitsize==32)
4298 || eq(result_fvd,S(sint32))
4299 #endif
4300 #if (long_bitsize==64)
4301 || eq(result_fvd,S(sint64))
4302 #endif
4303 ) {
4304 va_start_long(alist);
4305 } else if (eq(result_fvd,S(ulong))
4306 #if (int_bitsize<32) && (long_bitsize==32)
4307 || eq(result_fvd,S(uint32))
4308 #endif
4309 #if (long_bitsize==64)
4310 || eq(result_fvd,S(uint64))
4311 #endif
4312 ) {
4313 va_start_ulong(alist);
4314 }
4315 #if (long_bitsize<64)
4316 #if defined(HAVE_LONG_LONG_INT)
4317 else if (eq(result_fvd,S(sint64))) {
4318 va_start_longlong(alist);
4319 } else if (eq(result_fvd,S(uint64))) {
4320 va_start_ulonglong(alist);
4321 }
4322 #else
4323 else if (eq(result_fvd,S(sint64))) {
4324 va_start_struct(alist,struct_sint64,va_word_splittable_2(sint32,sint32));
4325 } else if (eq(result_fvd,S(uint64))) {
4326 va_start_struct(alist,struct_uint64,va_word_splittable_2(uint32,uint32));
4327 }
4328 #endif
4329 #endif
4330 else if (eq(result_fvd,S(single_float))) {
4331 if (flags & ff_lang_ansi_c) {
4332 va_start_float(alist);
4333 } else { /* `float' promotes to `double' */
4334 va_start_double(alist);
4335 }
4336 } else if (eq(result_fvd,S(double_float))) {
4337 va_start_double(alist);
4338 } else if (eq(result_fvd,S(c_pointer)) || eq(result_fvd,S(c_string))) {
4339 va_start_ptr(alist,void*);
4340 } else {
4341 error_foreign_type(result_fvd);
4342 }
4343 } else if (simple_vector_p(result_fvd)) {
4344 var object result_fvdtype = TheSvector(result_fvd)->data[0];
4345 if (eq(result_fvdtype,S(c_struct)) || eq(result_fvdtype,S(c_union))
4346 || eq(result_fvdtype,S(c_array)) || eq(result_fvdtype,S(c_array_max)))
4347 _va_start_struct(alist,result_size,result_alignment,result_splittable);
4348 else if (eq(result_fvdtype,S(c_function))
4349 || eq(result_fvdtype,S(c_ptr))
4350 || eq(result_fvdtype,S(c_ptr_null))
4351 || eq(result_fvdtype,S(c_pointer))
4352 || eq(result_fvdtype,S(c_array_ptr))) {
4353 va_start_ptr(alist,void*);
4354 } else {
4355 error_foreign_type(result_fvd);
4356 }
4357 } else {
4358 var object inttype = gethash(result_fvd,O(foreign_inttype_table),false);
4359 if (!eq(inttype,nullobj))
4360 do_va_start (flags, inttype, alist, result_size, result_alignment,
4361 result_splittable);
4362 else error_foreign_type(result_fvd);
4363 }
4364 if (flags & ff_lang_stdcall)
4365 alist->flags |= __VA_STDCALL_CLEANUP;
4366 }
4367
4368 /* Call the appropriate va_arg_xxx macro for an arguemnt
4369 and return its address (in temporary storage).
4370 do_va_arg(flags,xarg_fvd,alist) */
do_va_arg(uintWL flags,object arg_fvd,va_alist alist)4371 local void* do_va_arg (uintWL flags, object arg_fvd, va_alist alist)
4372 {
4373 if (symbolp(arg_fvd)) {
4374 if (eq(arg_fvd,S(nil))) {
4375 return NULL;
4376 } else if (eq(arg_fvd,S(char)) || eq(arg_fvd,S(sint8))) {
4377 alist->tmp._schar =
4378 (flags & ff_lang_ansi_c
4379 ? va_arg_schar(alist)
4380 : /* `signed char' promotes to `int' */
4381 va_arg_int(alist));
4382 return &alist->tmp._schar;
4383 } else if (eq(arg_fvd,S(uchar)) || eq(arg_fvd,S(uint8))
4384 || eq(arg_fvd,S(character))) {
4385 alist->tmp._uchar =
4386 (flags & ff_lang_ansi_c
4387 ? va_arg_uchar(alist)
4388 : /* `unsigned char' promotes to `unsigned int' */
4389 va_arg_uint(alist));
4390 return &alist->tmp._uchar;
4391 } else if (eq(arg_fvd,S(short)) || eq(arg_fvd,S(sint16))) {
4392 alist->tmp._short =
4393 (flags & ff_lang_ansi_c
4394 ? va_arg_short(alist)
4395 : /* `short' promotes to `int' */
4396 va_arg_int(alist));
4397 return &alist->tmp._short;
4398 } else if (eq(arg_fvd,S(ushort)) || eq(arg_fvd,S(uint16))) {
4399 alist->tmp._ushort =
4400 (flags & ff_lang_ansi_c
4401 ? va_arg_ushort(alist)
4402 : /* `unsigned short' promotes to `unsigned int' */
4403 va_arg_uint(alist));
4404 return &alist->tmp._ushort;
4405 } else if (eq(arg_fvd,S(boolean)) || eq(arg_fvd,S(int))
4406 #if (int_bitsize==32)
4407 || eq(arg_fvd,S(sint32))
4408 #endif
4409 ) {
4410 alist->tmp._int = va_arg_int(alist);
4411 return &alist->tmp._int;
4412 } else if (eq(arg_fvd,S(uint))
4413 #if (int_bitsize==32)
4414 || eq(arg_fvd,S(uint32))
4415 #endif
4416 ) {
4417 alist->tmp._uint = va_arg_uint(alist);
4418 return &alist->tmp._uint;
4419 } else if (eq(arg_fvd,S(long))
4420 #if (int_bitsize<32) && (long_bitsize==32)
4421 || eq(arg_fvd,S(sint32))
4422 #endif
4423 #if (long_bitsize==64)
4424 || eq(arg_fvd,S(sint64))
4425 #endif
4426 ) {
4427 alist->tmp._long = va_arg_long(alist);
4428 return &alist->tmp._long;
4429 } else if (eq(arg_fvd,S(ulong))
4430 #if (int_bitsize<32) && (long_bitsize==32)
4431 || eq(arg_fvd,S(uint32))
4432 #endif
4433 #if (long_bitsize==64)
4434 || eq(arg_fvd,S(uint64))
4435 #endif
4436 ) {
4437 alist->tmp._ulong = va_arg_ulong(alist);
4438 return &alist->tmp._ulong;
4439 }
4440 #if (long_bitsize<64)
4441 #if defined(HAVE_LONG_LONG_INT)
4442 else if (eq(arg_fvd,S(sint64))) {
4443 alist->tmp._longlong = va_arg_longlong(alist);
4444 return &alist->tmp._longlong;
4445 } else if (eq(arg_fvd,S(uint64))) {
4446 alist->tmp._ulonglong = va_arg_ulonglong(alist);
4447 return &alist->tmp._ulonglong;
4448 }
4449 #else
4450 else if (eq(arg_fvd,S(sint64))) {
4451 return &va_arg_struct(alist,struct_sint64);
4452 } else if (eq(arg_fvd,S(uint64))) {
4453 return &va_arg_struct(alist,struct_uint64);
4454 }
4455 #endif
4456 #endif
4457 else if (eq(arg_fvd,S(single_float))) {
4458 alist->tmp._float =
4459 (flags & ff_lang_ansi_c
4460 ? va_arg_float(alist)
4461 : /* `float' promotes to `double' */
4462 va_arg_double(alist));
4463 return &alist->tmp._float;
4464 } else if (eq(arg_fvd,S(double_float))) {
4465 alist->tmp._double = va_arg_double(alist);
4466 return &alist->tmp._double;
4467 } else if (eq(arg_fvd,S(c_pointer)) || eq(arg_fvd,S(c_string))) {
4468 alist->tmp._ptr = va_arg_ptr(alist,void*);
4469 return &alist->tmp._ptr;
4470 } else {
4471 error_foreign_type(arg_fvd);
4472 }
4473 } else if (simple_vector_p(arg_fvd)) {
4474 var object arg_fvdtype = TheSvector(arg_fvd)->data[0];
4475 if (eq(arg_fvdtype,S(c_struct)) || eq(arg_fvdtype,S(c_union))
4476 || eq(arg_fvdtype,S(c_array)) || eq(arg_fvdtype,S(c_array_max))) {
4477 var struct foreign_layout sas;
4478 foreign_layout(arg_fvd,&sas);
4479 var uintL arg_size = sas.size;
4480 var uintL arg_alignment = sas.alignment;
4481 return _va_arg_struct(alist,arg_size,arg_alignment);
4482 } else if (eq(arg_fvdtype,S(c_function))
4483 || eq(arg_fvdtype,S(c_ptr))
4484 || eq(arg_fvdtype,S(c_ptr_null))
4485 || eq(arg_fvdtype,S(c_pointer))
4486 || eq(arg_fvdtype,S(c_array_ptr))) {
4487 alist->tmp._ptr = va_arg_ptr(alist,void*);
4488 return &alist->tmp._ptr;
4489 } else {
4490 error_foreign_type(arg_fvd);
4491 }
4492 } else {
4493 var object inttype = gethash(arg_fvd,O(foreign_inttype_table),false);
4494 if (!eq(inttype,nullobj))
4495 return do_va_arg (flags, inttype, alist);
4496 else error_foreign_type(arg_fvd);
4497 }
4498 }
4499
4500 /* Call the appropriate va_return_xxx macro for the result.
4501 do_va_return(flags,result_fvd,alist,result_size,result_alignment); */
do_va_return(uintWL flags,object result_fvd,va_alist alist,void * result_address,uintL result_size,uintL result_alignment)4502 local void do_va_return (uintWL flags, object result_fvd, va_alist alist, void* result_address, uintL result_size, uintL result_alignment)
4503 {
4504 if (symbolp(result_fvd)) {
4505 if (eq(result_fvd,S(nil))) {
4506 va_return_void(alist);
4507 } else if (eq(result_fvd,S(char)) || eq(result_fvd,S(sint8))) {
4508 if (flags & ff_lang_ansi_c) {
4509 va_return_schar(alist,*(sint8*)result_address);
4510 } else { /* `signed char' promotes to `int' */
4511 va_return_int(alist,*(sint8*)result_address);
4512 }
4513 } else if (eq(result_fvd,S(uchar)) || eq(result_fvd,S(uint8))
4514 || eq(result_fvd,S(character))) {
4515 if (flags & ff_lang_ansi_c) {
4516 va_return_uchar(alist,*(uint8*)result_address);
4517 } else { /* `unsigned char' promotes to `unsigned int' */
4518 va_return_uint(alist,*(uint8*)result_address);
4519 }
4520 } else if (eq(result_fvd,S(short)) || eq(result_fvd,S(sint16))) {
4521 if (flags & ff_lang_ansi_c) {
4522 va_return_short(alist,*(sint16*)result_address);
4523 } else { /* `short' promotes to `int' */
4524 va_return_int(alist,*(sint16*)result_address);
4525 }
4526 } else if (eq(result_fvd,S(ushort)) || eq(result_fvd,S(uint16))) {
4527 if (flags & ff_lang_ansi_c) {
4528 va_return_ushort(alist,*(uint16*)result_address);
4529 } else { /* `unsigned short' promotes to `unsigned int' */
4530 va_return_uint(alist,*(uint16*)result_address);
4531 }
4532 } else if (eq(result_fvd,S(boolean)) || eq(result_fvd,S(int))
4533 #if (int_bitsize==32)
4534 || eq(result_fvd,S(sint32))
4535 #endif
4536 ) {
4537 va_return_int(alist,*(int*)result_address);
4538 } else if (eq(result_fvd,S(uint))
4539 #if (int_bitsize==32)
4540 || eq(result_fvd,S(uint32))
4541 #endif
4542 ) {
4543 va_return_uint(alist,*(unsigned int *)result_address);
4544 } else if (eq(result_fvd,S(long))
4545 #if (int_bitsize<32) && (long_bitsize==32)
4546 || eq(result_fvd,S(sint32))
4547 #endif
4548 #if (long_bitsize==64)
4549 || eq(result_fvd,S(sint64))
4550 #endif
4551 ) {
4552 va_return_long(alist,*(long*)result_address);
4553 } else if (eq(result_fvd,S(ulong))
4554 #if (int_bitsize<32) && (long_bitsize==32)
4555 || eq(result_fvd,S(uint32))
4556 #endif
4557 #if (long_bitsize==64)
4558 || eq(result_fvd,S(uint64))
4559 #endif
4560 ) {
4561 va_return_ulong(alist,*(unsigned long *)result_address);
4562 }
4563 #if (long_bitsize<64)
4564 #if defined(HAVE_LONG_LONG_INT)
4565 else if (eq(result_fvd,S(sint64))) {
4566 va_return_longlong(alist,*(sint64*)result_address);
4567 } else if (eq(result_fvd,S(uint64))) {
4568 va_return_ulonglong(alist,*(uint64*)result_address);
4569 }
4570 #else
4571 else if (eq(result_fvd,S(sint64))) {
4572 va_return_struct(alist,struct_sint64,*(struct_sint64*)result_address);
4573 } else if (eq(result_fvd,S(uint64))) {
4574 va_return_struct(alist,struct_uint64,*(struct_uint64*)result_address);
4575 }
4576 #endif
4577 #endif
4578 else if (eq(result_fvd,S(single_float))) {
4579 if (flags & ff_lang_ansi_c) {
4580 va_return_float(alist,*(float*)result_address);
4581 } else { /* `float' promotes to `double' */
4582 va_return_double(alist,*(float*)result_address);
4583 }
4584 } else if (eq(result_fvd,S(double_float))) {
4585 va_return_double(alist,*(double*)result_address);
4586 } else if (eq(result_fvd,S(c_pointer)) || eq(result_fvd,S(c_string))) {
4587 va_return_ptr(alist,void*,*(void**)result_address);
4588 } else {
4589 error_foreign_type(result_fvd);
4590 }
4591 } else if (simple_vector_p(result_fvd)) {
4592 var object result_fvdtype = TheSvector(result_fvd)->data[0];
4593 if (eq(result_fvdtype,S(c_struct))
4594 || eq(result_fvdtype,S(c_union))
4595 || eq(result_fvdtype,S(c_array))
4596 || eq(result_fvdtype,S(c_array_max))) {
4597 _va_return_struct(alist,result_size,result_alignment,result_address);
4598 } else if (eq(result_fvdtype,S(c_function))
4599 || eq(result_fvdtype,S(c_ptr))
4600 || eq(result_fvdtype,S(c_ptr_null))
4601 || eq(result_fvdtype,S(c_pointer))
4602 || eq(result_fvdtype,S(c_array_ptr))) {
4603 va_return_ptr(alist,void*,*(void**)result_address);
4604 } else
4605 error_foreign_type(result_fvd);
4606 } else {
4607 var object inttype = gethash(result_fvd,O(foreign_inttype_table),false);
4608 if (!eq(inttype,nullobj))
4609 do_va_return (flags, inttype, alist, result_address,
4610 result_size, result_alignment);
4611 else error_foreign_type(result_fvd);
4612 }
4613 }
4614
4615 /* This is the CALL-IN function called by the trampolines. */
callback(void * data,va_alist alist)4616 local void callback (void* data, va_alist alist)
4617 {
4618 begin_callback();
4619 var gcv_object_t* triple = &TheSvector(TheIarray(O(foreign_callin_vector))->data)->data[3*((uintL)(uintP)data)-2];
4620 var object fun = triple[0];
4621 var object ffun = triple[1];
4622 var uintWL flags = posfixnum_to_V(TheFfunction(ffun)->ff_flags);
4623 var object result_fvd = TheFfunction(ffun)->ff_resulttype;
4624 var object argfvds_top = TheFfunction(ffun)->ff_argtypes;
4625 var uintL argcount = Svector_length(argfvds_top)/2;
4626 pushSTACK(result_fvd);
4627 pushSTACK(fun);
4628 pushSTACK(argfvds_top);
4629 switch (flags & 0x7F00) {
4630 /* For the moment, the only supported languages are "C" and "ANSI C". */
4631 case ff_lang_c:
4632 case ff_lang_ansi_c:
4633 break;
4634 default:
4635 error_function_no_fvd(ffun,S(foreign_call_in));
4636 }
4637 var struct foreign_layout sas;
4638 foreign_layout(result_fvd,&sas);
4639 var uintL result_size = sas.size;
4640 var uintL result_alignment = sas.alignment;
4641 var bool result_splittable = sas.splittable;
4642 /* Call va_start_xxx: */
4643 begin_system_call();
4644 do_va_start(flags,result_fvd,alist,result_size,result_alignment,
4645 result_splittable);
4646 end_system_call();
4647 { /* Walk through the arguments, convert them to Lisp data: */
4648 var uintL i;
4649 for (i = 0; i < argcount; i++) {
4650 var object argfvds = STACK_(i);
4651 var object arg_fvd = TheSvector(argfvds)->data[2*i];
4652 var uintWL arg_flags = posfixnum_to_V(TheSvector(argfvds)->data[2*i+1]);
4653 begin_system_call();
4654 var void* arg_addr = do_va_arg(flags,arg_fvd,alist);
4655 end_system_call();
4656 var object arg = convert_from_foreign(arg_fvd,arg_addr);
4657 if (arg_flags & ff_malloc)
4658 free_foreign(arg_fvd,arg_addr);
4659 pushSTACK(arg);
4660 }
4661 }
4662 /* Call the Lisp function: */
4663 funcall(STACK_(1+argcount),argcount);
4664 /* Allocate space for the result: */
4665 var DYNAMIC_ARRAY(result_room,char,result_size+result_alignment/*-1*/);
4666 var void* result_address = (void*)((uintP)(result_room+result_alignment-1)
4667 & -(long)result_alignment);
4668 /* Convert the result: */
4669 convert_to_foreign(STACK_2,value1,result_address,
4670 (flags & ff_malloc) ? &mallocing : &nomalloc,NULL);
4671 /* Call va_return_xxx: */
4672 begin_system_call();
4673 do_va_return(flags,STACK_2,alist,result_address,result_size,
4674 result_alignment);
4675 end_system_call();
4676 FREE_DYNAMIC_ARRAY(result_room);
4677 skipSTACK(3);
4678 end_callback();
4679 }
4680
4681
4682 /* ============================= Global stuff ============================= */
4683
4684 /* Allow everybody the creation of a FOREIGN-VARIABLE and FOREIGN-FUNCTION
4685 object, even without any module.
4686 This allows, among others, a self-test of the FFI (see testsuite). */
ffi_identity(uintP arg)4687 local uintP ffi_identity (uintP arg) { return arg; }
4688 global void* ffi_user_pointer = NULL;
4689
4690 /* Initialize the FFI. */
init_ffi(void)4691 global maygc void init_ffi (void) {
4692 /* Allocate a fresh zero foreign pointer: */
4693 O(fp_zero) = allocate_fpointer((void*)0);
4694 ffi_user_pointer = NULL;
4695 register_foreign_inttype("size_t",sizeof(size_t),false);
4696 register_foreign_inttype("ssize_t",sizeof(ssize_t),true);
4697 register_foreign_inttype("ffi_uintp",sizeof(uintP),false);
4698 register_foreign_variable(&ffi_user_pointer,"ffi_user_pointer",
4699 0,sizeof(ffi_user_pointer));
4700 register_foreign_function((void*)&ffi_identity,"ffi_identity",
4701 ff_lang_ansi_c);
4702 }
4703
4704 /* De-Initialize the FFI. */
exit_ffi(void)4705 global void exit_ffi (void) {
4706 #if defined(WIN32_NATIVE) || defined(HAVE_DLOPEN)
4707 /* Close all foreign libraries. */
4708 var object alist = O(foreign_libraries);
4709 while (consp(alist)) {
4710 var object lib_spec = Car(alist);
4711 var object obj = Car(Cdr(lib_spec));
4712 if (stringp(Car(lib_spec)) && fp_validp(TheFpointer(obj)))
4713 close_library(obj);
4714 alist = Cdr(alist);
4715 }
4716 O(foreign_libraries) = NIL;
4717 #endif
4718 }
4719
4720 #endif
4721