From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Mon, 18 Apr 2011 00:08:38 +0000 (-0700)
Subject: Added FFI test.
X-Git-Tag: 20110426-Gtk~2^2~2
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=56fd6a47ab79b74b96b98661c5c14c46d37d1748;p=mit-scheme.git

Added FFI test.

* doc/ffi/ffi.texinfo: Punt the Makefile fragments for the example,
and the logic behind the leak-proof malloc/free procedures.

* doc/user-manual/user.texinfo: Needlessly picked some consistency nits.

* src/Clean.sh, src/Setup.sh: Link config.sub and config.guess to
microcode/*, and clean them too.  These scripts are used by
src/configure.ac, which uses AC_CANONICAL_HOST to configure the
compilation and linking of FFIs.

* src/Makefile.in (FFIS, build-ffis): Added FFIS, the list of
configured foreign library interfaces (subdirs).  These are built by
the new build-ffis target, which follows build-bands in most places,
and does `make build' in each ffi subdir.

* src/configure.ac: Added --enable-debugging, FFIS, CCLD, DEFS,
CFLAGS, CPPFLAGS, LDFLAGS, SHIM_CFLAGS and SHIM_LDFLAGS.  Include
microcode/achost.ac.  Added FFIS to the bundles list.

* src/etc/compile.scm (compile-ffi): New.  This procedure arranges to
compile an FFI subdir as a LIARC bundle when LIARC is in use.

* src/etc/functions.sh (maybe_rm): Remove symlinks too.

* src/etc/make-liarc.sh: Added build-ffis after build-bands.

* src/etc/std-makefile-prefix: Added CC, CCLD, DEFS, CFLAGS, CPPFLAGS,
LDFLAGS, COMPILE, LINK, SHIM_CFLAGS, SHIM_LDFLAGS, COMPILE_SHIM and
LINK_SHIM, useful when building a foreign library interface shim.

* src/ffi/.gitignore: Ignore ffi-test-* build products.

* src/ffi/Clean.sh: Punt prhello example.  Clean up ffi-test-* build
products.

* src/ffi/Makefile-fragment: Punt prhello example.  Build and install
an FFI test lib instead.

* src/ffi/: ffi-test.c.stay, ffi-test.cdecl, ffi-test.h: The new test
foreign library and interface.

* src/ffi/: prhello.cdecl, prhello.scm: Removed.  Now in doc/;
replaced in src/ by ffi-test*.*.

* src/microcode/: achost.ac, configure.ac: Moved the host
configuration from configure.ac to the new achost.ac, to share with
src/configure.ac.

* src/runtime/ffi.scm (guarantee-alien, error:not-alien): Use the
standard arglist (object operator), not (operator object #!optional
ctype), and do not loop insisting on a qualifying object.  Integrate
the test, separated from the restart code, which goes in the new,
global error:not-alien procedure.

(guarantee-alien-function, error:not-alien-function): New, like
guarantee-alien and error:not-alien.  Use them in call-alien.

(make-alien-to-free): New, for interfacing to C functions like
malloc() that return something that needs to be freed with free().
Use it in the Scheme malloc procedure, and the test FFI.

* src/runtime/runtime.pkg: Added error:not-alien,
guarantee-alien-function, error:not-alien-function and
make-alien-to-free.

* tests/Clean.sh: New, for cleaning up after tests.

* tests/check.scm: Added tests/ffi/test-ffi.scm.  Hacked handling of
test-flonum-casts.com so that `make check' works on portable C.

* tests/ffi/test-ffi-wrapper.scm: New.  Code that needs to be
syntaxed/compiled as part of the FFI test.

* tests/ffi/test-ffi.scm: New.  A test of the C/Unix FFI.
---

diff --git a/doc/ffi/ffi.texinfo b/doc/ffi/ffi.texinfo
index f292e54f8..e023561a3 100644
--- a/doc/ffi/ffi.texinfo
+++ b/doc/ffi/ffi.texinfo
@@ -492,41 +492,6 @@ restore marks all malloced aliens as though they have been freed.
 (free (malloc '|GdkRectangle|))
 @end smallexample
 
-In general, if a callout returns a pointer to a toolkit resource that
-should be freed, some care is necessary.  Typically such a resource is
-registered with a weak reference to a Scheme representative.  When the
-representative disappears (is garbage collected), the resource is
-freed.  The callout trampoline might cons a fresh alien and return it
-to Scheme, to be registered for later freeing, but an interrupt
-between the return and the registration may leave the
-alien un-registered, never to be freed.
-
-@smallexample
-    (let* ((alien (make-alien)))
-      (c-call "library_function" alien)
-      ;; An interrupt or non-local exit here can drop the alien resource.
-      (register-alien-to-free! alien)
-      ...mumble...
-      (c-free alien))
-@end smallexample
-
-To close the hole a null alien can be allocated and registered
-@emph{before} the callout.  If something interrupts normal execution
-before the callout trampoline can write to it, and the continuation is
-eventually abandoned, the null alien will be swept up in the next GC,
-but not erroneously freed.  If the alien is dropped immediately after
-the trampoline returns to Scheme, it will still be swept up and, no
-longer null, properly freed.
-
-@smallexample
-    (let* ((alien (make-alien '|GdkRectangle|)))
-      (register-alien-to-free! alien)
-      ;; Prepared to free the resource whether allocated or not.
-      (c-call "library_function" alien)
-      ...mumble...
-      (c-free alien))
-@end smallexample
-
 
 @node Alien Functions, Callbacks, Alien Data, Top
 @chapter Alien Functions
@@ -673,11 +638,9 @@ the types, constants and functions declared in the @file{.cdecl} file.
 @end table
 
 The following Makefile rules describe the process of building and
-installing a shim for the example ``Hello, World!'' program.  They can
-be found in @file{src/ffi/Makefile}
+installing a shim for the example ``Hello, World!'' program.
 
 @example
-@comment INCLUDE ../../src/ffi/Makefile-fragment FROM /^install-example:/ TO END
 @verbatim
 install-example: build-example
 	$(INSTALL_DATA) prhello-types.bin ../lib/.
@@ -738,42 +701,6 @@ Here are the C declarations.
 @verbatiminclude prhello.cdecl
 @end example
 
-To run the example:
-
-@smallexample
-@verbatim
-	cd src/ffi/
-	make install-example
-	../microcode/scheme --library ../lib
-	(load-option 'FFI)
-	(load "prhello.scm")
-	(hello)
-@end verbatim
-@end smallexample
-
-You might also syntax the Scheme code first, as in the following
-script.  The syntactic transformers of the FFI are needed here.
-
-@smallexample
-@verbatim
-	../microcode/scheme --library ../lib --batch-mode <<EOF
-	(load-option 'FFI)
-	(sf "prhello.scm")
-	EOF
-@end verbatim
-@end smallexample
-
-The resulting @file{prhello.bin} file can be loaded and run with just
-the FFI-enhanced runtime.  The FFI option is not needed.
-
-@smallexample
-@verbatim
-	../microcode/scheme --library ../lib
-	(load "prhello")
-	(hello)
-@end verbatim
-@end smallexample
-
 
 @node GNU Free Documentation License, , Hello World, Top
 @appendix GNU Free Documentation License
diff --git a/doc/user-manual/user.texinfo b/doc/user-manual/user.texinfo
index 12a526f3e..ce892b70d 100644
--- a/doc/user-manual/user.texinfo
+++ b/doc/user-manual/user.texinfo
@@ -294,15 +294,15 @@ altogether, at which point you should ask for help.  Note that you can
 pass configure options to the script.
 
 @example
- etc/make-liarc.sh --help
- etc/make-liarc.sh --prefix=/usr
+./etc/make-liarc.sh --help
+./etc/make-liarc.sh --prefix=/usr
 @end example
 
 @item
 Install the program:
 
 @example
- make install
+make install
 @end example
 
 Depending on configuration options and file-system permissions, you
diff --git a/src/Clean.sh b/src/Clean.sh
index a9fe1d4de..2f301e1d7 100755
--- a/src/Clean.sh
+++ b/src/Clean.sh
@@ -74,6 +74,7 @@ fi
 
 if [ ${MAINTAINER} = yes ]; then
     maybe_rm autom4te.cache configure lib stamp_* boot-root makefiles_created
+    maybe_rm config.sub config.guess
 fi
 
 for SUBDIR in ${SUBDIRS}; do
diff --git a/src/Makefile.in b/src/Makefile.in
index 0d7524df7..95d2269c0 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -62,9 +62,10 @@ mkinstalldirs = $(SHELL) $(top_srcdir)/microcode/mkinstalldirs
 
 LIARC_BOOT_BUNDLES = compiler cref sf star-parser
 LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin ffi imail sos ssp xml
+FFIS = @FFIS@
 
 SUBDIRS = $(INSTALLED_SUBDIRS) 6001 compiler rcs win32 xdoc
-INSTALLED_SUBDIRS = microcode runtime $(LIARC_BUNDLES)
+INSTALLED_SUBDIRS = microcode runtime $(LIARC_BUNDLES) $(FFIS)
 
 MIT_SCHEME_EXE = @MIT_SCHEME_EXE@
 AUXDIR_NAME = @AUXDIR_NAME@
@@ -78,14 +79,13 @@ check:
 	  --load ../tests/check.scm --eval '(%exit)'
 
 all-native: compile-microcode
-	@$(top_srcdir)/etc/compile.sh "$(MIT_SCHEME_EXE)" \
-					--compiler --batch-mode
-	$(MAKE) build-bands
+	@$(top_srcdir)/etc/compile.sh "$(MIT_SCHEME_EXE)" --batch-mode
+	$(MAKE) build-bands build-ffis
 
 all-svm: microcode/svm1-defns.h
 	$(MAKE) compile-microcode
 	@$(top_srcdir)/etc/compile-svm.sh "$(MIT_SCHEME_EXE)"
-	$(MAKE) build-bands
+	$(MAKE) build-bands build-ffis
 
 microcode/svm1-defns.h: compiler/machines/svm/svm1-defns.h
 	if cmp compiler/machines/svm/svm1-defns.h microcode/svm1-defns.h; \
@@ -102,8 +102,11 @@ compiler/machines/svm/svm1-defns.h: \
 		</dev/null )
 
 all-liarc:
-	@$(top_srcdir)/etc/c-compile.sh "$(MIT_SCHEME_EXE)" --compiler
-	$(MAKE) compile-liarc-bundles build-bands
+	@$(top_srcdir)/etc/c-compile.sh "$(MIT_SCHEME_EXE)" --batch-mode
+	$(MAKE) compile-liarc-bundles build-bands build-ffis
+
+build-ffis:
+	etc/make-in-subdirs.sh build ffi $(FFIS)
 
 macosx-app: stamp_macosx-app
 
diff --git a/src/Setup.sh b/src/Setup.sh
index 3d1771a4d..77fdbd53e 100755
--- a/src/Setup.sh
+++ b/src/Setup.sh
@@ -86,6 +86,8 @@ maybe_link lib/optiondb.scm ../etc/optiondb.scm
 maybe_link lib/runtime ../runtime
 maybe_link lib/mit-scheme.h ../microcode/pruxffi.h
 maybe_link lib/ffi ../ffi
+maybe_link config.sub microcode/config.sub
+maybe_link config.guess microcode/config.guess
 
 for SUBDIR in ${INSTALLED_SUBDIRS} ${OTHER_SUBDIRS}; do
     echo "setting up ${SUBDIR}"
diff --git a/src/configure.ac b/src/configure.ac
index 1f6bb9ee9..36cec94ca 100644
--- a/src/configure.ac
+++ b/src/configure.ac
@@ -28,6 +28,11 @@ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
 USA.
 ])
 
+AC_ARG_ENABLE([debugging],
+    AS_HELP_STRING([--enable-debugging],
+	[Compile with debugging support [[no]]]))
+: ${enable_debugging='no'}
+
 AC_ARG_ENABLE([native-code],
     AS_HELP_STRING([--enable-native-code],
 	[Support native compiled code if available [[yes]]]))
@@ -93,6 +98,7 @@ directory, which is usually \`/usr/local/lib/mit-scheme-${mit_scheme_native_code
 fi
 
 AC_SUBST([ALL_TARGET])
+AC_SUBST([FFIS])
 AC_SUBST([INSTALL_COM])
 AC_SUBST([INSTALL_LIARC_BUNDLES])
 AC_SUBST([MIT_SCHEME_EXE])
@@ -106,10 +112,22 @@ then
     INSTALL="${INSTALL} --preserve-timestamps"
 fi
 
+echo etc/create-makefiles.sh "${MIT_SCHEME_EXE}" "${mit_scheme_native_code}"
 etc/create-makefiles.sh "${MIT_SCHEME_EXE}" "${mit_scheme_native_code}"
 compiler/configure "${mit_scheme_native_code}"
 
 AC_CONFIG_SUBDIRS([microcode])
+
+m4_include(microcode/achost.ac)
+
+AC_SUBST([CCLD])
+AC_SUBST([DEFS])
+AC_SUBST([CFLAGS])
+AC_SUBST([CPPFLAGS])
+AC_SUBST([LDFLAGS])
+AC_SUBST([SHIM_CFLAGS])
+AC_SUBST([SHIM_LDFLAGS])
+
 AC_CONFIG_FILES([
 Makefile
 6001/Makefile
@@ -138,7 +156,7 @@ if test x"${mit_scheme_native_code}" = xc; then
         (cd lib; rm -f ${BN}; ${LN_S} ../${BN} .)
     done
     for BUNDLE in 6001 compiler cref edwin ffi imail sf sos ssp star-parser \
-	    xdoc xml; do
+		  xdoc xml $FFIS; do
     	SO=${BUNDLE}.so
 	(cd lib/lib; rm -f ${SO}; ${LN_S} ../../${BUNDLE}/${SO} .)
     done
diff --git a/src/etc/compile.scm b/src/etc/compile.scm
index e185f69bb..a480c28e6 100644
--- a/src/etc/compile.scm
+++ b/src/etc/compile.scm
@@ -39,6 +39,14 @@ USA.
       (load "load")))
   (for-each compile-dir '("xml" "win32" "edwin" "imail" "ssp" "ffi")))
 
+(define (compile-ffi dir)
+  (if (eq? microcode-id/compiled-code-type 'C)
+      (in-liarc
+       (lambda ()
+	 (c-compile-dir dir)
+	 (run-synchronous-subprocess "make" '("compile-liarc-bundle"))))
+      (compile-dir dir)))
+
 (define (compile-boot-dirs compile-dir)
   (compile-cref compile-dir)
   (for-each compile-dir '("runtime" "cref" "sf" "compiler" "star-parser")))
diff --git a/src/etc/functions.sh b/src/etc/functions.sh
index 1cb0d19ae..ccfca4751 100644
--- a/src/etc/functions.sh
+++ b/src/etc/functions.sh
@@ -103,12 +103,12 @@ maybe_rm ()
     FILES=
     DIRS=
     for FN in "${@}"; do
-	if [ ! -L "${FN}" ]; then
-	    if [ -f "${FN}" ]; then
-		FILES="${FILES} ${FN}"
-	    elif [ -d "${FN}" ]; then
-		DIRS="${DIRS} ${FN}"
-	    fi
+	if [ -L "${FN}" ]; then
+	    FILES="${FILES} ${FN}"
+	elif [ -f "${FN}" ]; then
+	    FILES="${FILES} ${FN}"
+	elif [ -d "${FN}" ]; then
+	    DIRS="${DIRS} ${FN}"
 	fi
     done
     if [ "${FILES}" ]; then
diff --git a/src/etc/make-liarc.sh b/src/etc/make-liarc.sh
index 4b89fc6b5..fbcff508c 100755
--- a/src/etc/make-liarc.sh
+++ b/src/etc/make-liarc.sh
@@ -56,4 +56,4 @@ run_configure --prefix=`pwd`/boot-root --enable-native-code=c \
 run_make stamp_install-liarc-boot-compiler c-clean distclean
 
 run_configure --enable-native-code=c --disable-host-scheme-test "${@}"
-run_make stamp_compile-liarc-bundles build-bands clean-boot-root
+run_make stamp_compile-liarc-bundles build-bands clean-boot-root build-ffis
diff --git a/src/etc/std-makefile-prefix b/src/etc/std-makefile-prefix
index 595502390..43e78da11 100644
--- a/src/etc/std-makefile-prefix
+++ b/src/etc/std-makefile-prefix
@@ -66,6 +66,22 @@ mkinstalldirs = $(SHELL) $(top_srcdir)/microcode/mkinstalldirs
 
 # **** END BOILERPLATE ****
 
+CC = @CC@
+CCLD = @CCLD@
+
+DEFS = @DEFS@
+CFLAGS = @CFLAGS@
+CPPFLAGS = @CPPFLAGS@ -I../lib
+LDFLAGS = @LDFLAGS@
+
+COMPILE = $(CC) $(DEFS) $(CPPFLAGS) $(CFLAGS)
+LINK = $(CCLD) $(LDFLAGS) -o $@
+
+SHIM_CFLAGS = @SHIM_CFLAGS@
+SHIM_LDFLAGS = @SHIM_LDFLAGS@
+COMPILE_SHIM = $(COMPILE) $(SHIM_CFLAGS)
+LINK_SHIM = $(LINK) $(SHIM_LDFLAGS)
+
 AUXDIR = @AUXDIR@
 
 all:
diff --git a/src/ffi/.gitignore b/src/ffi/.gitignore
index e01eca8f5..407f53585 100644
--- a/src/ffi/.gitignore
+++ b/src/ffi/.gitignore
@@ -1,3 +1,9 @@
+ffi-test-const
+ffi-test-const.c
+ffi-test-const.scm
+ffi-test-shim.c
+ffi-test-shim.so
+ffi-test.c
 prhello-const
 prhello-const.c
 prhello-const.scm
diff --git a/src/ffi/Clean.sh b/src/ffi/Clean.sh
index ccd75293c..0ac442681 100755
--- a/src/ffi/Clean.sh
+++ b/src/ffi/Clean.sh
@@ -10,4 +10,5 @@ fi
 ../etc/Clean.sh "${1}"
 . ../etc/functions.sh
 
-maybe_rm prhello-const prhello-const.scm
+maybe_rm ffi-test.c
+maybe_rm ffi-test-shim.* ffi-test-const ffi-test-const.* ffi-test-types.*
diff --git a/src/ffi/Makefile-fragment b/src/ffi/Makefile-fragment
index ace73a104..b3153f4e7 100644
--- a/src/ffi/Makefile-fragment
+++ b/src/ffi/Makefile-fragment
@@ -3,6 +3,7 @@
 
 TARGET_DIR = $(AUXDIR)/ffi
 
+# Install the FFI option, and test lib.
 install:
 	rm -rf $(DESTDIR)$(TARGET_DIR)
 	$(mkinstalldirs) $(DESTDIR)$(TARGET_DIR)
@@ -10,38 +11,52 @@ install:
 	$(INSTALL_DATA) *.bci $(DESTDIR)$(TARGET_DIR)/.
 	$(INSTALL_DATA) ffi-*.pkd $(DESTDIR)$(TARGET_DIR)/.
 	$(INSTALL_DATA) make.scm $(DESTDIR)$(TARGET_DIR)/.
+	$(INSTALL_DATA) ffi-test-shim.so ffi-test-types.bin ffi-test-const.bin \
+			$(DESTDIR)$(AUXDIR_DIR)/.
 
-clean-example:
-	rm -rf prhello-shim.* prhello-types.bin
-	rm -rf prhello-const prhello-const.*
+# Build a test library interface.
 
-install-example: build-example
-	$(INSTALL_DATA) prhello-types.bin ../lib/.
-	$(INSTALL_DATA) prhello-const.bin ../lib/.
-	$(INSTALL_DATA) prhello-shim.so ../lib/.
+# This target is built after everything else (during build-ffis), and
+# should use the new machine, runtime, etc.
 
-build-example: prhello-shim.so prhello-types.bin prhello-const.bin
+# This interface is for tests/ffi/test-ffi.scm, which uses its own
+# wrapper, so there is no need for the compile-ffi procedure (hint).
+build: ../lib/ffi-test-types.bin ../lib/ffi-test-const.bin		\
+       ../lib/ffi-test-shim.so
 
-prhello-shim.so: prhello-shim.o
-	$(CC) -shared -fPIC -o $@ $^ `pkg-config --libs gtk+-2.0`
+../lib/ffi-test-shim.so: ffi-test-shim.o ffi-test.o
+	$(LINK_SHIM) $^ -o $@
 
-prhello-shim.o: prhello-shim.c
-	$(CC) -I../lib -Wall -fPIC `pkg-config --cflags gtk+-2.0` -o $@ -c $<
+ffi-test-shim.o: ffi-test-shim.c ffi-test.h
+	$(COMPILE_SHIM) -o $@ -c $<
 
-prhello-shim.c prhello-const.c prhello-types.bin: prhello.cdecl
+ffi-test-shim.c ffi-test-const.c ../lib/ffi-test-types.bin: ffi-test.cdecl
 	(echo "(load-option 'FFI)"; \
-	 echo '(C-generate "prhello" "#include <gtk/gtk.h>")') \
+	 echo '(C-generate "ffi-test" "#include \"ffi-test.h\"")') \
 	| ../microcode/scheme --library ../lib --batch-mode
+	cp -p ffi-test-types.bin ../lib/ffi-test-types.bin
 
-prhello-const.bin: prhello-const.scm
-	echo '(sf "prhello-const")' | mit-scheme --compiler --batch-mode
+../lib/ffi-test-const.bin: ffi-test-const.scm
+	echo '(sf "ffi-test-const")' \
+	| ../microcode/scheme --library ../lib --batch-mode
+	cp -p ffi-test-const.bin ../lib/ffi-test-const.bin
 
-prhello-const.scm: prhello-const
-	./prhello-const
+ffi-test-const.scm: ffi-test-const
+	./ffi-test-const
 
-prhello-const: prhello-const.o
+ffi-test-const: ffi-test-const.o
 	@rm -f $@
-	$(CC) $(CFLAGS) $(LDFLAGS) -o $@ $^ `pkg-config --libs gtk+-2.0`
+	$(CC) $(CFLAGS) $(LDFLAGS) -o $@ $^
+
+ffi-test-const.o: ffi-test-const.c
+	$(CC) $(CFLAGS) -o $@ -c $<
+
+# Finally, the test library itself.
+
+ffi-test.o: ffi-test.c ffi-test.h
+	$(COMPILE_SHIM) -o $@ -c $<
+
+ffi-test.c: ffi-test.c.stay
+	cp -p ffi-test.c.stay ffi-test.c
 
-prhello-const.o: prhello-const.c
-	$(CC) `pkg-config --cflags gtk+-2.0` $(CFLAGS) -o $@ -c $<
+.PHONY: build
diff --git a/src/ffi/ffi-test.c.stay b/src/ffi/ffi-test.c.stay
new file mode 100644
index 000000000..033715697
--- /dev/null
+++ b/src/ffi/ffi-test.c.stay
@@ -0,0 +1,32 @@
+/* -*-C-*- */
+
+/* A test library; used to test the C/Unix FFI. */
+
+#include "ffi-test.h"
+
+static void *callback_data;
+static TestDoubleCallback callback_func;
+
+extern void
+test_register_double (TestDoubleCallback callback, void *user_data)
+{
+  callback_func = callback;
+  callback_data = user_data;
+}
+
+extern double
+test_double (double d, TestStruct *s)
+{
+  if (!callback_data) return 0.0;
+  return (d * callback_func (s->second, callback_data));
+}
+
+extern char *
+test_string (char *stri, TestStruct *stru)
+{
+  int l1 = strlen (stri);
+  int l2 = strlen (stru->fourth);
+  char *s = malloc (3);
+  snprintf (s, 3, "%d", l1 + l2);
+  return (s);
+}
diff --git a/src/ffi/ffi-test.cdecl b/src/ffi/ffi-test.cdecl
new file mode 100644
index 000000000..71bab5901
--- /dev/null
+++ b/src/ffi/ffi-test.cdecl
@@ -0,0 +1,27 @@
+;;; -*-Scheme-*-
+
+;;;; Declarations for a test library; used to test the C/Unix FFI.
+
+(typedef TestStruct
+  (struct
+    (first char)
+    (second double)
+    (third char)
+    (fourth (* char))))
+
+(extern double test_double
+	(d double)
+	(s (* TestStruct)))
+
+(extern (* char) test_string
+	(c (* char))
+	(s (* TestStruct)))
+
+(extern void test_register_double
+	(CALLBACK TestDoubleCallback)
+	(ID (* void)))
+(typedef TestDoubleCallback (* mumble))
+
+(callback double test_double_callback
+	  (d double)
+	  (ID (* void)))
\ No newline at end of file
diff --git a/src/ffi/ffi-test.h b/src/ffi/ffi-test.h
new file mode 100644
index 000000000..f8e5aebcc
--- /dev/null
+++ b/src/ffi/ffi-test.h
@@ -0,0 +1,23 @@
+/* -*-C-*- */
+
+/* Header for a test library; used to test the C/Unix FFI. */
+
+#include <string.h>
+#include <stdio.h>
+
+typedef struct {
+
+  char first;
+
+  double second;
+
+  char third;
+
+  char * fourth;
+} TestStruct;
+
+typedef double (* TestDoubleCallback) (double d, void *user_data);
+
+extern double test_double (double d, TestStruct *s);
+extern char * test_string (char *c, TestStruct *s);
+extern void test_register_double (TestDoubleCallback callback, void *id);
diff --git a/src/ffi/prhello.cdecl b/src/ffi/prhello.cdecl
deleted file mode 100644
index 91a85df34..000000000
--- a/src/ffi/prhello.cdecl
+++ /dev/null
@@ -1,85 +0,0 @@
-#| -*-Scheme-*-
-
-C declarations for prhello.scm. |#
-
-(typedef gint int)
-(typedef guint uint)
-(typedef gchar char)
-(typedef gboolean gint)
-(typedef gpointer (* mumble))
-
-(extern void
-	gtk_init
-	(argc (* int))
-	(argv (* (* (* char)))))
-
-(extern (* GtkWidget)
-	gtk_window_new
-	(type GtkWindowType))
-
-(typedef GtkWindowType
-	 (enum
-	  (GTK_WINDOW_TOPLEVEL)
-	  (GTK_WINDOW_POPUP)))
-
-(extern (* GtkWidget)
-	gtk_button_new)
-
-(extern (* GtkWidget)
-	gtk_label_new
-	(str (* (const char))))
-
-(extern void
-	gtk_container_add
-	(container (* GtkContainer))
-	(widget    (* GtkWidget)))
-
-(extern void
-	gtk_window_set_title
-	(window (* GtkWindow))
-	(title  (* (const gchar))))
-
-(extern void
-	gtk_container_set_border_width
-	(container (* GtkContainer))
-	(border_width guint))
-
-(extern void
-	gtk_widget_show_all
-	(widget (* GtkWidget)))
-
-(extern void
-	g_signal_connect
-	(object (* GtkObject))
-	(name (* gchar))
-	(CALLBACK GtkSignalFunc)
-	(ID gpointer))
-
-(typedef GtkSignalFunc (* mumble))
-
-(callback gboolean
-	  delete_event
-	  (window (* GtkWidget))
-	  (event (* GdkEventAny))
-	  (ID gpointer))
-
-(callback void
-	  clicked
-	  (widget (* GtkWidget))
-	  (ID gpointer))
-
-(extern void
-	gtk_widget_destroy
-	(widget (* GtkWidget)))
-
-(extern (* (const gchar))
-	gtk_label_get_text
-	(label (* GtkLabel)))
-
-(extern void
-	gtk_label_set_text
-	(label (* GtkLabel))
-	(str (* (const char))))
-
-(extern void gtk_main)
-(extern void gtk_main_quit)
\ No newline at end of file
diff --git a/src/ffi/prhello.scm b/src/ffi/prhello.scm
deleted file mode 100644
index 25caeff5f..000000000
--- a/src/ffi/prhello.scm
+++ /dev/null
@@ -1,55 +0,0 @@
-#| -*-Scheme-*-
-
-This is Havoc Pennington's Hello World example from GGAD, in the raw
-FFI.  Note that no arrangements have been made to de-register the
-callbacks. |#
-
-(declare (usual-integrations))
-
-(C-include "prhello")
-
-(define (hello)
-  (C-call "gtk_init" 0 null-alien)
-  (let ((window (let ((alien (make-alien '|GtkWidget|)))
-		  (C-call "gtk_window_new" alien
-			  (C-enum "GTK_WINDOW_TOPLEVEL"))
-		  (if (alien-null? alien) (error "Could not create window."))
-		  alien))
-	(button (let ((alien (make-alien '|GtkWidget|)))
-		  (C-call "gtk_button_new" alien)
-		  (if (alien-null? alien) (error "Could not create button."))
-		  alien))
-	(label (let ((alien (make-alien '|GtkWidget|)))
-		 (C-call "gtk_label_new" alien "Hello, World!")
-		 (if (alien-null? alien) (error "Could not create label."))
-		 alien)))
-    (C-call "gtk_container_add" button label)
-    (C-call "gtk_container_add" window button)
-    (C-call "gtk_window_set_title" window "Hello")
-    (C-call "gtk_container_set_border_width" button 10)
-    (let ((counter 0))
-      (C-call "g_signal_connect" window "delete_event"
-	      (C-callback "delete_event")	;trampoline
-	      (C-callback			;callback ID
-	       (lambda (w e)
-		 (outf-console ";Delete me "(- 2 counter)" times.\n")
-		 (set! counter (1+ counter))
-		 ;; Three or more is the charm.
-		 (if (> counter 2)
-		     (begin
-		       (C-call "gtk_main_quit")
-		       0)
-		     1))))
-      (C-call "g_signal_connect" button "clicked"
-	      (C-callback "clicked")	;trampoline
-	      (C-callback			;callback ID
-	       (lambda (w)
-		 (let ((gstring (make-alien '(* |gchar|))))
-		   (C-call "gtk_label_get_text" gstring label)
-		   (let ((text (c-peek-cstring gstring)))
-		     (C-call "gtk_label_set_text" label
-			     (list->string (reverse! (string->list text))))))
-		 unspecific))))
-    (C-call "gtk_widget_show_all" window)
-    (C-call "gtk_main")
-    window))
\ No newline at end of file
diff --git a/src/microcode/achost.ac b/src/microcode/achost.ac
new file mode 100644
index 000000000..145fdd204
--- /dev/null
+++ b/src/microcode/achost.ac
@@ -0,0 +1,219 @@
+### -*-M4-*-
+###
+### Copyright (C) 2010 Massachusetts Institute of Technology
+###
+### This file is part of MIT/GNU Scheme.
+###
+### MIT/GNU Scheme is free software; you can redistribute it and/or
+### modify it under the terms of the GNU General Public License as
+### published by the Free Software Foundation; either version 2 of the
+### License, or (at your option) any later version.
+###
+### MIT/GNU Scheme is distributed in the hope that it will be useful,
+### but WITHOUT ANY WARRANTY; without even the implied warranty of
+### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+### General Public License for more details.
+###
+### You should have received a copy of the GNU General Public License
+### along with MIT/GNU Scheme; if not, write to the Free Software
+### Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+### 02110-1301, USA.
+
+AC_CANONICAL_HOST
+
+dnl Save these prior to running AC_PROG_CC.
+SAVED_CFLAGS=${CFLAGS}
+SAVED_LDFLAGS=${LDFLAGS}
+
+dnl Checks for programs.
+AC_PROG_CC
+AC_PROG_CC_STDC
+if test "x${ac_cv_prog_cc_c99}" != xno; then
+   AC_DEFINE([HAVE_STDC_99], [1], [Does the compiler support C99?])
+fi
+if test "x${ac_cv_prog_cc_c89}" != xno; then
+   AC_DEFINE([HAVE_STDC_89], [1], [Does the compiler support C89?])
+fi
+AC_C_BACKSLASH_A
+AC_C_BIGENDIAN
+AC_C_CONST
+AC_C_RESTRICT
+AC_C_VOLATILE
+AC_C_INLINE
+AC_C_STRINGIZE
+AC_C_PROTOTYPES
+AC_PROG_EGREP
+AC_PROG_FGREP
+AC_PROG_GREP
+AC_PROG_INSTALL
+AC_PROG_LN_S
+AC_PROG_MAKE_SET
+
+if test ${GCC} = yes; then
+
+    dnl Discard flags computed by AC_PROG_CC; we'll use our own.
+    CFLAGS=${SAVED_CFLAGS}
+    LDFLAGS=${SAVED_LDFLAGS}
+
+    if test ${enable_debugging} = no; then
+	CFLAGS="${CFLAGS} -O3"
+    else
+	CFLAGS="${CFLAGS} -O0 -g -DENABLE_DEBUGGING_TOOLS"
+	LDFLAGS="${LDFLAGS} -g"
+    fi
+    CFLAGS="${CFLAGS} -Wall -Wundef -Wpointer-arith -Winline"
+    CFLAGS="${CFLAGS} -Wstrict-prototypes -Wnested-externs -Wredundant-decls"
+
+    AC_MSG_CHECKING([for GCC>=4])
+    AC_COMPILE_IFELSE(
+	[AC_LANG_PROGRAM(
+	    [[
+	    #if __GNUC__ >= 4
+	    ;
+	    #else
+	    #error "gcc too old"
+	    #endif
+	    ]],
+	    [[]]
+	)],
+	[
+	AC_MSG_RESULT([yes])
+	CFLAGS="${CFLAGS} -Wextra -Wno-sign-compare -Wno-unused-parameter"
+	CFLAGS="${CFLAGS} -Wold-style-definition"
+	],
+	[AC_MSG_RESULT([no])])
+
+    # other possibilities:
+    # -Wmissing-prototypes -Wunreachable-code -Wwrite-strings
+fi
+FOO=`${INSTALL} --help 2> /dev/null | ${FGREP} -e --preserve-timestamps`
+if test "x${FOO}" != x; then
+    INSTALL="${INSTALL} --preserve-timestamps"
+fi
+CCLD=${CC}
+
+MIT_SCHEME_NATIVE_CODE([${enable_native_code}],[${host_cpu}])
+
+if test x${mit_scheme_native_code} = xhppa; then
+   GC_HEAD_FILES="${GC_HEAD_FILES} hppacach.h"
+fi
+
+AUXDIR_NAME=mit-scheme-${mit_scheme_native_code}
+EXE_NAME=mit-scheme-${mit_scheme_native_code}
+
+dnl Add OS-dependent customizations.  This must happen before checking
+dnl any headers or library routines, because it may add CFLAGS or
+dnl LDFLAGS that the subsequent checks require.
+
+DO_GCC_TESTS=no
+GNU_LD=no
+case ${host_os} in
+linux-gnu)
+    M4_FLAGS="${M4_FLAGS} -P __linux__,1"
+    DO_GCC_TESTS=yes
+    GNU_LD=yes
+    ;;
+freebsd*)
+    M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1"
+    DO_GCC_TESTS=yes
+    GNU_LD=yes
+    ;;
+dragonfly*)
+    M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1"
+    DO_GCC_TESTS=yes
+    GNU_LD=yes
+    ;;
+darwin*)
+    if test -n "${with_macosx_version}"; then
+	MACOSX=${with_macosx_version}
+	MACOSX_CFLAGS="-mmacosx-version-min=${MACOSX}"
+    else
+	MACOSX=`sw_vers | ${GREP} ^ProductVersion: \
+	    | ${EGREP} -o '[[0-9]+\.[0-9]+]'`
+	if test -z "${MACOSX}"; then
+	    AC_MSG_ERROR([Unable to determine MacOSX version])
+	fi
+	MACOSX_CFLAGS=
+    fi
+    if test "${MACOSX}" = 10.4; then
+	SDK=MacOSX${MACOSX}u
+    else
+	SDK=MacOSX${MACOSX}
+    fi
+    MACOSX_SYSROOT=/Developer/SDKs/${SDK}.sdk
+    if test ! -d "${MACOSX_SYSROOT}"; then
+	AC_MSG_ERROR([No MacOSX SDK for version: ${MACOSX}])
+    fi
+    MACOSX_CFLAGS="${MACOSX_CFLAGS} -isysroot ${MACOSX_SYSROOT}"
+    MACOSX_CFLAGS="${MACOSX_CFLAGS} -fconstant-cfstrings"
+    AC_MSG_NOTICE([Compiling for MacOSX version ${MACOSX}])
+    case ${mit_scheme_native_code} in
+    i386)
+	MACOSX_CFLAGS="-arch i386 ${MACOSX_CFLAGS}"
+	AS_FLAGS="-arch i386 ${AS_FLAGS}"
+	SCHEME_LDFLAGS="${SCHEME_LDFLAGS} -Wl,-pagezero_size,04000000"
+    	;;
+    x86-64)
+	MACOSX_CFLAGS="-arch x86_64 ${MACOSX_CFLAGS}"
+	AS_FLAGS="-arch x86_64 ${AS_FLAGS}"
+    	;;
+    esac
+    CFLAGS="${CFLAGS} ${MACOSX_CFLAGS} -frounding-math"
+    LDFLAGS="${LDFLAGS} ${MACOSX_CFLAGS} -Wl,-syslibroot,${MACOSX_SYSROOT}"
+    LDFLAGS="${LDFLAGS} -framework CoreFoundation"
+    MODULE_LDFLAGS="${MODULE_LDFLAGS} -bundle"
+    if test "${with_module_loader}" != no; then
+      if test "${with_module_loader}" = yes; then
+	MODULE_LOADER='${SCHEME_EXE}'
+      else
+	MODULE_LOADER="${with_module_loader}"
+      fi
+      MODULE_LDFLAGS="${MODULE_LDFLAGS} -bundle_loader ${MODULE_LOADER}"
+    fi
+    AUX_PROGRAMS="${AUX_PROGRAMS} macosx-starter"
+    ;;
+netbsd*)
+    DO_GCC_TESTS=yes
+    GNU_LD=yes
+    ;;
+openbsd*)
+    M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1"
+    DO_GCC_TESTS=yes
+    GNU_LD=yes
+    ;;
+solaris*)
+    # How do we tell whether we're using GNU ld or Solaris ld?
+    if test ${GCC} = yes; then
+	DO_GCC_TESTS=yes
+	M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1"
+    fi
+    LDFLAGS="${LDFLAGS} -lsocket -lnsl"
+    ;;
+esac
+
+if test "${DO_GCC_TESTS}" = yes; then
+    if test "${GNU_LD}" = yes; then
+	SCHEME_LDFLAGS="${SCHEME_LDFLAGS} -export-dynamic"
+    fi
+    MODULE_CFLAGS="${MODULE_CFLAGS} -fPIC"
+    MODULE_LDFLAGS="${MODULE_LDFLAGS} -shared -fPIC"
+    SHIM_CFLAGS="${SHIM_CFLAGS} -fPIC"
+    SHIM_LDFLAGS="${SHIM_LDFLAGS} -shared -fPIC"
+    AC_MSG_CHECKING([for ELF binaries])
+    AC_RUN_IFELSE(
+	[AC_LANG_PROGRAM(
+	    [[]],
+	    [[
+	    #ifdef __ELF__
+	    return 0;
+	    #endif
+	    return 1;
+	    ]]
+	)],
+	[
+	AC_MSG_RESULT([yes])
+	M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1"
+	M4_FLAGS="${M4_FLAGS} -P __ELF__,1"
+	],
+	[AC_MSG_RESULT([no])])
+fi
diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac
index f913ec9bf..3bb800a91 100644
--- a/src/microcode/configure.ac
+++ b/src/microcode/configure.ac
@@ -201,202 +201,7 @@ AUXDIR_NAME=
 EXE_NAME=
 INSTALL_INCLUDE=
 
-AC_CANONICAL_HOST
-
-dnl Save these prior to running AC_PROG_CC.
-SAVED_CFLAGS=${CFLAGS}
-SAVED_LDFLAGS=${LDFLAGS}
-
-dnl Checks for programs.
-AC_PROG_CC
-AC_PROG_CC_STDC
-if test "x${ac_cv_prog_cc_c99}" != xno; then
-   AC_DEFINE([HAVE_STDC_99], [1], [Does the compiler support C99?])
-fi
-if test "x${ac_cv_prog_cc_c89}" != xno; then
-   AC_DEFINE([HAVE_STDC_89], [1], [Does the compiler support C89?])
-fi
-AC_C_BACKSLASH_A
-AC_C_BIGENDIAN
-AC_C_CONST
-AC_C_RESTRICT
-AC_C_VOLATILE
-AC_C_INLINE
-AC_C_STRINGIZE
-AC_C_PROTOTYPES
-AC_PROG_EGREP
-AC_PROG_FGREP
-AC_PROG_GREP
-AC_PROG_INSTALL
-AC_PROG_LN_S
-AC_PROG_MAKE_SET
-
-if test ${GCC} = yes; then
-
-    dnl Discard flags computed by AC_PROG_CC; we'll use our own.
-    CFLAGS=${SAVED_CFLAGS}
-    LDFLAGS=${SAVED_LDFLAGS}
-
-    if test ${enable_debugging} = no; then
-	CFLAGS="${CFLAGS} -O3"
-    else
-	CFLAGS="${CFLAGS} -O0 -g -DENABLE_DEBUGGING_TOOLS"
-	LDFLAGS="${LDFLAGS} -g"
-    fi
-    CFLAGS="${CFLAGS} -Wall -Wundef -Wpointer-arith -Winline"
-    CFLAGS="${CFLAGS} -Wstrict-prototypes -Wnested-externs -Wredundant-decls"
-
-    AC_MSG_CHECKING([for GCC>=4])
-    AC_COMPILE_IFELSE(
-	[AC_LANG_PROGRAM(
-	    [[
-	    #if __GNUC__ >= 4
-	    ;
-	    #else
-	    #error "gcc too old"
-	    #endif
-	    ]],
-	    [[]]
-	)],
-	[
-	AC_MSG_RESULT([yes])
-	CFLAGS="${CFLAGS} -Wextra -Wno-sign-compare -Wno-unused-parameter"
-	CFLAGS="${CFLAGS} -Wold-style-definition"
-	],
-	[AC_MSG_RESULT([no])])
-
-    # other possibilities:
-    # -Wmissing-prototypes -Wunreachable-code -Wwrite-strings
-fi
-FOO=`${INSTALL} --help 2> /dev/null | ${FGREP} -e --preserve-timestamps`
-if test "x${FOO}" != x; then
-    INSTALL="${INSTALL} --preserve-timestamps"
-fi
-CCLD=${CC}
-
-MIT_SCHEME_NATIVE_CODE([${enable_native_code}],[${host_cpu}])
-
-if test x${mit_scheme_native_code} = xhppa; then
-   GC_HEAD_FILES="${GC_HEAD_FILES} hppacach.h"
-fi
-
-AUXDIR_NAME=mit-scheme-${mit_scheme_native_code}
-EXE_NAME=mit-scheme-${mit_scheme_native_code}
-
-dnl Add OS-dependent customizations.  This must happen before checking
-dnl any headers or library routines, because it may add CFLAGS or
-dnl LDFLAGS that the subsequent checks require.
-
-DO_GCC_TESTS=no
-GNU_LD=no
-case ${host_os} in
-linux-gnu)
-    M4_FLAGS="${M4_FLAGS} -P __linux__,1"
-    DO_GCC_TESTS=yes
-    GNU_LD=yes
-    ;;
-freebsd*)
-    M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1"
-    DO_GCC_TESTS=yes
-    GNU_LD=yes
-    ;;
-dragonfly*)
-    M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1"
-    DO_GCC_TESTS=yes
-    GNU_LD=yes
-    ;;
-darwin*)
-    if test -n "${with_macosx_version}"; then
-	MACOSX=${with_macosx_version}
-	MACOSX_CFLAGS="-mmacosx-version-min=${MACOSX}"
-    else
-	MACOSX=`sw_vers | ${GREP} ^ProductVersion: \
-	    | ${EGREP} -o '[[0-9]+\.[0-9]+]'`
-	if test -z "${MACOSX}"; then
-	    AC_MSG_ERROR([Unable to determine MacOSX version])
-	fi
-	MACOSX_CFLAGS=
-    fi
-    if test "${MACOSX}" = 10.4; then
-	SDK=MacOSX${MACOSX}u
-    else
-	SDK=MacOSX${MACOSX}
-    fi
-    MACOSX_SYSROOT=/Developer/SDKs/${SDK}.sdk
-    if test ! -d "${MACOSX_SYSROOT}"; then
-	AC_MSG_ERROR([No MacOSX SDK for version: ${MACOSX}])
-    fi
-    MACOSX_CFLAGS="${MACOSX_CFLAGS} -isysroot ${MACOSX_SYSROOT}"
-    MACOSX_CFLAGS="${MACOSX_CFLAGS} -fconstant-cfstrings"
-    AC_MSG_NOTICE([Compiling for MacOSX version ${MACOSX}])
-    case ${mit_scheme_native_code} in
-    i386)
-	MACOSX_CFLAGS="-arch i386 ${MACOSX_CFLAGS}"
-	AS_FLAGS="-arch i386 ${AS_FLAGS}"
-	SCHEME_LDFLAGS="${SCHEME_LDFLAGS} -Wl,-pagezero_size,04000000"
-    	;;
-    x86-64)
-	MACOSX_CFLAGS="-arch x86_64 ${MACOSX_CFLAGS}"
-	AS_FLAGS="-arch x86_64 ${AS_FLAGS}"
-    	;;
-    esac
-    CFLAGS="${CFLAGS} ${MACOSX_CFLAGS} -frounding-math"
-    LDFLAGS="${LDFLAGS} ${MACOSX_CFLAGS} -Wl,-syslibroot,${MACOSX_SYSROOT}"
-    LDFLAGS="${LDFLAGS} -framework CoreFoundation"
-    MODULE_LDFLAGS="${MODULE_LDFLAGS} -bundle"
-    if test "${with_module_loader}" != no; then
-      if test "${with_module_loader}" = yes; then
-	MODULE_LOADER='${SCHEME_EXE}'
-      else
-	MODULE_LOADER="${with_module_loader}"
-      fi
-      MODULE_LDFLAGS="${MODULE_LDFLAGS} -bundle_loader ${MODULE_LOADER}"
-    fi
-    AUX_PROGRAMS="${AUX_PROGRAMS} macosx-starter"
-    ;;
-netbsd*)
-    DO_GCC_TESTS=yes
-    GNU_LD=yes
-    ;;
-openbsd*)
-    M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1"
-    DO_GCC_TESTS=yes
-    GNU_LD=yes
-    ;;
-solaris*)
-    # How do we tell whether we're using GNU ld or Solaris ld?
-    if test ${GCC} = yes; then
-	DO_GCC_TESTS=yes
-	M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1"
-    fi
-    LDFLAGS="${LDFLAGS} -lsocket -lnsl"
-    ;;
-esac
-
-if test "${DO_GCC_TESTS}" = yes; then
-    if test "${GNU_LD}" = yes; then
-	SCHEME_LDFLAGS="${SCHEME_LDFLAGS} -export-dynamic"
-    fi
-    MODULE_CFLAGS="${MODULE_CFLAGS} -fPIC"
-    MODULE_LDFLAGS="${MODULE_LDFLAGS} -shared -fPIC"
-    AC_MSG_CHECKING([for ELF binaries])
-    AC_RUN_IFELSE(
-	[AC_LANG_PROGRAM(
-	    [[]],
-	    [[
-	    #ifdef __ELF__
-	    return 0;
-	    #endif
-	    return 1;
-	    ]]
-	)],
-	[
-	AC_MSG_RESULT([yes])
-	M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1"
-	M4_FLAGS="${M4_FLAGS} -P __ELF__,1"
-	],
-	[AC_MSG_RESULT([no])])
-fi
+m4_include(achost.ac)
 
 dnl Checks for libraries.
 AC_CHECK_LIB([m], [exp])
diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index 55d38d578..489ddca42 100644
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -162,26 +162,24 @@ USA.
       (set-%alien/ctype! alien ctype))
   alien)
 
-(define (guarantee-alien operator object #!optional ctype)
-  (let loop ((object object))
-    (if (and (alien? object)
-	     (or (default-object? ctype)
-		 (equal? (%alien/ctype object) ctype)))
-	object
-	(loop
-	 (call-with-current-continuation
-	  (lambda (continuation)
-	    (with-restart
-	     'USE-VALUE			;name
-	     "Continue with an alien."	;reporter
-	     continuation		;effector
-	     (lambda ()			;interactor
-	       (values
-		(prompt-for-evaluated-expression
-		 "New alien (an expression to be evaluated)")))
-	     (lambda ()			;thunk
-	       (error:wrong-type-argument
-		object "an alien" operator)))))))))
+(declare (integrate-operator guarantee-alien))
+(define (guarantee-alien object operator)
+  (if (not (alien? object))
+      (error:not-alien object operator)))
+
+(define (error:not-alien object operator)
+  (call-with-current-continuation
+   (lambda (continuation)
+     (with-restart
+      'USE-VALUE			;name
+      "Continue with an alien."		;reporter
+      continuation			;effector
+      (lambda ()			;interactor
+	(values
+	 (prompt-for-evaluated-expression
+	  "New alien (an expression to be evaluated)")))
+      (lambda ()			;thunk
+	(error:wrong-type-argument object "an alien" operator))))))
 
 
 ;;; Alien Functions
@@ -220,6 +218,14 @@ USA.
   ;; Band ID
   band-id)
 
+(declare (integrate-operator guarantee-alien-function))
+(define (guarantee-alien-function object operator)
+  (if (not (alien-function? object))
+      (error:not-alien-function object operator)))
+
+(define (error:not-alien-function object operator)
+  (error:wrong-type-argument object "an alien function" operator))
+
 (define (make-alien-function name library return-type params filename)
   (%make-alien-function 0 0 (string-append "Scm_" name)
 			library return-type params filename #f))
@@ -303,8 +309,7 @@ USA.
 	      (loop (cdr consts)))))))
 
 (define (call-alien alien-function . args)
-  (if (not (alien-function? alien-function))
-      (error:bad-range-argument alien-function 'call-alien))
+  (guarantee-alien-function alien-function 'call-alien)
   (alien-function-cache! alien-function)
   (for-each
    (lambda (arg)
@@ -361,19 +366,24 @@ USA.
 	  (loop (cdr aliens)))))
   (set! malloced-aliens '()))
 
-(define (malloc size ctype)
-  ;; Add copy to malloced-aliens BEFORE calling malloc.
-  (let ((alien (make-alien ctype))
-	(copy (make-alien ctype)))
-    (let ((entry (weak-cons alien copy)))
-      (without-interrupts
-       (lambda ()
-	 (set! malloced-aliens (cons entry malloced-aliens)))))
-    ((ucode-primitive c-malloc 2) copy size)
-    ;; Even an interrupt here will not leak a byte.
-    (copy-alien-address! alien copy)
+(define (make-alien-to-free ctype init)
+  ;; Register BEFORE initializing (allocating).
+  (let ((alien (make-alien ctype)))
+    (let ((copy (make-alien ctype)))
+      (let ((entry (weak-cons alien copy)))
+	(without-interrupts
+	 (lambda ()
+	   (set! malloced-aliens (cons entry malloced-aliens)))))
+      (init copy)
+      ;; Even an abort here will not leak a byte.
+      (copy-alien-address! alien copy))
     alien))
 
+(define (malloc size ctype)
+  (make-alien-to-free ctype
+		      (lambda (alien)
+			((ucode-primitive c-malloc 2) alien size))))
+
 (define (free alien)
   (if (not (alien? alien))
       (warn "Cannot free a non-alien:" alien)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d81887c41..da5ebdb11 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3259,6 +3259,9 @@ USA.
 	  alien-function/name
 	  alien-byte-increment
 	  alien-byte-increment!
+	  error:not-alien
+	  guarantee-alien-function
+	  error:not-alien-function
 	  guarantee-alien
 	  c-peek-cstring
 	  c-peek-cstring!
@@ -3270,6 +3273,7 @@ USA.
 	  c-poke-string!
 	  c-enum-name
 	  call-alien
+	  make-alien-to-free
 	  malloc
 	  free
 	  register-c-callback
diff --git a/tests/Clean.sh b/tests/Clean.sh
new file mode 100755
index 000000000..3d290a22d
--- /dev/null
+++ b/tests/Clean.sh
@@ -0,0 +1,15 @@
+#!/bin/sh
+
+set -e
+
+if [ ${#} -ne 1 ]; then
+    echo "usage: ${0} <command>"
+    exit 1
+fi
+COMMAND=${1}
+
+TOPDIR=../src ../src/etc/Clean.sh ${COMMAND}
+
+for SUBDIR in ffi microcode runtime star-parser xml; do
+    ( cd $SUBDIR; TOPDIR=../../src ../../src/etc/Clean.sh ${COMMAND} )
+done
diff --git a/tests/check.scm b/tests/check.scm
index d4b020f82..37f7b7a5c 100644
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -29,8 +29,6 @@ USA.
 
 (declare (usual-integrations))
 
-(load (merge-pathnames "load" (directory-pathname (current-load-pathname))))
-
 ;;; Can't just look at */test-*.scm because not everything has been
 ;;; converted to use the automatic framework.
 
@@ -51,11 +49,13 @@ USA.
     "runtime/test-process"
     "runtime/test-regsexp"
     ("runtime/test-wttree" (runtime wt-tree))
+    "ffi/test-ffi"
     ))
 
 (with-working-directory-pathname
     (directory-pathname (current-load-pathname))
   (lambda ()
+    (load "load")
     (for-each (lambda (entry)
                 (receive (pathname environment)
                          (if (pair? entry)
@@ -81,5 +81,11 @@ USA.
                               (compile-file (file-pathname pathname)
                                             '()
                                             environment))))
-                      (run-unit-tests pathname environment)))))
-              known-tests)))
+                      (let* ((t (pathname-type pathname))
+                             (p (if (and t (string=? "com" t)
+                                         (eq? 'C
+                                              microcode-id/compiled-code-type))
+                                    (pathname-new-type pathname "so")
+                                    pathname)))
+                        (run-unit-tests p environment))))))
+              known-tests)))
\ No newline at end of file
diff --git a/tests/ffi/test-ffi-wrapper.scm b/tests/ffi/test-ffi-wrapper.scm
new file mode 100644
index 000000000..6450ccf76
--- /dev/null
+++ b/tests/ffi/test-ffi-wrapper.scm
@@ -0,0 +1,30 @@
+;;;-*-Scheme-*-
+
+(C-include "ffi-test")
+
+(define (test-ffi)
+  (let* ((struct (malloc (c-sizeof "TestStruct") '|TestStruct|))
+	 (string "input string")
+	 (pi (* 4 (atan 1 1)))
+	 (chars (malloc (1+ (* (c-sizeof "char") (string-length string)))
+			'(* char))))
+    (C->= struct "TestStruct first" (char->ascii #\A))
+    (C->= struct "TestStruct second" pi)
+    (C->= struct "TestStruct third" (char->ascii #\C))
+    (c-poke-string chars string)
+    (C->= struct "TestStruct fourth" chars)
+    (C-call "test_register_double"
+	    (C-callback "test_double_callback")
+	    (C-callback (lambda (d) (* d pi))))
+    (list
+     (let ((d (C-call "test_double" pi struct)))
+       (assert-equal (* pi pi pi) d))
+     (assert-equal (number->string (* 2 (string-length string)))
+		   (let* ((alien (make-alien-to-free
+				  '(* char)
+				  (lambda (retval)
+				    (C-call "test_string" retval
+					    string struct))))
+			  (new (c-peek-cstring alien)))
+		     (free alien)
+		     new)))))
\ No newline at end of file
diff --git a/tests/ffi/test-ffi.scm b/tests/ffi/test-ffi.scm
new file mode 100644
index 000000000..1240038c1
--- /dev/null
+++ b/tests/ffi/test-ffi.scm
@@ -0,0 +1,8 @@
+;;;-*-Scheme-*-
+
+(load-option 'FFI)
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+  (lambda ()
+    (compile-file "test-ffi-wrapper")
+    (load "test-ffi-wrapper")))
+(define-test 'ffi test-ffi)
\ No newline at end of file