From 5f67ff0ca95c24276e4823da2f369b8482e699cd Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Tue, 19 Apr 2011 00:49:14 -0700 Subject: [PATCH] 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. --- src/compiler/base/toplev.scm | 10 ++-- src/cref/butils.scm | 93 ++++++++++++++++++++++++++++++++++++ src/cref/cref.pkg | 6 +++ src/ffi/compile.scm | 30 ++++++++++++ src/ffi/ffi.cbf | 6 --- src/ffi/ffi.sf | 42 ---------------- 6 files changed, 136 insertions(+), 51 deletions(-) create mode 100644 src/cref/butils.scm create mode 100644 src/ffi/compile.scm delete mode 100644 src/ffi/ffi.cbf delete mode 100644 src/ffi/ffi.sf diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm index 9516dad54..358375fba 100644 --- 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 index 000000000..01ffa682c --- /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)) + +(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 ca8dab83e..ebae97f20 100644 --- 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 index 000000000..93018b764 --- /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 index d81904058..000000000 --- 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 index 2dc098295..000000000 --- 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 -- 2.25.1