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/>. */
33 # include "mule/file-coding.h"
39 #endif /* HAVE_LIBFFI */
42 # include "events/workers.h"
43 # include "events/worker-asyneq.h"
44 #endif /* EF_USE_ASYNEQ */
46 /* For `x-device-display' */
47 #include "ui/X11/console-x.h"
48 #include "ui/device.h"
50 #define EFFI_CODING Qnative
53 * Some compatibility for XEmacs
56 # define SIGNAL_ERROR signal_error
57 # define FFIBYTE Bufbyte
58 # define WRITE_C_STRING(x,y) write_c_string((x),(y))
59 # define WRITE_FMT_STRING(x,y,...) write_fmt_string((x),(y),__VA_ARGS__)
60 # define LRECORD_DESCRIPTION lrecord_description
62 # define SIGNAL_ERROR Fsignal
63 # define FFIBYTE Ibyte
64 # define WRITE_C_STRING(x,y) write_c_string((y),(x))
65 # define WRITE_FMT_STRING(x,y,...) \
68 int wcss = snprintf(wcsb, sizeof(wcsb), \
70 write_c_string((y),wcsb); \
72 # define LRECORD_DESCRIPTION memory_description
77 * byte, ubyte, char, uchar,
78 * short, ushort, int, uint,
81 * void, pointer, c-string
85 * (function RET-TYPE IN-TYPE .. IN-TYPE)
91 * Structures and unions types:
101 * pointer or (pointer TYPE)
104 /* Foreign types, not defined as symbols elsewhere. */
105 Lisp_Object Qarray, Qbyte, Qc_data, Qc_string, Qdouble, Qlong, Qstruct;
106 Lisp_Object Qunion, Qunsigned_byte, Qunsigned_char, Qunsigned_int;
107 Lisp_Object Qunsigned_long, Qunsigned_short;
109 #define FFI_POINTERP(type) (EQ(type, Qpointer) \
110 || (CONSP(type) && EQ(XCAR(type), Qpointer)))
112 #define FFI_TPTR(type) (EQ(type, Qc_string) \
113 || EQ(type, Qc_data) \
114 || FFI_POINTERP(type) \
115 || (CONSP(type) && ((EQ(XCAR(type), Qc_data)) \
116 || EQ(XCAR(type), Qarray))))
117 Lisp_Object Qffiobjectp;
118 Lisp_Object Qffi_translate_to_foreign;
119 Lisp_Object Qffi_translate_from_foreign;
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 Qffi_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);
146 escapeflag = escapeflag; /* shutup compiler */
147 if (print_readably) {
149 error("printing unreadable object #<ffiobject 0x%x>",
152 signal_ferror(Qinternal_error,
153 "printing unreadable object #<ffiobject 0x%x>",
157 WRITE_C_STRING("#<ffiobject ", printcharfun);
158 /* Print FFIO type */
159 if (!NILP(ffio->type)) {
160 WRITE_C_STRING("type=", printcharfun);
161 print_internal(ffio->type, printcharfun, 1);
162 WRITE_C_STRING(" ", printcharfun);
164 WRITE_FMT_STRING(printcharfun,"size=%ld fotype=%d foptr=%p>",
165 (long)XINT(ffio->size), ffio->fotype, ffio->fop.generic);
168 static const struct LRECORD_DESCRIPTION ffiobject_description[] = {
169 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, type)},
170 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, size)},
171 {XD_LISP_OBJECT, offsetof(Lisp_EffiObject, plist)},
172 {XD_INT, offsetof(Lisp_EffiObject, fotype)},
173 {XD_OPAQUE_PTR, offsetof(Lisp_EffiObject, fop)},
175 {XD_SIZE_T, offsetof(Lisp_EffiObject, storage_size)},
177 {XD_ELEMCOUNT, offsetof(Lisp_EffiObject, storage_size)},
183 ffi_getprop(Lisp_Object fo, Lisp_Object property)
185 return external_plist_get(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
189 ffi_putprop(Lisp_Object fo, Lisp_Object property, Lisp_Object value)
191 external_plist_put(&XEFFIO(fo)->plist, property, value, 0, ERROR_ME);
196 ffi_remprop(Lisp_Object fo, Lisp_Object property)
198 return external_remprop(&XEFFIO(fo)->plist, property, 0, ERROR_ME);
203 sizeof_ffiobject(const void *header)
205 const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
206 return (sizeof(Lisp_EffiObject) + effio->storage_size);
210 sizeof_ffiobject(const void *header)
212 const Lisp_EffiObject *effio = (const Lisp_EffiObject *)header;
213 return (sizeof(Lisp_EffiObject) + effio->storage_size);
217 /* Define ffiobject implementation */
218 const struct lrecord_implementation lrecord_ffiobject = {
220 .marker = mark_ffiobject,
221 .printer = print_ffiobject,
225 .description = ffiobject_description,
226 .getprop = ffi_getprop,
227 .putprop = ffi_putprop,
228 .remprop = ffi_remprop,
231 .size_in_bytes_method = sizeof_ffiobject,
232 .lrecord_type_index = lrecord_type_ffiobject,
237 /** alignment in union and structures **/
241 * - An entire structure or union is aligned on the same boundary as
242 * its most strictly aligned member.
244 * - Each member is assigned to the lowest available offset with the
245 * appropriate alignment. This may require /internal padding/,
246 * depending on the previous member.
248 * - A structure's size is increased, if necessary, to make it a
249 * multiple of the alignment. This may require /tail padding/,
250 * depending on the last member.
255 * char c; .-------2+---1+---0.
256 * short s; | s |pad | c |
257 * } `--------+----+----'
259 * Internal and Tail padding:
261 * struct { .------------1+---0.
262 * char c; | pad | c |
263 * double d; |-------------+---4|
265 * } |-----------------8|
267 * |------14+-------12|
269 * `--------+---------'
273 * union { .------------1+---0.
274 * char c; | pad | c |
275 * short s; |-------2+----+---0|
277 * } |--------+--------0|
279 * `------------------'
282 ffi_check_type(Lisp_Object type)
284 return apply1(Vffi_type_checker, Fcons(type, Fcons(Qt, Qnil)));
287 DEFUN("ffi-basic-type-p", Fffi_basic_type_p, 1, 1, 0, /*
288 Return non-nil if TYPE is a basic FFI type.
290 A type is said to be basic, if it is neither a pointer nor a
291 function, and there is a corresponding built-in type in C.
295 if (EQ(type, Qbyte) || EQ(type, Qunsigned_byte) || EQ(type, Qchar)
296 || EQ(type, Qunsigned_char) || EQ(type, Qshort)
297 || EQ(type, Qunsigned_short) || EQ(type, Qint)
298 || EQ(type, Qunsigned_int) || EQ(type, Qlong)
299 || EQ(type, Qunsigned_long) || EQ(type, Qfloat)
300 || EQ(type, Qdouble) || EQ(type, Qvoid)
301 || EQ(type, Qc_string) || EQ(type, Qc_data)
302 || (CONSP(type) && EQ(XCAR(type), Qc_data)))
310 ffi_canonicalise_type(Lisp_Object type)
312 /* this function canNOT GC */
314 while (!NILP(type) && NILP(Fffi_basic_type_p(type)) && SYMBOLP(type)) {
315 if EQ(type, Qpointer)
317 type = Fcdr(Fassq(type, Vffi_named_types));
323 DEFUN("ffi-canonicalise-type", Fffi_canonicalise_type, 1, 1, 0, /*
324 Return FFI type TYPE in a canonical form.
328 Lisp_Object canon_type = ffi_canonicalise_type(type);
329 if (NILP(canon_type)) {
331 signal_simple_error("No such FFI type", type);
333 signal_error(Qinternal_error, "No such FFI type", type);
339 DEFUN("ffi-size-of-type", Fffi_size_of_type, 1, 1, 0, /*
340 Return the size of the foreign type TYPE.
342 Valid foreign types are: `byte', `unsigned-byte', `char',
343 `unsigned-char', `short', `unsigned-short', `int', `unsigned-int',
344 `long', `unsigned-long', `pointer', `float', `double',
345 `object', and `c-string'.
351 type = ffi_canonicalise_type(type);
354 else if (EQ(type, Qbyte))
355 tsize = sizeof(int8_t);
356 else if (EQ(type, Qunsigned_byte))
357 tsize = sizeof(uint8_t);
358 else if (EQ(type, Qchar))
359 tsize = sizeof(char);
360 else if (EQ(type, Qunsigned_char))
361 tsize = sizeof(unsigned char);
362 else if (EQ(type, Qshort))
363 tsize = sizeof(short);
364 else if (EQ(type, Qunsigned_short))
365 tsize = sizeof(unsigned short);
366 else if (EQ(type, Qint))
368 else if (EQ(type, Qunsigned_int))
369 tsize = sizeof(unsigned int);
370 else if (EQ(type, Qlong))
371 tsize = sizeof(long);
372 else if (EQ(type, Qunsigned_long))
373 tsize = sizeof(unsigned long);
374 else if (EQ(type, Qfloat))
375 tsize = sizeof(float);
376 else if (EQ(type, Qdouble))
377 tsize = sizeof(double);
378 else if (EQ(type, Qc_string))
379 tsize = sizeof(char *);
380 else if (FFI_POINTERP(type))
381 tsize = sizeof(void *);
382 else if (EQ(type, Qc_data))
383 tsize = sizeof(void *);
384 else if (CONSP(type) && EQ(XCAR(type), Qc_data)) {
385 Lisp_Object cdsize = XCDR(type);
387 tsize = XINT(cdsize);
388 } else if (CONSP(type) && EQ(XCAR(type), Qfunction))
389 tsize = sizeof(void(*));
390 else if (CONSP(type) && EQ(XCAR(type), Qarray)) {
391 Lisp_Object atype = Fcar(XCDR(type));
392 Lisp_Object asize = Fcar(Fcdr(XCDR(type)));
395 tsize = XINT(asize) * XINT(Fffi_size_of_type(atype));
396 } else if (CONSP(type) && EQ(XCAR(type), Qstruct)) {
397 return Fffi_slot_offset(type, Qnil);
398 } else if (CONSP(type) && EQ(XCAR(type), Qunion)) {
399 Lisp_Object slots = Fcdr(XCDR(type));
404 while (!NILP(slots)) {
405 Lisp_Object slot_type = Fcar(Fcdr(XCAR(slots)));
406 int slot_size = XINT(Fffi_size_of_type(slot_type));
407 if (slot_size > tsize)
413 signal_simple_error("Unrecognized foreign type", type);
415 signal_error(Qinternal_error, "Unrecognized foreign type", type);
419 return make_int(tsize);
422 DEFUN("make-ffi-object", Fmake_ffi_object, 1, 2, 0, /*
423 Create a new FFI object of type TYPE.
424 If optional argument SIZE is non-nil it should be an
425 integer, in this case additional storage size to hold data
426 of at least length SIZE is allocated.
432 Lisp_Object result = Qnil;
433 Lisp_EffiObject *ffio;
438 /* NOTE: ffi_check_type returns canonical type */
439 ctype = ffi_check_type(type);
441 size = Fffi_size_of_type(type);
444 if (CONSP(ctype) && EQ(XCAR(ctype), Qc_data) && INTP(XCDR(ctype)))
447 cs_or_cd = EQ(ctype, Qc_string) || (EQ(ctype, Qc_data));
448 if ((cs_or_cd && (XINT(size) < 1))
449 || (!(cs_or_cd || FFI_POINTERP(ctype))
450 && (XINT(size) < XINT(Fffi_size_of_type(type)))))
452 signal_simple_error("storage size too small to store type",
455 ffio = alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
457 XSETEFFIO(result, ffio);
459 signal_error(Qinternal_error,
460 "storage size too small to store type",
463 ffio = old_basic_alloc_lcrecord(sizeof(Lisp_EffiObject)+XINT(size),
465 result = wrap_effio(ffio);
468 ffio->size = Fffi_size_of_type(type);
472 /* Initialize foreign pointer */
473 ffio->fotype = EFFI_FOT_NONE;
474 ffio->storage_size = XINT(size);
475 ffio->fop.ptr = ffio->fostorage;
477 if (!NILP(Vffi_all_objects))
478 XWEAK_LIST_LIST(Vffi_all_objects) =
479 Fcons(result, XWEAK_LIST_LIST(Vffi_all_objects));
481 RETURN_UNGCPRO(result);
484 DEFUN("ffi-object-p", Fffi_object_p, 1, 1, 0, /*
485 Return non-nil if FO is an FFI object, nil otherwise.
489 return (EFFIOP(fo) ? Qt : Qnil);
492 DEFUN("ffi-object-address", Fffi_object_address, 1, 1, 0, /*
493 Return the address FO points to.
498 return make_float((long)XEFFIO(fo)->fop.ptr);
501 DEFUN("ffi-make-pointer", Fffi_make_pointer, 1, 1, 0, /*
502 "Return a pointer pointing to ADDRESS."
510 addr = XINT(address);
511 else if (FLOATP(address))
512 addr = XFLOATINT(address);
515 signal_simple_error("FFI: invalid address type", address);
517 signal_error(Qinternal_error, "FFI: invalid address type",
522 ptr = Fmake_ffi_object(Qpointer, Qnil);
523 XEFFIO(ptr)->fop.ptr = (void*)addr;
527 DEFUN("ffi-object-canonical-type", Fffi_object_canonical_type, 1, 1, 0, /*
528 Return FO's real type, that is after resolving user defined types.
533 return ffi_canonicalise_type(XEFFIO(fo)->type);
536 DEFUN("ffi-object-type", Fffi_object_type, 1, 1, 0, /*
542 return (XEFFIO(fo)->type);
545 DEFUN("ffi-set-object-type", Fffi_set_object_type, 2, 2, 0, /*
546 Cast FO to type TYPE and reassign the cast value.
552 ffi_check_type(type);
553 XEFFIO(fo)->type = type;
558 DEFUN("ffi-object-size", Fffi_object_size, 1, 1, 0, /*
559 Return the size of the allocated space of FO.
564 return (XEFFIO(fo)->size);
567 DEFUN("ffi-set-storage-size", Fffi_set_storage_size, 2, 2, 0, /*
568 Set the size of the allocated space of FO.
574 XEFFIO(fo)->storage_size = XUINT(size);
578 DEFUN("ffi-load-library", Fffi_load_library, 1, 1, 0, /*
579 Load library LIBNAME and return a foreign object handle if successful,
580 or `nil' if the library cannot be loaded.
582 The argument LIBNAME should be the file-name string of a shared object
583 library. Normally you should omit the file extension, as this
584 function will add the appripriate extension for the current platform
587 The library should reside in one of the directories specified by the
588 $LD_LIBRARY_PATH environment variable or the more global ld.so.cache.
593 #ifdef LTDL_SHLIB_EXT
594 # define EXT LTDL_SHLIB_EXT
595 #elif defined(HAVE_DYLD) || defined(HAVE_MACH_O_DYLD_H)
596 # define EXT ".dylib"
599 #endif /* LTDL_SHLIB_EXT */
601 void *handler, *dotpos;
602 Lisp_Object fo = Qnil;
603 Lisp_EffiObject *ffio;
607 CHECK_STRING(libname);
609 /* Add an extension if we need to */
610 dotpos = strrchr((char *)XSTRING_DATA(libname),'.');
611 if ( dotpos == NULL || strncmp(dotpos, EXT, sizeof(EXT))) {
612 ssize_t liblen = XSTRING_LENGTH(libname);
613 ssize_t soname_len = liblen + sizeof(EXT) + 1;
614 soname = xmalloc( soname_len);
615 xstrncpy(soname, (char *)XSTRING_DATA(libname), soname_len);
616 xstrncpy(soname+liblen, EXT, soname_len-liblen);
619 if ( soname == NULL ) {
620 handler = dlopen((const char *)XSTRING_DATA(libname),
621 RTLD_GLOBAL|RTLD_NOW);
623 handler = dlopen(soname, RTLD_GLOBAL|RTLD_NOW);
631 fo = Fmake_ffi_object(Qpointer, Qnil);
634 ffio->fotype = EFFI_FOT_BIND;
635 ffio->fop.ptr = handler;
640 DEFUN("ffi-bind", Fffi_bind, 2, 2, 0, /*
641 Make and return a foreign object of type TYPE and bind it to the
644 The argument TYPE can be any type-cell.
645 The argument SYM should be a string naming an arbitrary symbol
646 in one of the loaded libraries.
648 If SYM does not exist in any of the loaded libraries, `nil' is
653 Lisp_Object fo = Qnil;
654 Lisp_EffiObject *ffio;
657 ffi_check_type(type);
661 fo = Fmake_ffi_object(type, Qnil);
663 ffio->fop.ptr = dlsym(RTLD_DEFAULT, (const char*)XSTRING_DATA(sym));
664 if (ffio->fop.ptr == NULL) {
669 ffio->fotype = EFFI_FOT_BIND;
674 DEFUN("ffi-dlerror", Fffi_dlerror, 0, 0, 0, /*
675 Return dl error string.
679 const char *dles = dlerror();
681 if (LIKELY(dles != NULL)) {
682 size_t sz = strlen(dles);
683 return make_ext_string((const Extbyte*)dles, sz, EFFI_CODING);
689 DEFUN("ffi-defun", Fffi_defun, 2, 2, 0, /*
690 Make and return a foreign object of type TYPE and bind it to the
693 The argument TYPE should be a function type-cell.
694 The argument SYM should be a string naming a function in one of
695 the loaded libraries.
697 If SYM does not exist in any of the loaded libraries, an error
700 This is like `ffi-bind' but for function objects.
704 Lisp_Object fo = Qnil;
705 Lisp_EffiObject *ffio;
708 ffi_check_type(type);
713 fo = Fmake_ffi_object(type, Qnil);
715 ffio->fop.fun = dlsym(RTLD_DEFAULT, (const char *)XSTRING_DATA(sym));
716 if (ffio->fop.fun == NULL) {
718 signal_simple_error("Can't define function", sym);
720 signal_error(Qinternal_error, "Can't define function", sym);
724 ffio->fotype = EFFI_FOT_FUNC;
730 * Return alignment policy for struct or union FFI_SU.
731 * x86: Return 1, 2 or 4.
732 * mips: Return 1, 2, 4 or 8.
735 ffi_type_align(Lisp_Object type)
737 type = ffi_canonicalise_type(type);
739 if (EQ(type, Qbyte) || EQ(type, Qunsigned_byte)
740 || EQ(type, Qchar) || EQ(type, Qunsigned_char))
742 if (EQ(type, Qshort) || EQ(type, Qunsigned_short))
745 if (EQ(type, Qdouble))
747 #endif /* FFI_MIPS */
750 } else if (CONSP(type)
751 && (EQ(XCAR(type), Qstruct) || EQ(XCAR(type), Qunion))) {
754 for (al = 0, type = Fcdr(Fcdr(type));
758 Lisp_Object stype = Fcar(Fcdr(Fcar(type)));
759 int tmp_al = ffi_type_align(stype);
771 DEFUN("ffi-type-alignment", Fffi_type_alignment, 1, 1, 0, /*
772 Return TYPE alignment.
776 return make_int(ffi_type_align(type));
779 DEFUN("ffi-slot-offset", Fffi_slot_offset, 2, 2, 0, /*
780 Return the offset of SLOT in TYPE.
781 SLOT can be either a valid (named) slot in TYPE or `nil'.
782 If SLOT is `nil' return the size of the struct.
787 int lpad, align, retoff;
789 type = ffi_canonicalise_type(type);
792 error("Not struct or union");
794 Fsignal(Qwrong_type_argument,
795 list2(Qstringp, build_string("Not struct or union")));
800 lpad = align = ffi_type_align(type);
801 slots = Fcdr(XCDR(type));
803 while (!NILP(slots)) {
804 Lisp_Object tmp_slot = Fcar(Fcdr(XCAR(slots)));
810 * - for basic types TMP_ALIGN and TMP_SIZE are equal
812 tmp_align = ffi_type_align(tmp_slot);
814 if (EQ(XCAR(XCAR(slots)), slot)) {
816 /* TODO: add support for :offset keyword in SLOT */
817 if (lpad < tmp_align) {
825 tmp_size = XINT(Fffi_size_of_type(tmp_slot));
826 while (tmp_size > 0) {
827 if (lpad < tmp_align) {
831 tmp_size -= tmp_align;
838 if (NILP(slots) && !NILP(slot)) {
840 signal_simple_error("FFI: Slot not found", slot);
842 signal_error(Qinternal_error, "FFI: Slot not found", slot);
845 return make_int(retoff + lpad);
849 * TYPE must be already canonicalised
852 ffi_fetch_foreign(void *ptr, Lisp_Object type)
854 /* this function canNOT GC */
855 Lisp_Object retval = Qnone;
858 retval = make_char(*(char*)ptr);
859 else if (EQ(type, Qunsigned_char))
860 retval = make_char(*(char unsigned*)ptr);
861 else if (EQ(type, Qbyte))
862 retval = make_int(*(char*)ptr);
863 else if (EQ(type, Qunsigned_byte))
864 retval = make_int(*(unsigned char*)ptr);
865 else if (EQ(type, Qshort))
866 retval = make_int(*(short*)ptr);
867 else if (EQ(type, Qunsigned_short))
868 retval = make_int(*(unsigned short*)ptr);
869 else if (EQ(type, Qint))
870 retval = make_int(*(int*)ptr);
871 else if (EQ(type, Qunsigned_int))
872 retval = make_int(*(unsigned int*)ptr);
873 else if (EQ(type, Qlong))
874 retval = make_int(*(long*)ptr);
875 else if (EQ(type, Qunsigned_long))
876 retval = make_int(*(unsigned long*)ptr);
877 else if (EQ(type, Qfloat))
878 retval = make_float(*(float*)ptr);
879 else if (EQ(type, Qdouble))
880 retval = make_float(*(double*)ptr);
881 else if (EQ(type, Qc_string)) {
882 retval = build_ext_string((char*)ptr, Qbinary);
883 } else if (EQ(type, Qvoid)) {
885 } else if (FFI_POINTERP(type)) {
886 retval = Fmake_ffi_object(type, Qnil);
887 XEFFIO(retval)->fop.ptr = *(void**)ptr;
888 } else if (CONSP(type) && EQ(XCAR(type), Qfunction)) {
889 retval = Fmake_ffi_object(type, Qnil);
890 XEFFIO(retval)->fop.fun = (void*)ptr;
891 XEFFIO(retval)->fotype = EFFI_FOT_FUNC;
897 DEFUN("ffi-fetch", Fffi_fetch, 3, 3, 0, /*
898 Fetch value from the foreign object FO from OFFSET position.
899 TYPE specifies value for data to be fetched.
903 Lisp_Object origtype = type;
904 Lisp_Object retval = Qnil;
905 Lisp_EffiObject *ffio;
913 ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
915 type = ffi_canonicalise_type(type);
918 /* Fetch value and translate it according to translators */
919 retval = ffi_fetch_foreign(ptr, type);
920 if (EQ(retval, Qnone)) {
921 /* Special case for c-data */
922 if (EQ(type, Qc_data) ||
923 (CONSP(type) && EQ(XCAR(type), Qc_data)))
926 if (EQ(type, Qc_data)) {
927 tlen = ffio->storage_size - XINT(offset);
929 CHECK_INT(XCDR(type));
930 tlen = XUINT(XCDR(type));
933 retval = make_ext_string(ptr, tlen, Qbinary);
936 signal_simple_error("Can't fetch for this type", origtype);
938 signal_error(Qinternal_error, "Can't fetch for this type",
943 retval = apply1(Findirect_function(Qffi_translate_from_foreign),
944 list2(retval, origtype));
946 RETURN_UNGCPRO(retval);
949 DEFUN("ffi-aref", Fffi_aref, 2, 2, 0, /*
950 Return the element of FARRAY at index IDX (starting with 0).
959 type = ffi_canonicalise_type(XEFFIO(farray)->type);
960 if (!FFI_TPTR(type)) {
962 signal_simple_error("Not an array type", type);
964 signal_error(Qinternal_error, "Not an array type", type);
967 if (EQ(type, Qc_string))
970 type = Fcar(XCDR(type));
972 return Fffi_fetch(farray,
973 make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
977 DEFUN("ffi-store", Fffi_store, 4, 4, 0, /*
978 For foreign object FO at specified OFFSET store data.
979 Type of data is specified by VAL-TYPE and data itself specified in VAL.
981 VAL-TYPE can be either a basic FFI type or an FFI pointer.
982 If VAL-TYPE is a basic FFI type, then VAL can be an
983 ordinary, but suitable Emacs lisp object.
984 If VAL-TYPE is an FFI pointer then VAL _must_ be an FFI
985 object of the underlying type pointed to.
987 (fo, offset, val_type, val))
989 Lisp_Object origtype = val_type;
990 Lisp_EffiObject *ffio;
997 ptr = (void*)((char*)ffio->fop.ptr + XINT(offset));
999 val_type = ffi_canonicalise_type(val_type);
1001 /* Translate value */
1002 val = apply1(Findirect_function(Qffi_translate_to_foreign),
1003 list2(val, origtype));
1005 if (EQ(val_type, Qchar) || EQ(val_type, Qunsigned_char)) {
1007 SIGNAL_ERROR(Qwrong_type_argument,
1008 list2(Qcharacterp, val));
1010 *(char*)ptr = XCHAR(val);
1011 } else if (EQ(val_type, Qbyte) || EQ(val_type, Qunsigned_byte)) {
1013 SIGNAL_ERROR(Qwrong_type_argument,
1014 list2(Qintegerp, val));
1016 *(char*)ptr = XINT(val);
1017 } else if (EQ(val_type, Qshort) || EQ(val_type, Qunsigned_short)) {
1019 SIGNAL_ERROR(Qwrong_type_argument,
1020 list2(Qintegerp, val));
1022 *(short*)ptr = (short)XINT(val);
1023 } else if (EQ(val_type, Qint) || EQ(val_type, Qunsigned_int)) {
1025 *(int*)ptr = XINT(val);
1026 } else if (FLOATP(val)) {
1027 fpfloat tmp = XFLOATINT(val);
1028 *(int*)ptr = (int)tmp;
1030 SIGNAL_ERROR(Qwrong_type_argument,
1031 list2(Qfloatp, val));
1033 } else if (EQ(val_type, Qlong) || EQ(val_type, Qunsigned_long)) {
1035 *(long*)ptr = (long)XINT(val);
1036 } else if (FLOATP(val)) {
1037 fpfloat tmp = XFLOATINT(val);
1038 *(long*)ptr = (long int)tmp;
1040 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1042 } else if (EQ(val_type, Qfloat)) {
1044 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1045 *(float*)ptr = XFLOATINT(val);
1046 } else if (EQ(val_type, Qdouble)) {
1048 SIGNAL_ERROR(Qwrong_type_argument, list2(Qfloatp, val));
1049 *(double*)ptr = XFLOAT_DATA(val);
1050 } else if (EQ(val_type, Qc_string)) {
1054 SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1056 TO_EXTERNAL_FORMAT(LISP_STRING, val,
1057 ALLOCA, (tmp, tmplen), Qnil);
1058 if ( tmp != NULL ) {
1059 memcpy((char*)ptr, tmp, tmplen + 1);
1063 (const char *)XSTRING_DATA(val),
1064 XSTRING_LENGTH(val) + 1);
1066 } else if (EQ(val_type, Qc_data) ||
1068 EQ(XCAR(val_type), Qc_data) && INTP(XCDR(val_type)))) {
1069 char *val_ext = NULL;
1070 unsigned int val_ext_len;
1072 SIGNAL_ERROR(Qwrong_type_argument, list2(Qstringp, val));
1074 TO_EXTERNAL_FORMAT(LISP_STRING, val, ALLOCA,
1075 (val_ext, val_ext_len), Qbinary);
1076 if (val_ext == NULL ||
1077 (CONSP(val_type) && (val_ext_len > XINT(XCDR(val_type))))) {
1079 error("storage size too small");
1081 Fsignal(Qrange_error,
1083 build_string("storage size too small")));
1084 #endif /* SXEMACS */
1086 memcpy((char*)ptr, (const char *)val_ext, val_ext_len);
1088 } else if (FFI_POINTERP(val_type)) {
1091 signal_simple_error("FFI: Value not of pointer type", \
1092 list2(origtype, val));
1094 Fsignal(Qwrong_type_argument,
1095 list2(Qstringp, build_string("type")));
1096 #endif /* SXEMACS */
1098 *(void**)ptr = (void*)XEFFIO(val)->fop.ptr;
1099 } else if (CONSP(val_type) && EQ(XCAR(val_type), Qstruct)) {
1102 signal_simple_error("FFI: Value not FFI object", \
1103 list2(origtype, val));
1105 Fsignal(Qwrong_type_argument,
1106 list2(Qstringp, build_string("type")));
1107 #endif /* SXEMACS */
1109 memcpy((char*)ptr, (const char *)XEFFIO(val)->fop.ptr, \
1110 XINT(Fffi_size_of_type(val_type)));
1113 signal_simple_error("FFI: Non basic or pointer type", origtype);
1115 Fsignal(Qinternal_error,
1117 build_string("non basic or pointer type")));
1118 #endif /* SXEMACS */
1124 DEFUN("ffi-aset", Fffi_aset, 3, 3, 0, /*
1125 Store the element VALUE in FARRAY at index IDX (starting with 0).
1127 (farray, idx, value))
1131 CHECK_EFFIO(farray);
1134 type = ffi_canonicalise_type(XEFFIO(farray)->type);
1135 if (!FFI_TPTR(type)) {
1137 signal_simple_error("Not an array type", type);
1139 signal_error(Qinternal_error, "Not an array type", type);
1140 #endif /* SXEMACS */
1142 if (EQ(type, Qc_string))
1145 type = Fcar(XCDR(type));
1147 return Fffi_store(farray,
1148 make_int(XINT(Fffi_size_of_type(type)) * XINT(idx)),
1152 DEFUN("ffi-address-of", Fffi_address_of, 1, 1, 0, /*
1153 Return the FFI object that stores the address of given FFI object FO.
1155 This is the equivalent of the `&' operator in C.
1159 Lisp_Object newfo = Qnil;
1160 Lisp_EffiObject *ffio, *newffio;
1161 struct gcpro gcpro1;
1167 newfo = Fmake_ffi_object(Qpointer, Qnil);
1168 newffio = XEFFIO(newfo);
1170 newffio->fotype = EFFI_FOT_BIND;
1171 if (FFI_TPTR(ffio->type))
1172 newffio->fop.ptr = (void*)&ffio->fop.ptr;
1174 newffio->fop.ptr = ffio->fop.ptr;
1176 RETURN_UNGCPRO(newfo);
1179 DEFUN("ffi-lisp-object-to-pointer", Fffi_lisp_object_to_pointer, 1, 1, 0, /*
1180 Convert lisp object to FFI pointer.
1184 Lisp_Object newfo = Qnil;
1185 Lisp_EffiObject *newffio;
1186 struct gcpro gcpro1;
1190 newfo = Fmake_ffi_object(Qpointer, Qnil);
1191 newffio = XEFFIO(newfo);
1192 newffio->fotype = EFFI_FOT_BIND;
1193 newffio->fop.ptr = (void*)obj;
1195 /* Hold a reference to OBJ in NEWFO's plist */
1196 Fput(newfo, intern("lisp-object"), obj);
1198 RETURN_UNGCPRO(newfo);
1201 DEFUN("ffi-pointer-to-lisp-object", Fffi_pointer_to_lisp_object, 1, 1, 0, /*
1202 Convert FFI pointer to lisp object.
1207 return (Lisp_Object)XEFFIO(ptr)->fop.ptr;
1210 DEFUN("ffi-plist", Fffi_plist, 1, 1, 0, /*
1211 Return properties list for FFI object FO.
1216 return (XEFFIO(fo)->plist);
1221 static int lf_cindex = 0;
1225 * This will work in most cases.
1226 * However it might not work for large structures,
1227 * In general we should allocate these spaces dynamically
1229 #define MAX_TYPES_VALUES 1024
1230 /* ex_ffitypes_dummies used for structure types */
1231 static ffi_type ex_ffitypes_dummies[MAX_TYPES_VALUES + 1];
1232 static ffi_type *ex_ffitypes[MAX_TYPES_VALUES + 1];
1233 static void *ex_values[MAX_TYPES_VALUES + 1];
1235 #if SIZEOF_LONG == 4
1236 # define effi_type_ulong ffi_type_uint32
1237 # define effi_type_slong ffi_type_sint32
1238 #elif SIZEOF_LONG == 8
1239 # define effi_type_ulong ffi_type_uint64
1240 # define effi_type_slong ffi_type_sint64
1244 extffi_setup_argument(Lisp_Object type, ffi_type **ft)
1246 type = ffi_canonicalise_type(type);
1247 if (EQ(type, Qchar) || EQ(type, Qbyte))
1248 *ft = &ffi_type_schar;
1249 else if (EQ(type, Qunsigned_char) || EQ(type, Qunsigned_byte))
1250 *ft = &ffi_type_uchar;
1251 else if (EQ(type, Qshort))
1252 *ft = &ffi_type_sshort;
1253 else if (EQ(type, Qunsigned_short))
1254 *ft = &ffi_type_ushort;
1255 else if (EQ(type, Qint))
1256 *ft = &ffi_type_sint;
1257 else if (EQ(type, Qunsigned_int))
1258 *ft = &ffi_type_uint;
1259 else if (EQ(type, Qunsigned_long))
1260 *ft = &effi_type_ulong;
1261 else if (EQ(type, Qlong))
1262 *ft = &effi_type_slong;
1263 else if (EQ(type, Qfloat))
1264 *ft = &ffi_type_float;
1265 else if (EQ(type, Qdouble))
1266 *ft = &ffi_type_double;
1267 else if (EQ(type, Qvoid))
1268 *ft = &ffi_type_void;
1269 else if (FFI_TPTR(type))
1270 *ft = &ffi_type_pointer;
1271 else if (CONSP(type) && EQ(XCAR(type), Qstruct)) {
1272 Lisp_Object slots = Fcdr(XCDR(type));
1278 nt_size = XINT(Flength(slots)) + 1;
1279 if (nt_size + lf_cindex > MAX_TYPES_VALUES) {
1280 lf_cindex = 0; /* reset cindex */
1282 error("cindex overflow");
1284 Fsignal(Qoverflow_error,
1286 build_string("cindex overflow")));
1287 #endif /* SXEMACS */
1289 ntypes = &ex_ffitypes[lf_cindex];
1290 *ft = &ex_ffitypes_dummies[lf_cindex];
1292 /* Update lf_cindex in case TYPE struct contains other
1294 lf_cindex += nt_size;
1296 (*ft)->type = FFI_TYPE_STRUCT;
1297 (*ft)->alignment = ffi_type_align(type);
1298 (*ft)->elements = ntypes;
1300 for (i = 0; (i < nt_size) && !NILP(slots); slots = XCDR(slots), i++)
1301 extffi_setup_argument(Fcar(Fcdr(XCAR(slots))), &ntypes[i]);
1305 signal_simple_error("Can't setup argument for type", type);
1307 signal_error(Qinternal_error,
1308 "Can't setup argument for type", type);
1309 #endif /* SXEMACS */
1314 ffi_call_using_libffi(Lisp_Object fo_fun, Lisp_Object ret_fo,
1315 int in_nargs, Lisp_Object *in_args)
1317 Lisp_EffiObject *ffio;
1324 lf_cindex = in_nargs; /* reserve */
1325 for (i = 0; i < in_nargs; i++) {
1326 ffio = XEFFIO(in_args[i]);
1327 fft = Fffi_canonicalise_type(ffio->type);
1328 extffi_setup_argument(fft, &ex_ffitypes[i]);
1330 ex_values[i] = &ffio->fop.ptr;
1332 ex_values[i] = ffio->fop.ptr;
1335 ffio = XEFFIO(ret_fo);
1336 fft = Fffi_canonicalise_type(ffio->type);
1337 extffi_setup_argument(fft, &rtype);
1339 rvalue = &ffio->fop.ptr;
1341 rvalue = ffio->fop.ptr;
1343 if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, in_nargs,
1344 rtype, ex_ffitypes) == FFI_OK)
1346 stop_async_timeouts();
1347 ffi_call(&cif, (void(*)(void))XEFFIO(fo_fun)->fop.fun, rvalue,
1349 start_async_timeouts();
1356 #endif /* HAVE_LIBFFI */
1358 DEFUN("ffi-call-function", Fffi_call_function, 1, MANY, 0, /*
1359 Call a function referred to by FO with arguments ARGS, maybe
1360 return a foreign object with the result or nil if there is
1363 Arguments are: FO &rest FO-ARGS
1365 FO should be a foreign binding initiated by `ffi-defun', and
1366 ARGS should be foreign data objects or pointers to these.
1368 (int nargs, Lisp_Object * args))
1370 Lisp_Object faf = Qnil, retfo = Qnil;
1371 Lisp_EffiObject *ffio;
1373 struct gcpro gcpro1, gcpro2;
1379 retfo = Fmake_ffi_object(XCAR(XCDR(ffio->type)), Qnil);
1382 ret = ffi_call_using_libffi(args[0], retfo, nargs-1, &args[1]);
1383 #endif /* HAVE_LIBFFI */
1385 RETURN_UNGCPRO(ret == 0 ? retfo : Qnil);
1388 #ifdef EF_USE_ASYNEQ
1389 /* handler for asynchronously calling ffi code */
1390 Lisp_Object Qffi_jobp;
1391 #define EFFI_DEBUG_JOB(args...)
1393 exec_sentinel_unwind(Lisp_Object SXE_UNUSED(datum))
1399 exec_sentinel(void *job, ffi_job_t ffij)
1400 __attribute__((always_inline));
1402 exec_sentinel(void *job, ffi_job_t ffij)
1404 /* This function can GC */
1405 /* called from main thread */
1406 int speccount = specpdl_depth(), nargs = ffij->sntnl_nargs, i;
1407 Lisp_Object funcell[nargs+2];
1408 struct gcpro gcpro1;
1410 funcell[0] = ffij->sntnl;
1411 funcell[1] = (Lisp_Object)job;
1412 for (i = 0; i < nargs; i++) {
1413 funcell[2+i] = ffij->sntnl_args[i];
1415 GCPROn(funcell, nargs+2);
1417 record_unwind_protect(exec_sentinel_unwind, Qnil);
1418 /* call the funcell */
1419 Ffuncall(nargs+2, funcell);
1420 /* reset to previous state */
1421 restore_match_data();
1423 unbind_to(speccount, Qnil);
1427 static inline ffi_job_t
1428 allocate_ffi_job(void)
1430 ffi_job_t ffij = xnew(struct ffi_job_s);
1431 EFFI_DEBUG_JOB("allocated: 0x%lx\n", (long unsigned int)ffij);
1435 static inline ffi_job_t
1436 make_ffi_job(Lisp_Object fof, int fof_nargs, Lisp_Object *fof_args,
1437 Lisp_Object sntnl, int sntnl_nargs, Lisp_Object *sntnl_args)
1439 /* exec'd in the main thread */
1440 ffi_job_t ffij = allocate_ffi_job();
1443 SXE_MUTEX_INIT(&ffij->mtx);
1445 if (fof_nargs > 0) {
1446 ffij->fof_nargs = fof_nargs;
1447 ffij->fof_args = xnew_array(Lisp_Object, fof_nargs);
1448 for (i = 0; i < fof_nargs; i++) {
1449 ffij->fof_args[i] = fof_args[i];
1452 ffij->fof_nargs = 0;
1453 ffij->fof_args = NULL;
1456 ffij->sntnl = sntnl;
1457 if (sntnl_nargs > 0) {
1458 ffij->sntnl_nargs = sntnl_nargs;
1459 ffij->sntnl_args = xnew_array(Lisp_Object, sntnl_nargs);
1460 for (i = 0; i < sntnl_nargs; i++) {
1461 ffij->sntnl_args[i] = sntnl_args[i];
1464 ffij->sntnl_nargs = 0;
1465 ffij->sntnl_args = NULL;
1468 ffij->result = Qnil;
1469 ffij->retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil);
1474 mark_ffi_job(worker_job_t job)
1476 ffi_job_t ffij = ffi_job(job);
1482 SXE_MUTEX_LOCK(&ffij->mtx);
1483 mark_object(ffij->fof);
1484 for (i = 0; i < ffij->fof_nargs; i++) {
1485 mark_object(ffij->fof_args[i]);
1487 mark_object(ffij->sntnl);
1488 for (i = 0; i < ffij->sntnl_nargs; i++) {
1489 mark_object(ffij->sntnl_args[i]);
1491 mark_object(ffij->retfo);
1492 mark_object(ffij->result);
1493 SXE_MUTEX_UNLOCK(&ffij->mtx);
1498 print_ffi_job(worker_job_t job, Lisp_Object pcf)
1500 ffi_job_t ffij = ffi_job(job);
1502 SXE_MUTEX_LOCK(&ffij->mtx);
1503 WRITE_FMT_STRING(pcf, " carrying #<ffi-job 0x%lx>",
1504 (long unsigned int)ffij);
1505 SXE_MUTEX_UNLOCK(&ffij->mtx);
1510 finish_ffi_job_data(ffi_job_t ffij)
1512 SXE_MUTEX_LOCK(&ffij->mtx);
1513 xfree(ffij->fof_args);
1514 xfree(ffij->sntnl_args);
1515 SXE_MUTEX_UNLOCK(&ffij->mtx);
1516 SXE_MUTEX_FINI(&ffij->mtx);
1518 EFFI_DEBUG_JOB("finished: 0x%lx\n", (long unsigned int)ffij);
1523 finish_ffi_job(worker_job_t job)
1527 lock_worker_job(job);
1528 ffij = ffi_job(job);
1531 finish_ffi_job_data(ffij);
1533 worker_job_data(job) = NULL;
1534 unlock_worker_job(job);
1539 ffi_job_handle(worker_job_t job)
1542 /* usually called from aux threads */
1544 Lisp_Object fof = Qnil, retfo = Qnil, *args = NULL;
1545 int nargs, ret = -1;
1547 lock_worker_job(job);
1548 ffij = ffi_job(job);
1549 unlock_worker_job(job);
1550 SXE_MUTEX_LOCK(&ffij->mtx);
1552 nargs = ffij->fof_nargs;
1553 args = ffij->fof_args;
1554 SXE_MUTEX_UNLOCK(&ffij->mtx);
1556 /* can't ... Fmake_ffi_object is not mt-safe */
1557 /* retfo = Fmake_ffi_object(XCAR(XCDR(XEFFIO(fof)->type)), Qnil); */
1558 retfo = ffij->retfo;
1561 ret = ffi_call_using_libffi(fof, retfo, nargs, args);
1562 #endif /* HAVE_LIBFFI */
1564 SXE_MUTEX_LOCK(&ffij->mtx);
1565 ffij->result = retfo;
1566 SXE_MUTEX_UNLOCK(&ffij->mtx);
1569 EFFI_DEBUG_JOB("job 0x%lx succeeded\n", (long unsigned int)ffij);
1574 ffi_job_finished(worker_job_t job)
1576 if (NILP(ffi_job_sentinel(job) /* sentinel */)) {
1579 /* called from main thread */
1580 exec_sentinel(job, ffi_job(job));
1584 static struct work_handler_s ffi_job_handler = {
1585 mark_ffi_job, print_ffi_job, finish_ffi_job,
1586 ffi_job_handle, NULL, ffi_job_finished
1590 make_ffi_asyneq_job(ffi_job_t ffij)
1592 /* create a job digestible by the asyneq */
1593 Lisp_Object job = Qnil;
1594 struct gcpro gcpro1;
1597 job = wrap_object(make_worker_job(&ffi_job_handler));
1598 XWORKER_JOB_DATA(job) = ffij;
1599 /* the scratch buffer thingie */
1604 DEFUN("ffi-call-function&", Fffi_call_functionX, 1, MANY, 0, /*
1605 Call a function referred to by FO with arguments ARGS asynchronously,
1606 return a job object.
1608 Arguments are: FO &rest FO-ARGS &aux SENTINEL &rest SENTINEL-ARGS
1610 FO should be a foreign binding initiated by `ffi-defun'.
1611 FO-ARGS should be exactly as many foreign data objects as FO needs.
1612 SENTINEL is a lisp sentinel function called when the job finished,
1613 the function should take at least one argument JOB, further arguments
1614 may be specified by passing further SENTINEL-ARGS.
1616 (int nargs, Lisp_Object *args))
1618 Lisp_Object job = Qnil;
1619 Lisp_Object sntnl, fof, *sntnl_args, *fof_args;
1620 int sntnl_nargs, fof_nargs;
1622 struct gcpro gcpro1, gcpro2;
1624 CHECK_EFFIO(args[0]);
1625 GCPRO1n(job, args, nargs);
1628 /* determine how many args belong to the fof */
1629 fof_nargs = XINT(Flength(XCDR(XEFFIO(fof)->type)))-1;
1630 fof_args = &args[1];
1632 if ((sntnl_nargs = nargs - fof_nargs - 2) >= 0) {
1633 sntnl = args[fof_nargs+1];
1634 sntnl_args = &args[fof_nargs+2];
1640 /* create the job data object */
1641 ffij = make_ffi_job(fof, fof_nargs, fof_args,
1642 sntnl, sntnl_nargs, sntnl_args);
1643 /* now prepare the job to dispatch */
1644 job = make_ffi_asyneq_job(ffij);
1645 /* ... and dispatch it, change its state to queued */
1646 XWORKER_JOB_STATE(job) = WORKER_JOB_QUEUED;
1647 eq_enqueue(delegate_eq, job);
1648 /* brag about new jobs in the queue */
1649 eq_queue_trigger_all(delegate_eq);
1654 #endif /* EF_USE_ASYNEQ */
1656 extern struct device *decode_x_device(Lisp_Object device);
1658 DEFUN("x-device-display", Fx_device_display, 0, 1, 0, /*
1659 Return DEVICE display as FFI object.
1666 fo = Fmake_ffi_object(Qpointer, Qnil);
1667 XEFFIO(fo)->fotype = EFFI_FOT_BIND;
1668 XEFFIO(fo)->fop.ptr = (void*)DEVICE_X_DISPLAY(decode_x_device(device));
1676 #define FFI_CC_CDECL 0
1678 #if defined __i386__
1680 ffi_callback_call_x86(Lisp_Object cbk_info, char *arg_buffer)
1682 Lisp_Object fun, alist = Qnil, retlo, foret;
1683 Lisp_Object rtype, argtypes;
1684 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1687 fun = Fcar(cbk_info);
1688 rtype = Fcar(Fcdr(cbk_info));
1689 argtypes = Fcar(Fcdr(Fcdr(cbk_info)));
1691 CHECK_LIST(argtypes);
1693 arg_buffer += 4; /* Skip return address */
1694 while (!NILP(argtypes)) {
1695 Lisp_Object result, ctype;
1698 ctype = ffi_canonicalise_type(XCAR(argtypes));
1699 size = XINT(Fffi_size_of_type(ctype));
1700 if (EQ(ctype, Qc_string)) {
1701 char *aptr = *(char**)arg_buffer;
1703 result = ffi_fetch_foreign(aptr, ctype);
1707 result = ffi_fetch_foreign(arg_buffer, ctype);
1708 /* Apply translators and put the result into alist */
1709 result = apply1(Findirect_function(Qffi_translate_from_foreign),
1710 list2(result, XCAR(argtypes)));
1711 alist = Fcons(result, alist);
1714 int sp = (size + mask) & ~mask;
1717 argtypes = XCDR(argtypes);
1719 alist = Fnreverse(alist);
1721 /* Special case, we have no return value */
1722 if (EQ(rtype, Qvoid)) {
1723 GCPRO3(fun, alist, rtype);
1729 GCPRO5(fun, alist, rtype, retlo, foret);
1730 retlo = apply1(fun, alist);
1731 foret = Fmake_ffi_object(rtype, Qnil);
1732 Fffi_store(foret, make_int(0), rtype, retlo);
1733 ptr = (void*)XEFFIO(foret)->fop.ptr;
1734 if (EQ(rtype, Qdouble)) {
1737 asm volatile ("fldl (%0)" :: "a" (ptr));
1740 } else if (EQ(rtype, Qfloat)) {
1743 asm volatile ("flds (%0)" :: "a" (ptr));
1749 if (EQ(rtype, Qbyte) || EQ(rtype, Qchar))
1751 else if (EQ(rtype, Qunsigned_byte) || EQ(rtype, Qunsigned_char))
1752 iv = *(char unsigned*)ptr;
1753 else if (EQ(rtype, Qshort))
1755 else if (EQ(rtype, Qunsigned_short))
1756 iv = *(unsigned short*)ptr;
1761 asm volatile ("movl %0,%%eax;" :: "r" (iv) : "%eax");
1768 ffi_make_callback_x86(Lisp_Object data, int cc_type)
1772 * pushl <data> 68 <addr32>
1773 * call ffi_callback_call_x86 E8 <disp32>
1781 char *buf = xmalloc(sizeof(char)*16);
1782 *(char*) (buf+0) = 0x54;
1783 *(char*) (buf+1) = 0x68;
1784 *(long*) (buf+2) = (long)data;
1785 *(char*) (buf+6) = 0xE8;
1786 *(long*) (buf+7) = (long)ffi_callback_call_x86 - (long)(buf+11);
1787 *(char*) (buf+11) = 0x59;
1788 *(char*) (buf+12) = 0x59;
1789 if (cc_type == FFI_CC_CDECL) {
1790 *(char*) (buf+13) = 0xc3;
1791 *(short*)(buf+14) = 0x9090;
1793 Lisp_Object arg_types = Fcar(Fcdr(Fcdr(data)));
1797 CHECK_CONS(arg_types);
1799 while (!NILP(arg_types)) {
1800 int sz = XINT(Fffi_size_of_type(XCAR(arg_types)));
1801 byte_size += ((sz+mask)&(~mask));
1802 arg_types = XCDR(arg_types);
1805 *(char*) (buf+13) = 0xc2;
1806 *(short*)(buf+14) = (short)byte_size;
1811 #endif /* __i386__ */
1813 DEFUN("ffi-make-callback", Fffi_make_callback, 4, 4, 0, /*
1814 Create dynamic callback and return pointer to it.
1816 (fun, rtype, argtypes, cctype))
1823 data = list3(fun, rtype, argtypes);
1824 /* Put data as property of the fun, so it(data) wont be GCed */
1825 Fput(fun, Qffi_callback, data);
1826 ptr = Fmake_ffi_object(Qpointer, Qnil);
1828 XEFFIO(ptr)->fop.ptr = ffi_make_callback_x86(data, XINT(cctype));
1829 #endif /* __i386__ */
1836 INIT_LRECORD_IMPLEMENTATION(ffiobject);
1841 DEFSYMBOL(Qc_string);
1846 DEFSYMBOL(Qunsigned_byte);
1847 DEFSYMBOL(Qunsigned_char);
1848 DEFSYMBOL(Qunsigned_int);
1849 DEFSYMBOL(Qunsigned_long);
1850 DEFSYMBOL(Qunsigned_short);
1852 /* ### This is broken, the lrecord needs to be called ffi_object,
1853 and then this would be a DEFSYMBOL_MULTIWORD_PREDICATE(). Not
1854 doing it in this commit, though. */
1855 defsymbol(&Qffiobjectp, "ffi-object-p");
1857 DEFSYMBOL(Qffi_translate_to_foreign);
1858 DEFSYMBOL(Qffi_translate_from_foreign);
1860 DEFSYMBOL(Qffi_callback);
1862 DEFSUBR(Fffi_basic_type_p);
1863 DEFSUBR(Fffi_canonicalise_type);
1864 DEFSUBR(Fffi_size_of_type);
1865 DEFSUBR(Fmake_ffi_object);
1866 DEFSUBR(Fffi_object_p);
1867 DEFSUBR(Fffi_make_pointer);
1868 DEFSUBR(Fffi_object_address);
1869 DEFSUBR(Fffi_object_canonical_type);
1870 DEFSUBR(Fffi_object_type);
1871 DEFSUBR(Fffi_object_size);
1872 DEFSUBR(Fffi_set_storage_size);
1873 DEFSUBR(Fffi_set_object_type);
1874 DEFSUBR(Fffi_fetch);
1876 DEFSUBR(Fffi_store);
1878 DEFSUBR(Fffi_address_of);
1879 DEFSUBR(Fffi_type_alignment);
1880 DEFSUBR(Fffi_slot_offset);
1881 DEFSUBR(Fffi_load_library);
1883 DEFSUBR(Fffi_dlerror);
1884 DEFSUBR(Fffi_defun);
1885 DEFSUBR(Fffi_call_function);
1887 DEFSUBR(Fffi_lisp_object_to_pointer);
1888 DEFSUBR(Fffi_pointer_to_lisp_object);
1889 DEFSUBR(Fffi_plist);
1891 #ifdef EF_USE_ASYNEQ
1892 DEFSUBR(Fffi_call_functionX);
1893 defsymbol(&Qffi_jobp, "ffi-job-p");
1896 DEFSUBR(Fx_device_display);
1898 DEFSUBR(Fffi_make_callback);
1902 reinit_vars_of_ffi(void)
1904 staticpro_nodump(&Vffi_all_objects);
1905 Vffi_all_objects = make_weak_list(WEAK_LIST_SIMPLE);
1911 reinit_vars_of_ffi();
1913 DEFVAR_LISP("ffi-named-types", &Vffi_named_types /*
1914 Alist of named FFI types with elements of the form (NAME . FFI-TYPE).
1916 Vffi_named_types = Qnil;
1918 DEFVAR_LISP("ffi-loaded-libraries", &Vffi_loaded_libraries /*
1919 Alist of loaded libraries with elements of the form (LIB-NAME . FFIO).
1921 Vffi_loaded_libraries = Qnil;
1923 DEFVAR_LISP("ffi-type-checker", &Vffi_type_checker /*
1924 Function to call when the validity of an FFI type shall be checked.
1926 Vffi_type_checker = intern("ffi-type-p");