From: Matt Birkholz Date: Wed, 9 Oct 2013 18:59:26 +0000 (-0700) Subject: Eliminate compile-system. X-Git-Tag: release-9.2.0~68 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=164ffcba1d508f6a2a90c32479d3c166ba9bd526;p=mit-scheme.git Eliminate compile-system. --- diff --git a/src/blowfish/compile.scm b/src/blowfish/compile.scm index 7f6406d5f..477c7c8ba 100644 --- a/src/blowfish/compile.scm +++ b/src/blowfish/compile.scm @@ -2,11 +2,12 @@ ;;;; Compile the Blowfish wrapper. -(fluid-let ((load/suppress-loading-message? #t)) - (load-option 'CREF) - (load-option 'FFI)) - -(with-system-library-directories - '("./") - (lambda () - (compile-system "blowfish" (directory-pathname (current-load-pathname))))) \ No newline at end of file +(load-option 'CREF) +(load-option 'FFI) +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (with-system-library-directories + '("./") + (lambda () + (compile-file "blowfish" '() (->environment '(RUNTIME))))) + (cref/generate-constructors "blowfish" 'ALL))) \ No newline at end of file diff --git a/src/cref/butils.scm b/src/cref/butils.scm deleted file mode 100644 index 512de2c6e..000000000 --- a/src/cref/butils.scm +++ /dev/null @@ -1,131 +0,0 @@ -#| -*-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: (cross-reference build-utilities) - -(declare (usual-integrations)) - -(define (compile-system name directory . options) - ;; Gets a list of files from DIRECTORY/NAME.pkg, creates the - ;; packages described therein, and loads each file, in order, - ;; re-compiling it first when necessary. - ;; - ;; 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). - ;; - ;; If OPTIONS includes 'imports, its value should be a list, - ;; - ;; ( ( . )... ) - ;; - ;; e.g. (((gtk keys) (ffi) find-c-includes c-enum-constant-values)). - ;; Each symbol in is bound in the target package and - ;; linked to the same name in the source package. - ;; and should be package names -- lists of symbols. - - (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)) - (dependencies (find-option 'dependencies options '())) - (imports (find-option 'imports options '()))) - - (declare (integrate-operator file-package)) - (define (file-package file) - (let loop ((packages (pmodel/packages pmodel))) - (if (pair? packages) - (if (find (lambda (f) (pathname=? f file)) - (package/files (car packages))) - (car packages) - (loop (cdr packages))) - (error "No cref package for file:" file pmodel)))) - - (define-integrable (file-environment file) - (->environment (package/name (file-package file)))) - - (define-integrable (file-dependencies file) - (let ((entry (assoc (->namestring file) dependencies))) - (if entry (cdr entry) '()))) - - (for-each (lambda (file.deps) - (if (not (for-all? file.deps string?)) - (error "Bogus dependency:" file.deps))) - dependencies) - - (for-each (lambda (import) - (let ((target (car import)) - (source (cadr import)) - (names (cddr import)) - (glt guarantee-list-of-type)) - (declare (integrate glt)) - (glt target symbol? "package name" 'compile-system) - (glt source symbol? "package name" 'compile-system) - (glt names symbol? "imported names" 'compile-system))) - imports) - - (let ((existing - (let loop ((packages (pmodel/packages pmodel))) - (if (pair? packages) - (or (name->package (package/name (car packages))) - (loop (cdr packages))) - #f)))) - (if existing - (error "Package already exists:" existing) - (construct-packages-from-file - (construct-external-descriptions pmodel)))) - - (for-each - (lambda (import) - (let ((target (->environment (car import))) - (source (->environment (cadr import))) - (names (cddr import))) - (for-each (lambda (name) - (environment-link-name target source name)) - names))) - imports) - - (for-each - (lambda (file) - (let ((env (file-environment file)) - (deps (file-dependencies file)) - (type - (if (or compile-file:sf-only? compiler:cross-compiling?) - "bin" - #f))) - (compile-file file deps env) - (load (pathname-new-type file type) env))) - (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 f6d071341..830e2faa6 100644 --- a/src/cref/cref.pkg +++ b/src/cref/cref.pkg @@ -41,12 +41,6 @@ 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/cref/triv.pkg b/src/cref/triv.pkg index 999b1d5d0..ecf77513f 100644 --- a/src/cref/triv.pkg +++ b/src/cref/triv.pkg @@ -53,10 +53,6 @@ USA. cref/generate-trivial-constructor cref/package-files) '()) - (package '(cross-reference build-utilities) - '((cross-reference) ()) - '((compile-system)) - '()) (package '(cross-reference analyze-file) '((cross-reference) ()) '(analyze-file) @@ -83,7 +79,6 @@ USA. '#() '#())))) (vector (files '(cross-reference) "mset" "object" "toplev") - (files '(cross-reference build-utilities) "butils") (files '(cross-reference analyze-file) "anfile") (files '(cross-reference constructor) "conpkg") (files '(cross-reference formatter) "forpkg") diff --git a/src/etc/compile.scm b/src/etc/compile.scm index f9252cf45..f5eca8a40 100644 --- a/src/etc/compile.scm +++ b/src/etc/compile.scm @@ -43,18 +43,6 @@ USA. (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) - (let* ((line '("make" "compile-liarc-bundle")) - (code (run-synchronous-subprocess - (car line) (cdr line) 'working-directory dir))) - (if (not (zero? code)) - (error "Process exited with error code:" code line))))) - (compile-dir dir))) - (define (compile-boot-dirs compile-dir) (compile-cref compile-dir) (for-each compile-dir '("runtime" "cref" "sf" "compiler" "star-parser"))) diff --git a/src/ffi/compile.scm b/src/ffi/compile.scm index 944b6dfcb..7e6f1aa47 100644 --- a/src/ffi/compile.scm +++ b/src/ffi/compile.scm @@ -1,14 +1,11 @@ -#| -*-Scheme-*- +#| -*-Scheme-*- |# -Compile the FFI system. |# +;;;; Compile the C/FFI. (load-option 'CREF) - -;; 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 +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (for-each (lambda (file) + (compile-file file '() (->environment '(RUNTIME)))) + '("ctypes" "cdecls" "syntax" "generator" "build")) + (cref/generate-constructors "ffi" 'ALL))) \ No newline at end of file diff --git a/src/gdbm/compile.scm b/src/gdbm/compile.scm index b94c01ac7..2052264a1 100644 --- a/src/gdbm/compile.scm +++ b/src/gdbm/compile.scm @@ -2,11 +2,12 @@ ;;;; Compile the GDBM wrapper. -(fluid-let ((load/suppress-loading-message? #t)) - (load-option 'CREF) - (load-option 'FFI)) - -(with-system-library-directories - '("./") - (lambda () - (compile-system "gdbm" (directory-pathname (current-load-pathname))))) \ No newline at end of file +(load-option 'CREF) +(load-option 'FFI) +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (with-system-library-directories + '("./") + (lambda () + (compile-file "gdbm" '() (->environment '(RUNTIME))))) + (cref/generate-constructors "gdbm" 'ALL))) \ No newline at end of file diff --git a/src/md5/compile.scm b/src/md5/compile.scm index bae363634..749754eb4 100644 --- a/src/md5/compile.scm +++ b/src/md5/compile.scm @@ -2,11 +2,12 @@ ;;;; Compile the MD5 wrapper. -(fluid-let ((load/suppress-loading-message? #t)) - (load-option 'CREF) - (load-option 'FFI)) - -(with-system-library-directories - '("./") - (lambda () - (compile-system "md5" (directory-pathname (current-load-pathname))))) \ No newline at end of file +(load-option 'CREF) +(load-option 'FFI) +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (with-system-library-directories + '("./") + (lambda () + (compile-file "md5" '() (->environment '(RUNTIME))))) + (cref/generate-constructors "md5" 'ALL))) \ No newline at end of file diff --git a/src/mhash/compile.scm b/src/mhash/compile.scm index 0f4899c2e..e5b92ce1a 100644 --- a/src/mhash/compile.scm +++ b/src/mhash/compile.scm @@ -2,11 +2,12 @@ ;;;; Compile the mhash wrapper. -(fluid-let ((load/suppress-loading-message? #t)) - (load-option 'CREF) - (load-option 'FFI)) - -(with-system-library-directories - '("./") - (lambda () - (compile-system "mhash" (directory-pathname (current-load-pathname))))) \ No newline at end of file +(load-option 'CREF) +(load-option 'FFI) +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (with-system-library-directories + '("./") + (lambda () + (compile-file "mhash" '() (->environment '(RUNTIME))))) + (cref/generate-constructors "mhash" 'ALL))) \ No newline at end of file