Add some prototype to silence silly warnings.
[sxemacs] / src / effi.c
1 /*
2  * effi.c --- Foreign Function Interface for SXEmacs.
3  *
4  * Copyright (C) 2004-2008 Zajcev Evgeny
5  *
6 This file is part of SXEmacs
7
8 SXEmacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
12
13 SXEmacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
20
21
22 #include <config.h>
23 #include "lisp.h"
24
25 #include <dlfcn.h>
26 #include <math.h>
27 #include "sysdep.h"
28 #include "ent/ent.h"
29 #include "effi.h"
30
31 #include "buffer.h"
32 #ifdef FILE_CODING
33 #  include "mule/file-coding.h"
34 #endif
35
36 #ifdef HAVE_LIBFFI
37 #  undef ALIGN
38 #  include <ffi.h>
39 #endif  /* HAVE_LIBFFI */
40
41 #ifdef EF_USE_ASYNEQ
42 #  include "events/workers.h"
43 #  include "events/worker-asyneq.h"
44 #endif  /* EF_USE_ASYNEQ */
45
46 /* For `x-device-display' */
47 #include "ui/X11/console-x.h"
48 #include "ui/device.h"
49
50 #define EFFI_CODING     Qnative
51
52 /*
53  * Some compatibility for XEmacs
54  */
55 #ifdef SXEMACS
56 #  define SIGNAL_ERROR signal_error
57 #  define FFIBYTE Bufbyte
58 #  define WRITE_C_STRING(x,y) write_c_string((x),(y))
59 #  define WRITE_FMT_STRING(x,y,...) write_fmt_string((x),(y),__VA_ARGS__)
60 #  define LRECORD_DESCRIPTION lrecord_description
61 #else
62 #  define SIGNAL_ERROR Fsignal
63 #  define FFIBYTE Ibyte
64 #  define WRITE_C_STRING(x,y) write_c_string((y),(x))
65 #  define WRITE_FMT_STRING(x,y,...)                     \
66         do {                                            \
67                 char wcsb[128];                         \
68                 int wcss = snprintf(wcsb, sizeof(wcsb), \
69                                     (y),__VA_ARGS__);   \
70                 write_c_string((y),wcsb);               \
71         } while(0)
72 #  define LRECORD_DESCRIPTION memory_description
73 #endif  /* SXEMACS */
74
75 /*
76  * Built-in types:
77  *   byte, ubyte, char, uchar,
78  *   short, ushort, int, uint,
79  *   long, ulong,
80  *   float, double,
81  *   void, pointer, c-string
82  *
83  * Function type:
84  *
85  *   (function RET-TYPE IN-TYPE .. IN-TYPE)
86  *
87  * Array types:
88  *
89  *   (array TYPE SIZE)
90  *
91  * Structures and unions types:
92  *
93  *   (struct|union NAME
94  *     (SLOT-NAME TYPE)
95  *     (SLOT-NAME TYPE)
96  *     ...
97  *     (SLOT-NAME TYPE))
98  *
99  * Pointers:
100  *
101  *   pointer or (pointer TYPE)
102  */
103
104 /* Foreign types, not defined as symbols elsewhere. */
105 Lisp_Object Qarray, Qbyte, Qc_data, Qc_string, Qdouble, Qlong, Qstruct;
106 Lisp_Object Qunion, Qunsigned_byte, Qunsigned_char, Qunsigned_int;
107 Lisp_Object Qunsigned_long, Qunsigned_short;
108
109 #define FFI_POINTERP(type) (EQ(type, Qpointer)                                \
110                             || (CONSP(type) && EQ(XCAR(type), Qpointer)))
111
112 #define FFI_TPTR(type) (EQ(type, Qc_string)                                   \
113                         || EQ(type, Qc_data)                                  \
114                         || FFI_POINTERP(type)                                  \
115                         || (CONSP(type) && ((EQ(XCAR(type), Qc_data))         \
116                                             || EQ(XCAR(type), Qarray))))
117 Lisp_Object Qffiobjectp;
118 Lisp_Object Qffi_translate_to_foreign;
119 Lisp_Object Qffi_translate_from_foreign;
120
121 /* Alist with elements in form (NAME . TYPE) */
122 Lisp_Object Vffi_loaded_libraries;
123 Lisp_Object Vffi_named_types;
124
125 Lisp_Object Vffi_type_checker;
126
127 static Lisp_Object Vffi_all_objects;
128
129 Lisp_Object Qffi_callback;
130
131 static Lisp_Object
132 mark_ffiobject(Lisp_Object obj)
133 {
134         Lisp_EffiObject *ffio = XEFFIO(obj);
135         mark_object(ffio->type);
136         mark_object(ffio->size);
137         mark_object(ffio->plist);
138         return (ffio->plist);
139 }
140
141 static void
142 print_ffiobject(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
143 {
144         /* This function can GC */
145         Lisp_EffiObject *ffio = XEFFIO(obj);
146         escapeflag = escapeflag;        /* shutup compiler */
147         if (print_readably) {
148 #ifdef SXEMACS
149                 error("printing unreadable object #<ffiobject 0x%x>",
150                       ffio->header.uid);
151 #else
152                 signal_ferror(Qinternal_error,
153                               "printing unreadable object #<ffiobject 0x%x>",
154                               ffio->header.uid);
155 #endif  /* SXEMACS */
156         }
157         WRITE_C_STRING("#<ffiobject ", printcharfun);
158         /* Print FFIO type */
159         if (!NILP(ffio->type)) {
160                 WRITE_C_STRING("type=", printcharfun);
161                 print_internal(ffio->type, printcharfun, 1);
162                 WRITE_C_STRING(" ", printcharfun);
163         }
164         WRITE_FMT_STRING(printcharfun,"size=%ld fotype=%d foptr=%p>",
165                          (long)XINT(ffio->size), ffio->fotype, ffio->fop.generic);
166 }
167
168 static const struct LRECORD_DESCRIPTION ffiobject_description[] = {
169         {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, type)},
170         {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, size)},
171         {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, plist)},
172         {XD_INT, offsetof(Lisp_EffiObject, fotype)},
173         {XD_OPAQUE_PTR, offsetof(Lisp_EffiObject, fop)},
174 #ifdef SXEMACS
175         {XD_SIZE_T, offsetof(Lisp_EffiObject, storage_size)},
176 #else
177         {XD_ELEMCOUNT, offsetof(Lisp_EffiObject, storage_size)},
178 #endif  /* SXEMACS */
179         {XD_END}
180 };
181
182 static Lisp_Object
183 ffi_getprop(Lisp_Object fo, Lisp_Object property)
184 {
185         return external_plist_get(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
186 }
187
188 static int
189 ffi_putprop(Lisp_Object fo, Lisp_Object property, Lisp_Object value)
190 {
191         external_plist_put(&XEFFIO(fo)->plist, property, value, 0, ERROR_ME);
192         return 1;
193 }
194
195 static int
196 ffi_remprop(Lisp_Object fo, Lisp_Object property)
197 {
198         return external_remprop(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
199 }
200
201 #ifdef SXEMACS
202 static size_t
203 sizeof_ffiobject(const void *header)
204 {
205         const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
206         return (sizeof(Lisp_EffiObject) + effio->storage_size);
207 }
208 #else
209 static Bytecount
210 sizeof_ffiobject(const void *header)
211 {
212         const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
213         return (sizeof(Lisp_EffiObject) + effio->storage_size);
214 }
215 #endif  /* SXEMACS */
216
217 /* Define ffiobject implementation */
218 const struct lrecord_implementation lrecord_ffiobject = {
219         .name = "ffiobject",
220         .marker = mark_ffiobject,
221         .printer = print_ffiobject,
222         .finalizer = 0,
223         .equal = 0,
224         .hash = 0,
225         .description = ffiobject_description,
226         .getprop = ffi_getprop,
227         .putprop = ffi_putprop,
228         .remprop = ffi_remprop,
229         .plist = Fffi_plist,
230         .static_size = 0,
231         .size_in_bytes_method = sizeof_ffiobject,
232         .lrecord_type_index = lrecord_type_ffiobject,
233         .basic_p = 0
234 };
235
236 \f
237 /** alignment in union and structures **/
238 /*
239  * x86:
240  *
241  *   - An entire structure or union is aligned on the same boundary as
242  *     its most strictly aligned member.
243  *
244  *   - Each member is assigned to the lowest available offset with the
245  *     appropriate alignment.  This may require /internal padding/,
246  *     depending on the previous member.
247  *
248  *   - A structure's size is increased, if necessary, to make it a
249  *     multiple of the alignment.  This may require /tail padding/,
250  *     depending on the last member.
251  *
252  *  Internal padding:
253  *
254  *    struct {
255  *     char c;            .-------2+---1+---0.
256  *     short s;           |  s     |pad |  c |
257  *    }                   `--------+----+----'
258  *
259  *  Internal and Tail padding:
260  *
261  *    struct {            .------------1+---0.
262  *     char c;            |     pad     |  c |
263  *     double d;          |-------------+---4|
264  *     short s;           |         d        |
265  *    }                   |-----------------8|
266  *                        |         d        |
267  *                        |------14+-------12|
268  *                        |   pad  |    s    |
269  *                        `--------+---------'
270  *
271  *  Union allocation:
272  *
273  *    union {             .------------1+---0.
274  *     char c;            |     pad     |  c |
275  *     short s;           |-------2+----+---0|
276  *     int j;             |  pad   |    s    |
277  *    }                   |--------+--------0|
278  *                        |        j         |
279  *                        `------------------'
280  */
281 static Lisp_Object
282 ffi_check_type(Lisp_Object type)
283 {
284         return apply1(Vffi_type_checker, Fcons(type, Fcons(Qt, Qnil)));
285 }
286
287 DEFUN("ffi-basic-type-p", Fffi_basic_type_p, 1, 1, 0, /*
288 Return non-nil if TYPE is a basic FFI type.
289
290 A type is said to be basic, if it is neither a pointer nor a
291 function, and there is a corresponding built-in type in C.
292 */
293       (type))
294 {
295         if (EQ(type, Qbyte) || EQ(type, Qunsigned_byte) || EQ(type, Qchar)
296             || EQ(type, Qunsigned_char) || EQ(type, Qshort)
297             || EQ(type, Qunsigned_short) || EQ(type, Qint)
298             || EQ(type, Qunsigned_int) || EQ(type, Qlong)
299             || EQ(type, Qunsigned_long) || EQ(type, Qfloat)
300             || EQ(type, Qdouble) || EQ(type, Qvoid)
301             || EQ(type, Qc_string) || EQ(type, Qc_data)
302             || (CONSP(type) && EQ(XCAR(type), Qc_data)))
303                 return Qt;
304         else
305                 return Qnil;
306 }
307
308
309 static Lisp_Object
310 ffi_canonicalise_type(Lisp_Object type)
311 {
312 /* this function canNOT GC */
313
314         while (!NILP(type) && NILP(Fffi_basic_type_p(type)) && SYMBOLP(type)) {
315                 if EQ(type, Qpointer)
316                         break;
317                 type = Fcdr(Fassq(type, Vffi_named_types));
318         }
319
320         return type;
321 }
322
323 DEFUN("ffi-canonicalise-type", Fffi_canonicalise_type, 1, 1, 0, /*
324 Return FFI type TYPE in a canonical form.
325 */
326       (type))
327 {
328         Lisp_Object canon_type = ffi_canonicalise_type(type);
329         if (NILP(canon_type)) {
330 #ifdef SXEMACS
331                 signal_simple_error("No such FFI type", type);
332 #else
333                 signal_error(Qinternal_error, "No such FFI type", type);
334 #endif  /* SXEMACS */
335         }
336         return canon_type;
337 }
338
339 DEFUN("ffi-size-of-type", Fffi_size_of_type, 1, 1, 0,   /*
340 Return the size of the foreign type TYPE.
341
342 Valid foreign types are: `byte', `unsigned-byte', `char',
343 `unsigned-char', `short', `unsigned-short', `int', `unsigned-int',
344 `long', `unsigned-long', `pointer', `float', `double',
345 `object', and `c-string'.
346 */
347       (type))
348 {
349         int tsize;
350
351         type = ffi_canonicalise_type(type);
352         if (EQ(type, Qvoid))
353                 tsize = 0;
354         else if (EQ(type, Qbyte))
355                 tsize = sizeof(int8_t);
356         else if (EQ(type, Qunsigned_byte))
357                 tsize = sizeof(uint8_t);
358         else if (EQ(type, Qchar))
359                 tsize = sizeof(char);
360         else if (EQ(type, Qunsigned_char))
361                 tsize = sizeof(unsigned char);
362         else if (EQ(type, Qshort))
363                 tsize = sizeof(short);
364         else if (EQ(type, Qunsigned_short))
365                 tsize = sizeof(unsigned short);
366         else if (EQ(type, Qint))
367                 tsize = sizeof(int);
368         else if (EQ(type, Qunsigned_int))
369                 tsize = sizeof(unsigned int);
370         else if (EQ(type, Qlong))
371                 tsize = sizeof(long);
372         else if (EQ(type, Qunsigned_long))
373                 tsize = sizeof(unsigned long);
374         else if (EQ(type, Qfloat))
375                 tsize = sizeof(float);
376         else if (EQ(type, Qdouble))
377                 tsize = sizeof(double);
378         else if (EQ(type, Qc_string))
379                 tsize = sizeof(char *);
380         else if (FFI_POINTERP(type))
381                 tsize = sizeof(void *);
382         else if (EQ(type, Qc_data))
383                 tsize = sizeof(void *);
384         else if (CONSP(type) && EQ(XCAR(type), Qc_data)) {
385                 Lisp_Object cdsize = XCDR(type);
386                 CHECK_INT(cdsize);
387                 tsize = XINT(cdsize);
388         } else if (CONSP(type) && EQ(XCAR(type), Qfunction))
389                 tsize = sizeof(void(*));
390         else if (CONSP(type) && EQ(XCAR(type), Qarray)) {
391                 Lisp_Object atype = Fcar(XCDR(type));
392                 Lisp_Object asize = Fcar(Fcdr(XCDR(type)));
393
394                 CHECK_INT(asize);
395                 tsize = XINT(asize) * XINT(Fffi_size_of_type(atype));
396         } else if (CONSP(type) && EQ(XCAR(type), Qstruct)) {
397                 return Fffi_slot_offset(type, Qnil);
398         } else if (CONSP(type) && EQ(XCAR(type), Qunion)) {
399                 Lisp_Object slots = Fcdr(XCDR(type));
400
401                 CHECK_CONS(slots);
402
403                 tsize = 0;
404                 while (!NILP(slots)) {
405                         Lisp_Object slot_type = Fcar(Fcdr(XCAR(slots)));
406                         int slot_size = XINT(Fffi_size_of_type(slot_type));
407                         if (slot_size > tsize)
408                                 tsize = slot_size;
409                         slots = XCDR(slots);
410                 }
411         } else {
412 #ifdef SXEMACS
413                 signal_simple_error("Unrecognized foreign type", type);
414 #else
415                 signal_error(Qinternal_error, "Unrecognized foreign type", type);
416 #endif  /* SXEMACS */
417         }
418
419         return make_int(tsize);
420 }
421
422 DEFUN("make-ffi-object", Fmake_ffi_object, 1, 2, 0, /*
423 Create a new FFI object of type TYPE.
424 If optional argument SIZE is non-nil it should be an
425 integer, in this case additional storage size to hold data
426 of at least length SIZE is allocated.
427 */
428       (type, size))
429 {
430         int cs_or_cd;
431         Lisp_Object ctype;
432         Lisp_Object result = Qnil;
433         Lisp_EffiObject *ffio;
434         struct gcpro gcpro1;
435
436         GCPRO1(result);
437
438         /* NOTE: ffi_check_type returns canonical type */
439         ctype = ffi_check_type(type);
440         if (NILP(size))
441                 size = Fffi_size_of_type(type);
442         CHECK_INT(size);
443
444         if (CONSP(ctype) && EQ(XCAR(ctype), Qc_data) && INTP(XCDR(ctype)))
445                 size = XCDR(type);
446
447         cs_or_cd = EQ(ctype, Qc_string) || (EQ(ctype, Qc_data));
448         if ((cs_or_cd && (XINT(size) < 1))
449             || (!(cs_or_cd || FFI_POINTERP(ctype))
450                 && (XINT(size) < XINT(Fffi_size_of_type(type)))))
451 #ifdef SXEMACS
452                 signal_simple_error("storage size too small to store type",
453                                     list2(size, type));
454
455         ffio = alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
456                               &lrecord_ffiobject);
457         XSETEFFIO(result, ffio);
458 #else
459                 signal_error(Qinternal_error,
460                              "storage size too small to store type",
461                              list2(size, type));
462
463         ffio = old_basic_alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
464                                         &lrecord_ffiobject);
465         result = wrap_effio(ffio);
466 #endif  /* SXEMACS */
467
468         ffio->size = Fffi_size_of_type(type);
469         ffio->type = type;
470         ffio->plist = Qnil;
471
472         /* Initialize foreign pointer */
473         ffio->fotype = EFFI_FOT_NONE;
474         ffio->storage_size = XINT(size);
475         ffio->fop.ptr = ffio->fostorage;
476
477         if (!NILP(Vffi_all_objects))
478                 XWEAK_LIST_LIST(Vffi_all_objects) =
479                         Fcons(result, XWEAK_LIST_LIST(Vffi_all_objects));
480
481         RETURN_UNGCPRO(result);
482 }
483
484 DEFUN("ffi-object-p", Fffi_object_p, 1, 1, 0, /*
485 Return non-nil if FO is an FFI object, nil otherwise.
486 */
487       (fo))
488 {
489         return (EFFIOP(fo) ? Qt : Qnil);
490 }
491
492 DEFUN("ffi-object-address", Fffi_object_address, 1, 1, 0, /*
493 Return the address FO points to.
494 */
495       (fo))
496 {
497         CHECK_EFFIO(fo);
498         return make_float((long)XEFFIO(fo)->fop.ptr);
499 }
500
501 DEFUN("ffi-make-pointer", Fffi_make_pointer, 1, 1, 0, /*
502   "Return a pointer pointing to ADDRESS."
503 */
504       (address))
505 {
506         long addr;
507         Lisp_Object ptr;
508
509         if (INTP(address))
510                 addr = XINT(address);
511         else if (FLOATP(address))
512                 addr = XFLOATINT(address);
513         else {
514 #ifdef SXEMACS
515                 signal_simple_error("FFI: invalid address type", address);
516 #else
517                 signal_error(Qinternal_error, "FFI: invalid address type",
518                              address);
519 #endif  /* SXEMACS */
520         }
521
522         ptr = Fmake_ffi_object(Qpointer, Qnil);
523         XEFFIO(ptr)->fop.ptr = (void*)addr;
524         return ptr;
525 }
526
527 DEFUN("ffi-object-canonical-type", Fffi_object_canonical_type, 1, 1, 0, /*
528 Return FO's real type, that is after resolving user defined types.
529 */
530       (fo))
531 {
532         CHECK_EFFIO(fo);
533         return ffi_canonicalise_type(XEFFIO(fo)->type);
534 }
535
536 DEFUN("ffi-object-type", Fffi_object_type, 1, 1, 0, /*
537 Return FO's type.
538 */
539       (fo))
540 {
541         CHECK_EFFIO(fo);
542         return (XEFFIO(fo)->type);
543 }
544
545 DEFUN("ffi-set-object-type", Fffi_set_object_type, 2, 2, 0, /*
546 Cast FO to type TYPE and reassign the cast value.
547 Return casted foreign object.
548 */
549       (fo, type))
550 {
551         CHECK_EFFIO(fo);
552
553         ffi_check_type(type);
554         XEFFIO(fo)->type = type;
555
556         return fo;
557 }
558
559 DEFUN("ffi-object-size", Fffi_object_size, 1, 1, 0, /*
560 Return the size of the allocated space of FO.
561 */
562       (fo))
563 {
564         CHECK_EFFIO(fo);
565         return (XEFFIO(fo)->size);
566 }
567
568 DEFUN("ffi-set-storage-size", Fffi_set_storage_size, 2, 2, 0, /*
569 Set the size of the allocated space of FO.
570 */
571       (fo, size))
572 {
573         CHECK_EFFIO(fo);
574         CHECK_INT(size);
575         XEFFIO(fo)->storage_size = XUINT(size);
576         return Qt;
577 }
578
579 DEFUN("ffi-load-library", Fffi_load_library, 1, 1, 0, /*
580 Load library LIBNAME and return a foreign object handle if successful,
581 or `nil' if the library cannot be loaded.
582
583 The argument LIBNAME should be the file-name string of a shared object
584 library.  Normally you should omit the file extension, as this
585 function will add the appripriate extension for the current platform
586 if one is missing.
587
588 The library should reside in one of the directories specified by the
589 $LD_LIBRARY_PATH environment variable or the more global ld.so.cache.
590 */
591       (libname))
592 {
593
594 #ifdef LTDL_SHLIB_EXT
595 #  define EXT LTDL_SHLIB_EXT
596 #elif defined(HAVE_DYLD) || defined(HAVE_MACH_O_DYLD_H)
597 #    define EXT ".dylib"
598 #  else
599 #    define EXT ".so"
600 #endif  /* LTDL_SHLIB_EXT */
601
602         void *handler, *dotpos;
603         Lisp_Object fo = Qnil;
604         Lisp_EffiObject *ffio;
605         struct gcpro gcpro1;
606         char *soname = NULL;
607
608         CHECK_STRING(libname);
609
610         /* Add an extension if we need to */
611         dotpos = strrchr((char *)XSTRING_DATA(libname),'.');
612         if ( dotpos == NULL || strncmp(dotpos, EXT, sizeof(EXT))) {
613                 ssize_t liblen = XSTRING_LENGTH(libname);
614                 ssize_t soname_len = liblen + sizeof(EXT) + 1;
615                 soname = xmalloc( soname_len);
616                 xstrncpy(soname, (char *)XSTRING_DATA(libname), soname_len);
617                 xstrncpy(soname+liblen, EXT, soname_len-liblen);
618         }
619
620         if ( soname == NULL ) {
621                 handler = dlopen((const char *)XSTRING_DATA(libname),
622                                  RTLD_GLOBAL|RTLD_NOW);
623         } else {
624                 handler = dlopen(soname, RTLD_GLOBAL|RTLD_NOW);
625                 xfree(soname);
626         }
627
628         if (handler == NULL)
629                 return Qnil;
630
631         GCPRO1(fo);
632         fo = Fmake_ffi_object(Qpointer, Qnil);
633         ffio = XEFFIO(fo);
634
635         ffio->fotype = EFFI_FOT_BIND;
636         ffio->fop.ptr = handler;
637
638         RETURN_UNGCPRO(fo);
639 }
640
641 DEFUN("ffi-bind", Fffi_bind, 2, 2, 0, /*
642 Make and return a foreign object of type TYPE and bind it to the
643 external symbol SYM.
644
645 The argument TYPE can be any type-cell.
646 The argument SYM should be a string naming an arbitrary symbol
647 in one of the loaded libraries.
648
649 If SYM does not exist in any of the loaded libraries, `nil' is
650 returned.
651 */
652       (type, sym))
653 {
654         Lisp_Object fo = Qnil;
655         Lisp_EffiObject *ffio;
656         struct gcpro gcpro1;
657
658         ffi_check_type(type);
659         CHECK_STRING(sym);
660
661         GCPRO1(fo);
662         fo = Fmake_ffi_object(type, Qnil);
663         ffio = XEFFIO(fo);
664         ffio->fop.ptr = dlsym(RTLD_DEFAULT, (const char*)XSTRING_DATA(sym));
665         if (ffio->fop.ptr == NULL) {
666                 UNGCPRO;
667                 return Qnil;
668         }
669
670         ffio->fotype = EFFI_FOT_BIND;
671
672         RETURN_UNGCPRO(fo);
673 }
674
675 DEFUN("ffi-dlerror", Fffi_dlerror, 0, 0, 0, /*
676 Return dl error string.
677 */
678       ())
679 {
680         const char *dles = dlerror();
681
682         if (LIKELY(dles != NULL)) {
683                 size_t sz = strlen(dles);
684                 return make_ext_string((const Extbyte*)dles, sz, EFFI_CODING);
685         } else {
686                 return Qnil;
687         }
688 }
689
690 DEFUN("ffi-defun", Fffi_defun, 2, 2, 0, /*
691 Make and return a foreign object of type TYPE and bind it to the
692 external symbol SYM.
693
694 The argument TYPE should be a function type-cell.
695 The argument SYM should be a string naming a function in one of
696 the loaded libraries.
697
698 If SYM does not exist in any of the loaded libraries, an error
699 is indicated.
700
701 This is like `ffi-bind' but for function objects.
702 */
703       (type, sym))
704 {
705         Lisp_Object fo = Qnil;
706         Lisp_EffiObject *ffio;
707         struct gcpro gcpro1;
708
709         ffi_check_type(type);
710         CHECK_STRING(sym);
711
712         GCPRO1(fo);
713
714         fo = Fmake_ffi_object(type, Qnil);
715         ffio = XEFFIO(fo);
716         ffio->fop.fun = dlsym(RTLD_DEFAULT, (const char *)XSTRING_DATA(sym));
717         if (ffio->fop.fun == NULL) {
718 #ifdef SXEMACS
719                 signal_simple_error("Can't define function", sym);
720 #else
721                 signal_error(Qinternal_error, "Can't define function", sym);
722 #endif  /* SXEMACS */
723         }
724
725         ffio->fotype = EFFI_FOT_FUNC;
726
727         RETURN_UNGCPRO(fo);
728 }
729
730 /*
731  * Return alignment policy for struct or union FFI_SU.
732  * x86: Return 1, 2 or 4.
733  * x86_64: Return 1, 2, 4 or 8
734  * mips: Return 1, 2, 4 or 8.
735  */
736 static int
737 ffi_type_align(Lisp_Object type)
738 {
739         type = ffi_canonicalise_type(type);
740         if (SYMBOLP(type)) {
741                 if (EQ(type, Qbyte) || EQ(type, Qunsigned_byte)
742                     || EQ(type, Qchar) || EQ(type, Qunsigned_char))
743                         return 1;
744                 if (EQ(type, Qshort) || EQ(type, Qunsigned_short))
745                         return 2;
746 #ifdef __x86_64__
747                 if (EQ(type, Qlong) || EQ(type, Qunsigned_long)
748                     || EQ(type, Qdouble))
749                         return 8;
750 #endif  /* __x86_64__ */
751
752 #ifdef FFI_MIPS
753                 if (EQ(type, Qdouble))
754                         return 8;
755 #endif  /* FFI_MIPS */
756                 return 4;
757                 /* NOT REACHED */
758 #ifdef __x86_64__
759         } else if (FFI_TPTR(type)) {
760                 return 8;
761 #endif  /* __x86_64__ */
762         } else if (CONSP(type)
763                    && (EQ(XCAR(type), Qstruct) || EQ(XCAR(type), Qunion))) {
764                 int al;
765
766                 for (al = 0, type = Fcdr(Fcdr(type));
767                      !NILP(type);
768                      type = Fcdr(type))
769                 {
770                         Lisp_Object stype = Fcar(Fcdr(Fcar(type)));
771                         int tmp_al = ffi_type_align(stype);
772
773                         if (tmp_al > al)
774                                 al = tmp_al;
775                 }
776
777                 return al;
778         }
779
780         return 4;
781 }
782
783 DEFUN("ffi-type-alignment", Fffi_type_alignment, 1, 1, 0, /*
784 Return TYPE alignment.
785 */
786       (type))
787 {
788         return make_int(ffi_type_align(type));
789 }
790
791 #define EFFI_ALIGN_OFF(off, a) (((off) + ((a)-1)) & ~((a)-1))
792
793 DEFUN("ffi-slot-offset", Fffi_slot_offset, 2, 2, 0, /*
794 Return the offset of SLOT in TYPE.
795 SLOT can be either a valid (named) slot in TYPE or `nil'.
796 If SLOT is `nil' return the size of the struct.
797 */
798       (type, slot))
799 {
800         Lisp_Object slots;
801         size_t retoff = 0;
802
803         type = ffi_canonicalise_type(type);
804         if (!CONSP(type)) {
805 #ifdef SXEMACS
806                 error("Not struct or union");
807 #else
808                 Fsignal(Qwrong_type_argument,
809                         list2(Qstringp, build_string("Not struct or union")));
810 #endif  /* SXEMACS */
811         }
812
813         slots = Fcdr(XCDR(type));
814         CHECK_CONS(slots);
815         while (!NILP(slots)) {
816                 Lisp_Object tmp_slot = Fcar(Fcdr(XCAR(slots)));
817
818                 retoff = EFFI_ALIGN_OFF(retoff, ffi_type_align(tmp_slot));
819                 if (EQ(XCAR(XCAR(slots)), slot)) {
820                         /* SLOT found */
821                         /* TODO: add support for :offset keyword in SLOT */
822                         break;
823                         /* NOT REACHED */
824                 }
825                 retoff += XINT(Fffi_size_of_type(tmp_slot));
826
827                 slots = XCDR(slots);
828         }
829         if (NILP(slots) && !NILP(slot)) {
830 #ifdef SXEMACS
831                 signal_simple_error("FFI: Slot not found", slot);
832 #else
833                 signal_error(Qinternal_error, "FFI: Slot not found", slot);
834 #endif  /* SXEMACS */
835         }
836         return make_int(retoff);
837 }
838
839 /*
840  * TYPE must be already canonicalised
841  */
842 static Lisp_Object
843 ffi_fetch_foreign(void *ptr, Lisp_Object type)
844 {
845 /* this function canNOT GC */
846         Lisp_Object retval = Qnone;
847
848         if (EQ(type, Qchar))
849                 retval = make_char(*(char*)ptr);
850         else if (EQ(type, Qunsigned_char))
851                 retval = make_char(*(char unsigned*)ptr);
852         else if (EQ(type, Qbyte))
853                 retval = make_int(*(char*)ptr);
854         else if (EQ(type, Qunsigned_byte))
855                 retval = make_int(*(unsigned char*)ptr);
856         else if (EQ(type, Qshort))
857                 retval = make_int(*(short*)ptr);
858         else if (EQ(type, Qunsigned_short))
859                 retval = make_int(*(unsigned short*)ptr);
860         else if (EQ(type, Qint))
861                 retval = make_int(*(int*)ptr);
862         else if (EQ(type, Qunsigned_int))
863                 retval = make_int(*(unsigned int*)ptr);
864         else if (EQ(type, Qlong))
865                 retval = make_int(*(long*)ptr);
866         else if (EQ(type, Qunsigned_long))
867                 retval = make_int(*(unsigned long*)ptr);
868         else if (EQ(type, Qfloat))
869                 retval = make_float(*(float*)ptr);
870         else if (EQ(type, Qdouble))
871                 retval = make_float(*(double*)ptr);
872         else if (EQ(type, Qc_string)) {
873                 retval = build_ext_string((char*)ptr, Qbinary);
874         } else if (EQ(type, Qvoid)) {
875                 retval = Qnil;
876         } else if (FFI_POINTERP(type)) {
877                 retval = Fmake_ffi_object(type, Qnil);
878                 XEFFIO(retval)->fop.ptr = *(void**)ptr;
879         } else if (CONSP(type) && EQ(XCAR(type), Qfunction)) {
880                 retval = Fmake_ffi_object(type, Qnil);
881                 XEFFIO(retval)->fop.fun = (void*)ptr;
882                 XEFFIO(retval)->fotype = EFFI_FOT_FUNC;
883         }
884
885         return retval;
886 }
887
888 DEFUN("ffi-fetch", Fffi_fetch, 3, 3, 0, /*
889 Fetch value from the foreign object FO from OFFSET position.
890 TYPE specifies value for data to be fetched.
891 */
892       (fo, offset, type))
893 {
894         Lisp_Object origtype = type;
895         Lisp_Object retval = Qnil;
896         Lisp_EffiObject *ffio;
897         void *ptr;
898         struct gcpro gcpro1;
899
900         CHECK_EFFIO(fo);
901         CHECK_INT(offset);
902
903         ffio = XEFFIO(fo);
904         ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
905
906         type = ffi_canonicalise_type(type);
907
908         GCPRO1(retval);
909         /* Fetch value and translate it according to translators */
910         retval = ffi_fetch_foreign(ptr, type);
911         if (EQ(retval, Qnone)) {
912                 /* Special case for c-data */
913                 if (EQ(type, Qc_data) ||
914                     (CONSP(type) && EQ(XCAR(type), Qc_data)))
915                 {
916                         size_t tlen;
917                         if (EQ(type, Qc_data)) {
918                                 tlen = ffio->storage_size - XINT(offset);
919                         } else {
920                                 CHECK_INT(XCDR(type));
921                                 tlen = XUINT(XCDR(type));
922                         }
923
924                         retval = make_ext_string(ptr, tlen, Qbinary);
925                 } else {
926 #ifdef SXEMACS
927                         signal_simple_error("Can't fetch for this type", origtype);
928 #else
929                         signal_error(Qinternal_error, "Can't fetch for this type",
930                                      origtype);
931 #endif  /* SXEMACS */
932                 }
933         }
934         retval = apply1(Findirect_function(Qffi_translate_from_foreign),
935                         list2(retval, origtype));
936
937         RETURN_UNGCPRO(retval);
938 }
939
940 DEFUN("ffi-aref", Fffi_aref, 2, 2, 0, /*
941 Return the element of FARRAY at index IDX (starting with 0).
942 */
943       (farray, idx))
944 {
945         Lisp_Object type;
946
947         CHECK_EFFIO(farray);
948         CHECK_INT(idx);
949
950         type = ffi_canonicalise_type(XEFFIO(farray)->type);
951         if (!FFI_TPTR(type)) {
952 #ifdef SXEMACS
953                 signal_simple_error("Not an array type", type);
954 #else
955                 signal_error(Qinternal_error, "Not an array type", type);
956 #endif  /* SXEMACS */
957         }
958         if (EQ(type, Qc_string))
959                 type = Qchar;
960         else
961                 type = Fcar(XCDR(type));
962
963         return Fffi_fetch(farray,
964                           make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
965                           type);
966 }
967
968 DEFUN("ffi-store", Fffi_store, 4, 4, 0, /*
969 For foreign object FO at specified OFFSET store data.
970 Type of data is specified by VAL-TYPE and data itself specified in VAL.
971
972 VAL-TYPE can be either a basic FFI type or an FFI pointer.
973 If VAL-TYPE is a basic FFI type, then VAL can be an
974 ordinary, but suitable Emacs lisp object.
975 If VAL-TYPE is an FFI pointer then VAL _must_ be an FFI
976 object of the underlying type pointed to.
977 */
978       (fo, offset, val_type, val))
979 {
980         Lisp_Object origtype = val_type;
981         Lisp_EffiObject *ffio;
982         void *ptr;
983
984         CHECK_EFFIO(fo);
985         CHECK_INT(offset);
986
987         ffio = XEFFIO(fo);
988         ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
989
990         val_type = ffi_canonicalise_type(val_type);
991
992         /* Translate value */
993         val = apply1(Findirect_function(Qffi_translate_to_foreign),
994                      list2(val, origtype));
995
996         if (EQ(val_type, Qchar) || EQ(val_type, Qunsigned_char)) {
997                 if (!CHARP(val)) {
998                         SIGNAL_ERROR(Qwrong_type_argument,
999                                      list2(Qcharacterp, val));
1000                 }
1001                 *(char*)ptr = XCHAR(val);
1002         } else if (EQ(val_type, Qbyte) || EQ(val_type, Qunsigned_byte)) {
1003                 if (!INTP(val)) {
1004                         SIGNAL_ERROR(Qwrong_type_argument,
1005                                      list2(Qintegerp, val));
1006                 }
1007                 *(char*)ptr = XINT(val);
1008         } else if (EQ(val_type, Qshort) || EQ(val_type, Qunsigned_short)) {
1009                 if (!INTP(val)) {
1010                         SIGNAL_ERROR(Qwrong_type_argument,
1011                                      list2(Qintegerp, val));
1012                 }
1013                 *(short*)ptr = (short)XINT(val);
1014         } else if (EQ(val_type, Qint) || EQ(val_type, Qunsigned_int)) {
1015                 if (INTP(val)) {
1016                         *(int*)ptr = XINT(val);
1017                 } else if (FLOATP(val)) {
1018                         fpfloat tmp = XFLOATINT(val);
1019                         *(int*)ptr = (int)tmp;
1020                 } else {
1021                         SIGNAL_ERROR(Qwrong_type_argument,
1022                                      list2(Qfloatp, val));
1023                 }
1024         } else if (EQ(val_type, Qlong) || EQ(val_type, Qunsigned_long)) {
1025                 if (INTP(val)) {
1026                         *(long*)ptr = (long)XINT(val);
1027                 } else if (FLOATP(val)) {
1028                         fpfloat tmp = XFLOATINT(val);
1029                         *(long*)ptr = (long int)tmp;
1030                 } else {
1031                         SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1032                 }
1033         } else if (EQ(val_type, Qfloat)) {
1034                 if (!FLOATP(val))
1035                         SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1036                 *(float*)ptr = XFLOATINT(val);
1037         } else if (EQ(val_type, Qdouble)) {
1038                 if (!FLOATP(val))
1039                         SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1040                 *(double*)ptr = XFLOAT_DATA(val);
1041         } else if (EQ(val_type, Qc_string)) {
1042                 char *tmp = NULL;
1043                 int tmplen;
1044                 if (!STRINGP(val))
1045                         SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1046 #if defined(MULE)
1047                 TO_EXTERNAL_FORMAT(LISP_STRING, val,
1048                                    ALLOCA, (tmp, tmplen), Qnil);
1049                 if ( tmp != NULL ) {
1050                              memcpy((char*)ptr, tmp, tmplen + 1);
1051                 }
1052 #else
1053                 memcpy((char*)ptr,
1054                        (const char *)XSTRING_DATA(val),
1055                        XSTRING_LENGTH(val) + 1);
1056 #endif
1057         } else if (EQ(val_type, Qc_data) ||
1058                    (CONSP(val_type) &&
1059                     EQ(XCAR(val_type), Qc_data) && INTP(XCDR(val_type)))) {
1060                 char *val_ext = NULL;
1061                 unsigned int val_ext_len;
1062                 if (!STRINGP(val))
1063                         SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1064
1065                 TO_EXTERNAL_FORMAT(LISP_STRING, val, ALLOCA,
1066                                    (val_ext, val_ext_len), Qbinary);
1067                 if (val_ext == NULL ||
1068                     (CONSP(val_type) && (val_ext_len > XINT(XCDR(val_type))))) {
1069 #ifdef SXEMACS
1070                         error("storage size too small");
1071 #else
1072                         Fsignal(Qrange_error,
1073                                 list2(Qstringp,
1074                                       build_string("storage size too small")));
1075 #endif  /* SXEMACS */
1076                 } else {
1077                         memcpy((char*)ptr, (const char *)val_ext, val_ext_len);
1078                 }
1079         } else if (FFI_POINTERP(val_type)) {
1080                 if (!EFFIOP(val)) {
1081 #ifdef SXEMACS
1082                         signal_simple_error("FFI: Value not of pointer type", \
1083                                             list2(origtype, val));
1084 #else
1085                         Fsignal(Qwrong_type_argument,
1086                                 list2(Qstringp, build_string("type")));
1087 #endif  /* SXEMACS */
1088                 }
1089                 *(void**)ptr = (void*)XEFFIO(val)->fop.ptr;
1090         } else if (CONSP(val_type) && EQ(XCAR(val_type), Qstruct)) {
1091                 if (!EFFIOP(val)) {
1092 #ifdef SXEMACS
1093                         signal_simple_error("FFI: Value not FFI object", \
1094                                             list2(origtype, val));
1095 #else
1096                         Fsignal(Qwrong_type_argument,
1097                                 list2(Qstringp, build_string("type")));
1098 #endif  /* SXEMACS */
1099                 }
1100                 memcpy((char*)ptr, (const char *)XEFFIO(val)->fop.ptr, \
1101                        XINT(Fffi_size_of_type(val_type)));
1102         } else {
1103 #ifdef SXEMACS
1104                 signal_simple_error("FFI: Non basic or pointer type", origtype);
1105 #else
1106                 Fsignal(Qinternal_error,
1107                         list2(Qstringp,
1108                               build_string("non basic or pointer type")));
1109 #endif  /* SXEMACS */
1110         }
1111
1112         return val;
1113 }
1114
1115 DEFUN("ffi-aset", Fffi_aset, 3, 3, 0, /*
1116 Store the element VALUE in FARRAY at index IDX (starting with 0).
1117 */
1118       (farray, idx, value))
1119 {
1120         Lisp_Object type;
1121
1122         CHECK_EFFIO(farray);
1123         CHECK_INT(idx);
1124
1125         type = ffi_canonicalise_type(XEFFIO(farray)->type);
1126         if (!FFI_TPTR(type)) {
1127 #ifdef SXEMACS
1128                 signal_simple_error("Not an array type", type);
1129 #else
1130                 signal_error(Qinternal_error, "Not an array type", type);
1131 #endif  /* SXEMACS */
1132         }
1133         if (EQ(type, Qc_string))
1134                 type = Qchar;
1135         else
1136                 type = Fcar(XCDR(type));
1137
1138         return Fffi_store(farray,
1139                           make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
1140                           type, value);
1141 }
1142
1143 DEFUN("ffi-address-of", Fffi_address_of, 1, 1, 0, /*
1144 Return the FFI object that stores the address of given FFI object FO.
1145
1146 This is the equivalent of the `&' operator in C.
1147 */
1148       (fo))
1149 {
1150         Lisp_Object newfo = Qnil;
1151         Lisp_EffiObject *ffio, *newffio;
1152         struct gcpro gcpro1;
1153
1154         CHECK_EFFIO(fo);
1155         ffio = XEFFIO(fo);
1156
1157         GCPRO1(newfo);
1158         newfo = Fmake_ffi_object(Qpointer, Qnil);
1159         newffio = XEFFIO(newfo);
1160
1161         newffio->fotype = EFFI_FOT_BIND;
1162         if (FFI_TPTR(ffio->type))
1163                 newffio->fop.ptr = (void*)&ffio->fop.ptr;
1164         else
1165                 newffio->fop.ptr = ffio->fop.ptr;
1166
1167         RETURN_UNGCPRO(newfo);
1168 }
1169
1170 DEFUN("ffi-lisp-object-to-pointer", Fffi_lisp_object_to_pointer, 1, 1, 0, /*
1171 Convert lisp object to FFI pointer.
1172 */
1173       (obj))
1174 {
1175         Lisp_Object newfo = Qnil;
1176         Lisp_EffiObject *newffio;
1177         struct gcpro gcpro1;
1178
1179         GCPRO1(obj);
1180
1181         newfo = Fmake_ffi_object(Qpointer, Qnil);
1182         newffio = XEFFIO(newfo);
1183         newffio->fotype = EFFI_FOT_BIND;
1184         newffio->fop.ptr = (void*)obj;
1185
1186         /* Hold a reference to OBJ in NEWFO's plist */
1187         Fput(newfo, intern("lisp-object"), obj);
1188
1189         RETURN_UNGCPRO(newfo);
1190 }
1191
1192 DEFUN("ffi-pointer-to-lisp-object", Fffi_pointer_to_lisp_object, 1, 1, 0, /*
1193 Convert FFI pointer to lisp object.
1194 */
1195       (ptr))
1196 {
1197         CHECK_EFFIO(ptr);
1198         return (Lisp_Object)XEFFIO(ptr)->fop.ptr;
1199 }
1200
1201 DEFUN("ffi-plist", Fffi_plist, 1, 1, 0, /*
1202 Return properties list for FFI object FO.
1203 */
1204       (fo))
1205 {
1206         CHECK_EFFIO(fo);
1207         return (XEFFIO(fo)->plist);
1208 }
1209
1210 #ifdef HAVE_LIBFFI
1211
1212 static int lf_cindex = 0;
1213
1214 /*
1215  * XXX
1216  *  This will work in most cases.
1217  *  However it might not work for large structures,
1218  *  In general we should allocate these spaces dynamically
1219  */
1220 #define MAX_TYPES_VALUES 1024
1221 /* ex_ffitypes_dummies used for structure types */
1222 static ffi_type ex_ffitypes_dummies[MAX_TYPES_VALUES + 1];
1223 static ffi_type *ex_ffitypes[MAX_TYPES_VALUES + 1];
1224 static void *ex_values[MAX_TYPES_VALUES + 1];
1225
1226 #if SIZEOF_LONG == 4
1227 #  define effi_type_ulong ffi_type_uint32
1228 #  define effi_type_slong ffi_type_sint32
1229 #elif SIZEOF_LONG == 8
1230 #  define effi_type_ulong ffi_type_uint64
1231 #  define effi_type_slong ffi_type_sint64
1232 #endif
1233
1234 static void
1235 extffi_setup_argument(Lisp_Object type, ffi_type **ft)
1236 {
1237         type = ffi_canonicalise_type(type);
1238         if (EQ(type, Qchar) || EQ(type, Qbyte))
1239                 *ft = &ffi_type_schar;
1240         else if (EQ(type, Qunsigned_char) || EQ(type, Qunsigned_byte))
1241                 *ft = &ffi_type_uchar;
1242         else if (EQ(type, Qshort))
1243                 *ft = &ffi_type_sshort;
1244         else if (EQ(type, Qunsigned_short))
1245                 *ft = &ffi_type_ushort;
1246         else if (EQ(type, Qint))
1247                 *ft = &ffi_type_sint;
1248         else if (EQ(type, Qunsigned_int))
1249                 *ft = &ffi_type_uint;
1250         else if (EQ(type, Qunsigned_long))
1251                 *ft = &effi_type_ulong;
1252         else if (EQ(type, Qlong))
1253                 *ft = &effi_type_slong;
1254         else if (EQ(type, Qfloat))
1255                 *ft = &ffi_type_float;
1256         else if (EQ(type, Qdouble))
1257                 *ft = &ffi_type_double;
1258         else if (EQ(type, Qvoid))
1259                 *ft = &ffi_type_void;
1260         else if (FFI_TPTR(type))
1261                 *ft = &ffi_type_pointer;
1262         else if (CONSP(type) && EQ(XCAR(type), Qstruct)) {
1263                 Lisp_Object slots = Fcdr(XCDR(type));
1264                 ffi_type **ntypes;
1265                 int nt_size, i;
1266
1267                 CHECK_CONS(slots);
1268
1269                 nt_size = XINT(Flength(slots)) + 1;
1270                 if (nt_size + lf_cindex > MAX_TYPES_VALUES) {
1271                         lf_cindex = 0;  /* reset cindex */
1272 #ifdef SXEMACS
1273                         error("cindex overflow");
1274 #else
1275                         Fsignal(Qoverflow_error,
1276                                 list2(Qstringp,
1277                                       build_string("cindex overflow")));
1278 #endif  /* SXEMACS */
1279                 }
1280                 ntypes = &ex_ffitypes[lf_cindex];
1281                 *ft = &ex_ffitypes_dummies[lf_cindex];
1282
1283                 /* Update lf_cindex in case TYPE struct contains other
1284                  * structures */
1285                 lf_cindex += nt_size;
1286
1287                 (*ft)->type = FFI_TYPE_STRUCT;
1288                 (*ft)->alignment = ffi_type_align(type);
1289                 (*ft)->elements = ntypes;
1290
1291                 for (i = 0; (i < nt_size) && !NILP(slots); slots = XCDR(slots), i++)
1292                         extffi_setup_argument(Fcar(Fcdr(XCAR(slots))), &ntypes[i]);
1293                 ntypes[i] = NULL;
1294         } else {
1295 #ifdef SXEMACS
1296                 signal_simple_error("Can't setup argument for type", type);
1297 #else
1298                 signal_error(Qinternal_error,
1299                              "Can't setup argument for type", type);
1300 #endif  /* SXEMACS */
1301         }
1302 }
1303
1304 static int
1305 ffi_call_using_libffi(Lisp_Object fo_fun, Lisp_Object ret_fo,
1306                       int in_nargs, Lisp_Object *in_args)
1307 {
1308         Lisp_EffiObject *ffio;
1309         Lisp_Object fft;
1310         ffi_cif cif;
1311         ffi_type *rtype;
1312         void *rvalue;
1313         int i;
1314
1315         lf_cindex = in_nargs;           /* reserve */
1316         for (i = 0; i < in_nargs; i++) {
1317                 ffio = XEFFIO(in_args[i]);
1318                 fft = Fffi_canonicalise_type(ffio->type);
1319                 extffi_setup_argument(fft, &ex_ffitypes[i]);
1320                 if (FFI_TPTR(fft))
1321                         ex_values[i] = &ffio->fop.ptr;
1322                 else
1323                         ex_values[i] = ffio->fop.ptr;
1324         }
1325
1326         ffio = XEFFIO(ret_fo);
1327         fft = Fffi_canonicalise_type(ffio->type);
1328         extffi_setup_argument(fft, &rtype);
1329         if (FFI_TPTR(fft))
1330                 rvalue = &ffio->fop.ptr;
1331         else
1332                 rvalue = ffio->fop.ptr;
1333
1334         if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, in_nargs,
1335                          rtype, ex_ffitypes) == FFI_OK)
1336         {
1337                 stop_async_timeouts();
1338                 ffi_call(&cif, (void(*)(void))XEFFIO(fo_fun)->fop.fun, rvalue,
1339                          ex_values);
1340                 start_async_timeouts();
1341                 return 0;
1342         }
1343
1344         /* FAILURE */
1345         return 1;
1346 }
1347 #endif  /* HAVE_LIBFFI */
1348
1349 DEFUN("ffi-call-function", Fffi_call_function, 1, MANY, 0, /*
1350 Call a function referred to by FO with arguments ARGS, maybe
1351 return a foreign object with the result or nil if there is
1352 none.
1353
1354 Arguments are: FO &rest FO-ARGS
1355
1356 FO should be a foreign binding initiated by `ffi-defun', and
1357 ARGS should be foreign data objects or pointers to these.
1358 */
1359       (int nargs, Lisp_Object * args))
1360 {
1361         Lisp_Object faf = Qnil, retfo = Qnil;
1362         Lisp_EffiObject *ffio;
1363         int ret = -1;
1364         struct gcpro gcpro1, gcpro2;
1365
1366         GCPRO2(faf, retfo);
1367
1368         faf =  args[0];
1369         ffio = XEFFIO(faf);
1370         retfo = Fmake_ffi_object(XCAR(XCDR(ffio->type)), Qnil);
1371
1372 #ifdef HAVE_LIBFFI
1373         ret = ffi_call_using_libffi(args[0], retfo, nargs-1, &args[1]);
1374 #endif  /* HAVE_LIBFFI */
1375
1376         RETURN_UNGCPRO(ret == 0 ? retfo : Qnil);
1377 }
1378
1379 #ifdef EF_USE_ASYNEQ
1380 /* handler for asynchronously calling ffi code */
1381 Lisp_Object Qffi_jobp;
1382 #define EFFI_DEBUG_JOB(args...)
1383 static Lisp_Object
1384 exec_sentinel_unwind(Lisp_Object SXE_UNUSED(datum))
1385 {
1386         return Qnil;
1387 }
1388
1389 static inline void
1390 exec_sentinel(void *job, ffi_job_t ffij)
1391         __attribute__((always_inline));
1392 static inline void
1393 exec_sentinel(void *job, ffi_job_t ffij)
1394 {
1395         /* This function can GC */
1396         /* called from main thread */
1397         int speccount = specpdl_depth(), nargs = ffij->sntnl_nargs, i;
1398         Lisp_Object funcell[nargs+2];
1399         struct gcpro gcpro1;
1400
1401         funcell[0] = ffij->sntnl;
1402         funcell[1] = (Lisp_Object)job;
1403         for (i = 0; i < nargs; i++) {
1404                 funcell[2+i] = ffij->sntnl_args[i];
1405         }
1406         GCPROn(funcell, nargs+2);
1407
1408         record_unwind_protect(exec_sentinel_unwind, Qnil);
1409         /* call the funcell */
1410         Ffuncall(nargs+2, funcell);
1411         /* reset to previous state */
1412         restore_match_data();
1413         UNGCPRO;
1414         unbind_to(speccount, Qnil);
1415         return;
1416 }
1417
1418 static inline ffi_job_t
1419 allocate_ffi_job(void)
1420 {
1421         ffi_job_t ffij = xnew(struct ffi_job_s);
1422         EFFI_DEBUG_JOB("allocated: 0x%lx\n", (long unsigned int)ffij);
1423         return ffij;
1424 }
1425
1426 static inline ffi_job_t
1427 make_ffi_job(Lisp_Object fof, int fof_nargs, Lisp_Object *fof_args,
1428              Lisp_Object sntnl, int sntnl_nargs, Lisp_Object *sntnl_args)
1429 {
1430 /* exec'd in the main thread */
1431         ffi_job_t ffij = allocate_ffi_job();
1432         int i;
1433
1434         SXE_MUTEX_INIT(&ffij->mtx);
1435         ffij->fof = fof;
1436         if (fof_nargs > 0) {
1437                 ffij->fof_nargs = fof_nargs;
1438                 ffij->fof_args = xnew_array(Lisp_Object, fof_nargs);
1439                 for (i = 0; i < fof_nargs; i++) {
1440                         ffij->fof_args[i] = fof_args[i];
1441                 }
1442         } else {
1443                 ffij->fof_nargs = 0;
1444                 ffij->fof_args = NULL;
1445         }
1446
1447         ffij->sntnl = sntnl;
1448         if (sntnl_nargs > 0) {
1449                 ffij->sntnl_nargs = sntnl_nargs;
1450                 ffij->sntnl_args = xnew_array(Lisp_Object, sntnl_nargs);
1451                 for (i = 0; i < sntnl_nargs; i++) {
1452                         ffij->sntnl_args[i] = sntnl_args[i];
1453                 }
1454         } else {
1455                 ffij->sntnl_nargs = 0;
1456                 ffij->sntnl_args = NULL;
1457         }
1458
1459         ffij->result = Qnil;
1460         ffij->retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil);
1461         return ffij;
1462 }
1463
1464 static void
1465 mark_ffi_job(worker_job_t job)
1466 {
1467         ffi_job_t ffij = ffi_job(job);
1468         int i;
1469
1470         if (!ffij)
1471                 return;
1472
1473         SXE_MUTEX_LOCK(&ffij->mtx);
1474         mark_object(ffij->fof);
1475         for (i = 0; i < ffij->fof_nargs; i++) {
1476                 mark_object(ffij->fof_args[i]);
1477         }
1478         mark_object(ffij->sntnl);
1479         for (i = 0; i < ffij->sntnl_nargs; i++) {
1480                 mark_object(ffij->sntnl_args[i]);
1481         }
1482         mark_object(ffij->retfo);
1483         mark_object(ffij->result);
1484         SXE_MUTEX_UNLOCK(&ffij->mtx);
1485         return;
1486 }
1487
1488 static void
1489 print_ffi_job(worker_job_t job, Lisp_Object pcf)
1490 {
1491         ffi_job_t ffij = ffi_job(job);
1492
1493         SXE_MUTEX_LOCK(&ffij->mtx);
1494         WRITE_FMT_STRING(pcf, " carrying  #<ffi-job 0x%lx>",
1495                          (long unsigned int)ffij);
1496         SXE_MUTEX_UNLOCK(&ffij->mtx);
1497         return;
1498 }
1499
1500 static inline void
1501 finish_ffi_job_data(ffi_job_t ffij)
1502 {
1503         SXE_MUTEX_LOCK(&ffij->mtx);
1504         xfree(ffij->fof_args);
1505         xfree(ffij->sntnl_args);
1506         SXE_MUTEX_UNLOCK(&ffij->mtx);
1507         SXE_MUTEX_FINI(&ffij->mtx);
1508
1509         EFFI_DEBUG_JOB("finished: 0x%lx\n", (long unsigned int)ffij);
1510         xfree(ffij);
1511 }
1512
1513 static void
1514 finish_ffi_job(worker_job_t job)
1515 {
1516         ffi_job_t ffij;
1517
1518         lock_worker_job(job);
1519         ffij = ffi_job(job);
1520
1521         if (ffij) {
1522                 finish_ffi_job_data(ffij);
1523         }
1524         worker_job_data(job) = NULL;
1525         unlock_worker_job(job);
1526         return;
1527 }
1528
1529 static void
1530 ffi_job_handle(worker_job_t job)
1531 {
1532         /* thread-safe */
1533         /* usually called from aux threads */
1534         ffi_job_t ffij;
1535         Lisp_Object fof = Qnil, retfo = Qnil, *args = NULL;
1536         int nargs, ret = -1;
1537
1538         lock_worker_job(job);
1539         ffij = ffi_job(job);
1540         unlock_worker_job(job);
1541         SXE_MUTEX_LOCK(&ffij->mtx);
1542         fof = ffij->fof;
1543         nargs = ffij->fof_nargs;
1544         args = ffij->fof_args;
1545         SXE_MUTEX_UNLOCK(&ffij->mtx);
1546
1547         /* can't ... Fmake_ffi_object is not mt-safe */
1548         /* retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil); */
1549         retfo = ffij->retfo;
1550
1551 #ifdef HAVE_LIBFFI
1552         ret = ffi_call_using_libffi(fof, retfo, nargs, args);
1553 #endif  /* HAVE_LIBFFI */
1554         if (ret == 0) {
1555                 SXE_MUTEX_LOCK(&ffij->mtx);
1556                 ffij->result = retfo;
1557                 SXE_MUTEX_UNLOCK(&ffij->mtx);
1558         }
1559
1560         EFFI_DEBUG_JOB("job 0x%lx succeeded\n", (long unsigned int)ffij);
1561         return;
1562 }
1563
1564 static void
1565 ffi_job_finished(worker_job_t job)
1566 {
1567         if (NILP(ffi_job_sentinel(job) /* sentinel */)) {
1568                 return;
1569         }
1570         /* called from main thread */
1571         exec_sentinel(job, ffi_job(job));
1572         return;
1573 }
1574
1575 static struct work_handler_s ffi_job_handler = {
1576         mark_ffi_job, print_ffi_job, finish_ffi_job,
1577         ffi_job_handle, NULL, ffi_job_finished
1578 };
1579
1580 static Lisp_Object
1581 make_ffi_asyneq_job(ffi_job_t ffij)
1582 {
1583         /* create a job digestible by the asyneq */
1584         Lisp_Object job = Qnil;
1585         struct gcpro gcpro1;
1586
1587         GCPRO1(job);
1588         job = wrap_object(make_worker_job(&ffi_job_handler));
1589         XWORKER_JOB_DATA(job) = ffij;
1590         /* the scratch buffer thingie */
1591         UNGCPRO;
1592         return job;
1593 }
1594
1595 DEFUN("ffi-call-function&", Fffi_call_functionX, 1, MANY, 0, /*
1596 Call a function referred to by FO with arguments ARGS asynchronously,
1597 return a job object.
1598
1599 Arguments are: FO &rest FO-ARGS &aux SENTINEL &rest SENTINEL-ARGS
1600
1601 FO should be a foreign binding initiated by `ffi-defun'.
1602 FO-ARGS should be exactly as many foreign data objects as FO needs.
1603 SENTINEL is a lisp sentinel function called when the job finished,
1604   the function should take at least one argument JOB, further arguments
1605   may be specified by passing further SENTINEL-ARGS.
1606 */
1607       (int nargs, Lisp_Object *args))
1608 {
1609         Lisp_Object job = Qnil;
1610         Lisp_Object sntnl, fof, *sntnl_args, *fof_args;
1611         int sntnl_nargs, fof_nargs;
1612         ffi_job_t ffij;
1613         struct gcpro gcpro1, gcpro2;
1614
1615         CHECK_EFFIO(args[0]);
1616         GCPRO1n(job, args, nargs);
1617
1618         fof = args[0];
1619         /* determine how many args belong to the fof */
1620         fof_nargs = XINT(Flength(XCDR(XEFFIO(fof)->type)))-1;
1621         fof_args = &args[1];
1622
1623         if ((sntnl_nargs = nargs - fof_nargs - 2) >= 0) {
1624                 sntnl = args[fof_nargs+1];
1625                 sntnl_args = &args[fof_nargs+2];
1626         } else {
1627                 sntnl = Qnil;
1628                 sntnl_args = NULL;
1629         }
1630
1631         /* create the job data object */
1632         ffij = make_ffi_job(fof, fof_nargs, fof_args,
1633                             sntnl, sntnl_nargs, sntnl_args);
1634         /* now prepare the job to dispatch */
1635         job = make_ffi_asyneq_job(ffij);
1636         /* ... and dispatch it, change its state to queued */
1637         XWORKER_JOB_STATE(job) = WORKER_JOB_QUEUED;
1638         eq_enqueue(delegate_eq, job);
1639         /* brag about new jobs in the queue */
1640         eq_queue_trigger_all(delegate_eq);
1641
1642         UNGCPRO;
1643         return job;
1644 }
1645 #endif  /* EF_USE_ASYNEQ */
1646
1647 extern struct device *decode_x_device(Lisp_Object device);
1648
1649 DEFUN("x-device-display", Fx_device_display, 0, 1, 0,   /*
1650 Return DEVICE display as FFI object.
1651 */
1652       (device))
1653 {
1654 #if HAVE_X_WINDOWS
1655         Lisp_Object fo;
1656
1657         fo = Fmake_ffi_object(Qpointer, Qnil);
1658         XEFFIO(fo)->fotype = EFFI_FOT_BIND;
1659         XEFFIO(fo)->fop.ptr = (void*)DEVICE_X_DISPLAY(decode_x_device(device));
1660         return fo;
1661 #else
1662         return Qnil;
1663 #endif
1664 }
1665
1666 /* Callbacks */
1667 #define FFI_CC_CDECL 0
1668
1669 void* ffi_make_callback_x86(Lisp_Object data, int cc_type);
1670
1671 #if defined __i386__
1672 static void
1673 ffi_callback_call_x86(Lisp_Object cbk_info, char *arg_buffer)
1674 {
1675         Lisp_Object fun, alist = Qnil, retlo, foret;
1676         Lisp_Object rtype, argtypes;
1677         struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1678         void *ptr;
1679
1680         fun = Fcar(cbk_info);
1681         rtype = Fcar(Fcdr(cbk_info));
1682         argtypes = Fcar(Fcdr(Fcdr(cbk_info)));
1683
1684         CHECK_LIST(argtypes);
1685
1686         arg_buffer += 4;                /* Skip return address */
1687         while (!NILP(argtypes)) {
1688                 Lisp_Object result, ctype;
1689                 int size;
1690
1691                 ctype = ffi_canonicalise_type(XCAR(argtypes));
1692                 size = XINT(Fffi_size_of_type(ctype));
1693                 if (EQ(ctype, Qc_string)) {
1694                         char *aptr = *(char**)arg_buffer;
1695                         if (aptr)
1696                                 result = ffi_fetch_foreign(aptr, ctype);
1697                         else
1698                                 result = Qnil;
1699                 } else
1700                         result = ffi_fetch_foreign(arg_buffer, ctype);
1701                 /* Apply translators and put the result into alist */
1702                 result = apply1(Findirect_function(Qffi_translate_from_foreign),
1703                                 list2(result, XCAR(argtypes)));
1704                 alist = Fcons(result, alist);
1705                 {
1706                         int mask = 3;
1707                         int sp = (size + mask) & ~mask;
1708                         arg_buffer += (sp);
1709                 }
1710                 argtypes = XCDR(argtypes);
1711         }
1712         alist = Fnreverse(alist);
1713
1714         /* Special case, we have no return value */
1715         if (EQ(rtype, Qvoid)) {
1716                 GCPRO3(fun, alist, rtype);
1717                 apply1(fun, alist);
1718                 UNGCPRO;
1719                 return;
1720         }
1721
1722         GCPRO5(fun, alist, rtype, retlo, foret);
1723         retlo = apply1(fun, alist);
1724         foret = Fmake_ffi_object(rtype, Qnil);
1725         Fffi_store(foret, make_int(0), rtype, retlo);
1726         ptr = (void*)XEFFIO(foret)->fop.ptr;
1727         if (EQ(rtype, Qdouble)) {
1728                 UNGCPRO;
1729                 {
1730                 asm volatile ("fldl (%0)" :: "a" (ptr));
1731                 }
1732                 return;
1733         } else if (EQ(rtype, Qfloat)) {
1734                 UNGCPRO;
1735                 {
1736                 asm volatile ("flds (%0)" :: "a" (ptr));
1737                 }
1738                 return;
1739         } else {
1740                 int iv;
1741
1742                 if (EQ(rtype, Qbyte) || EQ(rtype, Qchar))
1743                         iv = *(char*)ptr;
1744                 else if (EQ(rtype, Qunsigned_byte) || EQ(rtype, Qunsigned_char))
1745                         iv = *(char unsigned*)ptr;
1746                 else if (EQ(rtype, Qshort))
1747                         iv = *(short*)ptr;
1748                 else if (EQ(rtype, Qunsigned_short))
1749                         iv = *(unsigned short*)ptr;
1750                 else
1751                         iv = *(int*)ptr;
1752                 UNGCPRO;
1753                 {
1754                         asm volatile ("movl %0,%%eax;" :: "r" (iv) : "%eax");
1755                 }
1756                 return;
1757         }
1758 }
1759
1760 void*
1761 ffi_make_callback_x86(Lisp_Object data, int cc_type)
1762 {
1763         /*
1764          *      push    %esp                            54
1765          *      pushl   <data>                          68 <addr32>
1766          *      call    ffi_callback_call_x86           E8 <disp32>
1767          *      pop     %ecx                            59
1768          *      pop     %ecx                            59
1769          *      ret                                     c3
1770          *      nop                                     90
1771          *      nop                                     90
1772          */
1773
1774         char *buf = xmalloc(sizeof(char)*16);
1775         *(char*) (buf+0)  = 0x54;
1776         *(char*) (buf+1)  = 0x68;
1777         *(long*) (buf+2)  = (long)data;
1778         *(char*) (buf+6)  = 0xE8;
1779         *(long*) (buf+7)  = (long)ffi_callback_call_x86 - (long)(buf+11);
1780         *(char*) (buf+11) = 0x59;
1781         *(char*) (buf+12) = 0x59;
1782         if (cc_type == FFI_CC_CDECL) {
1783                 *(char*) (buf+13) = 0xc3;
1784                 *(short*)(buf+14) = 0x9090;
1785         } else {
1786                 Lisp_Object arg_types = Fcar(Fcdr(Fcdr(data)));
1787                 int byte_size = 0;
1788                 int mask = 3;
1789
1790                 CHECK_CONS(arg_types);
1791
1792                 while (!NILP(arg_types)) {
1793                         int sz = XINT(Fffi_size_of_type(XCAR(arg_types)));
1794                         byte_size += ((sz+mask)&(~mask));
1795                         arg_types = XCDR(arg_types);
1796                 }
1797
1798                 *(char*) (buf+13) = 0xc2;
1799                 *(short*)(buf+14) = (short)byte_size;
1800         }
1801
1802         return buf;
1803 }
1804 #endif  /* __i386__ */
1805
1806 DEFUN("ffi-make-callback", Fffi_make_callback, 4, 4, 0, /*
1807 Create dynamic callback and return pointer to it.
1808 */
1809       (fun, rtype, argtypes, cctype))
1810 {
1811         Lisp_Object data;
1812         Lisp_Object ptr;
1813
1814         CHECK_INT(cctype);
1815
1816         data = list3(fun, rtype, argtypes);
1817         /* Put data as property of the fun, so it(data) wont be GCed */
1818         Fput(fun, Qffi_callback, data);
1819         ptr = Fmake_ffi_object(Qpointer, Qnil);
1820 #ifdef __i386__
1821         XEFFIO(ptr)->fop.ptr = ffi_make_callback_x86(data, XINT(cctype));
1822 #else
1823 #ifdef SXEMACS
1824         error("FFI Callbacks not supported on this configuration");
1825 #else
1826         signal_ferror(Qinternal_error,
1827                       "FFI Callbacks not supported on this configuration");
1828 #endif  /* SXEMACS */
1829 #endif /* __i386__ */
1830         return ptr;
1831 }
1832
1833 void
1834 syms_of_ffi(void)
1835 {
1836         INIT_LRECORD_IMPLEMENTATION(ffiobject);
1837
1838         DEFSYMBOL(Qarray);
1839         DEFSYMBOL(Qbyte);
1840         DEFSYMBOL(Qc_data);
1841         DEFSYMBOL(Qc_string);
1842         DEFSYMBOL(Qdouble);
1843         DEFSYMBOL(Qlong);
1844         DEFSYMBOL(Qstruct);
1845         DEFSYMBOL(Qunion);
1846         DEFSYMBOL(Qunsigned_byte);
1847         DEFSYMBOL(Qunsigned_char);
1848         DEFSYMBOL(Qunsigned_int);
1849         DEFSYMBOL(Qunsigned_long);
1850         DEFSYMBOL(Qunsigned_short);
1851
1852         /* ### This is broken, the lrecord needs to be called ffi_object,
1853            and then this would be a DEFSYMBOL_MULTIWORD_PREDICATE(). Not
1854            doing it in this commit, though. */
1855         defsymbol(&Qffiobjectp, "ffi-object-p");
1856
1857         DEFSYMBOL(Qffi_translate_to_foreign);
1858         DEFSYMBOL(Qffi_translate_from_foreign);
1859
1860         DEFSYMBOL(Qffi_callback);
1861
1862         DEFSUBR(Fffi_basic_type_p);
1863         DEFSUBR(Fffi_canonicalise_type);
1864         DEFSUBR(Fffi_size_of_type);
1865         DEFSUBR(Fmake_ffi_object);
1866         DEFSUBR(Fffi_object_p);
1867         DEFSUBR(Fffi_make_pointer);
1868         DEFSUBR(Fffi_object_address);
1869         DEFSUBR(Fffi_object_canonical_type);
1870         DEFSUBR(Fffi_object_type);
1871         DEFSUBR(Fffi_object_size);
1872         DEFSUBR(Fffi_set_storage_size);
1873         DEFSUBR(Fffi_set_object_type);
1874         DEFSUBR(Fffi_fetch);
1875         DEFSUBR(Fffi_aref);
1876         DEFSUBR(Fffi_store);
1877         DEFSUBR(Fffi_aset);
1878         DEFSUBR(Fffi_address_of);
1879         DEFSUBR(Fffi_type_alignment);
1880         DEFSUBR(Fffi_slot_offset);
1881         DEFSUBR(Fffi_load_library);
1882         DEFSUBR(Fffi_bind);
1883         DEFSUBR(Fffi_dlerror);
1884         DEFSUBR(Fffi_defun);
1885         DEFSUBR(Fffi_call_function);
1886
1887         DEFSUBR(Fffi_lisp_object_to_pointer);
1888         DEFSUBR(Fffi_pointer_to_lisp_object);
1889         DEFSUBR(Fffi_plist);
1890
1891 #ifdef EF_USE_ASYNEQ
1892         DEFSUBR(Fffi_call_functionX);
1893         defsymbol(&Qffi_jobp, "ffi-job-p");
1894 #endif
1895
1896         DEFSUBR(Fx_device_display);
1897
1898         DEFSUBR(Fffi_make_callback);
1899 }
1900
1901 void
1902 reinit_vars_of_ffi(void)
1903 {
1904         staticpro_nodump(&Vffi_all_objects);
1905         Vffi_all_objects = make_weak_list(WEAK_LIST_SIMPLE);
1906 }
1907
1908 void
1909 vars_of_ffi(void)
1910 {
1911         reinit_vars_of_ffi();
1912
1913         DEFVAR_LISP("ffi-named-types", &Vffi_named_types        /*
1914 Alist of named FFI types with elements of the form (NAME . FFI-TYPE).
1915                                                  */ );
1916         Vffi_named_types = Qnil;
1917
1918         DEFVAR_LISP("ffi-loaded-libraries", &Vffi_loaded_libraries /*
1919 Alist of loaded libraries with elements of the form (LIB-NAME . FFIO).
1920                                                  */ );
1921         Vffi_loaded_libraries = Qnil;
1922
1923         DEFVAR_LISP("ffi-type-checker", &Vffi_type_checker /*
1924 Function to call when the validity of an FFI type shall be checked.
1925                                                            */ );
1926         Vffi_type_checker = intern("ffi-type-p");
1927 }