Automatic generation of calls to C functions, plus fixes on the handling of :CSTRING arguments to C-INLINE

src/CHANGELOG

@@ -51,6 +51,15 @@ ECL 0.9h
    with a user-defined foreign type that is an alias for a primitive type
    (M. Goffioul)
 
+ - C-INLINE forms which contain :CSTRING as argument are now automatically
+   rewritten in terms of WITH-CSTRING. This way, the null terminated strings
+   that are generated at run time will not be garbage collected.
+
+ - There is a primitive implementation of run-time automatic generation of
+   interfaces to C functions. This allows us to call functions in shared
+   libraries without need of the compiler. The current implementation only
+   works on the intel architecture with GCC, but should be easily extended.
+
 ;;; Local Variables: ***
 ;;; mode:text ***
 ;;; fill-column:79 ***

src/aclocal.m4

@@ -497,3 +497,25 @@ AC_MSG_RESULT([${CFLAGS}])
 AC_MSG_CHECKING([Linker flags])
 AC_MSG_RESULT([${LDFLAGS}])
 ])
+
+dnl
+dnl ------------------------------------------------------------
+dnl Do we have a non-portable implementation of calls to foreign
+dnl functions?
+dnl
+AC_DEFUN([ECL_FFI],[
+AC_MSG_CHECKING([whether we can dynamically build calls to C functions])
+case "${host_cpu}" in
+   i686 |i586 | pentium* | athlon* )
+	EXTRA_OBJS="${EXTRA_OBJS} ffi_x86.o"
+	dynamic_ffi=yes
+	;;
+   *)
+	dynamic_ffi=no
+	;;
+esac
+AC_MSG_RESULT([${dynamic_ffi}])
+if test "$dynamic_ffi" = "yes" ; then
+  AC_DEFINE(ECL_DYNAMIC_FFI, 1, [we can build calls to foreign functions])
+fi
+])

src/c/Makefile.in

@@ -56,6 +56,8 @@ OBJS	= main.o symbol.o package.o list.o\
 	$(CC) $(CFLAGS) -o $@ $<
 %.c: %.d $(DPP) $(HFILES)
 	if test -f ../CROSS-DPP ; then ../CROSS-DPP $< $@ ; else $(DPP) $< $@ ; fi
+%.c: arch/%.d $(DPP) $(HFILES)
+	if test -f ../CROSS-DPP ; then ../CROSS-DPP $< $@ ; else $(DPP) $< $@ ; fi
 
 all:	$(DPP) external.h ../libeclmin.a ../cinit.o
 .PHONY:	all
@@ -107,6 +109,8 @@ $(srcdir)/symbols_list2.h: $(srcdir)/symbols_list.h Makefile
 #
 gbc.o: gbc.c $(HFILES)
 	$(CC) $(CFLAGS) -O0 gbc.c -o $@
+ffi_x86.o: ffi_x86.c $(HFILES)
+	$(CC) $(CFLAGS) -O0 ffi_x86.c -o $@
 #
 # This reduces the overhead of jumping to other functions
 #

src/c/ffi.d

@@ -14,6 +14,43 @@
 
 #include <string.h>
 #include "ecl.h"
+#include "internal.h"
+
+static const cl_object ecl_foreign_type_table[] = {
+	@':char',
+	@':unsigned-char',
+	@':byte',
+	@':unsigned-byte',
+	@':short',
+	@':unsigned-short',
+	@':int',
+	@':unsigned-int',
+	@':long',
+	@':unsigned-long',
+	@':pointer-void',
+	@':cstring',
+	@':object',
+	@':float',
+	@':double',
+	@':void'};
+
+static unsigned int ecl_foreign_type_size[] = {
+	sizeof(char),
+	sizeof(unsigned char),
+	sizeof(int8_t),
+	sizeof(uint8_t),
+	sizeof(short),
+	sizeof(unsigned short),
+	sizeof(int),
+	sizeof(unsigned int),
+	sizeof(long),
+	sizeof(unsigned long),
+	sizeof(void *),
+	sizeof(char *),
+	sizeof(cl_object),
+	sizeof(float),
+	sizeof(double),
+	0};
 
 cl_object
 ecl_make_foreign_data(cl_object tag, cl_index size, void *data)
@@ -170,176 +207,148 @@ si_foreign_data_set(cl_object f, cl_object andx, cl_object value)
 	@(return value)
 }
 
-cl_object
-si_foreign_data_ref_elt(cl_object f, cl_object andx, cl_object tag)
+enum ecl_ffi_tag
+ecl_foreign_type_code(cl_object type)
 {
-	cl_object output;
-	cl_index ndx = fixnnint(andx);
-	cl_index limit = f->foreign.size;
-	void *p;
-
-	if (type_of(f) != t_foreign) {
-		FEwrong_type_argument(@'si::foreign-data', f);
+	int i;
+	for (i = 0; i <= ECL_FFI_VOID; i++) {
+		if (type == ecl_foreign_type_table[i])
+			return (enum ecl_ffi_tag)i;
 	}
-	if (ndx >= limit) {
-	ERROR:	FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
-	}
-	p = (void*)(f->foreign.data + ndx);
-	if (tag == @':byte') {
-		if (ndx + sizeof(int8_t) > limit) goto ERROR;
-		output = MAKE_FIXNUM(*(int8_t *)p);
-	} else if (tag == @':unsigned-byte') {
-		if (ndx + sizeof(uint8_t) > limit) goto ERROR;
-		output = MAKE_FIXNUM(*(uint8_t *)p);
-	} else if (tag == @':char') {
-		if (ndx + sizeof(char) > limit) goto ERROR;
-		output = CODE_CHAR(*(char *)p);
-	} else if (tag == @':unsigned-char') {
-		if (ndx + sizeof(unsigned char) > limit) goto ERROR;
-		output = CODE_CHAR(*(unsigned char *)p);
-	} else if (tag == @':short') {
-		if (ndx + sizeof(short) > limit) goto ERROR;
-		output = MAKE_FIXNUM(*(short *)p);
-	} else if (tag == @':unsigned-short') {
-		if (ndx + sizeof(unsigned short) > limit) goto ERROR;
-		output = MAKE_FIXNUM(*(unsigned short *)p);
-	} else if (tag == @':int') {
-		if (ndx + sizeof(int) > limit) goto ERROR;
-		output = make_integer(*(int *)p);
-	} else if (tag == @':unsigned-int') {
-		if (ndx + sizeof(unsigned int) > limit) goto ERROR;
-		output = make_unsigned_integer(*(unsigned int *)p);
-	} else if (tag == @':long') {
-		if (ndx + sizeof(long) > limit) goto ERROR;
-		output = make_integer(*(long *)p);
-	} else if (tag == @':unsigned-long') {
-		if (ndx + sizeof(unsigned long) > limit) goto ERROR;
-		output = make_unsigned_integer(*(unsigned long *)p);
-	} else if (tag == @':pointer-void') {
-		if (ndx + sizeof(void *) > limit) goto ERROR;
-		output = ecl_make_foreign_data(@':pointer-void', 0, *(void **)p);
-	} else if (tag == @':cstring') {
-		if (ndx + sizeof(char *) > limit) goto ERROR;
-		output = *(char **)p ? make_simple_string(*(char **)p) : Cnil;
-	} else if (tag == @':object') {
-		if (ndx + sizeof(cl_object) > limit) goto ERROR;
-		output = *(cl_object *)p;
-	} else if (tag == @':float') {
-		if (ndx + sizeof(float) > limit) goto ERROR;
-		output = make_shortfloat(*(float *)p);
-	} else if (tag == @':double') {
-		if (ndx + sizeof(double) > limit) goto ERROR;
-		output = make_longfloat(*(double *)p);
-	} else {
-		FEerror("~A does not denote a foreign type.", 1, tag);
-	}
-	@(return output)
+	FEerror("~A does not denote an elementary foreign type.", 1, type);
+	return ECL_FFI_VOID;
 }
 
 cl_object
-si_foreign_data_set_elt(cl_object f, cl_object andx, cl_object tag, cl_object value)
+ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag tag)
+{
+	switch (tag) {
+	case ECL_FFI_CHAR:
+		return CODE_CHAR(*(char *)p);
+	case ECL_FFI_UNSIGNED_CHAR:
+		return CODE_CHAR(*(unsigned char *)p);
+	case ECL_FFI_BYTE:
+		return MAKE_FIXNUM(*(int8_t *)p);
+	case ECL_FFI_UNSIGNED_BYTE:
+		return MAKE_FIXNUM(*(uint8_t *)p);
+	case ECL_FFI_SHORT:
+		return MAKE_FIXNUM(*(short *)p);
+	case ECL_FFI_UNSIGNED_SHORT:
+		return MAKE_FIXNUM(*(unsigned short *)p);
+	case ECL_FFI_INT:
+		return make_integer(*(int *)p);
+	case ECL_FFI_UNSIGNED_INT:
+		return make_unsigned_integer(*(unsigned int *)p);
+	case ECL_FFI_LONG:
+		return make_integer(*(long *)p);
+	case ECL_FFI_UNSIGNED_LONG:
+		return make_unsigned_integer(*(unsigned long *)p);
+	case ECL_FFI_POINTER_VOID:
+		return ecl_make_foreign_data(@':pointer-void', 0, *(void **)p);
+	case ECL_FFI_CSTRING:
+		return *(char **)p ? make_simple_string(*(char **)p) : Cnil;
+	case ECL_FFI_OBJECT:
+		return *(cl_object *)p;
+	case ECL_FFI_FLOAT:
+		return make_shortfloat(*(float *)p);
+	case ECL_FFI_DOUBLE:
+		return make_longfloat(*(double *)p);
+	case ECL_FFI_VOID:
+		return Cnil;
+	}
+}
+
+void
+ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag tag, cl_object value)
+{
+	switch (tag) {
+	case ECL_FFI_CHAR:
+		*(char *)p = char_code(value);
+		break;
+	case ECL_FFI_UNSIGNED_CHAR:
+		*(unsigned char*)p = char_code(value);
+		break;
+	case ECL_FFI_BYTE:
+		*(int8_t *)p = fixint(value);
+		break;
+	case ECL_FFI_UNSIGNED_BYTE:
+		*(uint8_t *)p = fixnnint(value);
+		break;
+	case ECL_FFI_SHORT:
+		*(short *)p = fixint(value);
+		break;
+	case ECL_FFI_UNSIGNED_SHORT:
+		*(unsigned short *)p = fixnnint(value);
+		break;
+	case ECL_FFI_INT:
+		*(int *)p = fixint(value);
+		break;
+	case ECL_FFI_UNSIGNED_INT:
+		*(unsigned int *)p = fixnnint(value);
+		break;
+	case ECL_FFI_LONG:
+		*(long *)p = fixint(value);
+		break;
+	case ECL_FFI_UNSIGNED_LONG:
+		*(unsigned long *)p = fixnnint(value);
+		break;
+	case ECL_FFI_POINTER_VOID:
+		*(void **)p = ecl_foreign_data_pointer_safe(value);
+		break;
+	case ECL_FFI_CSTRING:
+		*(char **)p = value == Cnil ? NULL : value->string.self;
+		break;
+	case ECL_FFI_OBJECT:
+		*(cl_object *)p = value;
+		break;
+	case ECL_FFI_FLOAT:
+		*(float *)p = object_to_float(value);
+		break;
+	case ECL_FFI_DOUBLE:
+		*(double *)p = object_to_double(value);
+		break;
+	case ECL_FFI_VOID:
+		break;
+	}
+}
+
+cl_object
+si_foreign_data_ref_elt(cl_object f, cl_object andx, cl_object type)
+{
+	cl_index ndx = fixnnint(andx);
+	cl_index limit = f->foreign.size;
+	enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
+	if (ndx >= limit || (ndx + ecl_foreign_type_size[tag] > limit)) {
+		FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
+	}
+	if (type_of(f) != t_foreign) {
+		FEwrong_type_argument(@'si::foreign-data', f);
+	}
+	@(return ecl_foreign_data_ref_elt((void*)(f->foreign.data + ndx), tag))
+}
+
+cl_object
+si_foreign_data_set_elt(cl_object f, cl_object andx, cl_object type, cl_object value)
 {
 	cl_index ndx = fixnnint(andx);
 	cl_index limit = f->foreign.size;
 	void *p;
-
+	enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
+	if (ndx >= limit || ndx + ecl_foreign_type_size[tag] > limit) {
+		FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
+	}
 	if (type_of(f) != t_foreign) {
 		FEwrong_type_argument(@'si::foreign-data', f);
 	}
-	if (ndx >= limit) {
-	ERROR:	FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
-	}
-	p = (void*)(f->foreign.data + ndx);
-	if (tag == @':byte') {
-		if (ndx + sizeof(int8_t) > limit) goto ERROR;
-		*(int8_t *)p = fixint(value);
-	} else if (tag == @':unsigned-byte') {
-		if (ndx + sizeof(uint8_t) > limit) goto ERROR;
-		*(uint8_t *)p = fixnnint(value);
-	} else if (tag == @':char') {
-		if (ndx + sizeof(char) > limit) goto ERROR;
-		*(char *)p = char_code(value);
-	} else if (tag == @':unsigned-char') {
-		if (ndx + sizeof(unsigned char) > limit) goto ERROR;
-		*(unsigned char*)p = char_code(value);
-	} else if (tag == @':short') {
-		if (ndx + sizeof(short) > limit) goto ERROR;
-		*(short *)p = fixint(value);
-	} else if (tag == @':unsigned-short') {
-		if (ndx + sizeof(unsigned short) > limit) goto ERROR;
-		*(unsigned short *)p = fixnnint(value);
-	} else if (tag == @':int') {
-		if (ndx + sizeof(int) > limit) goto ERROR;
-		*(int *)p = fixint(value);
-	} else if (tag == @':unsigned-int') {
-		if (ndx + sizeof(unsigned int) > limit) goto ERROR;
-		*(unsigned int *)p = fixnnint(value);
-	} else if (tag == @':long') {
-		if (ndx + sizeof(long) > limit) goto ERROR;
-		*(long *)p = fixint(value);
-	} else if (tag == @':unsigned-long') {
-		if (ndx + sizeof(unsigned long) > limit) goto ERROR;
-		*(unsigned long *)p = fixnnint(value);
-	} else if (tag == @':pointer-void') {
-		if (ndx + sizeof(void *) > limit) goto ERROR;
-		*(void **)p = ecl_foreign_data_pointer_safe(value);
-	} else if (tag == @':cstring') {
-		if (ndx + sizeof(void *) > limit) goto ERROR;
-		*(char **)p = value == Cnil ? NULL : value->string.self;
-	} else if (tag == @':object') {
-		if (ndx + sizeof(cl_object) > limit) goto ERROR;
-		*(cl_object *)p = value;
-	} else if (tag == @':float') {
-		if (ndx + sizeof(float) > limit) goto ERROR;
-		*(float *)p = object_to_float(value);
-	} else if (tag == @':double') {
-		if (ndx + sizeof(double) > limit) goto ERROR;
-		*(double *)p = object_to_double(value);
-	} else {
-		FEerror("~A does not denote a foreign type.", 1, tag);
-	}
+	ecl_foreign_data_set_elt((void*)(f->foreign.data + ndx), tag, value);
 	@(return value)
 }
 
 cl_object
-si_size_of_foreign_elt_type(cl_object tag)
+si_size_of_foreign_elt_type(cl_object type)
 {
-	cl_fixnum size;
-
-	if (tag == @':byte') {
-		size = sizeof(int8_t);
-	} else if (tag == @':unsigned-byte') {
-		size = sizeof(uint8_t);
-	} else if (tag == @':char') {
-		size = sizeof(char);
-	} else if (tag == @':unsigned-char') {
-		size = sizeof(unsigned char);
-	} else if (tag == @':short') {
-		size = sizeof(short);
-	} else if (tag == @':unsigned-short') {
-		size = sizeof(unsigned short);
-	} else if (tag == @':int') {
-		size = sizeof(int);
-	} else if (tag == @':unsigned-int') {
-		size = sizeof(unsigned int);
-	} else if (tag == @':long') {
-		size = sizeof(long);
-	} else if (tag == @':unsigned-long') {
-		size = sizeof(unsigned long);
-	} else if (tag == @':pointer-void') {
-		size = sizeof(void *);
-        } else if (tag == @':cstring') {
-		size = sizeof(char*);
-	} else if (tag == @':object') {
-		size = sizeof(cl_object);
-	} else if (tag == @':float') {
-		size = sizeof(float);
-	} else if (tag == @':double') {
-		size = sizeof(double);
-	} else {
-		FEerror("~A does not denote a foreign type.", 1, tag);
-	}
-	@(return MAKE_FIXNUM(size))
+	enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
+	@(return MAKE_FIXNUM(ecl_foreign_type_size[tag]))
 }
 
 cl_object
@@ -419,3 +428,95 @@ OUTPUT:
 	else
 		FEerror("FIND-FOREIGN-SYMBOL: Could not load foreign symbol ~S from module ~S (Error: ~S)", 3, var, module, output);
 }
+
+#ifdef ECL_DYNAMIC_FFI
+
+static void
+ecl_fficall_overflow()
+{
+	FEerror("Stack overflow on SI:CALL-CFUN", 0);
+}
+
+void
+ecl_fficall_prepare(cl_object return_type, cl_object arg_type)
+{
+	struct ecl_fficall *fficall = cl_env.fficall;
+	fficall->buffer_sp = fficall->buffer;
+	fficall->buffer_size = 0;
+	fficall->cstring = Cnil;
+}
+
+void
+ecl_fficall_push_bytes(void *data, size_t bytes)
+{
+	struct ecl_fficall *fficall = cl_env.fficall;
+	fficall->buffer_size += bytes;
+	if (fficall->buffer_size >= ECL_FFICALL_LIMIT)
+		ecl_fficall_overflow();
+	memcpy(fficall->buffer_sp, (char*)data, bytes);
+	fficall->buffer_sp += bytes;
+}
+
+void
+ecl_fficall_push_int(int data)
+{
+	ecl_fficall_push_bytes(&data, sizeof(int));
+}
+
+void
+ecl_fficall_align(int data)
+{
+	struct ecl_fficall *fficall = cl_env.fficall;
+	if (data == 1)
+		return;
+	else {
+		size_t sp = fficall->buffer_sp - fficall->buffer;
+		size_t mask = data - 1;
+		size_t new_sp = (sp + mask) & ~mask;
+		if (new_sp >= ECL_FFICALL_LIMIT)
+			ecl_fficall_overflow();
+		fficall->buffer_sp = fficall->buffer + new_sp;
+		fficall->buffer_size = new_sp;
+	}
+}
+
+cl_object
+si_call_cfun(cl_object fun, cl_object return_type, cl_object arg_types,
+	     cl_object args)
+{
+	struct ecl_fficall *fficall = cl_env.fficall;
+	void *cfun = ecl_foreign_data_pointer_safe(fun);
+	cl_object object;
+	enum ecl_ffi_tag return_type_tag = ecl_foreign_type_code(return_type);
+
+	ecl_fficall_prepare(return_type, arg_types);
+	while (CONSP(arg_types)) {
+		enum ecl_ffi_tag type;
+		if (!CONSP(args)) {
+			FEerror("In SI:CALL-CFUN, mismatch between argument types and argument list: ~A vs ~A", 0);
+		}
+		type = ecl_foreign_type_code(CAR(arg_types));
+		if (type == ECL_FFI_CSTRING) {
+			object = ecl_null_terminated_string(CAR(args));
+			if (CAR(args) != object)
+				fficall->cstring =
+					CONS(object, fficall->cstring);
+		} else {
+			object = CAR(args);
+		}
+		ecl_foreign_data_set_elt(&fficall->output, type, object);
+		ecl_fficall_push_arg(&fficall->output, type);
+		arg_types = CDR(arg_types);
+		args = CDR(args);
+	}
+	ecl_fficall_execute(cfun, fficall, return_type_tag);
+	object = ecl_foreign_data_ref_elt(&fficall->output, return_type_tag);
+
+	fficall->buffer_size = 0;
+	fficall->buffer_sp = fficall->buffer;
+	fficall->cstring = Cnil;
+
+	@(return object)
+}
+
+#endif /* ECL_DYNAMIC_FFI */

src/c/gbc.d

@@ -495,6 +495,11 @@ mark_cl_env(struct cl_env_struct *env)
 	mark_stack_conservative((cl_ptr)env->cs_org, (cl_ptr)(&where));
 # endif /* DOWN_STACK */
 #endif /* THREADS */
+
+#ifdef ECL_FFICALL
+	mark_contblock(env->fficall, sizeof(struct ecl_fficall));
+	mark_object(((struct ecl_fficall*)env->fficall)->cstring);
+#endif
 }
 
 static void

src/c/load.d

@@ -97,6 +97,9 @@ ecl_library_symbol(cl_object block, const char *symbol) {
 			CloseHandle(hndSnap);
 		}
 		return hnd;
+#endif
+#ifdef HAVE_DLFCN_H
+		return dlsym(0, symbol);
 #endif
 	} else {
 #ifdef HAVE_DLFCN_H

src/c/main.d

@@ -79,6 +79,10 @@ ecl_init_env(struct cl_env_struct *env)
 # endif /* THREADS */
 #endif /* !GBC_BOEHM */
 
+#ifdef ECL_DYNAMIC_FFI
+	env->fficall = malloc(sizeof(struct ecl_fficall));
+#endif
+
 	init_stacks(&i);
 }
 
@@ -433,6 +437,9 @@ cl_boot(int argc, char **argv)
 #endif
 #ifdef ECL_CLOS_STREAMS
 	ADD_FEATURE("CLOS-STREAMS");
+#endif
+#ifdef ECL_DYNAMIC_FFI
+	ADD_FEATURE("DFFI");
 #endif
 	/* This is assumed in all systems */
 	ADD_FEATURE("IEEE-FLOATING-POINT");

src/c/symbols_list.h

@@ -1552,6 +1552,8 @@ cl_symbols[] = {
 
 {SYS_ "*CODE-WALKER*", SI_SPECIAL, NULL, -1, OBJNULL},
 
+{SYS_ "CALL-CFUN", SI_ORDINARY, si_call_cfun, 4, OBJNULL},
+
 /* Tag for end of list */
 {NULL, CL_ORDINARY, NULL, -1, OBJNULL}};
 

src/c/symbols_list2.h

@@ -1552,6 +1552,8 @@ cl_symbols[] = {
 
 {SYS_ "*CODE-WALKER*",NULL},
 
+{SYS_ "CALL-CFUN","si_call_cfun"},
+
 /* Tag for end of list */
 {NULL,NULL}};
 

src/cmp/cmpffi.lsp

@@ -255,16 +255,17 @@
     ;; null-terminated strings, but not all of our lisp strings will
     ;; be null terminated. In particular, those with a fill pointer
     ;; will not.
-    (let ((ndx (position :cstring arguments)))
+    (let ((ndx (position :cstring arg-types)))
       (when ndx
 	(let* ((var (gensym))
-	       (value (elt ndx arguments)))
-	  (setf (elt ndx arguments) var
-		(elt ndx arg-types) :char*)
+	       (value (elt arguments ndx)))
+	  (setf (elt arguments ndx) var
+		(elt arg-types ndx) :char*)
 	  (return-from c1c-inline
-	    `(with-ctring (,var ,value)
-	      (c1c-inline ,arguments ,arg-types ,output-type ,c-expression
-	       ,@rest))))))
+	    (c1expr
+	     `(ffi::with-ctring (,var ,value)
+	       (c1c-inline ,arguments ,arg-types ,output-type ,c-expression
+		,@rest)))))))
     ;; Find out the output types of the inline form. The syntax is rather relax
     ;; 	output-type = lisp-type | c-type | (values {lisp-type | c-type}*)
     (flet ((produce-type-pair (type)

src/configure

@@ -6795,6 +6795,28 @@ rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
 fi
 
 
+echo "$as_me:$LINENO: checking whether we can dynamically build calls to C functions" >&5
+echo $ECHO_N "checking whether we can dynamically build calls to C functions... $ECHO_C" >&6
+case "${host_cpu}" in
+   i686 |i586 | pentium* | athlon* )
+	EXTRA_OBJS="${EXTRA_OBJS} ffi_x86.o"
+	dynamic_ffi=yes
+	;;
+   *)
+	dynamic_ffi=no
+	;;
+esac
+echo "$as_me:$LINENO: result: ${dynamic_ffi}" >&5
+echo "${ECHO_T}${dynamic_ffi}" >&6
+if test "$dynamic_ffi" = "yes" ; then
+
+cat >>confdefs.h <<\_ACEOF
+#define ECL_DYNAMIC_FFI 1
+_ACEOF
+
+fi
+
+
 
   echo "$as_me:$LINENO: checking whether stack growns downwards" >&5
 echo $ECHO_N "checking whether stack growns downwards... $ECHO_C" >&6

src/configure.in

@@ -330,6 +330,7 @@ fi
 ECL_LINEFEED_MODE
 ECL_FIND_SETJMP
 ECL_FILE_STRUCTURE
+ECL_FFI
 
 dnl -----------------------------------------------------------------------
 dnl Study the call conventions

src/h/config.h.in

@@ -149,6 +149,10 @@ typedef unsigned @CL_FIXNUM_TYPE@ cl_hashkey;
 /* Bytecodes and arguments are 8 and 16 bits large, respectively	*/
 #undef ECL_SMALL_BYTECODES
 
+/* We have non-portable implementation of FFI calls			*/
+#undef ECL_DYNAMIC_FFI
+
+
 /*
  * SYSTEM FEATURES:
  */

src/h/external.h

@@ -100,6 +100,9 @@ struct cl_env_struct {
 	cl_object own_process;
 #endif
 	int interrupt_pending;
+
+	/* foreign function interface */
+	void *fficall;
 };
 
 #ifndef __GNUC__
@@ -505,6 +508,7 @@ extern cl_object si_null_pointer_p(cl_object f);
 extern cl_object si_size_of_foreign_elt_type(cl_object tag);
 extern cl_object si_load_foreign_module(cl_object module);
 extern cl_object si_find_foreign_symbol(cl_object var, cl_object module, cl_object type, cl_object size);
+extern cl_object si_call_cfun(cl_object fun, cl_object return_type, cl_object arg_types, cl_object args);
 
 extern cl_object ecl_make_foreign_data(cl_object tag, cl_index size, void *data);
 extern cl_object ecl_allocate_foreign_data(cl_object tag, cl_index size);

src/h/internal.h

@@ -68,6 +68,66 @@ struct cl_compiler_env {
 #define cl_stack_ref(n) cl_env.stack[n]
 #define cl_stack_index() (cl_env.stack_top-cl_env.stack)
 
+/* ffi.d */
+
+#define ECL_FFICALL_LIMIT 256
+
+enum ecl_ffi_tag {
+	ECL_FFI_CHAR = 0,
+	ECL_FFI_UNSIGNED_CHAR,
+	ECL_FFI_BYTE,
+	ECL_FFI_UNSIGNED_BYTE,
+	ECL_FFI_SHORT,
+	ECL_FFI_UNSIGNED_SHORT,
+	ECL_FFI_INT,
+	ECL_FFI_UNSIGNED_INT,
+	ECL_FFI_LONG,
+	ECL_FFI_UNSIGNED_LONG,
+	ECL_FFI_POINTER_VOID,
+	ECL_FFI_CSTRING,
+	ECL_FFI_OBJECT,
+	ECL_FFI_FLOAT,
+	ECL_FFI_DOUBLE,
+	ECL_FFI_VOID
+};
+
+union ecl_ffi_values {
+	char c;
+	unsigned char uc;
+	int8_t b;
+	uint8_t ub;
+	int i;
+	unsigned int ui;
+	short s;
+	unsigned short us;
+	long l;
+	unsigned long ul;
+	void *pv;
+	char *pc;
+	cl_object o;
+	float f;
+	double d;
+};
+
+struct ecl_fficall {
+	char *buffer_sp;
+	size_t buffer_size;
+	union ecl_ffi_values output;
+	char buffer[ECL_FFICALL_LIMIT];
+	cl_object cstring;
+};
+
+enum ecl_ffi_tag ecl_foreign_type_code(cl_object type);
+void ecl_fficall_prepare(cl_object return_type, cl_object arg_types);
+void ecl_fficall_push_bytes(void *data, size_t bytes);
+void ecl_fficall_push_int(int word);
+void ecl_fficall_align(int data);
+cl_object ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag type);
+void ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag type, cl_object value);
+
+void ecl_fficall_push_arg(union ecl_ffi_values *data, enum ecl_ffi_tag type);
+void ecl_fficall_execute(void *f_ptr, struct ecl_fficall *fficall, enum ecl_ffi_tag return_type);
+
 /* file.d */
 
 /*

src/lsp/ffi.lsp

@@ -508,10 +508,24 @@
 	  (subseq "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z"
 		  0 (max 0 (1- (* nargs 3))))))
 
+;;; FIXME! We should turn this into a closure generator that produces no code.
+#+DFFI
+(defmacro def-lib-function (name args &key returning module)
+  (multiple-value-bind (c-name lisp-name) (if (consp name)
+					    (values-list name)
+					    (values (string name) name))
+    (let* ((return-type (ffi::%convert-to-return-type returning))
+	   (return-required (not (eq return-type :void)))
+	   (argtypes (mapcar #'(lambda (a) (ffi::%convert-to-arg-type (second a))) args)))
+      `(let ((c-fun (find-foreign-symbol ,c-name ,module :pointer-void 0)))
+	(defun ,lisp-name ,(mapcar #'first args)
+	  (call-cfun c-fun ',return-type ',argtypes (list ,@(mapcar #'first args))))))))
+
 (defmacro def-function (name args &key module (returning :void))
-  (cond ((and module (macro-function (find-symbol "DEF-LIB-FUNCTION" "FFI")))
-	 `(def-lib-function ,name ,args :returning ,returning :module ,module))
-	(t
+  #+DFFI
+  (when module
+    (return-from def-function
+      `(def-lib-function ,name ,args :returning ,returning :module ,module)))
   (multiple-value-bind (c-name lisp-name)
       (lisp-to-c-name name)
     (let* ((arguments (mapcar #'first args))
@@ -535,7 +549,7 @@
 	(error "FFI can only handle C functions with up to 36 arguments"))
       `(defun ,lisp-name (,@arguments)
 	 ,inline-form)
-      )))))
+      )))
 
 (defmacro def-foreign-var (name type module)
   ;(declare (ignore module))
@@ -628,9 +642,10 @@
       `(eval-when (:compile-toplevel)
         (setf ,csl (nconc ,csl (copy-list ',args)))))))
 
-(eval-when (:load-toplevel)
-  (defmacro c-inline (&rest args)
-    '(error "The special form c-inline cannot be used in the interpreter.")))
+(eval-when (:load-toplevel :execute)
+  (defmacro c-inline (args arg-types ret-type &rest others)
+    `(error "The special form c-inline cannot be used in the interpreter: ~A"
+      (list (list ,@args) ',arg-types ',ret-type ,@others))))
 
 (defmacro definline (fun arg-types type code)
   `(eval-when (:compile-toplevel :load-toplevel :execute)