2 * effi.c --- Foreign Function Interface for SXEmacs.
4 * Copyright (C) 2004-2008 Zajcev Evgeny
6 This file is part of SXEmacs
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.
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.
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/>. */
32 # include "mule/file-coding.h"
38 #endif /* HAVE_LIBFFI */
41 # include "events/workers.h"
42 # include "events/worker-asyneq.h"
43 #endif /* EF_USE_ASYNEQ */
45 /* For `x-device-display' */
46 #include "ui/X11/console-x.h"
47 #include "ui/device.h"
49 #define EFFI_CODING Qnative
52 * Some compatibility for XEmacs
55 # define SIGNAL_ERROR signal_error
56 # define FFIBYTE Bufbyte
57 # define WRITE_C_STRING(x,y) write_c_string((x),(y))
58 # define LRECORD_DESCRIPTION lrecord_description
60 # define SIGNAL_ERROR Fsignal
61 # define FFIBYTE Ibyte
62 # define WRITE_C_STRING(x,y) write_c_string((y),(x))
63 # define LRECORD_DESCRIPTION memory_description
68 * byte, ubyte, char, uchar,
69 * short, ushort, int, uint,
72 * void, pointer, c-string
76 * (function RET-TYPE IN-TYPE .. IN-TYPE)
82 * Structures and unions types:
92 * pointer or (pointer TYPE)
96 Lisp_Object Q_byte, Q_unsigned_byte;
97 Lisp_Object Q_char, Q_unsigned_char;
98 Lisp_Object Q_short, Q_unsigned_short;
99 Lisp_Object Q_int, Q_unsigned_int;
100 Lisp_Object Q_long, Q_unsigned_long;
101 Lisp_Object Q_float, Q_double;
103 Lisp_Object Q_array, Q_pointer;
104 Lisp_Object Q_union, Q_struct;
105 Lisp_Object Q_function;
106 Lisp_Object Q_c_string, Q_c_data;
108 #define FFI_POINTERP(type) (EQ(type, Q_pointer) \
109 || (CONSP(type) && EQ(XCAR(type), Q_pointer)))
111 #define FFI_TPTR(type) (EQ(type, Q_c_string) \
112 || EQ(type, Q_c_data) \
113 || FFI_POINTERP(type) \
114 || (CONSP(type) && ((EQ(XCAR(type), Q_c_data)) \
115 || EQ(XCAR(type), Q_array))))
117 Lisp_Object Qffiobjectp;
118 Lisp_Object Qffi_translate_to_foreign;
119 Lisp_Object Qffi_translate_from_foreign;
121 /* Alist with elements in form (NAME . TYPE) */
122 Lisp_Object Vffi_loaded_libraries;
123 Lisp_Object Vffi_named_types;
125 Lisp_Object Vffi_type_checker;
127 static Lisp_Object Vffi_all_objects;
129 Lisp_Object Q_ffi_callback;
132 mark_ffiobject(Lisp_Object obj)
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);
142 print_ffiobject(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
144 /* This function can GC */
145 Lisp_EffiObject *ffio = XEFFIO(obj);
148 escapeflag = escapeflag; /* shutup compiler */
149 if (print_readably) {
151 error("printing unreadable object #<ffiobject 0x%x>",
154 signal_ferror(Qinternal_error,
155 "printing unreadable object #<ffiobject 0x%x>",
159 WRITE_C_STRING("#<ffiobject ", printcharfun);
160 /* Print FFIO type */
161 if (!NILP(ffio->type)) {
162 WRITE_C_STRING("type=", printcharfun);
163 print_internal(ffio->type, printcharfun, 1);
164 WRITE_C_STRING(" ", printcharfun);
166 snprintf(buf, 255, "size=%ld fotype=%d foptr=%p>",
167 (long)XINT(ffio->size), ffio->fotype, ffio->fop.generic);
168 WRITE_C_STRING(buf, printcharfun);
171 static const struct LRECORD_DESCRIPTION ffiobject_description[] = {
172 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, type)},
173 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, size)},
174 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, plist)},
175 {XD_INT, offsetof(Lisp_EffiObject, fotype)},
176 {XD_OPAQUE_PTR, offsetof(Lisp_EffiObject, fop)},
178 {XD_SIZE_T, offsetof(Lisp_EffiObject, storage_size)},
180 {XD_ELEMCOUNT, offsetof(Lisp_EffiObject, storage_size)},
186 ffi_getprop(Lisp_Object fo, Lisp_Object property)
188 return external_plist_get(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
192 ffi_putprop(Lisp_Object fo, Lisp_Object property, Lisp_Object value)
194 external_plist_put(&XEFFIO(fo)->plist, property, value, 0, ERROR_ME);
199 ffi_remprop(Lisp_Object fo, Lisp_Object property)
201 return external_remprop(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
206 sizeof_ffiobject(const void *header)
208 const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
209 return (sizeof(Lisp_EffiObject) + effio->storage_size);
213 sizeof_ffiobject(const void *header)
215 const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
216 return (sizeof(Lisp_EffiObject) + effio->storage_size);
220 /* Define ffiobject implementation */
221 const struct lrecord_implementation lrecord_ffiobject = {
223 .marker = mark_ffiobject,
224 .printer = print_ffiobject,
228 .description = ffiobject_description,
229 .getprop = ffi_getprop,
230 .putprop = ffi_putprop,
231 .remprop = ffi_remprop,
234 .size_in_bytes_method = sizeof_ffiobject,
235 .lrecord_type_index = lrecord_type_ffiobject,
240 /** alignment in union and structures **/
244 * - An entire structure or union is aligned on the same boundary as
245 * its most strictly aligned member.
247 * - Each member is assigned to the lowest available offset with the
248 * appropriate alignment. This may require /internal padding/,
249 * depending on the previous member.
251 * - A structure's size is increased, if necessary, to make it a
252 * multiple of the alignment. This may require /tail padding/,
253 * depending on the last member.
258 * char c; .-------2+---1+---0.
259 * short s; | s |pad | c |
260 * } `--------+----+----'
262 * Internal and Tail padding:
264 * struct { .------------1+---0.
265 * char c; | pad | c |
266 * double d; |-------------+---4|
268 * } |-----------------8|
270 * |------14+-------12|
272 * `--------+---------'
276 * union { .------------1+---0.
277 * char c; | pad | c |
278 * short s; |-------2+----+---0|
280 * } |--------+--------0|
282 * `------------------'
285 ffi_check_type(Lisp_Object type)
287 return apply1(Vffi_type_checker, Fcons(type, Fcons(Qt, Qnil)));
290 DEFUN("ffi-basic-type-p", Fffi_basic_type_p, 1, 1, 0, /*
291 Return non-nil if TYPE is a basic FFI type.
293 A type is said to be basic, if it is neither a pointer nor a
294 function, and there is a corresponding built-in type in C.
298 if (EQ(type, Q_byte) || EQ(type, Q_unsigned_byte) || EQ(type, Q_char)
299 || EQ(type, Q_unsigned_char) || EQ(type, Q_short)
300 || EQ(type, Q_unsigned_short) || EQ(type, Q_int)
301 || EQ(type, Q_unsigned_int) || EQ(type, Q_long)
302 || EQ(type, Q_unsigned_long) || EQ(type, Q_float)
303 || EQ(type, Q_double) || EQ(type, Q_void)
304 || EQ(type, Q_c_string) || EQ(type, Q_c_data)
305 || (CONSP(type) && EQ(XCAR(type), Q_c_data)))
313 ffi_canonicalise_type(Lisp_Object type)
315 /* this function canNOT GC */
317 while (!NILP(type) && NILP(Fffi_basic_type_p(type)) && SYMBOLP(type)) {
318 if EQ(type, Q_pointer)
320 type = Fcdr(Fassq(type, Vffi_named_types));
326 DEFUN("ffi-canonicalise-type", Fffi_canonicalise_type, 1, 1, 0, /*
327 Return FFI type TYPE in a canonical form.
331 Lisp_Object canon_type = ffi_canonicalise_type(type);
332 if (NILP(canon_type)) {
334 signal_simple_error("No such FFI type", type);
336 signal_error(Qinternal_error, "No such FFI type", type);
342 DEFUN("ffi-size-of-type", Fffi_size_of_type, 1, 1, 0, /*
343 Return the size of the foreign type TYPE.
345 Valid foreign types are: `byte', `unsigned-byte', `char',
346 `unsigned-char', `short', `unsigned-short', `int', `unsigned-int',
347 `long', `unsigned-long', `pointer', `float', `double',
348 `object', and `c-string'.
354 type = ffi_canonicalise_type(type);
355 if (EQ(type, Q_void))
357 else if (EQ(type, Q_byte))
358 tsize = sizeof(int8_t);
359 else if (EQ(type, Q_unsigned_byte))
360 tsize = sizeof(uint8_t);
361 else if (EQ(type, Q_char))
362 tsize = sizeof(char);
363 else if (EQ(type, Q_unsigned_char))
364 tsize = sizeof(unsigned char);
365 else if (EQ(type, Q_short))
366 tsize = sizeof(short);
367 else if (EQ(type, Q_unsigned_short))
368 tsize = sizeof(unsigned short);
369 else if (EQ(type, Q_int))
371 else if (EQ(type, Q_unsigned_int))
372 tsize = sizeof(unsigned int);
373 else if (EQ(type, Q_long))
374 tsize = sizeof(long);
375 else if (EQ(type, Q_unsigned_long))
376 tsize = sizeof(unsigned long);
377 else if (EQ(type, Q_float))
378 tsize = sizeof(float);
379 else if (EQ(type, Q_double))
380 tsize = sizeof(double);
381 else if (EQ(type, Q_c_string))
382 tsize = sizeof(char *);
383 else if (FFI_POINTERP(type))
384 tsize = sizeof(void *);
385 else if (EQ(type, Q_c_data))
386 tsize = sizeof(void *);
387 else if (CONSP(type) && EQ(XCAR(type), Q_c_data)) {
388 Lisp_Object cdsize = XCDR(type);
390 tsize = XINT(cdsize);
391 } else if (CONSP(type) && EQ(XCAR(type), Q_function))
392 tsize = sizeof(void(*));
393 else if (CONSP(type) && EQ(XCAR(type), Q_array)) {
394 Lisp_Object atype = Fcar(XCDR(type));
395 Lisp_Object asize = Fcar(Fcdr(XCDR(type)));
398 tsize = XINT(asize) * XINT(Fffi_size_of_type(atype));
399 } else if (CONSP(type) && EQ(XCAR(type), Q_struct)) {
400 return Fffi_slot_offset(type, Qnil);
401 } else if (CONSP(type) && EQ(XCAR(type), Q_union)) {
402 Lisp_Object slots = Fcdr(XCDR(type));
407 while (!NILP(slots)) {
408 Lisp_Object slot_type = Fcar(Fcdr(XCAR(slots)));
409 int slot_size = XINT(Fffi_size_of_type(slot_type));
410 if (slot_size > tsize)
416 signal_simple_error("Unrecognized foreign type", type);
418 signal_error(Qinternal_error, "Unrecognized foreign type", type);
422 return make_int(tsize);
425 DEFUN("make-ffi-object", Fmake_ffi_object, 1, 2, 0, /*
426 Create a new FFI object of type TYPE.
427 If optional argument SIZE is non-nil it should be an
428 integer, in this case additional storage size to hold data
429 of at least length SIZE is allocated.
435 Lisp_Object result = Qnil;
436 Lisp_EffiObject *ffio;
441 /* NOTE: ffi_check_type returns canonical type */
442 ctype = ffi_check_type(type);
444 size = Fffi_size_of_type(type);
447 if (CONSP(ctype) && EQ(XCAR(ctype), Q_c_data) && INTP(XCDR(ctype)))
450 cs_or_cd = EQ(ctype, Q_c_string) || (EQ(ctype, Q_c_data));
451 if ((cs_or_cd && (XINT(size) < 1))
452 || (!(cs_or_cd || FFI_POINTERP(ctype))
453 && (XINT(size) < XINT(Fffi_size_of_type(type)))))
455 signal_simple_error("storage size too small to store type",
458 ffio = alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
460 XSETEFFIO(result, ffio);
462 signal_error(Qinternal_error,
463 "storage size too small to store type",
466 ffio = old_basic_alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
468 result = wrap_effio(ffio);
471 ffio->size = Fffi_size_of_type(type);
475 /* Initialize foreign pointer */
476 ffio->fotype = EFFI_FOT_NONE;
477 ffio->storage_size = XINT(size);
478 ffio->fop.ptr = ffio->fostorage;
480 if (!NILP(Vffi_all_objects))
481 XWEAK_LIST_LIST(Vffi_all_objects) =
482 Fcons(result, XWEAK_LIST_LIST(Vffi_all_objects));
484 RETURN_UNGCPRO(result);
487 DEFUN("ffi-object-p", Fffi_object_p, 1, 1, 0, /*
488 Return non-nil if FO is an FFI object, nil otherwise.
492 return (EFFIOP(fo) ? Qt : Qnil);
495 DEFUN("ffi-object-address", Fffi_object_address, 1, 1, 0, /*
496 Return the address FO points to.
501 return make_float((long)XEFFIO(fo)->fop.ptr);
504 DEFUN("ffi-make-pointer", Fffi_make_pointer, 1, 1, 0, /*
505 "Return a pointer pointing to ADDRESS."
513 addr = XINT(address);
514 else if (FLOATP(address))
515 addr = XFLOATINT(address);
518 signal_simple_error("FFI: invalid address type", address);
520 signal_error(Qinternal_error, "FFI: invalid address type",
525 ptr = Fmake_ffi_object(Q_pointer, Qnil);
526 XEFFIO(ptr)->fop.ptr = (void*)addr;
530 DEFUN("ffi-object-canonical-type", Fffi_object_canonical_type, 1, 1, 0, /*
531 Return FO's real type, that is after resolving user defined types.
536 return ffi_canonicalise_type(XEFFIO(fo)->type);
539 DEFUN("ffi-object-type", Fffi_object_type, 1, 1, 0, /*
545 return (XEFFIO(fo)->type);
548 DEFUN("ffi-set-object-type", Fffi_set_object_type, 2, 2, 0, /*
549 Cast FO to type TYPE and reassign the cast value.
555 ffi_check_type(type);
556 XEFFIO(fo)->type = type;
561 DEFUN("ffi-object-size", Fffi_object_size, 1, 1, 0, /*
562 Return the size of the allocated space of FO.
567 return (XEFFIO(fo)->size);
570 DEFUN("ffi-set-storage-size", Fffi_set_storage_size, 2, 2, 0, /*
571 Set the size of the allocated space of FO.
577 XEFFIO(fo)->storage_size = XUINT(size);
581 DEFUN("ffi-load-library", Fffi_load_library, 1, 1, 0, /*
582 Load library LIBNAME and return a foreign object handle if successful,
583 or `nil' if the library cannot be loaded.
585 The argument LIBNAME should be the file-name string of a shared object
586 library. Normally you should omit the file extension, as this
587 function will add the appripriate extension for the current platform
590 The library should reside in one of the directories specified by the
591 $LD_LIBRARY_PATH environment variable or the more global ld.so.cache.
596 #ifdef LTDL_SHLIB_EXT
597 # define EXT LTDL_SHLIB_EXT
598 #elif defined(HAVE_DYLD) || defined(HAVE_MACH_O_DYLD_H)
599 # define EXT ".dylib"
602 #endif /* LTDL_SHLIB_EXT */
604 void *handler, *dotpos;
605 Lisp_Object fo = Qnil;
606 Lisp_EffiObject *ffio;
610 CHECK_STRING(libname);
612 /* Add an extension if we need to */
613 dotpos = strrchr((char *)XSTRING_DATA(libname),'.');
614 if ( dotpos == NULL || strncmp(dotpos, EXT, sizeof(EXT))) {
615 soname = xmalloc(XSTRING_LENGTH(libname) + sizeof(EXT) + 1);
616 strcpy(soname, (char *)XSTRING_DATA(libname));
620 if ( soname == NULL ) {
621 handler = dlopen((const char *)XSTRING_DATA(libname),
622 RTLD_GLOBAL|RTLD_NOW);
624 handler = dlopen(soname, RTLD_GLOBAL|RTLD_NOW);
632 fo = Fmake_ffi_object(Q_pointer, Qnil);
635 ffio->fotype = EFFI_FOT_BIND;
636 ffio->fop.ptr = handler;
641 DEFUN("ffi-bind", Fffi_bind, 2, 2, 0, /*
642 Make and return a foreign object of type TYPE and bind it to the
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.
649 If SYM does not exist in any of the loaded libraries, `nil' is
654 Lisp_Object fo = Qnil;
655 Lisp_EffiObject *ffio;
658 ffi_check_type(type);
662 fo = Fmake_ffi_object(type, Qnil);
664 ffio->fop.ptr = dlsym(RTLD_DEFAULT, (const char*)XSTRING_DATA(sym));
665 if (ffio->fop.ptr == NULL) {
670 ffio->fotype = EFFI_FOT_BIND;
675 DEFUN("ffi-dlerror", Fffi_dlerror, 0, 0, 0, /*
676 Return dl error string.
680 const char *dles = dlerror();
682 if (LIKELY(dles != NULL)) {
683 size_t sz = strlen(dles);
684 return make_ext_string((const Extbyte*)dles, sz, EFFI_CODING);
690 DEFUN("ffi-defun", Fffi_defun, 2, 2, 0, /*
691 Make and return a foreign object of type TYPE and bind it to the
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.
698 If SYM does not exist in any of the loaded libraries, an error
701 This is like `ffi-bind' but for function objects.
705 Lisp_Object fo = Qnil;
706 Lisp_EffiObject *ffio;
709 ffi_check_type(type);
714 fo = Fmake_ffi_object(type, Qnil);
716 ffio->fop.fun = dlsym(RTLD_DEFAULT, (const char *)XSTRING_DATA(sym));
717 if (ffio->fop.fun == NULL) {
719 signal_simple_error("Can't define function", sym);
721 signal_error(Qinternal_error, "Can't define function", sym);
725 ffio->fotype = EFFI_FOT_FUNC;
731 * Return alignment policy for struct or union FFI_SU.
732 * x86: Return 1, 2 or 4.
733 * mips: Return 1, 2, 4 or 8.
736 ffi_type_align(Lisp_Object type)
738 type = ffi_canonicalise_type(type);
740 if (EQ(type, Q_byte) || EQ(type, Q_unsigned_byte)
741 || EQ(type, Q_char) || EQ(type, Q_unsigned_char))
743 if (EQ(type, Q_short) || EQ(type, Q_unsigned_short))
746 if (EQ(type, Q_double))
748 #endif /* FFI_MIPS */
751 } else if (CONSP(type)
752 && (EQ(XCAR(type), Q_struct) || EQ(XCAR(type), Q_union))) {
755 for (al = 0, type = Fcdr(Fcdr(type));
759 Lisp_Object stype = Fcar(Fcdr(Fcar(type)));
760 int tmp_al = ffi_type_align(stype);
772 DEFUN("ffi-type-alignment", Fffi_type_alignment, 1, 1, 0, /*
773 Return TYPE alignment.
777 return make_int(ffi_type_align(type));
780 DEFUN("ffi-slot-offset", Fffi_slot_offset, 2, 2, 0, /*
781 Return the offset of SLOT in TYPE.
782 SLOT can be either a valid (named) slot in TYPE or `nil'.
783 If SLOT is `nil' return the size of the struct.
788 int lpad, align, retoff;
790 type = ffi_canonicalise_type(type);
793 error("Not struct or union");
795 Fsignal(Qwrong_type_argument,
796 list2(Qstringp, build_string("Not struct or union")));
801 lpad = align = ffi_type_align(type);
802 slots = Fcdr(XCDR(type));
804 while (!NILP(slots)) {
805 Lisp_Object tmp_slot = Fcar(Fcdr(XCAR(slots)));
811 * - for basic types TMP_ALIGN and TMP_SIZE are equal
813 tmp_align = ffi_type_align(tmp_slot);
815 if (EQ(XCAR(XCAR(slots)), slot)) {
817 /* TODO: add support for :offset keyword in SLOT */
818 if (lpad < tmp_align) {
826 tmp_size = XINT(Fffi_size_of_type(tmp_slot));
827 while (tmp_size > 0) {
828 if (lpad < tmp_align) {
832 tmp_size -= tmp_align;
839 if (NILP(slots) && !NILP(slot)) {
841 signal_simple_error("FFI: Slot not found", slot);
843 signal_error(Qinternal_error, "FFI: Slot not found", slot);
846 return make_int(retoff + lpad);
850 * TYPE must be already canonicalised
853 ffi_fetch_foreign(void *ptr, Lisp_Object type)
855 /* this function canNOT GC */
856 Lisp_Object retval = Qnone;
858 if (EQ(type, Q_char))
859 retval = make_char(*(char*)ptr);
860 else if (EQ(type, Q_unsigned_char))
861 retval = make_char(*(char unsigned*)ptr);
862 else if (EQ(type, Q_byte))
863 retval = make_int(*(char*)ptr);
864 else if (EQ(type, Q_unsigned_byte))
865 retval = make_int(*(unsigned char*)ptr);
866 else if (EQ(type, Q_short))
867 retval = make_int(*(short*)ptr);
868 else if (EQ(type, Q_unsigned_short))
869 retval = make_int(*(unsigned short*)ptr);
870 else if (EQ(type, Q_int))
871 retval = make_int(*(int*)ptr);
872 else if (EQ(type, Q_unsigned_int))
873 retval = make_int(*(unsigned int*)ptr);
874 else if (EQ(type, Q_long))
875 retval = make_int(*(long*)ptr);
876 else if (EQ(type, Q_unsigned_long))
877 retval = make_int(*(unsigned long*)ptr);
878 else if (EQ(type, Q_float))
879 retval = make_float(*(float*)ptr);
880 else if (EQ(type, Q_double))
881 retval = make_float(*(double*)ptr);
882 else if (EQ(type, Q_c_string)) {
883 retval = build_ext_string((char*)ptr, Qbinary);
884 } else if (EQ(type, Q_void)) {
886 } else if (FFI_POINTERP(type)) {
887 retval = Fmake_ffi_object(type, Qnil);
888 XEFFIO(retval)->fop.ptr = *(void**)ptr;
889 } else if (CONSP(type) && EQ(XCAR(type), Q_function)) {
890 retval = Fmake_ffi_object(type, Qnil);
891 XEFFIO(retval)->fop.fun = (void*)ptr;
892 XEFFIO(retval)->fotype = EFFI_FOT_FUNC;
898 DEFUN("ffi-fetch", Fffi_fetch, 3, 3, 0, /*
899 Fetch value from the foreign object FO from OFFSET position.
900 TYPE specifies value for data to be fetched.
904 Lisp_Object origtype = type;
905 Lisp_Object retval = Qnil;
906 Lisp_EffiObject *ffio;
914 ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
916 type = ffi_canonicalise_type(type);
919 /* Fetch value and translate it according to translators */
920 retval = ffi_fetch_foreign(ptr, type);
921 if (EQ(retval, Qnone)) {
922 /* Special case for c-data */
923 if (EQ(type, Q_c_data) ||
924 (CONSP(type) && EQ(XCAR(type), Q_c_data)))
927 if (EQ(type, Q_c_data)) {
928 tlen = ffio->storage_size - XINT(offset);
930 CHECK_INT(XCDR(type));
931 tlen = XUINT(XCDR(type));
934 retval = make_ext_string(ptr, tlen, Qbinary);
937 signal_simple_error("Can't fetch for this type", origtype);
939 signal_error(Qinternal_error, "Can't fetch for this type",
944 retval = apply1(Findirect_function(Qffi_translate_from_foreign),
945 list2(retval, origtype));
947 RETURN_UNGCPRO(retval);
950 DEFUN("ffi-aref", Fffi_aref, 2, 2, 0, /*
951 Return the element of FARRAY at index IDX (starting with 0).
960 type = ffi_canonicalise_type(XEFFIO(farray)->type);
961 if (!FFI_TPTR(type)) {
963 signal_simple_error("Not an array type", type);
965 signal_error(Qinternal_error, "Not an array type", type);
968 if (EQ(type, Q_c_string))
971 type = Fcar(XCDR(type));
973 return Fffi_fetch(farray,
974 make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
978 DEFUN("ffi-store", Fffi_store, 4, 4, 0, /*
979 For foreign object FO at specified OFFSET store data.
980 Type of data is specified by VAL-TYPE and data itself specified in VAL.
982 VAL-TYPE can be either a basic FFI type or an FFI pointer.
983 If VAL-TYPE is a basic FFI type, then VAL can be an
984 ordinary, but suitable Emacs lisp object.
985 If VAL-TYPE is an FFI pointer then VAL _must_ be an FFI
986 object of the underlying type pointed to.
988 (fo, offset, val_type, val))
990 Lisp_Object origtype = val_type;
991 Lisp_EffiObject *ffio;
998 ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
1000 val_type = ffi_canonicalise_type(val_type);
1002 /* Translate value */
1003 val = apply1(Findirect_function(Qffi_translate_to_foreign),
1004 list2(val, origtype));
1006 if (EQ(val_type, Q_char) || EQ(val_type, Q_unsigned_char)) {
1008 SIGNAL_ERROR(Qwrong_type_argument,
1009 list2(Qcharacterp, val));
1011 *(char*)ptr = XCHAR(val);
1012 } else if (EQ(val_type, Q_byte) || EQ(val_type, Q_unsigned_byte)) {
1014 SIGNAL_ERROR(Qwrong_type_argument,
1015 list2(Qintegerp, val));
1017 *(char*)ptr = XINT(val);
1018 } else if (EQ(val_type, Q_short) || EQ(val_type, Q_unsigned_short)) {
1020 SIGNAL_ERROR(Qwrong_type_argument,
1021 list2(Qintegerp, val));
1023 *(short*)ptr = (short)XINT(val);
1024 } else if (EQ(val_type, Q_int) || EQ(val_type, Q_unsigned_int)) {
1026 *(int*)ptr = XINT(val);
1027 } else if (FLOATP(val)) {
1028 fpfloat tmp = XFLOATINT(val);
1029 *(int*)ptr = (int)tmp;
1031 SIGNAL_ERROR(Qwrong_type_argument,
1032 list2(Qfloatp, val));
1034 } else if (EQ(val_type, Q_long) || EQ(val_type, Q_unsigned_long)) {
1036 *(long*)ptr = (long)XINT(val);
1037 } else if (FLOATP(val)) {
1038 fpfloat tmp = XFLOATINT(val);
1039 *(long*)ptr = (long int)tmp;
1041 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1043 } else if (EQ(val_type, Q_float)) {
1045 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1046 *(float*)ptr = XFLOATINT(val);
1047 } else if (EQ(val_type, Q_double)) {
1049 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1050 *(double*)ptr = XFLOAT_DATA(val);
1051 } else if (EQ(val_type, Q_c_string)) {
1055 SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1057 TO_EXTERNAL_FORMAT(LISP_STRING, val,
1058 ALLOCA, (tmp, tmplen), Qnil);
1059 memcpy((char*)ptr, tmp, tmplen + 1);
1062 (const char *)XSTRING_DATA(val),
1063 XSTRING_LENGTH(val) + 1);
1065 } else if (EQ(val_type, Q_c_data) ||
1067 EQ(XCAR(val_type), Q_c_data) && INTP(XCDR(val_type)))) {
1069 unsigned int val_ext_len;
1071 SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1073 TO_EXTERNAL_FORMAT(LISP_STRING, val, ALLOCA,
1074 (val_ext, val_ext_len), Qbinary);
1075 if (CONSP(val_type) && (val_ext_len > XINT(XCDR(val_type)))) {
1077 error("storage size too small");
1079 Fsignal(Qrange_error,
1081 build_string("storage size too small")));
1082 #endif /* SXEMACS */
1084 memcpy((char*)ptr, (const char *)val_ext, val_ext_len);
1085 } else if (FFI_POINTERP(val_type)) {
1088 signal_simple_error("FFI: Value not of pointer type", \
1089 list2(origtype, val));
1091 Fsignal(Qwrong_type_argument,
1092 list2(Qstringp, build_string("type")));
1093 #endif /* SXEMACS */
1095 *(void**)ptr = (void*)XEFFIO(val)->fop.ptr;
1096 } else if (CONSP(val_type) && EQ(XCAR(val_type), Q_struct)) {
1099 signal_simple_error("FFI: Value not FFI object", \
1100 list2(origtype, val));
1102 Fsignal(Qwrong_type_argument,
1103 list2(Qstringp, build_string("type")));
1104 #endif /* SXEMACS */
1106 memcpy((char*)ptr, (const char *)XEFFIO(val)->fop.ptr, \
1107 XINT(Fffi_size_of_type(val_type)));
1110 signal_simple_error("FFI: Non basic or pointer type", origtype);
1112 Fsignal(Qinternal_error,
1114 build_string("non basic or pointer type")));
1115 #endif /* SXEMACS */
1121 DEFUN("ffi-aset", Fffi_aset, 3, 3, 0, /*
1122 Store the element VALUE in FARRAY at index IDX (starting with 0).
1124 (farray, idx, value))
1128 CHECK_EFFIO(farray);
1131 type = ffi_canonicalise_type(XEFFIO(farray)->type);
1132 if (!FFI_TPTR(type)) {
1134 signal_simple_error("Not an array type", type);
1136 signal_error(Qinternal_error, "Not an array type", type);
1137 #endif /* SXEMACS */
1139 if (EQ(type, Q_c_string))
1142 type = Fcar(XCDR(type));
1144 return Fffi_store(farray,
1145 make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
1149 DEFUN("ffi-address-of", Fffi_address_of, 1, 1, 0, /*
1150 Return the FFI object that stores the address of given FFI object FO.
1152 This is the equivalent of the `&' operator in C.
1156 Lisp_Object newfo = Qnil;
1157 Lisp_EffiObject *ffio, *newffio;
1158 struct gcpro gcpro1;
1164 newfo = Fmake_ffi_object(Q_pointer, Qnil);
1165 newffio = XEFFIO(newfo);
1167 newffio->fotype = EFFI_FOT_BIND;
1168 if (FFI_TPTR(ffio->type))
1169 newffio->fop.ptr = (void*)&ffio->fop.ptr;
1171 newffio->fop.ptr = ffio->fop.ptr;
1173 RETURN_UNGCPRO(newfo);
1176 DEFUN("ffi-lisp-object-to-pointer", Fffi_lisp_object_to_pointer, 1, 1, 0, /*
1177 Convert lisp object to FFI pointer.
1181 Lisp_Object newfo = Qnil;
1182 Lisp_EffiObject *newffio;
1183 struct gcpro gcpro1;
1187 newfo = Fmake_ffi_object(Q_pointer, Qnil);
1188 newffio = XEFFIO(newfo);
1189 newffio->fotype = EFFI_FOT_BIND;
1190 newffio->fop.ptr = (void*)obj;
1192 /* Hold a reference to OBJ in NEWFO's plist */
1193 Fput(newfo, intern("lisp-object"), obj);
1195 RETURN_UNGCPRO(newfo);
1198 DEFUN("ffi-pointer-to-lisp-object", Fffi_pointer_to_lisp_object, 1, 1, 0, /*
1199 Convert FFI pointer to lisp object.
1204 return (Lisp_Object)XEFFIO(ptr)->fop.ptr;
1207 DEFUN("ffi-plist", Fffi_plist, 1, 1, 0, /*
1208 Return properties list for FFI object FO.
1213 return (XEFFIO(fo)->plist);
1218 static int lf_cindex = 0;
1222 * This will work in most cases.
1223 * However it might not work for large structures,
1224 * In general we should allocate these spaces dynamically
1226 #define MAX_TYPES_VALUES 1024
1227 /* ex_ffitypes_dummies used for structure types */
1228 static ffi_type ex_ffitypes_dummies[MAX_TYPES_VALUES + 1];
1229 static ffi_type *ex_ffitypes[MAX_TYPES_VALUES + 1];
1230 static void *ex_values[MAX_TYPES_VALUES + 1];
1232 #if SIZEOF_LONG == 4
1233 # define effi_type_ulong ffi_type_uint32
1234 # define effi_type_slong ffi_type_sint32
1235 #elif SIZEOF_LONG == 8
1236 # define effi_type_ulong ffi_type_uint64
1237 # define effi_type_slong ffi_type_sint64
1241 extffi_setup_argument(Lisp_Object type, ffi_type **ft)
1243 type = ffi_canonicalise_type(type);
1244 if (EQ(type, Q_char) || EQ(type, Q_byte))
1245 *ft = &ffi_type_schar;
1246 else if (EQ(type, Q_unsigned_char) || EQ(type, Q_unsigned_byte))
1247 *ft = &ffi_type_uchar;
1248 else if (EQ(type, Q_short))
1249 *ft = &ffi_type_sshort;
1250 else if (EQ(type, Q_unsigned_short))
1251 *ft = &ffi_type_ushort;
1252 else if (EQ(type, Q_int))
1253 *ft = &ffi_type_sint;
1254 else if (EQ(type, Q_unsigned_int))
1255 *ft = &ffi_type_uint;
1256 else if (EQ(type, Q_unsigned_long))
1257 *ft = &effi_type_ulong;
1258 else if (EQ(type, Q_long))
1259 *ft = &effi_type_slong;
1260 else if (EQ(type, Q_float))
1261 *ft = &ffi_type_float;
1262 else if (EQ(type, Q_double))
1263 *ft = &ffi_type_double;
1264 else if (EQ(type, Q_void))
1265 *ft = &ffi_type_void;
1266 else if (FFI_TPTR(type))
1267 *ft = &ffi_type_pointer;
1268 else if (CONSP(type) && EQ(XCAR(type), Q_struct)) {
1269 Lisp_Object slots = Fcdr(XCDR(type));
1275 nt_size = XINT(Flength(slots)) + 1;
1276 if (nt_size + lf_cindex > MAX_TYPES_VALUES) {
1277 lf_cindex = 0; /* reset cindex */
1279 error("cindex overflow");
1281 Fsignal(Qoverflow_error,
1283 build_string("cindex overflow")));
1284 #endif /* SXEMACS */
1286 ntypes = &ex_ffitypes[lf_cindex];
1287 *ft = &ex_ffitypes_dummies[lf_cindex];
1289 /* Update lf_cindex in case TYPE struct contains other
1291 lf_cindex += nt_size;
1293 (*ft)->type = FFI_TYPE_STRUCT;
1294 (*ft)->alignment = ffi_type_align(type);
1295 (*ft)->elements = ntypes;
1297 for (i = 0; (i < nt_size) && !NILP(slots); slots = XCDR(slots), i++)
1298 extffi_setup_argument(Fcar(Fcdr(XCAR(slots))), &ntypes[i]);
1302 signal_simple_error("Can't setup argument for type", type);
1304 signal_error(Qinternal_error,
1305 "Can't setup argument for type", type);
1306 #endif /* SXEMACS */
1311 ffi_call_using_libffi(Lisp_Object fo_fun, Lisp_Object ret_fo,
1312 int in_nargs, Lisp_Object *in_args)
1314 Lisp_EffiObject *ffio;
1321 lf_cindex = in_nargs; /* reserve */
1322 for (i = 0; i < in_nargs; i++) {
1323 ffio = XEFFIO(in_args[i]);
1324 fft = Fffi_canonicalise_type(ffio->type);
1325 extffi_setup_argument(fft, &ex_ffitypes[i]);
1327 ex_values[i] = &ffio->fop.ptr;
1329 ex_values[i] = ffio->fop.ptr;
1332 ffio = XEFFIO(ret_fo);
1333 fft = Fffi_canonicalise_type(ffio->type);
1334 extffi_setup_argument(fft, &rtype);
1336 rvalue = &ffio->fop.ptr;
1338 rvalue = ffio->fop.ptr;
1340 if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, in_nargs,
1341 rtype, ex_ffitypes) == FFI_OK)
1343 stop_async_timeouts();
1344 ffi_call(&cif, (void(*)(void))XEFFIO(fo_fun)->fop.fun, rvalue,
1346 start_async_timeouts();
1353 #endif /* HAVE_LIBFFI */
1355 DEFUN("ffi-call-function", Fffi_call_function, 1, MANY, 0, /*
1356 Call a function referred to by FO with arguments ARGS, maybe
1357 return a foreign object with the result or nil if there is
1360 Arguments are: FO &rest FO-ARGS
1362 FO should be a foreign binding initiated by `ffi-defun', and
1363 ARGS should be foreign data objects or pointers to these.
1365 (int nargs, Lisp_Object * args))
1367 Lisp_Object faf = Qnil, retfo = Qnil;
1368 Lisp_EffiObject *ffio;
1370 struct gcpro gcpro1, gcpro2;
1376 retfo = Fmake_ffi_object(XCAR(XCDR(ffio->type)), Qnil);
1379 ret = ffi_call_using_libffi(args[0], retfo, nargs-1, &args[1]);
1380 #endif /* HAVE_LIBFFI */
1382 RETURN_UNGCPRO(ret == 0 ? retfo : Qnil);
1385 #ifdef EF_USE_ASYNEQ
1386 /* handler for asynchronously calling ffi code */
1387 Lisp_Object Qffi_jobp;
1388 #define EFFI_DEBUG_JOB(args...)
1390 exec_sentinel_unwind(Lisp_Object UNUSED(datum))
1396 exec_sentinel(void *job, ffi_job_t ffij)
1397 __attribute__((always_inline));
1399 exec_sentinel(void *job, ffi_job_t ffij)
1401 /* This function can GC */
1402 /* called from main thread */
1403 int speccount = specpdl_depth(), nargs = ffij->sntnl_nargs, i;
1404 Lisp_Object funcell[nargs+2];
1405 struct gcpro gcpro1;
1407 funcell[0] = ffij->sntnl;
1408 funcell[1] = (Lisp_Object)job;
1409 for (i = 0; i < nargs; i++) {
1410 funcell[2+i] = ffij->sntnl_args[i];
1412 GCPROn(funcell, nargs+2);
1414 record_unwind_protect(exec_sentinel_unwind, Qnil);
1415 /* call the funcell */
1416 Ffuncall(nargs+2, funcell);
1417 /* reset to previous state */
1418 restore_match_data();
1420 unbind_to(speccount, Qnil);
1424 static inline ffi_job_t
1425 allocate_ffi_job(void)
1427 ffi_job_t ffij = xnew(struct ffi_job_s);
1428 EFFI_DEBUG_JOB("allocated: 0x%lx\n", (long unsigned int)ffij);
1432 static inline ffi_job_t
1433 make_ffi_job(Lisp_Object fof, int fof_nargs, Lisp_Object *fof_args,
1434 Lisp_Object sntnl, int sntnl_nargs, Lisp_Object *sntnl_args)
1436 /* exec'd in the main thread */
1437 ffi_job_t ffij = allocate_ffi_job();
1440 SXE_MUTEX_INIT(&ffij->mtx);
1442 if (fof_nargs > 0) {
1443 ffij->fof_nargs = fof_nargs;
1444 ffij->fof_args = xnew_array(Lisp_Object, fof_nargs);
1445 for (i = 0; i < fof_nargs; i++) {
1446 ffij->fof_args[i] = fof_args[i];
1449 ffij->fof_nargs = 0;
1450 ffij->fof_args = NULL;
1453 ffij->sntnl = sntnl;
1454 if (sntnl_nargs > 0) {
1455 ffij->sntnl_nargs = sntnl_nargs;
1456 ffij->sntnl_args = xnew_array(Lisp_Object, sntnl_nargs);
1457 for (i = 0; i < sntnl_nargs; i++) {
1458 ffij->sntnl_args[i] = sntnl_args[i];
1461 ffij->sntnl_nargs = 0;
1462 ffij->sntnl_args = NULL;
1465 ffij->result = Qnil;
1466 ffij->retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil);
1471 mark_ffi_job(worker_job_t job)
1473 ffi_job_t ffij = ffi_job(job);
1479 SXE_MUTEX_LOCK(&ffij->mtx);
1480 mark_object(ffij->fof);
1481 for (i = 0; i < ffij->fof_nargs; i++) {
1482 mark_object(ffij->fof_args[i]);
1484 mark_object(ffij->sntnl);
1485 for (i = 0; i < ffij->sntnl_nargs; i++) {
1486 mark_object(ffij->sntnl_args[i]);
1488 mark_object(ffij->retfo);
1489 mark_object(ffij->result);
1490 SXE_MUTEX_UNLOCK(&ffij->mtx);
1495 print_ffi_job(worker_job_t job, Lisp_Object pcf)
1497 ffi_job_t ffij = ffi_job(job);
1498 char *str = alloca(64);
1500 SXE_MUTEX_LOCK(&ffij->mtx);
1501 WRITE_C_STRING(" carrying ", pcf);
1502 snprintf(str, 63, " #<ffi-job 0x%lx>", (long unsigned int)ffij);
1503 WRITE_C_STRING(str, pcf);
1504 SXE_MUTEX_UNLOCK(&ffij->mtx);
1509 finish_ffi_job_data(ffi_job_t ffij)
1511 SXE_MUTEX_LOCK(&ffij->mtx);
1512 xfree(ffij->fof_args);
1513 xfree(ffij->sntnl_args);
1514 SXE_MUTEX_UNLOCK(&ffij->mtx);
1515 SXE_MUTEX_FINI(&ffij->mtx);
1517 EFFI_DEBUG_JOB("finished: 0x%lx\n", (long unsigned int)ffij);
1522 finish_ffi_job(worker_job_t job)
1526 lock_worker_job(job);
1527 ffij = ffi_job(job);
1530 finish_ffi_job_data(ffij);
1532 worker_job_data(job) = NULL;
1533 unlock_worker_job(job);
1538 ffi_job_handle(worker_job_t job)
1541 /* usually called from aux threads */
1543 Lisp_Object fof = Qnil, retfo = Qnil, *args = NULL;
1544 int nargs, ret = -1;
1546 lock_worker_job(job);
1547 ffij = ffi_job(job);
1548 unlock_worker_job(job);
1549 SXE_MUTEX_LOCK(&ffij->mtx);
1551 nargs = ffij->fof_nargs;
1552 args = ffij->fof_args;
1553 SXE_MUTEX_UNLOCK(&ffij->mtx);
1555 /* can't ... Fmake_ffi_object is not mt-safe */
1556 /* retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil); */
1557 retfo = ffij->retfo;
1560 ret = ffi_call_using_libffi(fof, retfo, nargs, args);
1561 #endif /* HAVE_LIBFFI */
1563 SXE_MUTEX_LOCK(&ffij->mtx);
1564 ffij->result = retfo;
1565 SXE_MUTEX_UNLOCK(&ffij->mtx);
1568 EFFI_DEBUG_JOB("job 0x%lx succeeded\n", (long unsigned int)ffij);
1573 ffi_job_finished(worker_job_t job)
1575 if (NILP(ffi_job_sentinel(job) /* sentinel */)) {
1578 /* called from main thread */
1579 exec_sentinel(job, ffi_job(job));
1583 static struct work_handler_s ffi_job_handler = {
1584 mark_ffi_job, print_ffi_job, finish_ffi_job,
1585 ffi_job_handle, NULL, ffi_job_finished
1589 make_ffi_asyneq_job(ffi_job_t ffij)
1591 /* create a job digestible by the asyneq */
1592 Lisp_Object job = Qnil;
1593 struct gcpro gcpro1;
1596 job = wrap_object(make_worker_job(&ffi_job_handler));
1597 XWORKER_JOB_DATA(job) = ffij;
1598 /* the scratch buffer thingie */
1603 DEFUN("ffi-call-function&", Fffi_call_functionX, 1, MANY, 0, /*
1604 Call a function referred to by FO with arguments ARGS asynchronously,
1605 return a job object.
1607 Arguments are: FO &rest FO-ARGS &aux SENTINEL &rest SENTINEL-ARGS
1609 FO should be a foreign binding initiated by `ffi-defun'.
1610 FO-ARGS should be exactly as many foreign data objects as FO needs.
1611 SENTINEL is a lisp sentinel function called when the job finished,
1612 the function should take at least one argument JOB, further arguments
1613 may be specified by passing further SENTINEL-ARGS.
1615 (int nargs, Lisp_Object *args))
1617 Lisp_Object job = Qnil;
1618 Lisp_Object sntnl, fof, *sntnl_args, *fof_args;
1619 int sntnl_nargs, fof_nargs;
1621 struct gcpro gcpro1, gcpro2;
1623 CHECK_EFFIO(args[0]);
1624 GCPRO1n(job, args, nargs);
1627 /* determine how many args belong to the fof */
1628 fof_nargs = XINT(Flength(XCDR(XEFFIO(fof)->type)))-1;
1629 fof_args = &args[1];
1631 if ((sntnl_nargs = nargs - fof_nargs - 2) >= 0) {
1632 sntnl = args[fof_nargs+1];
1633 sntnl_args = &args[fof_nargs+2];
1639 /* create the job data object */
1640 ffij = make_ffi_job(fof, fof_nargs, fof_args,
1641 sntnl, sntnl_nargs, sntnl_args);
1642 /* now prepare the job to dispatch */
1643 job = make_ffi_asyneq_job(ffij);
1644 /* ... and dispatch it, change its state to queued */
1645 XWORKER_JOB_STATE(job) = WORKER_JOB_QUEUED;
1646 eq_enqueue(delegate_eq, job);
1647 /* brag about new jobs in the queue */
1648 eq_queue_trigger_all(delegate_eq);
1653 #endif /* EF_USE_ASYNEQ */
1655 extern struct device *decode_x_device(Lisp_Object device);
1657 DEFUN("x-device-display", Fx_device_display, 0, 1, 0, /*
1658 Return DEVICE display as FFI object.
1665 fo = Fmake_ffi_object(Q_pointer, Qnil);
1666 XEFFIO(fo)->fotype = EFFI_FOT_BIND;
1667 XEFFIO(fo)->fop.ptr = (void*)DEVICE_X_DISPLAY(decode_x_device(device));
1675 #define FFI_CC_CDECL 0
1677 #if defined __i386__
1679 ffi_callback_call_x86(Lisp_Object cbk_info, char *arg_buffer)
1681 Lisp_Object fun, alist = Qnil, retlo, foret;
1682 Lisp_Object rtype, argtypes;
1683 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1686 fun = Fcar(cbk_info);
1687 rtype = Fcar(Fcdr(cbk_info));
1688 argtypes = Fcar(Fcdr(Fcdr(cbk_info)));
1690 CHECK_LIST(argtypes);
1692 arg_buffer += 4; /* Skip return address */
1693 while (!NILP(argtypes)) {
1694 Lisp_Object result, ctype;
1697 ctype = ffi_canonicalise_type(XCAR(argtypes));
1698 size = XINT(Fffi_size_of_type(ctype));
1699 if (EQ(ctype, Q_c_string)) {
1700 char *aptr = *(char**)arg_buffer;
1702 result = ffi_fetch_foreign(aptr, ctype);
1706 result = ffi_fetch_foreign(arg_buffer, ctype);
1707 /* Apply translators and put the result into alist */
1708 result = apply1(Findirect_function(Qffi_translate_from_foreign),
1709 list2(result, XCAR(argtypes)));
1710 alist = Fcons(result, alist);
1713 int sp = (size + mask) & ~mask;
1716 argtypes = XCDR(argtypes);
1718 alist = Fnreverse(alist);
1720 /* Special case, we have no return value */
1721 if (EQ(rtype, Q_void)) {
1722 GCPRO3(fun, alist, rtype);
1728 GCPRO5(fun, alist, rtype, retlo, foret);
1729 retlo = apply1(fun, alist);
1730 foret = Fmake_ffi_object(rtype, Qnil);
1731 Fffi_store(foret, make_int(0), rtype, retlo);
1732 ptr = (void*)XEFFIO(foret)->fop.ptr;
1733 if (EQ(rtype, Q_double)) {
1736 asm volatile ("fldl (%0)" :: "a" (ptr));
1739 } else if (EQ(rtype, Q_float)) {
1742 asm volatile ("flds (%0)" :: "a" (ptr));
1748 if (EQ(rtype, Q_byte) || EQ(rtype, Q_char))
1750 else if (EQ(rtype, Q_unsigned_byte) || EQ(rtype, Q_unsigned_char))
1751 iv = *(char unsigned*)ptr;
1752 else if (EQ(rtype, Q_short))
1754 else if (EQ(rtype, Q_unsigned_short))
1755 iv = *(unsigned short*)ptr;
1760 asm volatile ("movl %0,%%eax;" :: "r" (iv) : "%eax");
1767 ffi_make_callback_x86(Lisp_Object data, int cc_type)
1771 * pushl <data> 68 <addr32>
1772 * call ffi_callback_call_x86 E8 <disp32>
1780 char *buf = xmalloc(sizeof(char)*16);
1781 *(char*) (buf+0) = 0x54;
1782 *(char*) (buf+1) = 0x68;
1783 *(long*) (buf+2) = (long)data;
1784 *(char*) (buf+6) = 0xE8;
1785 *(long*) (buf+7) = (long)ffi_callback_call_x86 - (long)(buf+11);
1786 *(char*) (buf+11) = 0x59;
1787 *(char*) (buf+12) = 0x59;
1788 if (cc_type == FFI_CC_CDECL) {
1789 *(char*) (buf+13) = 0xc3;
1790 *(short*)(buf+14) = 0x9090;
1792 Lisp_Object arg_types = Fcar(Fcdr(Fcdr(data)));
1796 CHECK_CONS(arg_types);
1798 while (!NILP(arg_types)) {
1799 int sz = XINT(Fffi_size_of_type(XCAR(arg_types)));
1800 byte_size += ((sz+mask)&(~mask));
1801 arg_types = XCDR(arg_types);
1804 *(char*) (buf+13) = 0xc2;
1805 *(short*)(buf+14) = (short)byte_size;
1810 #endif /* __i386__ */
1812 DEFUN("ffi-make-callback", Fffi_make_callback, 4, 4, 0, /*
1813 Create dynamic callback and return pointer to it.
1815 (fun, rtype, argtypes, cctype))
1822 data = list3(fun, rtype, argtypes);
1823 /* Put data as property of the fun, so it(data) wont be GCed */
1824 Fput(fun, Q_ffi_callback, data);
1825 ptr = Fmake_ffi_object(Q_pointer, Qnil);
1827 XEFFIO(ptr)->fop.ptr = ffi_make_callback_x86(data, XINT(cctype));
1828 #endif /* __i386__ */
1835 INIT_LRECORD_IMPLEMENTATION(ffiobject);
1837 defsymbol(&Q_byte, "byte");
1838 defsymbol(&Q_unsigned_byte, "unsigned-byte");
1839 defsymbol(&Q_char, "char");
1840 defsymbol(&Q_unsigned_char, "unsigned-char");
1841 defsymbol(&Q_short, "short");
1842 defsymbol(&Q_unsigned_short, "unsigned-short");
1843 defsymbol(&Q_int, "int");
1844 defsymbol(&Q_unsigned_int, "unsigned-int");
1845 defsymbol(&Q_long, "long");
1846 defsymbol(&Q_unsigned_long, "unsigned-long");
1847 defsymbol(&Q_float, "float");
1848 defsymbol(&Q_double, "double");
1849 defsymbol(&Q_void, "void");
1850 defsymbol(&Q_pointer, "pointer");
1851 defsymbol(&Q_struct, "struct");
1852 defsymbol(&Q_union, "union");
1853 defsymbol(&Q_array, "array");
1854 defsymbol(&Q_function, "function");
1855 defsymbol(&Q_c_string, "c-string");
1856 defsymbol(&Q_c_data, "c-data");
1858 defsymbol(&Qffiobjectp, "ffiobjectp");
1860 defsymbol(&Qffi_translate_to_foreign, "ffi-translate-to-foreign");
1861 defsymbol(&Qffi_translate_from_foreign, "ffi-translate-from-foreign");
1863 defsymbol(&Q_ffi_callback, "ffi-callback");
1865 DEFSUBR(Fffi_basic_type_p);
1866 DEFSUBR(Fffi_canonicalise_type);
1867 DEFSUBR(Fffi_size_of_type);
1868 DEFSUBR(Fmake_ffi_object);
1869 DEFSUBR(Fffi_object_p);
1870 DEFSUBR(Fffi_make_pointer);
1871 DEFSUBR(Fffi_object_address);
1872 DEFSUBR(Fffi_object_canonical_type);
1873 DEFSUBR(Fffi_object_type);
1874 DEFSUBR(Fffi_object_size);
1875 DEFSUBR(Fffi_set_storage_size);
1876 DEFSUBR(Fffi_set_object_type);
1877 DEFSUBR(Fffi_fetch);
1879 DEFSUBR(Fffi_store);
1881 DEFSUBR(Fffi_address_of);
1882 DEFSUBR(Fffi_type_alignment);
1883 DEFSUBR(Fffi_slot_offset);
1884 DEFSUBR(Fffi_load_library);
1886 DEFSUBR(Fffi_dlerror);
1887 DEFSUBR(Fffi_defun);
1888 DEFSUBR(Fffi_call_function);
1890 DEFSUBR(Fffi_lisp_object_to_pointer);
1891 DEFSUBR(Fffi_pointer_to_lisp_object);
1892 DEFSUBR(Fffi_plist);
1894 #ifdef EF_USE_ASYNEQ
1895 DEFSUBR(Fffi_call_functionX);
1896 defsymbol(&Qffi_jobp, "ffi-job-p");
1899 DEFSUBR(Fx_device_display);
1901 DEFSUBR(Fffi_make_callback);
1905 reinit_vars_of_ffi(void)
1907 staticpro_nodump(&Vffi_all_objects);
1908 Vffi_all_objects = make_weak_list(WEAK_LIST_SIMPLE);
1914 reinit_vars_of_ffi();
1916 DEFVAR_LISP("ffi-named-types", &Vffi_named_types /*
1917 Alist of named FFI types with elements of the form (NAME . FFI-TYPE).
1919 Vffi_named_types = Qnil;
1921 DEFVAR_LISP("ffi-loaded-libraries", &Vffi_loaded_libraries /*
1922 Alist of loaded libraries with elements of the form (LIB-NAME . FFIO).
1924 Vffi_loaded_libraries = Qnil;
1926 DEFVAR_LISP("ffi-type-checker", &Vffi_type_checker /*
1927 Function to call when the validity of an FFI type shall be checked.
1929 Vffi_type_checker = intern("ffi-type-p");