(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
@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/.
@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
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
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
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@
--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; \
</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
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}"
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]]]))
fi
AC_SUBST([ALL_TARGET])
+AC_SUBST([FFIS])
AC_SUBST([INSTALL_COM])
AC_SUBST([INSTALL_LIARC_BUNDLES])
AC_SUBST([MIT_SCHEME_EXE])
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
(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
(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")))
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
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
# **** 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:
+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
../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.*
TARGET_DIR = $(AUXDIR)/ffi
+# Install the FFI option, and test lib.
install:
rm -rf $(DESTDIR)$(TARGET_DIR)
$(mkinstalldirs) $(DESTDIR)$(TARGET_DIR)
$(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
--- /dev/null
+/* -*-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);
+}
--- /dev/null
+;;; -*-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
--- /dev/null
+/* -*-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);
+++ /dev/null
-#| -*-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
+++ /dev/null
-#| -*-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
--- /dev/null
+### -*-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
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])
(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))))))
\f
;;; Alien Functions
;; 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))
(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)
(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)
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!
c-poke-string!
c-enum-name
call-alien
+ make-alien-to-free
malloc
free
register-c-callback
--- /dev/null
+#!/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
(declare (usual-integrations))
\f
-(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.
"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)
(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
--- /dev/null
+;;;-*-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
--- /dev/null
+;;;-*-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
projects / mit-scheme.git / commitdiff