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 ffi_call(&cif, (void(*)(void))XEFFIO(fo_fun)->fop.fun, rvalue,
1351 #endif /* HAVE_LIBFFI */
1353 DEFUN("ffi-call-function", Fffi_call_function, 1, MANY, 0, /*
1354 Call a function referred to by FO with arguments ARGS, maybe
1355 return a foreign object with the result or nil if there is
1358 Arguments are: FO &rest FO-ARGS
1360 FO should be a foreign binding initiated by `ffi-defun', and
1361 ARGS should be foreign data objects or pointers to these.
1363 (int nargs, Lisp_Object * args))
1365 Lisp_Object faf = Qnil, retfo = Qnil;
1366 Lisp_EffiObject *ffio;
1368 struct gcpro gcpro1, gcpro2;
1374 retfo = Fmake_ffi_object(XCAR(XCDR(ffio->type)), Qnil);
1377 ret = ffi_call_using_libffi(args[0], retfo, nargs-1, &args[1]);
1378 #endif /* HAVE_LIBFFI */
1380 RETURN_UNGCPRO(ret == 0 ? retfo : Qnil);
1383 #ifdef EF_USE_ASYNEQ
1384 /* handler for asynchronously calling ffi code */
1385 Lisp_Object Qffi_jobp;
1386 #define EFFI_DEBUG_JOB(args...)
1388 exec_sentinel_unwind(Lisp_Object UNUSED(datum))
1394 exec_sentinel(void *job, ffi_job_t ffij)
1395 __attribute__((always_inline));
1397 exec_sentinel(void *job, ffi_job_t ffij)
1399 /* This function can GC */
1400 /* called from main thread */
1401 int speccount = specpdl_depth(), nargs = ffij->sntnl_nargs, i;
1402 Lisp_Object funcell[nargs+2];
1403 struct gcpro gcpro1;
1405 funcell[0] = ffij->sntnl;
1406 funcell[1] = (Lisp_Object)job;
1407 for (i = 0; i < nargs; i++) {
1408 funcell[2+i] = ffij->sntnl_args[i];
1410 GCPROn(funcell, nargs+2);
1412 record_unwind_protect(exec_sentinel_unwind, Qnil);
1413 /* call the funcell */
1414 Ffuncall(nargs+2, funcell);
1415 /* reset to previous state */
1416 restore_match_data();
1418 unbind_to(speccount, Qnil);
1422 static inline ffi_job_t
1423 allocate_ffi_job(void)
1425 ffi_job_t ffij = xnew(struct ffi_job_s);
1426 EFFI_DEBUG_JOB("allocated: 0x%lx\n", (long unsigned int)ffij);
1430 static inline ffi_job_t
1431 make_ffi_job(Lisp_Object fof, int fof_nargs, Lisp_Object *fof_args,
1432 Lisp_Object sntnl, int sntnl_nargs, Lisp_Object *sntnl_args)
1434 /* exec'd in the main thread */
1435 ffi_job_t ffij = allocate_ffi_job();
1438 SXE_MUTEX_INIT(&ffij->mtx);
1440 if (fof_nargs > 0) {
1441 ffij->fof_nargs = fof_nargs;
1442 ffij->fof_args = xnew_array(Lisp_Object, fof_nargs);
1443 for (i = 0; i < fof_nargs; i++) {
1444 ffij->fof_args[i] = fof_args[i];
1447 ffij->fof_nargs = 0;
1448 ffij->fof_args = NULL;
1451 ffij->sntnl = sntnl;
1452 if (sntnl_nargs > 0) {
1453 ffij->sntnl_nargs = sntnl_nargs;
1454 ffij->sntnl_args = xnew_array(Lisp_Object, sntnl_nargs);
1455 for (i = 0; i < sntnl_nargs; i++) {
1456 ffij->sntnl_args[i] = sntnl_args[i];
1459 ffij->sntnl_nargs = 0;
1460 ffij->sntnl_args = NULL;
1463 ffij->result = Qnil;
1464 ffij->retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil);
1469 mark_ffi_job(worker_job_t job)
1471 ffi_job_t ffij = ffi_job(job);
1477 SXE_MUTEX_LOCK(&ffij->mtx);
1478 mark_object(ffij->fof);
1479 for (i = 0; i < ffij->fof_nargs; i++) {
1480 mark_object(ffij->fof_args[i]);
1482 mark_object(ffij->sntnl);
1483 for (i = 0; i < ffij->sntnl_nargs; i++) {
1484 mark_object(ffij->sntnl_args[i]);
1486 mark_object(ffij->retfo);
1487 mark_object(ffij->result);
1488 SXE_MUTEX_UNLOCK(&ffij->mtx);
1493 print_ffi_job(worker_job_t job, Lisp_Object pcf)
1495 ffi_job_t ffij = ffi_job(job);
1496 char *str = alloca(64);
1498 SXE_MUTEX_LOCK(&ffij->mtx);
1499 WRITE_C_STRING(" carrying ", pcf);
1500 snprintf(str, 63, " #<ffi-job 0x%lx>", (long unsigned int)ffij);
1501 WRITE_C_STRING(str, pcf);
1502 SXE_MUTEX_UNLOCK(&ffij->mtx);
1507 finish_ffi_job_data(ffi_job_t ffij)
1509 SXE_MUTEX_LOCK(&ffij->mtx);
1510 xfree(ffij->fof_args);
1511 xfree(ffij->sntnl_args);
1512 SXE_MUTEX_UNLOCK(&ffij->mtx);
1513 SXE_MUTEX_FINI(&ffij->mtx);
1515 EFFI_DEBUG_JOB("finished: 0x%lx\n", (long unsigned int)ffij);
1520 finish_ffi_job(worker_job_t job)
1524 lock_worker_job(job);
1525 ffij = ffi_job(job);
1528 finish_ffi_job_data(ffij);
1530 worker_job_data(job) = NULL;
1531 unlock_worker_job(job);
1536 ffi_job_handle(worker_job_t job)
1539 /* usually called from aux threads */
1541 Lisp_Object fof = Qnil, retfo = Qnil, *args = NULL;
1542 int nargs, ret = -1;
1544 lock_worker_job(job);
1545 ffij = ffi_job(job);
1546 unlock_worker_job(job);
1547 SXE_MUTEX_LOCK(&ffij->mtx);
1549 nargs = ffij->fof_nargs;
1550 args = ffij->fof_args;
1551 SXE_MUTEX_UNLOCK(&ffij->mtx);
1553 /* can't ... Fmake_ffi_object is not mt-safe */
1554 /* retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil); */
1555 retfo = ffij->retfo;
1558 ret = ffi_call_using_libffi(fof, retfo, nargs, args);
1559 #endif /* HAVE_LIBFFI */
1561 SXE_MUTEX_LOCK(&ffij->mtx);
1562 ffij->result = retfo;
1563 SXE_MUTEX_UNLOCK(&ffij->mtx);
1566 EFFI_DEBUG_JOB("job 0x%lx succeeded\n", (long unsigned int)ffij);
1571 ffi_job_finished(worker_job_t job)
1573 if (NILP(ffi_job_sentinel(job) /* sentinel */)) {
1576 /* called from main thread */
1577 exec_sentinel(job, ffi_job(job));
1581 static struct work_handler_s ffi_job_handler = {
1582 mark_ffi_job, print_ffi_job, finish_ffi_job,
1583 ffi_job_handle, NULL, ffi_job_finished
1587 make_ffi_asyneq_job(ffi_job_t ffij)
1589 /* create a job digestible by the asyneq */
1590 Lisp_Object job = Qnil;
1591 struct gcpro gcpro1;
1594 job = wrap_object(make_worker_job(&ffi_job_handler));
1595 XWORKER_JOB_DATA(job) = ffij;
1596 /* the scratch buffer thingie */
1601 DEFUN("ffi-call-function&", Fffi_call_functionX, 1, MANY, 0, /*
1602 Call a function referred to by FO with arguments ARGS asynchronously,
1603 return a job object.
1605 Arguments are: FO &rest FO-ARGS &aux SENTINEL &rest SENTINEL-ARGS
1607 FO should be a foreign binding initiated by `ffi-defun'.
1608 FO-ARGS should be exactly as many foreign data objects as FO needs.
1609 SENTINEL is a lisp sentinel function called when the job finished,
1610 the function should take at least one argument JOB, further arguments
1611 may be specified by passing further SENTINEL-ARGS.
1613 (int nargs, Lisp_Object *args))
1615 Lisp_Object job = Qnil;
1616 Lisp_Object sntnl, fof, *sntnl_args, *fof_args;
1617 int sntnl_nargs, fof_nargs;
1619 struct gcpro gcpro1, gcpro2;
1621 CHECK_EFFIO(args[0]);
1622 GCPRO1n(job, args, nargs);
1625 /* determine how many args belong to the fof */
1626 fof_nargs = XINT(Flength(XCDR(XEFFIO(fof)->type)))-1;
1627 fof_args = &args[1];
1629 if ((sntnl_nargs = nargs - fof_nargs - 2) >= 0) {
1630 sntnl = args[fof_nargs+1];
1631 sntnl_args = &args[fof_nargs+2];
1637 /* create the job data object */
1638 ffij = make_ffi_job(fof, fof_nargs, fof_args,
1639 sntnl, sntnl_nargs, sntnl_args);
1640 /* now prepare the job to dispatch */
1641 job = make_ffi_asyneq_job(ffij);
1642 /* ... and dispatch it, change its state to queued */
1643 XWORKER_JOB_STATE(job) = WORKER_JOB_QUEUED;
1644 eq_enqueue(delegate_eq, job);
1645 /* brag about new jobs in the queue */
1646 eq_queue_trigger_all(delegate_eq);
1651 #endif /* EF_USE_ASYNEQ */
1653 extern struct device *decode_x_device(Lisp_Object device);
1655 DEFUN("x-device-display", Fx_device_display, 0, 1, 0, /*
1656 Return DEVICE display as FFI object.
1663 fo = Fmake_ffi_object(Q_pointer, Qnil);
1664 XEFFIO(fo)->fotype = EFFI_FOT_BIND;
1665 XEFFIO(fo)->fop.ptr = (void*)DEVICE_X_DISPLAY(decode_x_device(device));
1673 #define FFI_CC_CDECL 0
1675 #if defined __i386__
1677 ffi_callback_call_x86(Lisp_Object cbk_info, char *arg_buffer)
1679 Lisp_Object fun, alist = Qnil, retlo, foret;
1680 Lisp_Object rtype, argtypes;
1681 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1684 fun = Fcar(cbk_info);
1685 rtype = Fcar(Fcdr(cbk_info));
1686 argtypes = Fcar(Fcdr(Fcdr(cbk_info)));
1688 CHECK_LIST(argtypes);
1690 arg_buffer += 4; /* Skip return address */
1691 while (!NILP(argtypes)) {
1692 Lisp_Object result, ctype;
1695 ctype = ffi_canonicalise_type(XCAR(argtypes));
1696 size = XINT(Fffi_size_of_type(ctype));
1697 if (EQ(ctype, Q_c_string)) {
1698 char *aptr = *(char**)arg_buffer;
1700 result = ffi_fetch_foreign(aptr, ctype);
1704 result = ffi_fetch_foreign(arg_buffer, ctype);
1705 /* Apply translators and put the result into alist */
1706 result = apply1(Findirect_function(Qffi_translate_from_foreign),
1707 list2(result, XCAR(argtypes)));
1708 alist = Fcons(result, alist);
1711 int sp = (size + mask) & ~mask;
1714 argtypes = XCDR(argtypes);
1716 alist = Fnreverse(alist);
1718 /* Special case, we have no return value */
1719 if (EQ(rtype, Q_void)) {
1720 GCPRO3(fun, alist, rtype);
1726 GCPRO5(fun, alist, rtype, retlo, foret);
1727 retlo = apply1(fun, alist);
1728 foret = Fmake_ffi_object(rtype, Qnil);
1729 Fffi_store(foret, make_int(0), rtype, retlo);
1730 ptr = (void*)XEFFIO(foret)->fop.ptr;
1731 if (EQ(rtype, Q_double)) {
1734 asm volatile ("fldl (%0)" :: "a" (ptr));
1737 } else if (EQ(rtype, Q_float)) {
1740 asm volatile ("flds (%0)" :: "a" (ptr));
1746 if (EQ(rtype, Q_byte) || EQ(rtype, Q_char))
1748 else if (EQ(rtype, Q_unsigned_byte) || EQ(rtype, Q_unsigned_char))
1749 iv = *(char unsigned*)ptr;
1750 else if (EQ(rtype, Q_short))
1752 else if (EQ(rtype, Q_unsigned_short))
1753 iv = *(unsigned short*)ptr;
1758 asm volatile ("movl %0,%%eax;" :: "r" (iv) : "%eax");
1765 ffi_make_callback_x86(Lisp_Object data, int cc_type)
1769 * pushl <data> 68 <addr32>
1770 * call ffi_callback_call_x86 E8 <disp32>
1778 char *buf = xmalloc(sizeof(char)*16);
1779 *(char*) (buf+0) = 0x54;
1780 *(char*) (buf+1) = 0x68;
1781 *(long*) (buf+2) = (long)data;
1782 *(char*) (buf+6) = 0xE8;
1783 *(long*) (buf+7) = (long)ffi_callback_call_x86 - (long)(buf+11);
1784 *(char*) (buf+11) = 0x59;
1785 *(char*) (buf+12) = 0x59;
1786 if (cc_type == FFI_CC_CDECL) {
1787 *(char*) (buf+13) = 0xc3;
1788 *(short*)(buf+14) = 0x9090;
1790 Lisp_Object arg_types = Fcar(Fcdr(Fcdr(data)));
1794 CHECK_CONS(arg_types);
1796 while (!NILP(arg_types)) {
1797 int sz = XINT(Fffi_size_of_type(XCAR(arg_types)));
1798 byte_size += ((sz+mask)&(~mask));
1799 arg_types = XCDR(arg_types);
1802 *(char*) (buf+13) = 0xc2;
1803 *(short*)(buf+14) = (short)byte_size;
1808 #endif /* __i386__ */
1810 DEFUN("ffi-make-callback", Fffi_make_callback, 4, 4, 0, /*
1811 Create dynamic callback and return pointer to it.
1813 (fun, rtype, argtypes, cctype))
1820 data = list3(fun, rtype, argtypes);
1821 /* Put data as property of the fun, so it(data) wont be GCed */
1822 Fput(fun, Q_ffi_callback, data);
1823 ptr = Fmake_ffi_object(Q_pointer, Qnil);
1825 XEFFIO(ptr)->fop.ptr = ffi_make_callback_x86(data, XINT(cctype));
1826 #endif /* __i386__ */
1833 INIT_LRECORD_IMPLEMENTATION(ffiobject);
1835 defsymbol(&Q_byte, "byte");
1836 defsymbol(&Q_unsigned_byte, "unsigned-byte");
1837 defsymbol(&Q_char, "char");
1838 defsymbol(&Q_unsigned_char, "unsigned-char");
1839 defsymbol(&Q_short, "short");
1840 defsymbol(&Q_unsigned_short, "unsigned-short");
1841 defsymbol(&Q_int, "int");
1842 defsymbol(&Q_unsigned_int, "unsigned-int");
1843 defsymbol(&Q_long, "long");
1844 defsymbol(&Q_unsigned_long, "unsigned-long");
1845 defsymbol(&Q_float, "float");
1846 defsymbol(&Q_double, "double");
1847 defsymbol(&Q_void, "void");
1848 defsymbol(&Q_pointer, "pointer");
1849 defsymbol(&Q_struct, "struct");
1850 defsymbol(&Q_union, "union");
1851 defsymbol(&Q_array, "array");
1852 defsymbol(&Q_function, "function");
1853 defsymbol(&Q_c_string, "c-string");
1854 defsymbol(&Q_c_data, "c-data");
1856 defsymbol(&Qffiobjectp, "ffiobjectp");
1858 defsymbol(&Qffi_translate_to_foreign, "ffi-translate-to-foreign");
1859 defsymbol(&Qffi_translate_from_foreign, "ffi-translate-from-foreign");
1861 defsymbol(&Q_ffi_callback, "ffi-callback");
1863 DEFSUBR(Fffi_basic_type_p);
1864 DEFSUBR(Fffi_canonicalise_type);
1865 DEFSUBR(Fffi_size_of_type);
1866 DEFSUBR(Fmake_ffi_object);
1867 DEFSUBR(Fffi_object_p);
1868 DEFSUBR(Fffi_make_pointer);
1869 DEFSUBR(Fffi_object_address);
1870 DEFSUBR(Fffi_object_canonical_type);
1871 DEFSUBR(Fffi_object_type);
1872 DEFSUBR(Fffi_object_size);
1873 DEFSUBR(Fffi_set_storage_size);
1874 DEFSUBR(Fffi_set_object_type);
1875 DEFSUBR(Fffi_fetch);
1877 DEFSUBR(Fffi_store);
1879 DEFSUBR(Fffi_address_of);
1880 DEFSUBR(Fffi_type_alignment);
1881 DEFSUBR(Fffi_slot_offset);
1882 DEFSUBR(Fffi_load_library);
1884 DEFSUBR(Fffi_dlerror);
1885 DEFSUBR(Fffi_defun);
1886 DEFSUBR(Fffi_call_function);
1888 DEFSUBR(Fffi_lisp_object_to_pointer);
1889 DEFSUBR(Fffi_pointer_to_lisp_object);
1890 DEFSUBR(Fffi_plist);
1892 #ifdef EF_USE_ASYNEQ
1893 DEFSUBR(Fffi_call_functionX);
1894 defsymbol(&Qffi_jobp, "ffi-job-p");
1897 DEFSUBR(Fx_device_display);
1899 DEFSUBR(Fffi_make_callback);
1903 reinit_vars_of_ffi(void)
1905 staticpro_nodump(&Vffi_all_objects);
1906 Vffi_all_objects = make_weak_list(WEAK_LIST_SIMPLE);
1912 reinit_vars_of_ffi();
1914 DEFVAR_LISP("ffi-named-types", &Vffi_named_types /*
1915 Alist of named FFI types with elements of the form (NAME . FFI-TYPE).
1917 Vffi_named_types = Qnil;
1919 DEFVAR_LISP("ffi-loaded-libraries", &Vffi_loaded_libraries /*
1920 Alist of loaded libraries with elements of the form (LIB-NAME . FFIO).
1922 Vffi_loaded_libraries = Qnil;
1924 DEFVAR_LISP("ffi-type-checker", &Vffi_type_checker /*
1925 Function to call when the validity of an FFI type shall be checked.
1927 Vffi_type_checker = intern("ffi-type-p");