From 56fd6a47ab79b74b96b98661c5c14c46d37d1748 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sun, 17 Apr 2011 17:08:38 -0700 Subject: [PATCH] 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. --- doc/ffi/ffi.texinfo | 75 +---------- doc/user-manual/user.texinfo | 6 +- src/Clean.sh | 1 + src/Makefile.in | 17 +-- src/Setup.sh | 2 + src/configure.ac | 20 ++- src/etc/compile.scm | 8 ++ src/etc/functions.sh | 12 +- src/etc/make-liarc.sh | 2 +- src/etc/std-makefile-prefix | 16 +++ src/ffi/.gitignore | 6 + src/ffi/Clean.sh | 3 +- src/ffi/Makefile-fragment | 59 +++++---- src/ffi/ffi-test.c.stay | 32 +++++ src/ffi/ffi-test.cdecl | 27 ++++ src/ffi/ffi-test.h | 23 ++++ src/ffi/prhello.cdecl | 85 ------------- src/ffi/prhello.scm | 55 --------- src/microcode/achost.ac | 219 +++++++++++++++++++++++++++++++++ src/microcode/configure.ac | 197 +---------------------------- src/runtime/ffi.scm | 76 +++++++----- src/runtime/runtime.pkg | 4 + tests/Clean.sh | 15 +++ tests/check.scm | 14 ++- tests/ffi/test-ffi-wrapper.scm | 30 +++++ tests/ffi/test-ffi.scm | 8 ++ 26 files changed, 524 insertions(+), 488 deletions(-) create mode 100644 src/ffi/ffi-test.c.stay create mode 100644 src/ffi/ffi-test.cdecl create mode 100644 src/ffi/ffi-test.h delete mode 100644 src/ffi/prhello.cdecl delete mode 100644 src/ffi/prhello.scm create mode 100644 src/microcode/achost.ac create mode 100755 tests/Clean.sh create mode 100644 tests/ffi/test-ffi-wrapper.scm create mode 100644 tests/ffi/test-ffi.scm 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 <")') \ + 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 +#include + +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} " + 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 -- 2.25.1