ffi/build.scm.in: Support building shims separately.

A handful of new top-level bindings make a portickle Makefile.

gdbm-shim.so: gdbm-shim.o gdbm-adapter.o
	echo "(link-shim)" | mit-scheme --batch-mode -- -o $@ $^ -lgdbm

The new procedures (generate-shim, compile-shim, link-shim and
install-shim) autoload ffi/build.scm, which captured the build
configuration of the machine.  Compile-bundle and install-bundle are
also provided.

diff --git a/src/ffi/build.scm.in b/src/ffi/build.scm.in
new file mode 100644 (file)
index 0000000..847c199
--- /dev/null
+++ b/src/ffi/build.scm.in
@@ -0,0 +1,124 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 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.
+
+|#
+
+;;;; Build Utilities
+;;; package: (ffi build)
+
+(define (compile-bundle)
+  (with-system-library-directories
+   '("./")
+   (lambda ()
+     (if (eq? microcode-id/compiled-code-type 'C)
+        (fluid-let ((compiler:invoke-c-compiler? #f))
+          (compile-dir)
+          (c-compile-pkgs))
+        (compile-dir)))))
+
+(define (compile-shim)
+  (run-command (append cc-cmdline-prefix (command-line))))
+
+(define (link-shim)
+  (run-command (append CCLD LDFLAGS (command-line) MODULE_LDFLAGS)))
+
+(define (install-bundle)
+  (let* ((name (working-directory-name))
+        (target-dir (->namestring (system-library-pathname name #f))))
+    (run-command (list "rm" "-rf" target-dir))
+    (run-command (list "mkdir" target-dir))
+    (run-command (append (list "install" "-m" "644")
+                        (command-line)
+                        (list target-dir)))))
+
+(define (install-shim libname)
+  (run-command (list "install" "-m" "644"
+                    (string-append libname "-shim.so")
+                    (string-append libname "-types.bin")
+                    (string-append libname "-const.bin")
+                    (->namestring (system-library-directory-pathname)))))
+\f
+(define (parse-words string)
+  (burst-string string char-set:whitespace #t))
+
+(define CCLD (parse-words "@CCLD@"))
+(define LDFLAGS (parse-words "@LDFLAGS@"))
+(define MODULE_LDFLAGS (parse-words "@MODULE_LDFLAGS@"))
+(define AUXDIR/ "@libdir@/@AUXDIR_NAME@/")
+(define INSTALL_DATA (parse-words "@INSTALL_DATA@"))
+(define cc-cmdline-prefix
+  (append
+   (filter
+    (lambda (i) (not (string=? "-DMIT_SCHEME" i)))
+    (parse-words "@CC@ @DEFS@ @SCHEME_DEFS@ @CPPFLAGS@"))
+   (list (string-append "-I" (->namestring (system-library-pathname ""))))
+   (parse-words "@CFLAGS@ @MODULE_CFLAGS@")))
+
+(define (working-directory-name)
+  (let ((name (pathname-name (directory-pathname-as-file
+                             (working-directory-pathname)))))
+    (if (and (string? name) (not (string-null? name)))
+       name
+       (error "Could not find the current working directory name."))))
+
+(define (run-command command)
+  (with-notification
+   (lambda (port)
+     (write-string (decorated-string-append "" " " "" command) port)
+     (newline port))
+   (lambda ()
+     (let ((code (run-synchronous-subprocess
+                 (car command) (cdr command)
+                 'working-directory (working-directory-pathname))))
+       (if (not (zero? code))
+          (error "Process exited with error code:" code command))))))
+
+(define (compile-dir)
+  (let ((name (working-directory-name)))
+    (if (file-exists? (pathname-new-type name "sf"))
+       (begin
+         (load (pathname-new-type name "sf"))
+         (load (pathname-new-type name "cbf")))
+       (load "compile"))))
+
+(define (c-compile-pkgs)
+  (let* ((name (working-directory-name))
+        (root
+            (if (string=? name "star-parser")
+                "parser"
+                name))
+        (compile-pkg
+         (lambda (os)
+           (cbf-conditionally (string-append root "-" os ".pkd")))))
+    (compile-pkg "unx")
+    (compile-pkg "w32")
+    (compile-pkg "os2")))
+
+(define (cbf-conditionally pathname)
+  (let ((input (pathname-default-type pathname "bin"))
+       (file-type (if (eq? microcode-id/compiled-code-type 'C)
+                      "c" "com")))
+    (if (file-modification-time<? (pathname-new-type pathname file-type)
+                                 input)
+       (compile-file input))))
\ No newline at end of file

diff --git a/src/ffi/ffi.pkg b/src/ffi/ffi.pkg
index cf471ce5112bf50029930a3b470913b7d9978220..b166a0216baac7b7a2095904bd2022af42b73e67 100644 (file)
--- a/src/ffi/ffi.pkg
+++ b/src/ffi/ffi.pkg
@@ -35,4 +35,16 @@ FFI System Packaging |#
          alien-function/parameters
          alien-function/return-type)
   (export ()
-         c-generate))
\ No newline at end of file
+         c-generate))
+
+(define-package (ffi build)
+  (parent ())
+  (files "build")
+  (import (runtime pathname)
+         library-directory-path)
+  (export (ffi)
+         compile-shim
+         link-shim
+         install-shim
+         compile-bundle
+         install-bundle))
\ No newline at end of file

diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac
index 4c25bc6f82257c19594cb4804d9c39c9a33589f1..291fd5331e54cb32c47958685d85630fe3adcf87 100644 (file)
--- a/src/microcode/configure.ac
+++ b/src/microcode/configure.ac
@@ -927,6 +927,7 @@ AC_SUBST([INSTALL_INCLUDE])
 AC_SUBST([CCLD])
 
 AC_CONFIG_FILES([Makefile])
+AC_CONFIG_FILES([../ffi/build.scm])
 AC_OUTPUT
 
 # Make custom compilation program for "makegen.scm".

diff --git a/src/microcode/makegen/Makefile.in.in b/src/microcode/makegen/Makefile.in.in
index 4a8f79b5b8359500ff9cebf368238ed31f70e16e..94a89d14f629aed45481e57d8779f5c4f22529b3 100644 (file)
--- a/src/microcode/makegen/Makefile.in.in
+++ b/src/microcode/makegen/Makefile.in.in
@@ -147,7 +147,7 @@ CLEAN_FILES = $(ALL_PROGRAMS) $(ALL_LIBS) $(ALL_DATA) $(EXTRA_PROGRAMS)
 
 DISTCLEAN_FILES = Makefile config.h config.cache config.log config.status \
        cmpauxmd.m4 cmpauxmd.c cmpintmd.h makegen-cc \
-       cmpintmd-config.h cmpintmd.c liarc-cc liarc-ld
+       cmpintmd-config.h cmpintmd.c liarc-cc liarc-ld ../ffi/build.scm
 
 MAINTAINER_CLEAN_FILES = Makefile.in Makefile.deps liarc-vars liarc-rules \
        config.h.in configure TAGS

diff --git a/src/microcode/pruxffi.h b/src/microcode/pruxffi.h
index de71e8e399622dbf2d67f676e82627b49d7b74dd..017d64ac52a931c72a93c02434f357be92e41884 100644 (file)
--- a/src/microcode/pruxffi.h
+++ b/src/microcode/pruxffi.h
@@ -96,4 +96,5 @@ extern SCM cons (SCM car, SCM cdr);
 /* For debugging messages from shim code. */
 extern void outf_error (const char *, ...);
 extern void outf_flush_error (void);
+extern void error_external_return (void);
 #endif

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index 763c2698dc9878e2ce9c3166b59d85832aacde48..629b14ddba3fc9f3e7a11f4adf39b0d45fda9ca2 100644 (file)
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -523,6 +523,41 @@ USA.
   (vector-set! (get-fixed-objects-vector) #x41 callback-handler))
 \f
 
+;;; Build support, autoloaded
+
+(define (generate-shim library #!optional prefix)
+  (load-ffi-quietly)
+  ((environment-lookup (->environment '(ffi)) 'c-generate) library prefix))
+
+(define (compile-shim)
+  (load-ffi-quietly)
+  ((environment-lookup (->environment '(ffi)) 'compile-shim)))
+
+(define (link-shim)
+  (load-ffi-quietly)
+  ((environment-lookup (->environment '(ffi)) 'link-shim)))
+
+(define (install-shim library)
+  (load-ffi-quietly)
+  ((environment-lookup (->environment '(ffi)) 'install-shim) library))
+
+(define (compile-bundle)
+  (load-ffi-quietly)
+  ((environment-lookup (->environment '(ffi)) 'compile-bundle)))
+
+(define (install-bundle)
+  (load-ffi-quietly)
+  ((environment-lookup (->environment '(ffi)) 'install-bundle)))
+
+(define (load-ffi-quietly)
+  (if (not (name->package '(FFI)))
+      (with-notification
+       (lambda (port) (write-string "Loading FFI option" port))
+       (lambda ()
+        (fluid-let ((load/suppress-loading-message? #t))
+          (load-option 'ffi))))))
+\f
+
 (define calloutback-stack '())
 
 (define %trace? #f)

diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm
index d75ebdd29544324906ed55351e49284e75629916..f6d845ed673b2f6cf21666364f9023aea474a5eb 100644 (file)
--- a/src/runtime/pathnm.scm
+++ b/src/runtime/pathnm.scm
@@ -621,6 +621,20 @@ these rules:
              (else #f)))
       (%find-library-directory)))
 
+(define (with-system-library-directories directories thunk)
+  (define (existing-directory directory)
+    (let ((dirpath (pathname-as-directory (merge-pathnames directory))))
+      (if (file-directory? dirpath)
+         dirpath
+         (error:file-operation dirpath
+                               "find" "directory" "no such directory"
+                               'with-system-library-directories
+                               directories))))
+  (fluid-let ((library-directory-path
+              (append library-directory-path
+                      (map existing-directory directories))))
+    (thunk)))
+
 (define (%find-library-directory)
   (pathname-simplify
    (or (find-matching-item library-directory-path file-directory?)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 6feca330f3e68cd45a204ee456bfaab4034beb92..b2052c63b7c5db1843805e07ee9e8cccec185921 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3124,6 +3124,7 @@ USA.
          pathname?
          system-library-directory-pathname
          system-library-pathname
+         with-system-library-directories
          uri->pathname
          user-homedir-pathname)
   (initialization (initialize-package!)))
@@ -3331,7 +3332,13 @@ USA.
          free
          register-c-callback
          de-register-c-callback
-         outf-error)
+         outf-error
+         generate-shim
+         compile-shim
+         link-shim
+         install-shim
+         compile-bundle
+         install-bundle)
   (initialization (initialize-package!)))
 
 (define-package (runtime program-copier)