New compile-system procedure. Replaced ffi.sf and ffi.cbf.

* src/compiler/base/toplev.scm (compile-file): Only declare
integrate-external when dependencies have no type.  Thus a dependency
on e.g. "gtk-const.bin" might cause the dependent file to be
re-compiled without a spurious warning about a missing .ext file.

* src/cref/: butils.scm, cref.pkg: Added new file butils.scm,
containing a compile-system procedure that applies compile-file to
each file mentioned in a .pkg file.

* src/ffi/: compile.scm, ffi.cbf, ffi.sf: Replaced the old .cbf and
.sf files with a new, modern compile.scm file.

diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm
index 9516dad54e12f24e99dc7b11a9746cbf9a6e4a9d..358375fba41581f0b93152a1900ea9be9bb775b1 100644 (file)
--- a/src/compiler/base/toplev.scm
+++ b/src/compiler/base/toplev.scm
@@ -93,9 +93,13 @@ USA.
                          (sf/default-declarations
                           `((USUAL-INTEGRATIONS
                              ,@compile-file:override-usual-integrations)
-                            ,@(if (null? dependencies)
-                                  '()
-                                  `((INTEGRATE-EXTERNAL ,@dependencies))))))
+                            ,@(let ((deps (keep-matching-items
+                                           dependencies
+                                           (lambda (item)
+                                             (eq? #f (pathname-type item))))))
+                                (if (null? deps)
+                                    '()
+                                    `((INTEGRATE-EXTERNAL ,@deps)))))))
                (sf input-file output-file))))
          (if (not compile-file:sf-only?)
              (process-file (bin-pathname file)

diff --git a/src/cref/butils.scm b/src/cref/butils.scm
new file mode 100644 (file)
index 0000000..01ffa68
--- /dev/null
+++ b/src/cref/butils.scm
@@ -0,0 +1,93 @@
+#| -*-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 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: (cross-reference build-utilities)
+
+(declare (usual-integrations))
+\f
+(define (compile-system name directory . options)
+  ;; Gets a list of file.package from DIRECTORY/NAME.pkg, creates the
+  ;; packages described therein, then (re)compiles (as necessary) and
+  ;; loads each file in order.
+  ;;
+  ;; If OPTIONS includes 'dependencies, its value should be an alist
+  ;; of filenames, as they appear in the NAME.pkg file, each
+  ;; associated with a list of pathnames (relative to DIRECTORY).
+
+  (define (find-option name options default)
+    (let loop ((opts options))
+      (if (pair? opts)
+         (if (eq? (car opts) name)
+             (cadr opts)
+             (loop (cddr opts)))
+         default)))
+
+  (with-working-directory-pathname directory
+    (lambda ()
+      (let* ((os-type microcode-id/operating-system)
+            (pmodel (read-package-model name os-type))
+            (pathname (pmodel/pathname pmodel))
+            (dependencies (find-option 'dependencies options '()))
+            (syntax-only? (find-option 'syntax-only? options #f)))
+
+       (define (env file)
+         (->environment
+          (let loop ((cps (pmodel/packages pmodel)))
+            (if (pair? cps)
+                (if (find (lambda (f) (pathname=? f file))
+                          (package/files (car cps)))
+                    (package/name (car cps))
+                    (loop (cdr cps)))
+                (error "No cref-package for file:" file)))))
+
+       (define (deps file)
+         (let ((entry (assoc file dependencies)))
+           (if entry (cdr entry) '())))
+
+       (for-each (lambda (file.deps)
+                   (if (not (for-all? string? file.deps))
+                       (error "Bogus dependency:" file.deps)))
+                 dependencies)
+
+       (let ((existing
+              (let loop ((packages (pmodel/packages pmodel)))
+                (if (pair? packages)
+                    (or (name->package (package/name (car packages)))
+                        (loop (cdr packages)))
+                    #f))))
+         (if existing
+             (warn "Package already exists:" (package/name (car packages)))
+             ;; Build package(s) for use at syntax-time.
+             (construct-packages-from-file
+              (construct-external-descriptions pmodel))))
+
+       (for-each
+         (lambda (file)
+           (compile-file file (deps file) (env file))
+           (load file))
+         (append-map package/files (pmodel/packages pmodel)))
+
+       (cref/generate-constructors name 'ALL)))))
\ No newline at end of file

diff --git a/src/cref/cref.pkg b/src/cref/cref.pkg
index ca8dab83e97844af06928923c9817c7f1d615a07..ebae97f207c9c41806e680e2a422824cdefa0655 100644 (file)
--- a/src/cref/cref.pkg
+++ b/src/cref/cref.pkg
@@ -40,6 +40,12 @@ USA.
          cref/generate-trivial-constructor
          cref/package-files))
 
+(define-package (cross-reference build-utilities)
+  (files "butils")
+  (parent (cross-reference))
+  (export ()
+         compile-system))
+
 (define-package (cross-reference analyze-file)
   (files "anfile")
   (parent (cross-reference))

diff --git a/src/ffi/compile.scm b/src/ffi/compile.scm
new file mode 100644 (file)
index 0000000..93018b7
--- /dev/null
+++ b/src/ffi/compile.scm
@@ -0,0 +1,30 @@
+#| -*-Scheme-*-
+
+Compile the FFI system. |#
+
+(load-option 'CREF)
+
+;; Temporay hack.  Remove when (runtime ffi) is in the release.
+(if (not (name->package '(RUNTIME FFI)))
+    (let ((path (package-set-pathname "../runtime/runtime")))
+      (if (not (file-exists? path))
+         (cref/generate-trivial-constructor "../runtime/runtime"))
+      (eval `(for-each-vector-element
+             (package-file/descriptions (fasload ,path))
+             (lambda (description)
+               (if (equal? (package-description/name description) '(RUNTIME FFI))
+                   (begin
+                     (construct-normal-package-from-description description)
+                     (create-links-from-description description)
+                     (load "../runtime/ffi" (->environment '(RUNTIME FFI))
+                           'ignored #t)))))
+           (->environment '(PACKAGE)))))
+
+;; Temporary hack.  Remove when compile-system is in the release.
+(if (not (environment-bound? (->environment '()) 'compile-system))
+    (let ((butil-env (->environment '(cross-reference)))
+         (global-env (->environment '())))
+      (load "../cref/butils" butil-env)
+      (environment-link-name global-env butil-env 'compile-system)))
+
+(compile-system "ffi" (directory-pathname (current-load-pathname)))
\ No newline at end of file

diff --git a/src/ffi/ffi.cbf b/src/ffi/ffi.cbf
deleted file mode 100644 (file)
index d819040..0000000
--- a/src/ffi/ffi.cbf
+++ /dev/null
@@ -1,6 +0,0 @@
-#| -*-Scheme-*-
-
-Compile the FFI system. |#
-
-(fluid-let ((compiler:coalescing-constant-warnings? #f))
-  (compile-directory "."))
\ No newline at end of file

diff --git a/src/ffi/ffi.sf b/src/ffi/ffi.sf
deleted file mode 100644 (file)
index 2dc0982..0000000
--- a/src/ffi/ffi.sf
+++ /dev/null
@@ -1,42 +0,0 @@
-#| -*-Scheme-*-
-
-Syntax the FFI system. |#
-
-(load-option 'CREF)
-
-;; Temporary hack, until (runtime ffi) is in the released version.
-(if (not (name->package '(RUNTIME FFI)))
-    (let ((path (package-set-pathname "../runtime/runtime")))
-      (if (not (file-exists? path))
-         (cref/generate-trivial-constructor "../runtime/runtime"))
-      (eval `(for-each-vector-element
-             (package-file/descriptions (fasload ,path))
-             (lambda (description)
-               (if (equal? (package-description/name description) '(RUNTIME FFI))
-                   (begin
-                     (construct-normal-package-from-description description)
-                     (create-links-from-description description)
-                     (load "../runtime/ffi" (->environment '(RUNTIME FFI))
-                           'ignored #t)))))
-           (->environment '(PACKAGE)))))
-
-(with-working-directory-pathname (directory-pathname (current-load-pathname))
-  (lambda ()
-    (let ((ffi-files '("ctypes" "cdecls" "syntax" "generator")))
-
-      ;; Build an empty package for use at syntax-time.
-      ;; The imports should bind esp. ucode-primitive in (ffi).
-      (if (not (name->package '(FFI)))
-         (let ((path (package-set-pathname "ffi")))
-           (if (not (file-exists? path))
-               (cref/generate-trivial-constructor "ffi"))
-           (construct-packages-from-file (fasload path))))
-
-      ;; Syntax everything in (ffi).
-      (fluid-let ((sf/default-syntax-table (->environment '(ffi)))
-                 (sf/default-declarations
-                  (cons '(usual-integrations) sf/default-declarations)))
-       (for-each (lambda (f) (sf-conditionally f #t)) ffi-files))
-
-      ;; Cross-check.
-      (cref/generate-constructors "ffi" 'ALL))))
\ No newline at end of file