From: Matt Birkholz <matt@birkholz.chandler.az.us>
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,
- ;;
- ;; ( (<target-package> <source-package> . <bound-names>)... )
- ;;
- ;; e.g. (((gtk keys) (ffi) find-c-includes c-enum-constant-values)).
- ;; Each symbol in <bound-names> is bound in the target package and
- ;; linked to the same name in the source package. <target-package>
- ;; and <source-package> 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