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 WRITE_FMT_STRING(x,y,...) write_fmt_string((x),(y),__VA_ARGS__)
59 # define LRECORD_DESCRIPTION lrecord_description
61 # define SIGNAL_ERROR Fsignal
62 # define FFIBYTE Ibyte
63 # define WRITE_C_STRING(x,y) write_c_string((y),(x))
64 # define WRITE_FMT_STRING(x,y,...) \
67 int wcss = snprintf(wcsb, sizeof(wcsb), \
69 write_c_string((y),wcsb); \
71 # define LRECORD_DESCRIPTION memory_description
76 * byte, ubyte, char, uchar,
77 * short, ushort, int, uint,
80 * void, pointer, c-string
84 * (function RET-TYPE IN-TYPE .. IN-TYPE)
90 * Structures and unions types:
100 * pointer or (pointer TYPE)
104 Lisp_Object Q_byte, Q_unsigned_byte;
105 Lisp_Object Q_char, Q_unsigned_char;
106 Lisp_Object Q_short, Q_unsigned_short;
107 Lisp_Object Q_int, Q_unsigned_int;
108 Lisp_Object Q_long, Q_unsigned_long;
109 Lisp_Object Q_float, Q_double;
111 Lisp_Object Q_array, Q_pointer;
112 Lisp_Object Q_union, Q_struct;
113 Lisp_Object Q_function;
114 Lisp_Object Q_c_string, Q_c_data;
116 #define FFI_POINTERP(type) (EQ(type, Q_pointer) \
117 || (CONSP(type) && EQ(XCAR(type), Q_pointer)))
119 #define FFI_TPTR(type) (EQ(type, Q_c_string) \
120 || EQ(type, Q_c_data) \
121 || FFI_POINTERP(type) \
122 || (CONSP(type) && ((EQ(XCAR(type), Q_c_data)) \
123 || EQ(XCAR(type), Q_array))))
125 Lisp_Object Qffiobjectp;
126 Lisp_Object Qffi_translate_to_foreign;
127 Lisp_Object Qffi_translate_from_foreign;
129 /* Alist with elements in form (NAME . TYPE) */
130 Lisp_Object Vffi_loaded_libraries;
131 Lisp_Object Vffi_named_types;
133 Lisp_Object Vffi_type_checker;
135 static Lisp_Object Vffi_all_objects;
137 Lisp_Object Q_ffi_callback;
140 mark_ffiobject(Lisp_Object obj)
142 Lisp_EffiObject *ffio = XEFFIO(obj);
143 mark_object(ffio->type);
144 mark_object(ffio->size);
145 mark_object(ffio->plist);
146 return (ffio->plist);
150 print_ffiobject(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
152 /* This function can GC */
153 Lisp_EffiObject *ffio = XEFFIO(obj);
154 escapeflag = escapeflag; /* shutup compiler */
155 if (print_readably) {
157 error("printing unreadable object #<ffiobject 0x%x>",
160 signal_ferror(Qinternal_error,
161 "printing unreadable object #<ffiobject 0x%x>",
165 WRITE_C_STRING("#<ffiobject ", printcharfun);
166 /* Print FFIO type */
167 if (!NILP(ffio->type)) {
168 WRITE_C_STRING("type=", printcharfun);
169 print_internal(ffio->type, printcharfun, 1);
170 WRITE_C_STRING(" ", printcharfun);
172 WRITE_FMT_STRING(printcharfun,"size=%ld fotype=%d foptr=%p>",
173 (long)XINT(ffio->size), ffio->fotype, ffio->fop.generic);
176 static const struct LRECORD_DESCRIPTION ffiobject_description[] = {
177 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, type)},
178 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, size)},
179 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, plist)},
180 {XD_INT, offsetof(Lisp_EffiObject, fotype)},
181 {XD_OPAQUE_PTR, offsetof(Lisp_EffiObject, fop)},
183 {XD_SIZE_T, offsetof(Lisp_EffiObject, storage_size)},
185 {XD_ELEMCOUNT, offsetof(Lisp_EffiObject, storage_size)},
191 ffi_getprop(Lisp_Object fo, Lisp_Object property)
193 return external_plist_get(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
197 ffi_putprop(Lisp_Object fo, Lisp_Object property, Lisp_Object value)
199 external_plist_put(&XEFFIO(fo)->plist, property, value, 0, ERROR_ME);
204 ffi_remprop(Lisp_Object fo, Lisp_Object property)
206 return external_remprop(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
211 sizeof_ffiobject(const void *header)
213 const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
214 return (sizeof(Lisp_EffiObject) + effio->storage_size);
218 sizeof_ffiobject(const void *header)
220 const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
221 return (sizeof(Lisp_EffiObject) + effio->storage_size);
225 /* Define ffiobject implementation */
226 const struct lrecord_implementation lrecord_ffiobject = {
228 .marker = mark_ffiobject,
229 .printer = print_ffiobject,
233 .description = ffiobject_description,
234 .getprop = ffi_getprop,
235 .putprop = ffi_putprop,
236 .remprop = ffi_remprop,
239 .size_in_bytes_method = sizeof_ffiobject,
240 .lrecord_type_index = lrecord_type_ffiobject,
245 /** alignment in union and structures **/
249 * - An entire structure or union is aligned on the same boundary as
250 * its most strictly aligned member.
252 * - Each member is assigned to the lowest available offset with the
253 * appropriate alignment. This may require /internal padding/,
254 * depending on the previous member.
256 * - A structure's size is increased, if necessary, to make it a
257 * multiple of the alignment. This may require /tail padding/,
258 * depending on the last member.
263 * char c; .-------2+---1+---0.
264 * short s; | s |pad | c |
265 * } `--------+----+----'
267 * Internal and Tail padding:
269 * struct { .------------1+---0.
270 * char c; | pad | c |
271 * double d; |-------------+---4|
273 * } |-----------------8|
275 * |------14+-------12|
277 * `--------+---------'
281 * union { .------------1+---0.
282 * char c; | pad | c |
283 * short s; |-------2+----+---0|
285 * } |--------+--------0|
287 * `------------------'
290 ffi_check_type(Lisp_Object type)
292 return apply1(Vffi_type_checker, Fcons(type, Fcons(Qt, Qnil)));
295 DEFUN("ffi-basic-type-p", Fffi_basic_type_p, 1, 1, 0, /*
296 Return non-nil if TYPE is a basic FFI type.
298 A type is said to be basic, if it is neither a pointer nor a
299 function, and there is a corresponding built-in type in C.
303 if (EQ(type, Q_byte) || EQ(type, Q_unsigned_byte) || EQ(type, Q_char)
304 || EQ(type, Q_unsigned_char) || EQ(type, Q_short)
305 || EQ(type, Q_unsigned_short) || EQ(type, Q_int)
306 || EQ(type, Q_unsigned_int) || EQ(type, Q_long)
307 || EQ(type, Q_unsigned_long) || EQ(type, Q_float)
308 || EQ(type, Q_double) || EQ(type, Q_void)
309 || EQ(type, Q_c_string) || EQ(type, Q_c_data)
310 || (CONSP(type) && EQ(XCAR(type), Q_c_data)))
318 ffi_canonicalise_type(Lisp_Object type)
320 /* this function canNOT GC */
322 while (!NILP(type) && NILP(Fffi_basic_type_p(type)) && SYMBOLP(type)) {
323 if EQ(type, Q_pointer)
325 type = Fcdr(Fassq(type, Vffi_named_types));
331 DEFUN("ffi-canonicalise-type", Fffi_canonicalise_type, 1, 1, 0, /*
332 Return FFI type TYPE in a canonical form.
336 Lisp_Object canon_type = ffi_canonicalise_type(type);
337 if (NILP(canon_type)) {
339 signal_simple_error("No such FFI type", type);
341 signal_error(Qinternal_error, "No such FFI type", type);
347 DEFUN("ffi-size-of-type", Fffi_size_of_type, 1, 1, 0, /*
348 Return the size of the foreign type TYPE.
350 Valid foreign types are: `byte', `unsigned-byte', `char',
351 `unsigned-char', `short', `unsigned-short', `int', `unsigned-int',
352 `long', `unsigned-long', `pointer', `float', `double',
353 `object', and `c-string'.
359 type = ffi_canonicalise_type(type);
360 if (EQ(type, Q_void))
362 else if (EQ(type, Q_byte))
363 tsize = sizeof(int8_t);
364 else if (EQ(type, Q_unsigned_byte))
365 tsize = sizeof(uint8_t);
366 else if (EQ(type, Q_char))
367 tsize = sizeof(char);
368 else if (EQ(type, Q_unsigned_char))
369 tsize = sizeof(unsigned char);
370 else if (EQ(type, Q_short))
371 tsize = sizeof(short);
372 else if (EQ(type, Q_unsigned_short))
373 tsize = sizeof(unsigned short);
374 else if (EQ(type, Q_int))
376 else if (EQ(type, Q_unsigned_int))
377 tsize = sizeof(unsigned int);
378 else if (EQ(type, Q_long))
379 tsize = sizeof(long);
380 else if (EQ(type, Q_unsigned_long))
381 tsize = sizeof(unsigned long);
382 else if (EQ(type, Q_float))
383 tsize = sizeof(float);
384 else if (EQ(type, Q_double))
385 tsize = sizeof(double);
386 else if (EQ(type, Q_c_string))
387 tsize = sizeof(char *);
388 else if (FFI_POINTERP(type))
389 tsize = sizeof(void *);
390 else if (EQ(type, Q_c_data))
391 tsize = sizeof(void *);
392 else if (CONSP(type) && EQ(XCAR(type), Q_c_data)) {
393 Lisp_Object cdsize = XCDR(type);
395 tsize = XINT(cdsize);
396 } else if (CONSP(type) && EQ(XCAR(type), Q_function))
397 tsize = sizeof(void(*));
398 else if (CONSP(type) && EQ(XCAR(type), Q_array)) {
399 Lisp_Object atype = Fcar(XCDR(type));
400 Lisp_Object asize = Fcar(Fcdr(XCDR(type)));
403 tsize = XINT(asize) * XINT(Fffi_size_of_type(atype));
404 } else if (CONSP(type) && EQ(XCAR(type), Q_struct)) {
405 return Fffi_slot_offset(type, Qnil);
406 } else if (CONSP(type) && EQ(XCAR(type), Q_union)) {
407 Lisp_Object slots = Fcdr(XCDR(type));
412 while (!NILP(slots)) {
413 Lisp_Object slot_type = Fcar(Fcdr(XCAR(slots)));
414 int slot_size = XINT(Fffi_size_of_type(slot_type));
415 if (slot_size > tsize)
421 signal_simple_error("Unrecognized foreign type", type);
423 signal_error(Qinternal_error, "Unrecognized foreign type", type);
427 return make_int(tsize);
430 DEFUN("make-ffi-object", Fmake_ffi_object, 1, 2, 0, /*
431 Create a new FFI object of type TYPE.
432 If optional argument SIZE is non-nil it should be an
433 integer, in this case additional storage size to hold data
434 of at least length SIZE is allocated.
440 Lisp_Object result = Qnil;
441 Lisp_EffiObject *ffio;
446 /* NOTE: ffi_check_type returns canonical type */
447 ctype = ffi_check_type(type);
449 size = Fffi_size_of_type(type);
452 if (CONSP(ctype) && EQ(XCAR(ctype), Q_c_data) && INTP(XCDR(ctype)))
455 cs_or_cd = EQ(ctype, Q_c_string) || (EQ(ctype, Q_c_data));
456 if ((cs_or_cd && (XINT(size) < 1))
457 || (!(cs_or_cd || FFI_POINTERP(ctype))
458 && (XINT(size) < XINT(Fffi_size_of_type(type)))))
460 signal_simple_error("storage size too small to store type",
463 ffio = alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
465 XSETEFFIO(result, ffio);
467 signal_error(Qinternal_error,
468 "storage size too small to store type",
471 ffio = old_basic_alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
473 result = wrap_effio(ffio);
476 ffio->size = Fffi_size_of_type(type);
480 /* Initialize foreign pointer */
481 ffio->fotype = EFFI_FOT_NONE;
482 ffio->storage_size = XINT(size);
483 ffio->fop.ptr = ffio->fostorage;
485 if (!NILP(Vffi_all_objects))
486 XWEAK_LIST_LIST(Vffi_all_objects) =
487 Fcons(result, XWEAK_LIST_LIST(Vffi_all_objects));
489 RETURN_UNGCPRO(result);
492 DEFUN("ffi-object-p", Fffi_object_p, 1, 1, 0, /*
493 Return non-nil if FO is an FFI object, nil otherwise.
497 return (EFFIOP(fo) ? Qt : Qnil);
500 DEFUN("ffi-object-address", Fffi_object_address, 1, 1, 0, /*
501 Return the address FO points to.
506 return make_float((long)XEFFIO(fo)->fop.ptr);
509 DEFUN("ffi-make-pointer", Fffi_make_pointer, 1, 1, 0, /*
510 "Return a pointer pointing to ADDRESS."
518 addr = XINT(address);
519 else if (FLOATP(address))
520 addr = XFLOATINT(address);
523 signal_simple_error("FFI: invalid address type", address);
525 signal_error(Qinternal_error, "FFI: invalid address type",
530 ptr = Fmake_ffi_object(Q_pointer, Qnil);
531 XEFFIO(ptr)->fop.ptr = (void*)addr;
535 DEFUN("ffi-object-canonical-type", Fffi_object_canonical_type, 1, 1, 0, /*
536 Return FO's real type, that is after resolving user defined types.
541 return ffi_canonicalise_type(XEFFIO(fo)->type);
544 DEFUN("ffi-object-type", Fffi_object_type, 1, 1, 0, /*
550 return (XEFFIO(fo)->type);
553 DEFUN("ffi-set-object-type", Fffi_set_object_type, 2, 2, 0, /*
554 Cast FO to type TYPE and reassign the cast value.
560 ffi_check_type(type);
561 XEFFIO(fo)->type = type;
566 DEFUN("ffi-object-size", Fffi_object_size, 1, 1, 0, /*
567 Return the size of the allocated space of FO.
572 return (XEFFIO(fo)->size);
575 DEFUN("ffi-set-storage-size", Fffi_set_storage_size, 2, 2, 0, /*
576 Set the size of the allocated space of FO.
582 XEFFIO(fo)->storage_size = XUINT(size);
586 DEFUN("ffi-load-library", Fffi_load_library, 1, 1, 0, /*
587 Load library LIBNAME and return a foreign object handle if successful,
588 or `nil' if the library cannot be loaded.
590 The argument LIBNAME should be the file-name string of a shared object
591 library. Normally you should omit the file extension, as this
592 function will add the appripriate extension for the current platform
595 The library should reside in one of the directories specified by the
596 $LD_LIBRARY_PATH environment variable or the more global ld.so.cache.
601 #ifdef LTDL_SHLIB_EXT
602 # define EXT LTDL_SHLIB_EXT
603 #elif defined(HAVE_DYLD) || defined(HAVE_MACH_O_DYLD_H)
604 # define EXT ".dylib"
607 #endif /* LTDL_SHLIB_EXT */
609 void *handler, *dotpos;
610 Lisp_Object fo = Qnil;
611 Lisp_EffiObject *ffio;
615 CHECK_STRING(libname);
617 /* Add an extension if we need to */
618 dotpos = strrchr((char *)XSTRING_DATA(libname),'.');
619 if ( dotpos == NULL || strncmp(dotpos, EXT, sizeof(EXT))) {
620 ssize_t liblen = XSTRING_LENGTH(libname);
621 ssize_t soname_len = liblen + sizeof(EXT);
622 soname = xmalloc( soname_len + 1);
623 strncpy(soname, (char *)XSTRING_DATA(libname), liblen+1);
624 strncat(soname, EXT, sizeof(EXT)+1);
627 if ( soname == NULL ) {
628 handler = dlopen((const char *)XSTRING_DATA(libname),
629 RTLD_GLOBAL|RTLD_NOW);
631 handler = dlopen(soname, RTLD_GLOBAL|RTLD_NOW);
639 fo = Fmake_ffi_object(Q_pointer, Qnil);
642 ffio->fotype = EFFI_FOT_BIND;
643 ffio->fop.ptr = handler;
648 DEFUN("ffi-bind", Fffi_bind, 2, 2, 0, /*
649 Make and return a foreign object of type TYPE and bind it to the
652 The argument TYPE can be any type-cell.
653 The argument SYM should be a string naming an arbitrary symbol
654 in one of the loaded libraries.
656 If SYM does not exist in any of the loaded libraries, `nil' is
661 Lisp_Object fo = Qnil;
662 Lisp_EffiObject *ffio;
665 ffi_check_type(type);
669 fo = Fmake_ffi_object(type, Qnil);
671 ffio->fop.ptr = dlsym(RTLD_DEFAULT, (const char*)XSTRING_DATA(sym));
672 if (ffio->fop.ptr == NULL) {
677 ffio->fotype = EFFI_FOT_BIND;
682 DEFUN("ffi-dlerror", Fffi_dlerror, 0, 0, 0, /*
683 Return dl error string.
687 const char *dles = dlerror();
689 if (LIKELY(dles != NULL)) {
690 size_t sz = strlen(dles);
691 return make_ext_string((const Extbyte*)dles, sz, EFFI_CODING);
697 DEFUN("ffi-defun", Fffi_defun, 2, 2, 0, /*
698 Make and return a foreign object of type TYPE and bind it to the
701 The argument TYPE should be a function type-cell.
702 The argument SYM should be a string naming a function in one of
703 the loaded libraries.
705 If SYM does not exist in any of the loaded libraries, an error
708 This is like `ffi-bind' but for function objects.
712 Lisp_Object fo = Qnil;
713 Lisp_EffiObject *ffio;
716 ffi_check_type(type);
721 fo = Fmake_ffi_object(type, Qnil);
723 ffio->fop.fun = dlsym(RTLD_DEFAULT, (const char *)XSTRING_DATA(sym));
724 if (ffio->fop.fun == NULL) {
726 signal_simple_error("Can't define function", sym);
728 signal_error(Qinternal_error, "Can't define function", sym);
732 ffio->fotype = EFFI_FOT_FUNC;
738 * Return alignment policy for struct or union FFI_SU.
739 * x86: Return 1, 2 or 4.
740 * mips: Return 1, 2, 4 or 8.
743 ffi_type_align(Lisp_Object type)
745 type = ffi_canonicalise_type(type);
747 if (EQ(type, Q_byte) || EQ(type, Q_unsigned_byte)
748 || EQ(type, Q_char) || EQ(type, Q_unsigned_char))
750 if (EQ(type, Q_short) || EQ(type, Q_unsigned_short))
753 if (EQ(type, Q_double))
755 #endif /* FFI_MIPS */
758 } else if (CONSP(type)
759 && (EQ(XCAR(type), Q_struct) || EQ(XCAR(type), Q_union))) {
762 for (al = 0, type = Fcdr(Fcdr(type));
766 Lisp_Object stype = Fcar(Fcdr(Fcar(type)));
767 int tmp_al = ffi_type_align(stype);
779 DEFUN("ffi-type-alignment", Fffi_type_alignment, 1, 1, 0, /*
780 Return TYPE alignment.
784 return make_int(ffi_type_align(type));
787 DEFUN("ffi-slot-offset", Fffi_slot_offset, 2, 2, 0, /*
788 Return the offset of SLOT in TYPE.
789 SLOT can be either a valid (named) slot in TYPE or `nil'.
790 If SLOT is `nil' return the size of the struct.
795 int lpad, align, retoff;
797 type = ffi_canonicalise_type(type);
800 error("Not struct or union");
802 Fsignal(Qwrong_type_argument,
803 list2(Qstringp, build_string("Not struct or union")));
808 lpad = align = ffi_type_align(type);
809 slots = Fcdr(XCDR(type));
811 while (!NILP(slots)) {
812 Lisp_Object tmp_slot = Fcar(Fcdr(XCAR(slots)));
818 * - for basic types TMP_ALIGN and TMP_SIZE are equal
820 tmp_align = ffi_type_align(tmp_slot);
822 if (EQ(XCAR(XCAR(slots)), slot)) {
824 /* TODO: add support for :offset keyword in SLOT */
825 if (lpad < tmp_align) {
833 tmp_size = XINT(Fffi_size_of_type(tmp_slot));
834 while (tmp_size > 0) {
835 if (lpad < tmp_align) {
839 tmp_size -= tmp_align;
846 if (NILP(slots) && !NILP(slot)) {
848 signal_simple_error("FFI: Slot not found", slot);
850 signal_error(Qinternal_error, "FFI: Slot not found", slot);
853 return make_int(retoff + lpad);
857 * TYPE must be already canonicalised
860 ffi_fetch_foreign(void *ptr, Lisp_Object type)
862 /* this function canNOT GC */
863 Lisp_Object retval = Qnone;
865 if (EQ(type, Q_char))
866 retval = make_char(*(char*)ptr);
867 else if (EQ(type, Q_unsigned_char))
868 retval = make_char(*(char unsigned*)ptr);
869 else if (EQ(type, Q_byte))
870 retval = make_int(*(char*)ptr);
871 else if (EQ(type, Q_unsigned_byte))
872 retval = make_int(*(unsigned char*)ptr);
873 else if (EQ(type, Q_short))
874 retval = make_int(*(short*)ptr);
875 else if (EQ(type, Q_unsigned_short))
876 retval = make_int(*(unsigned short*)ptr);
877 else if (EQ(type, Q_int))
878 retval = make_int(*(int*)ptr);
879 else if (EQ(type, Q_unsigned_int))
880 retval = make_int(*(unsigned int*)ptr);
881 else if (EQ(type, Q_long))
882 retval = make_int(*(long*)ptr);
883 else if (EQ(type, Q_unsigned_long))
884 retval = make_int(*(unsigned long*)ptr);
885 else if (EQ(type, Q_float))
886 retval = make_float(*(float*)ptr);
887 else if (EQ(type, Q_double))
888 retval = make_float(*(double*)ptr);
889 else if (EQ(type, Q_c_string)) {
890 retval = build_ext_string((char*)ptr, Qbinary);
891 } else if (EQ(type, Q_void)) {
893 } else if (FFI_POINTERP(type)) {
894 retval = Fmake_ffi_object(type, Qnil);
895 XEFFIO(retval)->fop.ptr = *(void**)ptr;
896 } else if (CONSP(type) && EQ(XCAR(type), Q_function)) {
897 retval = Fmake_ffi_object(type, Qnil);
898 XEFFIO(retval)->fop.fun = (void*)ptr;
899 XEFFIO(retval)->fotype = EFFI_FOT_FUNC;
905 DEFUN("ffi-fetch", Fffi_fetch, 3, 3, 0, /*
906 Fetch value from the foreign object FO from OFFSET position.
907 TYPE specifies value for data to be fetched.
911 Lisp_Object origtype = type;
912 Lisp_Object retval = Qnil;
913 Lisp_EffiObject *ffio;
921 ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
923 type = ffi_canonicalise_type(type);
926 /* Fetch value and translate it according to translators */
927 retval = ffi_fetch_foreign(ptr, type);
928 if (EQ(retval, Qnone)) {
929 /* Special case for c-data */
930 if (EQ(type, Q_c_data) ||
931 (CONSP(type) && EQ(XCAR(type), Q_c_data)))
934 if (EQ(type, Q_c_data)) {
935 tlen = ffio->storage_size - XINT(offset);
937 CHECK_INT(XCDR(type));
938 tlen = XUINT(XCDR(type));
941 retval = make_ext_string(ptr, tlen, Qbinary);
944 signal_simple_error("Can't fetch for this type", origtype);
946 signal_error(Qinternal_error, "Can't fetch for this type",
951 retval = apply1(Findirect_function(Qffi_translate_from_foreign),
952 list2(retval, origtype));
954 RETURN_UNGCPRO(retval);
957 DEFUN("ffi-aref", Fffi_aref, 2, 2, 0, /*
958 Return the element of FARRAY at index IDX (starting with 0).
967 type = ffi_canonicalise_type(XEFFIO(farray)->type);
968 if (!FFI_TPTR(type)) {
970 signal_simple_error("Not an array type", type);
972 signal_error(Qinternal_error, "Not an array type", type);
975 if (EQ(type, Q_c_string))
978 type = Fcar(XCDR(type));
980 return Fffi_fetch(farray,
981 make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
985 DEFUN("ffi-store", Fffi_store, 4, 4, 0, /*
986 For foreign object FO at specified OFFSET store data.
987 Type of data is specified by VAL-TYPE and data itself specified in VAL.
989 VAL-TYPE can be either a basic FFI type or an FFI pointer.
990 If VAL-TYPE is a basic FFI type, then VAL can be an
991 ordinary, but suitable Emacs lisp object.
992 If VAL-TYPE is an FFI pointer then VAL _must_ be an FFI
993 object of the underlying type pointed to.
995 (fo, offset, val_type, val))
997 Lisp_Object origtype = val_type;
998 Lisp_EffiObject *ffio;
1005 ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
1007 val_type = ffi_canonicalise_type(val_type);
1009 /* Translate value */
1010 val = apply1(Findirect_function(Qffi_translate_to_foreign),
1011 list2(val, origtype));
1013 if (EQ(val_type, Q_char) || EQ(val_type, Q_unsigned_char)) {
1015 SIGNAL_ERROR(Qwrong_type_argument,
1016 list2(Qcharacterp, val));
1018 *(char*)ptr = XCHAR(val);
1019 } else if (EQ(val_type, Q_byte) || EQ(val_type, Q_unsigned_byte)) {
1021 SIGNAL_ERROR(Qwrong_type_argument,
1022 list2(Qintegerp, val));
1024 *(char*)ptr = XINT(val);
1025 } else if (EQ(val_type, Q_short) || EQ(val_type, Q_unsigned_short)) {
1027 SIGNAL_ERROR(Qwrong_type_argument,
1028 list2(Qintegerp, val));
1030 *(short*)ptr = (short)XINT(val);
1031 } else if (EQ(val_type, Q_int) || EQ(val_type, Q_unsigned_int)) {
1033 *(int*)ptr = XINT(val);
1034 } else if (FLOATP(val)) {
1035 fpfloat tmp = XFLOATINT(val);
1036 *(int*)ptr = (int)tmp;
1038 SIGNAL_ERROR(Qwrong_type_argument,
1039 list2(Qfloatp, val));
1041 } else if (EQ(val_type, Q_long) || EQ(val_type, Q_unsigned_long)) {
1043 *(long*)ptr = (long)XINT(val);
1044 } else if (FLOATP(val)) {
1045 fpfloat tmp = XFLOATINT(val);
1046 *(long*)ptr = (long int)tmp;
1048 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1050 } else if (EQ(val_type, Q_float)) {
1052 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1053 *(float*)ptr = XFLOATINT(val);
1054 } else if (EQ(val_type, Q_double)) {
1056 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1057 *(double*)ptr = XFLOAT_DATA(val);
1058 } else if (EQ(val_type, Q_c_string)) {
1062 SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1064 TO_EXTERNAL_FORMAT(LISP_STRING, val,
1065 ALLOCA, (tmp, tmplen), Qnil);
1066 memcpy((char*)ptr, tmp, tmplen + 1);
1069 (const char *)XSTRING_DATA(val),
1070 XSTRING_LENGTH(val) + 1);
1072 } else if (EQ(val_type, Q_c_data) ||
1074 EQ(XCAR(val_type), Q_c_data) && INTP(XCDR(val_type)))) {
1076 unsigned int val_ext_len;
1078 SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1080 TO_EXTERNAL_FORMAT(LISP_STRING, val, ALLOCA,
1081 (val_ext, val_ext_len), Qbinary);
1082 if (CONSP(val_type) && (val_ext_len > XINT(XCDR(val_type)))) {
1084 error("storage size too small");
1086 Fsignal(Qrange_error,
1088 build_string("storage size too small")));
1089 #endif /* SXEMACS */
1091 memcpy((char*)ptr, (const char *)val_ext, val_ext_len);
1092 } else if (FFI_POINTERP(val_type)) {
1095 signal_simple_error("FFI: Value not of pointer type", \
1096 list2(origtype, val));
1098 Fsignal(Qwrong_type_argument,
1099 list2(Qstringp, build_string("type")));
1100 #endif /* SXEMACS */
1102 *(void**)ptr = (void*)XEFFIO(val)->fop.ptr;
1103 } else if (CONSP(val_type) && EQ(XCAR(val_type), Q_struct)) {
1106 signal_simple_error("FFI: Value not FFI object", \
1107 list2(origtype, val));
1109 Fsignal(Qwrong_type_argument,
1110 list2(Qstringp, build_string("type")));
1111 #endif /* SXEMACS */
1113 memcpy((char*)ptr, (const char *)XEFFIO(val)->fop.ptr, \
1114 XINT(Fffi_size_of_type(val_type)));
1117 signal_simple_error("FFI: Non basic or pointer type", origtype);
1119 Fsignal(Qinternal_error,
1121 build_string("non basic or pointer type")));
1122 #endif /* SXEMACS */
1128 DEFUN("ffi-aset", Fffi_aset, 3, 3, 0, /*
1129 Store the element VALUE in FARRAY at index IDX (starting with 0).
1131 (farray, idx, value))
1135 CHECK_EFFIO(farray);
1138 type = ffi_canonicalise_type(XEFFIO(farray)->type);
1139 if (!FFI_TPTR(type)) {
1141 signal_simple_error("Not an array type", type);
1143 signal_error(Qinternal_error, "Not an array type", type);
1144 #endif /* SXEMACS */
1146 if (EQ(type, Q_c_string))
1149 type = Fcar(XCDR(type));
1151 return Fffi_store(farray,
1152 make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
1156 DEFUN("ffi-address-of", Fffi_address_of, 1, 1, 0, /*
1157 Return the FFI object that stores the address of given FFI object FO.
1159 This is the equivalent of the `&' operator in C.
1163 Lisp_Object newfo = Qnil;
1164 Lisp_EffiObject *ffio, *newffio;
1165 struct gcpro gcpro1;
1171 newfo = Fmake_ffi_object(Q_pointer, Qnil);
1172 newffio = XEFFIO(newfo);
1174 newffio->fotype = EFFI_FOT_BIND;
1175 if (FFI_TPTR(ffio->type))
1176 newffio->fop.ptr = (void*)&ffio->fop.ptr;
1178 newffio->fop.ptr = ffio->fop.ptr;
1180 RETURN_UNGCPRO(newfo);
1183 DEFUN("ffi-lisp-object-to-pointer", Fffi_lisp_object_to_pointer, 1, 1, 0, /*
1184 Convert lisp object to FFI pointer.
1188 Lisp_Object newfo = Qnil;
1189 Lisp_EffiObject *newffio;
1190 struct gcpro gcpro1;
1194 newfo = Fmake_ffi_object(Q_pointer, Qnil);
1195 newffio = XEFFIO(newfo);
1196 newffio->fotype = EFFI_FOT_BIND;
1197 newffio->fop.ptr = (void*)obj;
1199 /* Hold a reference to OBJ in NEWFO's plist */
1200 Fput(newfo, intern("lisp-object"), obj);
1202 RETURN_UNGCPRO(newfo);
1205 DEFUN("ffi-pointer-to-lisp-object", Fffi_pointer_to_lisp_object, 1, 1, 0, /*
1206 Convert FFI pointer to lisp object.
1211 return (Lisp_Object)XEFFIO(ptr)->fop.ptr;
1214 DEFUN("ffi-plist", Fffi_plist, 1, 1, 0, /*
1215 Return properties list for FFI object FO.
1220 return (XEFFIO(fo)->plist);
1225 static int lf_cindex = 0;
1229 * This will work in most cases.
1230 * However it might not work for large structures,
1231 * In general we should allocate these spaces dynamically
1233 #define MAX_TYPES_VALUES 1024
1234 /* ex_ffitypes_dummies used for structure types */
1235 static ffi_type ex_ffitypes_dummies[MAX_TYPES_VALUES + 1];
1236 static ffi_type *ex_ffitypes[MAX_TYPES_VALUES + 1];
1237 static void *ex_values[MAX_TYPES_VALUES + 1];
1239 #if SIZEOF_LONG == 4
1240 # define effi_type_ulong ffi_type_uint32
1241 # define effi_type_slong ffi_type_sint32
1242 #elif SIZEOF_LONG == 8
1243 # define effi_type_ulong ffi_type_uint64
1244 # define effi_type_slong ffi_type_sint64
1248 extffi_setup_argument(Lisp_Object type, ffi_type **ft)
1250 type = ffi_canonicalise_type(type);
1251 if (EQ(type, Q_char) || EQ(type, Q_byte))
1252 *ft = &ffi_type_schar;
1253 else if (EQ(type, Q_unsigned_char) || EQ(type, Q_unsigned_byte))
1254 *ft = &ffi_type_uchar;
1255 else if (EQ(type, Q_short))
1256 *ft = &ffi_type_sshort;
1257 else if (EQ(type, Q_unsigned_short))
1258 *ft = &ffi_type_ushort;
1259 else if (EQ(type, Q_int))
1260 *ft = &ffi_type_sint;
1261 else if (EQ(type, Q_unsigned_int))
1262 *ft = &ffi_type_uint;
1263 else if (EQ(type, Q_unsigned_long))
1264 *ft = &effi_type_ulong;
1265 else if (EQ(type, Q_long))
1266 *ft = &effi_type_slong;
1267 else if (EQ(type, Q_float))
1268 *ft = &ffi_type_float;
1269 else if (EQ(type, Q_double))
1270 *ft = &ffi_type_double;
1271 else if (EQ(type, Q_void))
1272 *ft = &ffi_type_void;
1273 else if (FFI_TPTR(type))
1274 *ft = &ffi_type_pointer;
1275 else if (CONSP(type) && EQ(XCAR(type), Q_struct)) {
1276 Lisp_Object slots = Fcdr(XCDR(type));
1282 nt_size = XINT(Flength(slots)) + 1;
1283 if (nt_size + lf_cindex > MAX_TYPES_VALUES) {
1284 lf_cindex = 0; /* reset cindex */
1286 error("cindex overflow");
1288 Fsignal(Qoverflow_error,
1290 build_string("cindex overflow")));
1291 #endif /* SXEMACS */
1293 ntypes = &ex_ffitypes[lf_cindex];
1294 *ft = &ex_ffitypes_dummies[lf_cindex];
1296 /* Update lf_cindex in case TYPE struct contains other
1298 lf_cindex += nt_size;
1300 (*ft)->type = FFI_TYPE_STRUCT;
1301 (*ft)->alignment = ffi_type_align(type);
1302 (*ft)->elements = ntypes;
1304 for (i = 0; (i < nt_size) && !NILP(slots); slots = XCDR(slots), i++)
1305 extffi_setup_argument(Fcar(Fcdr(XCAR(slots))), &ntypes[i]);
1309 signal_simple_error("Can't setup argument for type", type);
1311 signal_error(Qinternal_error,
1312 "Can't setup argument for type", type);
1313 #endif /* SXEMACS */
1318 ffi_call_using_libffi(Lisp_Object fo_fun, Lisp_Object ret_fo,
1319 int in_nargs, Lisp_Object *in_args)
1321 Lisp_EffiObject *ffio;
1328 lf_cindex = in_nargs; /* reserve */
1329 for (i = 0; i < in_nargs; i++) {
1330 ffio = XEFFIO(in_args[i]);
1331 fft = Fffi_canonicalise_type(ffio->type);
1332 extffi_setup_argument(fft, &ex_ffitypes[i]);
1334 ex_values[i] = &ffio->fop.ptr;
1336 ex_values[i] = ffio->fop.ptr;
1339 ffio = XEFFIO(ret_fo);
1340 fft = Fffi_canonicalise_type(ffio->type);
1341 extffi_setup_argument(fft, &rtype);
1343 rvalue = &ffio->fop.ptr;
1345 rvalue = ffio->fop.ptr;
1347 if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, in_nargs,
1348 rtype, ex_ffitypes) == FFI_OK)
1350 stop_async_timeouts();
1351 ffi_call(&cif, (void(*)(void))XEFFIO(fo_fun)->fop.fun, rvalue,
1353 start_async_timeouts();
1360 #endif /* HAVE_LIBFFI */
1362 DEFUN("ffi-call-function", Fffi_call_function, 1, MANY, 0, /*
1363 Call a function referred to by FO with arguments ARGS, maybe
1364 return a foreign object with the result or nil if there is
1367 Arguments are: FO &rest FO-ARGS
1369 FO should be a foreign binding initiated by `ffi-defun', and
1370 ARGS should be foreign data objects or pointers to these.
1372 (int nargs, Lisp_Object * args))
1374 Lisp_Object faf = Qnil, retfo = Qnil;
1375 Lisp_EffiObject *ffio;
1377 struct gcpro gcpro1, gcpro2;
1383 retfo = Fmake_ffi_object(XCAR(XCDR(ffio->type)), Qnil);
1386 ret = ffi_call_using_libffi(args[0], retfo, nargs-1, &args[1]);
1387 #endif /* HAVE_LIBFFI */
1389 RETURN_UNGCPRO(ret == 0 ? retfo : Qnil);
1392 #ifdef EF_USE_ASYNEQ
1393 /* handler for asynchronously calling ffi code */
1394 Lisp_Object Qffi_jobp;
1395 #define EFFI_DEBUG_JOB(args...)
1397 exec_sentinel_unwind(Lisp_Object SXE_UNUSED(datum))
1403 exec_sentinel(void *job, ffi_job_t ffij)
1404 __attribute__((always_inline));
1406 exec_sentinel(void *job, ffi_job_t ffij)
1408 /* This function can GC */
1409 /* called from main thread */
1410 int speccount = specpdl_depth(), nargs = ffij->sntnl_nargs, i;
1411 Lisp_Object funcell[nargs+2];
1412 struct gcpro gcpro1;
1414 funcell[0] = ffij->sntnl;
1415 funcell[1] = (Lisp_Object)job;
1416 for (i = 0; i < nargs; i++) {
1417 funcell[2+i] = ffij->sntnl_args[i];
1419 GCPROn(funcell, nargs+2);
1421 record_unwind_protect(exec_sentinel_unwind, Qnil);
1422 /* call the funcell */
1423 Ffuncall(nargs+2, funcell);
1424 /* reset to previous state */
1425 restore_match_data();
1427 unbind_to(speccount, Qnil);
1431 static inline ffi_job_t
1432 allocate_ffi_job(void)
1434 ffi_job_t ffij = xnew(struct ffi_job_s);
1435 EFFI_DEBUG_JOB("allocated: 0x%lx\n", (long unsigned int)ffij);
1439 static inline ffi_job_t
1440 make_ffi_job(Lisp_Object fof, int fof_nargs, Lisp_Object *fof_args,
1441 Lisp_Object sntnl, int sntnl_nargs, Lisp_Object *sntnl_args)
1443 /* exec'd in the main thread */
1444 ffi_job_t ffij = allocate_ffi_job();
1447 SXE_MUTEX_INIT(&ffij->mtx);
1449 if (fof_nargs > 0) {
1450 ffij->fof_nargs = fof_nargs;
1451 ffij->fof_args = xnew_array(Lisp_Object, fof_nargs);
1452 for (i = 0; i < fof_nargs; i++) {
1453 ffij->fof_args[i] = fof_args[i];
1456 ffij->fof_nargs = 0;
1457 ffij->fof_args = NULL;
1460 ffij->sntnl = sntnl;
1461 if (sntnl_nargs > 0) {
1462 ffij->sntnl_nargs = sntnl_nargs;
1463 ffij->sntnl_args = xnew_array(Lisp_Object, sntnl_nargs);
1464 for (i = 0; i < sntnl_nargs; i++) {
1465 ffij->sntnl_args[i] = sntnl_args[i];
1468 ffij->sntnl_nargs = 0;
1469 ffij->sntnl_args = NULL;
1472 ffij->result = Qnil;
1473 ffij->retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil);
1478 mark_ffi_job(worker_job_t job)
1480 ffi_job_t ffij = ffi_job(job);
1486 SXE_MUTEX_LOCK(&ffij->mtx);
1487 mark_object(ffij->fof);
1488 for (i = 0; i < ffij->fof_nargs; i++) {
1489 mark_object(ffij->fof_args[i]);
1491 mark_object(ffij->sntnl);
1492 for (i = 0; i < ffij->sntnl_nargs; i++) {
1493 mark_object(ffij->sntnl_args[i]);
1495 mark_object(ffij->retfo);
1496 mark_object(ffij->result);
1497 SXE_MUTEX_UNLOCK(&ffij->mtx);
1502 print_ffi_job(worker_job_t job, Lisp_Object pcf)
1504 ffi_job_t ffij = ffi_job(job);
1506 SXE_MUTEX_LOCK(&ffij->mtx);
1507 WRITE_FMT_STRING(pcf, " carrying #<ffi-job 0x%lx>",
1508 (long unsigned int)ffij);
1509 SXE_MUTEX_UNLOCK(&ffij->mtx);
1514 finish_ffi_job_data(ffi_job_t ffij)
1516 SXE_MUTEX_LOCK(&ffij->mtx);
1517 xfree(ffij->fof_args);
1518 xfree(ffij->sntnl_args);
1519 SXE_MUTEX_UNLOCK(&ffij->mtx);
1520 SXE_MUTEX_FINI(&ffij->mtx);
1522 EFFI_DEBUG_JOB("finished: 0x%lx\n", (long unsigned int)ffij);
1527 finish_ffi_job(worker_job_t job)
1531 lock_worker_job(job);
1532 ffij = ffi_job(job);
1535 finish_ffi_job_data(ffij);
1537 worker_job_data(job) = NULL;
1538 unlock_worker_job(job);
1543 ffi_job_handle(worker_job_t job)
1546 /* usually called from aux threads */
1548 Lisp_Object fof = Qnil, retfo = Qnil, *args = NULL;
1549 int nargs, ret = -1;
1551 lock_worker_job(job);
1552 ffij = ffi_job(job);
1553 unlock_worker_job(job);
1554 SXE_MUTEX_LOCK(&ffij->mtx);
1556 nargs = ffij->fof_nargs;
1557 args = ffij->fof_args;
1558 SXE_MUTEX_UNLOCK(&ffij->mtx);
1560 /* can't ... Fmake_ffi_object is not mt-safe */
1561 /* retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil); */
1562 retfo = ffij->retfo;
1565 ret = ffi_call_using_libffi(fof, retfo, nargs, args);
1566 #endif /* HAVE_LIBFFI */
1568 SXE_MUTEX_LOCK(&ffij->mtx);
1569 ffij->result = retfo;
1570 SXE_MUTEX_UNLOCK(&ffij->mtx);
1573 EFFI_DEBUG_JOB("job 0x%lx succeeded\n", (long unsigned int)ffij);
1578 ffi_job_finished(worker_job_t job)
1580 if (NILP(ffi_job_sentinel(job) /* sentinel */)) {
1583 /* called from main thread */
1584 exec_sentinel(job, ffi_job(job));
1588 static struct work_handler_s ffi_job_handler = {
1589 mark_ffi_job, print_ffi_job, finish_ffi_job,
1590 ffi_job_handle, NULL, ffi_job_finished
1594 make_ffi_asyneq_job(ffi_job_t ffij)
1596 /* create a job digestible by the asyneq */
1597 Lisp_Object job = Qnil;
1598 struct gcpro gcpro1;
1601 job = wrap_object(make_worker_job(&ffi_job_handler));
1602 XWORKER_JOB_DATA(job) = ffij;
1603 /* the scratch buffer thingie */
1608 DEFUN("ffi-call-function&", Fffi_call_functionX, 1, MANY, 0, /*
1609 Call a function referred to by FO with arguments ARGS asynchronously,
1610 return a job object.
1612 Arguments are: FO &rest FO-ARGS &aux SENTINEL &rest SENTINEL-ARGS
1614 FO should be a foreign binding initiated by `ffi-defun'.
1615 FO-ARGS should be exactly as many foreign data objects as FO needs.
1616 SENTINEL is a lisp sentinel function called when the job finished,
1617 the function should take at least one argument JOB, further arguments
1618 may be specified by passing further SENTINEL-ARGS.
1620 (int nargs, Lisp_Object *args))
1622 Lisp_Object job = Qnil;
1623 Lisp_Object sntnl, fof, *sntnl_args, *fof_args;
1624 int sntnl_nargs, fof_nargs;
1626 struct gcpro gcpro1, gcpro2;
1628 CHECK_EFFIO(args[0]);
1629 GCPRO1n(job, args, nargs);
1632 /* determine how many args belong to the fof */
1633 fof_nargs = XINT(Flength(XCDR(XEFFIO(fof)->type)))-1;
1634 fof_args = &args[1];
1636 if ((sntnl_nargs = nargs - fof_nargs - 2) >= 0) {
1637 sntnl = args[fof_nargs+1];
1638 sntnl_args = &args[fof_nargs+2];
1644 /* create the job data object */
1645 ffij = make_ffi_job(fof, fof_nargs, fof_args,
1646 sntnl, sntnl_nargs, sntnl_args);
1647 /* now prepare the job to dispatch */
1648 job = make_ffi_asyneq_job(ffij);
1649 /* ... and dispatch it, change its state to queued */
1650 XWORKER_JOB_STATE(job) = WORKER_JOB_QUEUED;
1651 eq_enqueue(delegate_eq, job);
1652 /* brag about new jobs in the queue */
1653 eq_queue_trigger_all(delegate_eq);
1658 #endif /* EF_USE_ASYNEQ */
1660 extern struct device *decode_x_device(Lisp_Object device);
1662 DEFUN("x-device-display", Fx_device_display, 0, 1, 0, /*
1663 Return DEVICE display as FFI object.
1670 fo = Fmake_ffi_object(Q_pointer, Qnil);
1671 XEFFIO(fo)->fotype = EFFI_FOT_BIND;
1672 XEFFIO(fo)->fop.ptr = (void*)DEVICE_X_DISPLAY(decode_x_device(device));
1680 #define FFI_CC_CDECL 0
1682 #if defined __i386__
1684 ffi_callback_call_x86(Lisp_Object cbk_info, char *arg_buffer)
1686 Lisp_Object fun, alist = Qnil, retlo, foret;
1687 Lisp_Object rtype, argtypes;
1688 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1691 fun = Fcar(cbk_info);
1692 rtype = Fcar(Fcdr(cbk_info));
1693 argtypes = Fcar(Fcdr(Fcdr(cbk_info)));
1695 CHECK_LIST(argtypes);
1697 arg_buffer += 4; /* Skip return address */
1698 while (!NILP(argtypes)) {
1699 Lisp_Object result, ctype;
1702 ctype = ffi_canonicalise_type(XCAR(argtypes));
1703 size = XINT(Fffi_size_of_type(ctype));
1704 if (EQ(ctype, Q_c_string)) {
1705 char *aptr = *(char**)arg_buffer;
1707 result = ffi_fetch_foreign(aptr, ctype);
1711 result = ffi_fetch_foreign(arg_buffer, ctype);
1712 /* Apply translators and put the result into alist */
1713 result = apply1(Findirect_function(Qffi_translate_from_foreign),
1714 list2(result, XCAR(argtypes)));
1715 alist = Fcons(result, alist);
1718 int sp = (size + mask) & ~mask;
1721 argtypes = XCDR(argtypes);
1723 alist = Fnreverse(alist);
1725 /* Special case, we have no return value */
1726 if (EQ(rtype, Q_void)) {
1727 GCPRO3(fun, alist, rtype);
1733 GCPRO5(fun, alist, rtype, retlo, foret);
1734 retlo = apply1(fun, alist);
1735 foret = Fmake_ffi_object(rtype, Qnil);
1736 Fffi_store(foret, make_int(0), rtype, retlo);
1737 ptr = (void*)XEFFIO(foret)->fop.ptr;
1738 if (EQ(rtype, Q_double)) {
1741 asm volatile ("fldl (%0)" :: "a" (ptr));
1744 } else if (EQ(rtype, Q_float)) {
1747 asm volatile ("flds (%0)" :: "a" (ptr));
1753 if (EQ(rtype, Q_byte) || EQ(rtype, Q_char))
1755 else if (EQ(rtype, Q_unsigned_byte) || EQ(rtype, Q_unsigned_char))
1756 iv = *(char unsigned*)ptr;
1757 else if (EQ(rtype, Q_short))
1759 else if (EQ(rtype, Q_unsigned_short))
1760 iv = *(unsigned short*)ptr;
1765 asm volatile ("movl %0,%%eax;" :: "r" (iv) : "%eax");
1772 ffi_make_callback_x86(Lisp_Object data, int cc_type)
1776 * pushl <data> 68 <addr32>
1777 * call ffi_callback_call_x86 E8 <disp32>
1785 char *buf = xmalloc(sizeof(char)*16);
1786 *(char*) (buf+0) = 0x54;
1787 *(char*) (buf+1) = 0x68;
1788 *(long*) (buf+2) = (long)data;
1789 *(char*) (buf+6) = 0xE8;
1790 *(long*) (buf+7) = (long)ffi_callback_call_x86 - (long)(buf+11);
1791 *(char*) (buf+11) = 0x59;
1792 *(char*) (buf+12) = 0x59;
1793 if (cc_type == FFI_CC_CDECL) {
1794 *(char*) (buf+13) = 0xc3;
1795 *(short*)(buf+14) = 0x9090;
1797 Lisp_Object arg_types = Fcar(Fcdr(Fcdr(data)));
1801 CHECK_CONS(arg_types);
1803 while (!NILP(arg_types)) {
1804 int sz = XINT(Fffi_size_of_type(XCAR(arg_types)));
1805 byte_size += ((sz+mask)&(~mask));
1806 arg_types = XCDR(arg_types);
1809 *(char*) (buf+13) = 0xc2;
1810 *(short*)(buf+14) = (short)byte_size;
1815 #endif /* __i386__ */
1817 DEFUN("ffi-make-callback", Fffi_make_callback, 4, 4, 0, /*
1818 Create dynamic callback and return pointer to it.
1820 (fun, rtype, argtypes, cctype))
1827 data = list3(fun, rtype, argtypes);
1828 /* Put data as property of the fun, so it(data) wont be GCed */
1829 Fput(fun, Q_ffi_callback, data);
1830 ptr = Fmake_ffi_object(Q_pointer, Qnil);
1832 XEFFIO(ptr)->fop.ptr = ffi_make_callback_x86(data, XINT(cctype));
1833 #endif /* __i386__ */
1840 INIT_LRECORD_IMPLEMENTATION(ffiobject);
1842 defsymbol(&Q_byte, "byte");
1843 defsymbol(&Q_unsigned_byte, "unsigned-byte");
1844 defsymbol(&Q_char, "char");
1845 defsymbol(&Q_unsigned_char, "unsigned-char");
1846 defsymbol(&Q_short, "short");
1847 defsymbol(&Q_unsigned_short, "unsigned-short");
1848 defsymbol(&Q_int, "int");
1849 defsymbol(&Q_unsigned_int, "unsigned-int");
1850 defsymbol(&Q_long, "long");
1851 defsymbol(&Q_unsigned_long, "unsigned-long");
1852 defsymbol(&Q_float, "float");
1853 defsymbol(&Q_double, "double");
1854 defsymbol(&Q_void, "void");
1855 defsymbol(&Q_pointer, "pointer");
1856 defsymbol(&Q_struct, "struct");
1857 defsymbol(&Q_union, "union");
1858 defsymbol(&Q_array, "array");
1859 defsymbol(&Q_function, "function");
1860 defsymbol(&Q_c_string, "c-string");
1861 defsymbol(&Q_c_data, "c-data");
1863 defsymbol(&Qffiobjectp, "ffiobjectp");
1865 defsymbol(&Qffi_translate_to_foreign, "ffi-translate-to-foreign");
1866 defsymbol(&Qffi_translate_from_foreign, "ffi-translate-from-foreign");
1868 defsymbol(&Q_ffi_callback, "ffi-callback");
1870 DEFSUBR(Fffi_basic_type_p);
1871 DEFSUBR(Fffi_canonicalise_type);
1872 DEFSUBR(Fffi_size_of_type);
1873 DEFSUBR(Fmake_ffi_object);
1874 DEFSUBR(Fffi_object_p);
1875 DEFSUBR(Fffi_make_pointer);
1876 DEFSUBR(Fffi_object_address);
1877 DEFSUBR(Fffi_object_canonical_type);
1878 DEFSUBR(Fffi_object_type);
1879 DEFSUBR(Fffi_object_size);
1880 DEFSUBR(Fffi_set_storage_size);
1881 DEFSUBR(Fffi_set_object_type);
1882 DEFSUBR(Fffi_fetch);
1884 DEFSUBR(Fffi_store);
1886 DEFSUBR(Fffi_address_of);
1887 DEFSUBR(Fffi_type_alignment);
1888 DEFSUBR(Fffi_slot_offset);
1889 DEFSUBR(Fffi_load_library);
1891 DEFSUBR(Fffi_dlerror);
1892 DEFSUBR(Fffi_defun);
1893 DEFSUBR(Fffi_call_function);
1895 DEFSUBR(Fffi_lisp_object_to_pointer);
1896 DEFSUBR(Fffi_pointer_to_lisp_object);
1897 DEFSUBR(Fffi_plist);
1899 #ifdef EF_USE_ASYNEQ
1900 DEFSUBR(Fffi_call_functionX);
1901 defsymbol(&Qffi_jobp, "ffi-job-p");
1904 DEFSUBR(Fx_device_display);
1906 DEFSUBR(Fffi_make_callback);
1910 reinit_vars_of_ffi(void)
1912 staticpro_nodump(&Vffi_all_objects);
1913 Vffi_all_objects = make_weak_list(WEAK_LIST_SIMPLE);
1919 reinit_vars_of_ffi();
1921 DEFVAR_LISP("ffi-named-types", &Vffi_named_types /*
1922 Alist of named FFI types with elements of the form (NAME . FFI-TYPE).
1924 Vffi_named_types = Qnil;
1926 DEFVAR_LISP("ffi-loaded-libraries", &Vffi_loaded_libraries /*
1927 Alist of loaded libraries with elements of the form (LIB-NAME . FFIO).
1929 Vffi_loaded_libraries = Qnil;
1931 DEFVAR_LISP("ffi-type-checker", &Vffi_type_checker /*
1932 Function to call when the validity of an FFI type shall be checked.
1934 Vffi_type_checker = intern("ffi-type-p");