From 819a59900c63c7a831da6e81c002113348c0cb05 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 4 Nov 1991 20:37:25 +0000 Subject: [PATCH] Changes to match runtime version 14.141. --- v7/src/compiler/base/crsend.scm | 17 +-- v7/src/compiler/base/crstop.scm | 10 +- v7/src/compiler/base/make.scm | 4 +- v7/src/compiler/base/toplev.scm | 17 +-- v7/src/compiler/etc/comcmp.scm | 6 +- v7/src/compiler/machines/bobcat/decls.scm | 13 +- v7/src/compiler/machines/mips/decls.scm | 13 +- v7/src/compiler/machines/spectrum/decls.scm | 13 +- v7/src/compiler/machines/vax/decls.scm | 13 +- v7/src/cref/conpkg.scm | 4 +- v7/src/cref/forpkg.scm | 6 +- v7/src/cref/make.scm | 4 +- v7/src/cref/redpkg.scm | 20 +-- v7/src/cref/toplev.scm | 8 +- v7/src/sf/butils.scm | 55 ++++---- v7/src/sf/make.scm | 4 +- v7/src/sf/toplev.scm | 135 ++++++++------------ v8/src/compiler/etc/comcmp.scm | 6 +- v8/src/sf/make.scm | 4 +- v8/src/sf/toplev.scm | 135 ++++++++------------ 20 files changed, 208 insertions(+), 279 deletions(-) diff --git a/v7/src/compiler/base/crsend.scm b/v7/src/compiler/base/crsend.scm index efe1049cb..5b007ecf8 100644 --- a/v7/src/compiler/base/crsend.scm +++ b/v7/src/compiler/base/crsend.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crsend.scm,v 1.5 1991/02/06 03:04:59 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crsend.scm,v 1.6 1991/11/04 20:35:20 cph Exp $ -Copyright (c) 1988, 1989, 1990, 1991 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -49,23 +49,18 @@ MIT in each case. |# (define (compiler-pathnames input-string output-string default transform) (let* ((core (lambda (input-string) - (let ((input-pathname - (pathname->input-truename - (merge-pathnames (->pathname input-string) default)))) - (if (not input-pathname) - (error "File does not exist" input-string)) + (let ((input-pathname (merge-pathnames input-string default))) (let ((output-pathname (let ((output-pathname (pathname-new-type input-pathname "com"))) (if output-string - (merge-pathnames (->pathname output-string) - output-pathname) + (merge-pathnames output-string output-pathname) output-pathname)))) (newline) (write-string "Compile File: ") - (write (pathname->string input-pathname)) + (write (enough-namestring input-pathname)) (write-string " => ") - (write (pathname->string output-pathname)) + (write (enough-namestring output-pathname)) (fasdump (transform input-pathname output-pathname) output-pathname))))) (kernel diff --git a/v7/src/compiler/base/crstop.scm b/v7/src/compiler/base/crstop.scm index 7bdffc00d..1c4b01f9d 100644 --- a/v7/src/compiler/base/crstop.scm +++ b/v7/src/compiler/base/crstop.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crstop.scm,v 1.8 1991/02/14 18:45:55 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crstop.scm,v 1.9 1991/11/04 20:35:26 cph Exp $ -Copyright (c) 1988, 1989, 1990, 1991 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -56,9 +56,7 @@ MIT in each case. |# (if (not (default-object? output-string)) output-string (merge-pathnames output-default - (pathname->input-truename - (merge-pathnames (->pathname input-string) - input-default)))) + (merge-pathnames input-string input-default))) input-default (lambda (input-pathname output-pathname) (maybe-open-file compiler:generate-rtl-files? @@ -109,7 +107,7 @@ MIT in each case. |# (fluid-let ((compiler:compile-by-procedures? false) (*info-output-filename* (if (pathname? info-output-pathname) - (pathname->string info-output-pathname) + (->namestring info-output-pathname) *info-output-filename*)) (*rtl-output-port* rtl-output-port) (*lap-output-port* lap-output-port)) diff --git a/v7/src/compiler/base/make.scm b/v7/src/compiler/base/make.scm index e3a403afc..dccfef089 100644 --- a/v7/src/compiler/base/make.scm +++ b/v7/src/compiler/base/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/make.scm,v 4.88 1991/10/25 00:00:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/make.scm,v 4.89 1991/11/04 20:35:30 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -46,5 +46,5 @@ MIT in each case. |# (initialize-package! '(COMPILER DECLARATIONS))) (add-system! (make-system (string-append "Liar (" architecture-name ")") - 4 88 + 4 89 '()))) \ No newline at end of file diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index 3f3dd73fe..bcc21c297 100644 --- a/v7/src/compiler/base/toplev.scm +++ b/v7/src/compiler/base/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.35 1991/07/25 02:33:41 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.36 1991/11/04 20:35:36 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -81,25 +81,20 @@ MIT in each case. |# (define (compiler-pathnames input-string output-string default transform) (let* ((core (lambda (input-string) - (let ((input-pathname - (pathname->input-truename - (merge-pathnames (->pathname input-string) default)))) - (if (not input-pathname) - (error "File does not exist" input-string)) + (let ((input-pathname (merge-pathnames input-string default))) (let ((output-pathname (let ((output-pathname (pathname-new-type input-pathname "com"))) (if output-string - (merge-pathnames (->pathname output-string) - output-pathname) + (merge-pathnames output-string output-pathname) output-pathname)))) (if compiler:noisy? (begin (newline) (write-string "Compile File: ") - (write (pathname->string input-pathname)) + (write (enough-namestring input-pathname)) (write-string " => ") - (write (pathname->string output-pathname)))) + (write (enough-namestring output-pathname)))) (fasdump (transform input-pathname output-pathname) output-pathname))))) (kernel @@ -534,7 +529,7 @@ MIT in each case. |# (if (default-object? wrapper) in-compiler wrapper))) (fluid-let ((*info-output-filename* (if (pathname? info-output-pathname) - (pathname->string info-output-pathname) + (->namestring info-output-pathname) *info-output-filename*)) (*rtl-output-port* rtl-output-port) (*lap-output-port* lap-output-port) diff --git a/v7/src/compiler/etc/comcmp.scm b/v7/src/compiler/etc/comcmp.scm index c61765a31..612df8974 100644 --- a/v7/src/compiler/etc/comcmp.scm +++ b/v7/src/compiler/etc/comcmp.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/etc/comcmp.scm,v 1.2 1989/09/21 01:55:35 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/etc/comcmp.scm,v 1.3 1991/11/04 20:36:02 cph Exp $ -Copyright (c) 1989 Massachusetts Institute of Technology +Copyright (c) 1989-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -205,7 +205,7 @@ MIT in each case. |# (define (show-differences f1 f2) (define (->name f) - (pathname->string (->pathname f))) + (enough-namestring (merge-pathnames f))) (let ((result (compare-com-files f1 f2))) (if (pair? result) diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index 4dc88173f..3370e62e7 100644 --- a/v7/src/compiler/machines/bobcat/decls.scm +++ b/v7/src/compiler/machines/bobcat/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.29 1991/10/30 20:52:36 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.30 1991/11/04 20:36:20 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -100,7 +100,7 @@ MIT in each case. |# (conc-name source-node/) (constructor make/source-node (filename))) (filename false read-only true) - (pathname (string->pathname filename) read-only true) + (pathname (->pathname filename) read-only true) (forward-links '()) (backward-links '()) (forward-closure '()) @@ -283,14 +283,14 @@ MIT in each case. |# (if (file-exists? pathname) (begin (write-string "\nTouch file: ") - (write (pathname->string pathname)) + (write (enough-namestring pathname)) (file-touch pathname)))) (define (pathname-delete! pathname) (if (file-exists? pathname) (begin (write-string "\nDelete file: ") - (write (pathname->string pathname)) + (write (enough-namestring pathname)) (delete-file pathname)))) (define (sc filename) @@ -579,7 +579,10 @@ MIT in each case. |# (make-pathname false false - (make-list (length (pathname-directory pathname)) 'UP) + (cons 'RELATIVE + (make-list + (length (cdr (pathname-directory pathname))) + 'UP)) false false false))) diff --git a/v7/src/compiler/machines/mips/decls.scm b/v7/src/compiler/machines/mips/decls.scm index 94cbb227f..d8292127d 100644 --- a/v7/src/compiler/machines/mips/decls.scm +++ b/v7/src/compiler/machines/mips/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/decls.scm,v 1.4 1991/10/30 20:56:59 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/decls.scm,v 1.5 1991/11/04 20:36:50 cph Exp $ $MC68020-Header: decls.scm,v 4.27 90/05/03 15:17:08 GMT jinx Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -101,7 +101,7 @@ MIT in each case. |# (conc-name source-node/) (constructor make/source-node (filename))) (filename false read-only true) - (pathname (string->pathname filename) read-only true) + (pathname (->pathname filename) read-only true) (forward-links '()) (backward-links '()) (forward-closure '()) @@ -284,14 +284,14 @@ MIT in each case. |# (if (file-exists? pathname) (begin (write-string "\nTouch file: ") - (write (pathname->string pathname)) + (write (enough-namestring pathname)) (file-touch pathname)))) (define (pathname-delete! pathname) (if (file-exists? pathname) (begin (write-string "\nDelete file: ") - (write (pathname->string pathname)) + (write (enough-namestring pathname)) (delete-file pathname)))) (define (sc filename) @@ -581,7 +581,10 @@ MIT in each case. |# (make-pathname false false - (make-list (length (pathname-directory pathname)) 'UP) + (cons 'RELATIVE + (make-list + (length (cdr (pathname-directory pathname))) + 'UP)) false false false))) diff --git a/v7/src/compiler/machines/spectrum/decls.scm b/v7/src/compiler/machines/spectrum/decls.scm index 45d32f514..d90c6d786 100644 --- a/v7/src/compiler/machines/spectrum/decls.scm +++ b/v7/src/compiler/machines/spectrum/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/decls.scm,v 4.29 1991/10/30 20:51:43 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/decls.scm,v 4.30 1991/11/04 20:37:08 cph Exp $ $MC68020-Header: decls.scm,v 4.27 90/05/03 15:17:08 GMT jinx Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -100,7 +100,7 @@ MIT in each case. |# (conc-name source-node/) (constructor make/source-node (filename))) (filename false read-only true) - (pathname (string->pathname filename) read-only true) + (pathname (->pathname filename) read-only true) (forward-links '()) (backward-links '()) (forward-closure '()) @@ -283,14 +283,14 @@ MIT in each case. |# (if (file-exists? pathname) (begin (write-string "\nTouch file: ") - (write (pathname->string pathname)) + (write (enough-namestring pathname)) (file-touch pathname)))) (define (pathname-delete! pathname) (if (file-exists? pathname) (begin (write-string "\nDelete file: ") - (write (pathname->string pathname)) + (write (enough-namestring pathname)) (delete-file pathname)))) (define (sc filename) @@ -578,7 +578,10 @@ MIT in each case. |# (make-pathname false false - (make-list (length (pathname-directory pathname)) 'UP) + (cons 'RELATIVE + (make-list + (length (cdr (pathname-directory pathname))) + 'UP)) false false false))) diff --git a/v7/src/compiler/machines/vax/decls.scm b/v7/src/compiler/machines/vax/decls.scm index 29e5db4fa..7cdfeb345 100644 --- a/v7/src/compiler/machines/vax/decls.scm +++ b/v7/src/compiler/machines/vax/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/decls.scm,v 4.7 1991/10/30 20:54:22 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/decls.scm,v 4.8 1991/11/04 20:37:25 cph Exp $ $MC68020-Header: decls.scm,v 4.27 90/05/03 15:17:08 GMT jinx Exp $ Copyright (c) 1987-91 Massachusetts Institute of Technology @@ -101,7 +101,7 @@ MIT in each case. |# (conc-name source-node/) (constructor make/source-node (filename))) (filename false read-only true) - (pathname (string->pathname filename) read-only true) + (pathname (->pathname filename) read-only true) (forward-links '()) (backward-links '()) (forward-closure '()) @@ -284,14 +284,14 @@ MIT in each case. |# (if (file-exists? pathname) (begin (write-string "\nTouch file: ") - (write (pathname->string pathname)) + (write (enough-namestring pathname)) (file-touch pathname)))) (define (pathname-delete! pathname) (if (file-exists? pathname) (begin (write-string "\nDelete file: ") - (write (pathname->string pathname)) + (write (enough-namestring pathname)) (delete-file pathname)))) (define (sc filename) @@ -582,7 +582,10 @@ MIT in each case. |# (make-pathname false false - (make-list (length (pathname-directory pathname)) 'UP) + (cons 'RELATIVE + (make-list + (length (cdr (pathname-directory pathname))) + 'UP)) false false false))) diff --git a/v7/src/cref/conpkg.scm b/v7/src/cref/conpkg.scm index 6900085b0..c1f32cdc3 100644 --- a/v7/src/cref/conpkg.scm +++ b/v7/src/cref/conpkg.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/conpkg.scm,v 1.2 1991/09/20 04:04:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/conpkg.scm,v 1.3 1991/11/04 20:33:57 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -144,7 +144,7 @@ MIT in each case. |# (if (null? files) `(FALSE) (map (lambda (file) - `(LOAD ,(pathname->string file) ,environment)) + `(LOAD ,(->namestring file) ,environment)) files)))) (define (package-definition name value) diff --git a/v7/src/cref/forpkg.scm b/v7/src/cref/forpkg.scm index f29180068..7260af8a3 100644 --- a/v7/src/cref/forpkg.scm +++ b/v7/src/cref/forpkg.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/forpkg.scm,v 1.6 1991/05/07 02:02:05 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/forpkg.scm,v 1.7 1991/11/04 20:34:03 cph Exp $ -Copyright (c) 1988-1991 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -176,7 +176,7 @@ MIT in each case. |# (for-each (lambda (pathname) (output-port/write-string port indentation) (output-port/write-char port #\") - (output-port/write-string port (pathname->string pathname)) + (output-port/write-string port (->namestring pathname)) (output-port/write-char port #\") (output-port/write-char port #\newline)) (package/files package))))) diff --git a/v7/src/cref/make.scm b/v7/src/cref/make.scm index bea6b825c..93abb780d 100644 --- a/v7/src/cref/make.scm +++ b/v7/src/cref/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/make.scm,v 1.7 1991/03/01 20:19:47 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/make.scm,v 1.8 1991/11/04 20:34:10 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -37,4 +37,4 @@ MIT in each case. |# (declare (usual-integrations)) (package/system-loader "cref" '() false) -(add-system! (make-system "CREF" 1 7 '())) \ No newline at end of file +(add-system! (make-system "CREF" 1 8 '())) \ No newline at end of file diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm index c121838d0..3c67cdfa4 100644 --- a/v7/src/cref/redpkg.scm +++ b/v7/src/cref/redpkg.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/redpkg.scm,v 1.3 1990/10/05 11:33:16 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/redpkg.scm,v 1.4 1991/11/04 20:34:18 cph Exp $ -Copyright (c) 1988, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -38,7 +38,7 @@ MIT in each case. |# (integrate-external "object")) (define (read-package-model filename) - (let ((model-pathname (pathname->absolute-pathname (->pathname filename)))) + (let ((model-pathname (merge-pathnames filename))) (with-values (lambda () (sort-descriptions @@ -52,7 +52,7 @@ MIT in each case. |# (lambda (pathname) (for-each (let ((expression (make-expression root-package - (pathname->string pathname) + (->namestring pathname) false))) (lambda (name) (bind! root-package name expression))) @@ -138,18 +138,10 @@ MIT in each case. |# (if (pathname=? pathname (analysis-cache/pathname (car caches))) (car caches) (loop (cdr caches)))))) - -(define (pathname=? x y) - (and (equal? (pathname-name x) (pathname-name y)) - (equal? (pathname-directory x) (pathname-directory y)) - (equal? (pathname-type x) (pathname-type y)) - (equal? (pathname-version x) (pathname-version y)) - (equal? (pathname-host x) (pathname-host y)) - (equal? (pathname-device x) (pathname-device y)))) (define (record-file-analysis! pmodel package pathname entries) (for-each - (let ((filename (pathname->string pathname)) + (let ((filename (->namestring pathname)) (root-package (pmodel/root-package pmodel)) (primitive-package (pmodel/primitive-package pmodel))) (lambda (entry) @@ -281,7 +273,7 @@ MIT in each case. |# (cdr file-case)))) (define-integrable (parse-filename filename) - (string->pathname filename)) + (->pathname filename)) (define (parse-initialization initialization) (if (not (and (pair? initialization) (null? (cdr initialization)))) diff --git a/v7/src/cref/toplev.scm b/v7/src/cref/toplev.scm index 24baae047..7bc706f5e 100644 --- a/v7/src/cref/toplev.scm +++ b/v7/src/cref/toplev.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/toplev.scm,v 1.4 1991/03/01 20:19:54 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/toplev.scm,v 1.5 1991/11/04 20:34:26 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -38,14 +38,14 @@ MIT in each case. |# (define (generate/common kernel) (lambda (filename) - (let ((pathname (pathname->absolute-pathname (->pathname filename)))) + (let ((pathname (merge-pathnames filename))) (let ((pmodel (read-package-model pathname))) (read-file-analyses! pmodel) (resolve-references! pmodel) (kernel pathname pmodel))))) (define (cref/generate-trivial-constructor filename) - (let ((pathname (pathname->absolute-pathname (->pathname filename)))) + (let ((pathname (merge-pathnames filename))) (write-constructor pathname (read-package-model pathname)))) (define cref/generate-cref diff --git a/v7/src/sf/butils.scm b/v7/src/sf/butils.scm index 0e238dbd5..79be51492 100644 --- a/v7/src/sf/butils.scm +++ b/v7/src/sf/butils.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/butils.scm,v 4.4 1991/08/22 17:59:32 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/butils.scm,v 4.5 1991/11/04 20:31:36 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,34 +39,30 @@ MIT in each case. |# (define (directory-processor input-type output-type process-file) (let ((directory-read (let ((input-pattern - (make-pathname false false '() 'WILD input-type 'NEWEST))) + (make-pathname false false false 'WILD input-type 'NEWEST))) (lambda (directory) (directory-read - (merge-pathnames (pathname-as-directory - (->pathname directory)) - input-pattern)))))) + (merge-pathnames + (pathname-as-directory (merge-pathnames directory)) + input-pattern)))))) (lambda (input-directory #!optional output-directory force?) (let ((output-directory (if (default-object? output-directory) false output-directory)) (force? (if (default-object? force?) false force?))) - (for-each (let ((output-directory-path - (and output-directory - (->pathname output-directory)))) - (lambda (pathname) - (if (or force? - (not - (compare-file-modification-times - (pathname-default-type pathname input-type) - (let ((output-pathname - (pathname-new-type pathname - output-type))) - (if output-directory-path - (merge-pathnames output-directory-path - output-pathname) - output-pathname))))) - (process-file pathname output-directory)))) + (for-each (lambda (pathname) + (if (or force? + (not (compare-file-modification-times + (pathname-default-type pathname input-type) + (let ((output-pathname + (pathname-new-type pathname + output-type))) + (if output-directory + (merge-pathnames output-directory + output-pathname) + output-pathname))))) + (process-file pathname output-directory))) (if (pair? input-directory) - (mapcan directory-read input-directory) + (append-map! directory-read input-directory) (directory-read input-directory))))))) (define sf-directory @@ -86,7 +82,7 @@ MIT in each case. |# output-directory (newline) (write-string "Process file: ") - (write-string (pathname->string pathname))))) + (write-string (enough-namestring pathname))))) (set! sf-directory? (directory-processor "scm" "bin" show-pathname)) (set! compile-directory? (directory-processor "bin" "com" show-pathname))) @@ -106,14 +102,13 @@ MIT in each case. |# (kernel filename)))) (define (file-processed? filename input-type output-type) - (let ((pathname (->pathname filename))) - (compare-file-modification-times - (pathname-default-type pathname input-type) - (pathname-new-type pathname output-type)))) + (compare-file-modification-times + (pathname-default-type filename input-type) + (pathname-new-type filename output-type))) (define (compare-file-modification-times source target) - (let ((source (file-modification-time source))) + (let ((source (file-modification-time-indirect source))) (and source - (let ((target (file-modification-time target))) + (let ((target (file-modification-time-indirect target))) (and target (<= source target)))))) \ No newline at end of file diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm index 107c8bb8e..4551e3f6e 100644 --- a/v7/src/sf/make.scm +++ b/v7/src/sf/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.21 1991/10/01 21:39:07 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.22 1991/11/04 20:31:40 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -39,4 +39,4 @@ MIT in each case. |# (package/system-loader "sf" '() 'QUERY) ((package/reference (find-package '(SCODE-OPTIMIZER)) 'USUAL-INTEGRATIONS/CACHE!)) -(add-system! (make-system "SF" 4 21 '())) \ No newline at end of file +(add-system! (make-system "SF" 4 22 '())) \ No newline at end of file diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm index 8bdb981de..25ab659d3 100644 --- a/v7/src/sf/toplev.scm +++ b/v7/src/sf/toplev.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 4.7 1990/04/10 15:46:39 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 4.8 1991/11/04 20:31:46 cph Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -34,9 +34,7 @@ MIT in each case. |# ;;;; SCode Optimizer: Top Level -(declare (usual-integrations) - (automagic-integrations) - (open-block-optimizations)) +(declare (usual-integrations)) ;;;; User Interface @@ -111,8 +109,7 @@ Currently only the 68000 implementation needs this." (lambda () sf/default-declarations))) (define (pathname/normalize pathname) - (pathname-default-type (pathname->absolute-pathname (->pathname pathname)) - "scm")) + (pathname-default-type (merge-pathnames pathname) "scm")) (define file-info/syntax-table (pathname-map/make)) @@ -169,37 +166,32 @@ Currently only the 68000 implementation needs this." (list input-string)))) (define (sf/pathname-defaulting input-string bin-string spec-string) - (let ((pathname - (merge-pathnames - (->pathname input-string) - (make-pathname false false '() false "scm" 'NEWEST)))) - (let ((input-path (pathname->input-truename pathname))) - (if (not input-path) - (error "SF: File does not exist" pathname)) - (let ((input-type (pathname-type input-path))) - (let ((bin-path - (let ((bin-path - (pathname-new-type - input-path - (if (equal? "scm" input-type) - "bin" - (string-append "b" input-type))))) - (if bin-string - (merge-pathnames (->pathname bin-string) bin-path) - bin-path)))) - (let ((spec-path - (and (or spec-string sfu?) - (let ((spec-path - (pathname-new-type - bin-path - (if (equal? "scm" input-type) - "unf" - (string-append "u" input-type))))) - (if spec-string - (merge-pathnames (->pathname spec-string) - spec-path) - spec-path))))) - (values input-path bin-path spec-path))))))) + (let ((input-path (pathname/normalize input-string))) + (let ((input-type (pathname-type input-path))) + (let ((bin-path + (let ((bin-path + (pathname-new-type + input-path + (if (and (string? input-type) + (not (string=? "scm" input-type))) + (string-append "b" input-type) + "bin")))) + (if bin-string + (merge-pathnames bin-string bin-path) + bin-path)))) + (let ((spec-path + (and (or spec-string sfu?) + (let ((spec-path + (pathname-new-type + bin-path + (if (and (string? input-type) + (not (string=? "scm" input-type))) + (string-append "u" input-type) + "unf")))) + (if spec-string + (merge-pathnames spec-string spec-path) + spec-path))))) + (values input-path bin-path spec-path)))))) (define (sf/internal input-pathname bin-pathname spec-pathname syntax-table declarations) @@ -210,33 +202,33 @@ Currently only the 68000 implementation needs this." false "ext" 'NEWEST))) - (let ((start-date (get-decoded-time)) - (input-filename (pathname->string input-pathname)) - (bin-filename (pathname->string bin-pathname)) - (spec-filename (and spec-pathname (pathname->string spec-pathname)))) + (let ((start-date (get-decoded-time))) (if sf:noisy? (begin (newline) (write-string "Syntax file: ") - (write input-filename) + (write (enough-namestring input-pathname)) (write-string " ") - (write bin-filename) - (write-string " ") - (write spec-filename))) + (write (enough-namestring bin-pathname)) + (if spec-pathname + (begin + (write-string " ") + (write (enough-namestring spec-pathname)))))) (with-values (lambda () (integrate/file input-pathname syntax-table declarations spec-pathname)) (lambda (expression externs events) (fasdump (wrapping-hook - (make-comment `((SOURCE-FILE . ,input-filename) - (DATE ,(decoded-time/year start-date) - ,(decoded-time/month start-date) - ,(decoded-time/day start-date)) - (TIME ,(decoded-time/hour start-date) - ,(decoded-time/minute start-date) - ,(decoded-time/second start-date))) - (set! expression false))) + (make-comment + `((SOURCE-FILE . ,(->namestring input-pathname)) + (DATE ,(decoded-time/year start-date) + ,(decoded-time/month start-date) + ,(decoded-time/day start-date)) + (TIME ,(decoded-time/hour start-date) + ,(decoded-time/minute start-date) + ,(decoded-time/second start-date))) + (set! expression false))) bin-pathname) (write-externs-file (pathname-new-type bin-pathname @@ -247,7 +239,7 @@ Currently only the 68000 implementation needs this." (begin (newline) (write-string "Writing ") - (write spec-filename))) + (write (enough-namestring spec-pathname)))) (with-output-to-file spec-pathname (lambda () (newline) @@ -258,9 +250,9 @@ Currently only the 68000 implementation needs this." ,(decoded-time/minute start-date) ,(decoded-time/second start-date))) (newline) - (write `(SOURCE-FILE ,input-filename)) + (write `(SOURCE-FILE ,(->namestring input-pathname))) (newline) - (write `(BINARY-FILE ,bin-filename)) + (write `(BINARY-FILE ,(->namestring bin-pathname))) (for-each (lambda (event) (newline) (write `(,(car event) @@ -270,12 +262,12 @@ Currently only the 68000 implementation needs this." (write-string " -- done"))))))))) (define (read-externs-file pathname) - (let ((pathname - (merge-pathnames (->pathname pathname) sf/default-externs-pathname))) + (let ((pathname (merge-pathnames pathname sf/default-externs-pathname))) (if (file-exists? pathname) (fasload pathname) - (begin (warn "Nonexistent externs file" (pathname->string pathname)) - '())))) + (begin + (warn "Nonexistent externs file" (->namestring pathname)) + '())))) (define (write-externs-file pathname externs) (cond ((not (null? externs)) @@ -283,27 +275,6 @@ Currently only the 68000 implementation needs this." ((file-exists? pathname) (delete-file pathname)))) -#| -;; This seems unused - -(define (print-spec identifier names) - (newline) - (newline) - (write-string "(") - (write identifier) - (let loop - ((names - (sort names - (lambda (x y) - (stringstring x) - (symbol->string y)))))) - (if (not (null? names)) - (begin (newline) - (write (car names)) - (loop (cdr names))))) - (write-string ")")) -|# - (define (wrapping-hook scode) scode) diff --git a/v8/src/compiler/etc/comcmp.scm b/v8/src/compiler/etc/comcmp.scm index 105af8855..5e1f68bc1 100644 --- a/v8/src/compiler/etc/comcmp.scm +++ b/v8/src/compiler/etc/comcmp.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/etc/comcmp.scm,v 1.2 1989/09/21 01:55:35 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/etc/comcmp.scm,v 1.3 1991/11/04 20:36:02 cph Exp $ -Copyright (c) 1989 Massachusetts Institute of Technology +Copyright (c) 1989-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -205,7 +205,7 @@ MIT in each case. |# (define (show-differences f1 f2) (define (->name f) - (pathname->string (->pathname f))) + (enough-namestring (merge-pathnames f))) (let ((result (compare-com-files f1 f2))) (if (pair? result) diff --git a/v8/src/sf/make.scm b/v8/src/sf/make.scm index 69498bf0f..539bc980d 100644 --- a/v8/src/sf/make.scm +++ b/v8/src/sf/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.21 1991/10/01 21:39:07 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 4.22 1991/11/04 20:31:40 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -39,4 +39,4 @@ MIT in each case. |# (package/system-loader "sf" '() 'QUERY) ((package/reference (find-package '(SCODE-OPTIMIZER)) 'USUAL-INTEGRATIONS/CACHE!)) -(add-system! (make-system "SF" 4 21 '())) \ No newline at end of file +(add-system! (make-system "SF" 4 22 '())) \ No newline at end of file diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm index e87b3e7ea..014240942 100644 --- a/v8/src/sf/toplev.scm +++ b/v8/src/sf/toplev.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 4.7 1990/04/10 15:46:39 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 4.8 1991/11/04 20:31:46 cph Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -34,9 +34,7 @@ MIT in each case. |# ;;;; SCode Optimizer: Top Level -(declare (usual-integrations) - (automagic-integrations) - (open-block-optimizations)) +(declare (usual-integrations)) ;;;; User Interface @@ -111,8 +109,7 @@ Currently only the 68000 implementation needs this." (lambda () sf/default-declarations))) (define (pathname/normalize pathname) - (pathname-default-type (pathname->absolute-pathname (->pathname pathname)) - "scm")) + (pathname-default-type (merge-pathnames pathname) "scm")) (define file-info/syntax-table (pathname-map/make)) @@ -169,37 +166,32 @@ Currently only the 68000 implementation needs this." (list input-string)))) (define (sf/pathname-defaulting input-string bin-string spec-string) - (let ((pathname - (merge-pathnames - (->pathname input-string) - (make-pathname false false '() false "scm" 'NEWEST)))) - (let ((input-path (pathname->input-truename pathname))) - (if (not input-path) - (error "SF: File does not exist" pathname)) - (let ((input-type (pathname-type input-path))) - (let ((bin-path - (let ((bin-path - (pathname-new-type - input-path - (if (equal? "scm" input-type) - "bin" - (string-append "b" input-type))))) - (if bin-string - (merge-pathnames (->pathname bin-string) bin-path) - bin-path)))) - (let ((spec-path - (and (or spec-string sfu?) - (let ((spec-path - (pathname-new-type - bin-path - (if (equal? "scm" input-type) - "unf" - (string-append "u" input-type))))) - (if spec-string - (merge-pathnames (->pathname spec-string) - spec-path) - spec-path))))) - (values input-path bin-path spec-path))))))) + (let ((input-path (pathname/normalize input-string))) + (let ((input-type (pathname-type input-path))) + (let ((bin-path + (let ((bin-path + (pathname-new-type + input-path + (if (and (string? input-type) + (not (string=? "scm" input-type))) + (string-append "b" input-type) + "bin")))) + (if bin-string + (merge-pathnames bin-string bin-path) + bin-path)))) + (let ((spec-path + (and (or spec-string sfu?) + (let ((spec-path + (pathname-new-type + bin-path + (if (and (string? input-type) + (not (string=? "scm" input-type))) + (string-append "u" input-type) + "unf")))) + (if spec-string + (merge-pathnames spec-string spec-path) + spec-path))))) + (values input-path bin-path spec-path)))))) (define (sf/internal input-pathname bin-pathname spec-pathname syntax-table declarations) @@ -210,33 +202,33 @@ Currently only the 68000 implementation needs this." false "ext" 'NEWEST))) - (let ((start-date (get-decoded-time)) - (input-filename (pathname->string input-pathname)) - (bin-filename (pathname->string bin-pathname)) - (spec-filename (and spec-pathname (pathname->string spec-pathname)))) + (let ((start-date (get-decoded-time))) (if sf:noisy? (begin (newline) (write-string "Syntax file: ") - (write input-filename) + (write (enough-namestring input-pathname)) (write-string " ") - (write bin-filename) - (write-string " ") - (write spec-filename))) + (write (enough-namestring bin-pathname)) + (if spec-pathname + (begin + (write-string " ") + (write (enough-namestring spec-pathname)))))) (with-values (lambda () (integrate/file input-pathname syntax-table declarations spec-pathname)) (lambda (expression externs events) (fasdump (wrapping-hook - (make-comment `((SOURCE-FILE . ,input-filename) - (DATE ,(decoded-time/year start-date) - ,(decoded-time/month start-date) - ,(decoded-time/day start-date)) - (TIME ,(decoded-time/hour start-date) - ,(decoded-time/minute start-date) - ,(decoded-time/second start-date))) - (set! expression false))) + (make-comment + `((SOURCE-FILE . ,(->namestring input-pathname)) + (DATE ,(decoded-time/year start-date) + ,(decoded-time/month start-date) + ,(decoded-time/day start-date)) + (TIME ,(decoded-time/hour start-date) + ,(decoded-time/minute start-date) + ,(decoded-time/second start-date))) + (set! expression false))) bin-pathname) (write-externs-file (pathname-new-type bin-pathname @@ -247,7 +239,7 @@ Currently only the 68000 implementation needs this." (begin (newline) (write-string "Writing ") - (write spec-filename))) + (write (enough-namestring spec-pathname)))) (with-output-to-file spec-pathname (lambda () (newline) @@ -258,9 +250,9 @@ Currently only the 68000 implementation needs this." ,(decoded-time/minute start-date) ,(decoded-time/second start-date))) (newline) - (write `(SOURCE-FILE ,input-filename)) + (write `(SOURCE-FILE ,(->namestring input-pathname))) (newline) - (write `(BINARY-FILE ,bin-filename)) + (write `(BINARY-FILE ,(->namestring bin-pathname))) (for-each (lambda (event) (newline) (write `(,(car event) @@ -270,12 +262,12 @@ Currently only the 68000 implementation needs this." (write-string " -- done"))))))))) (define (read-externs-file pathname) - (let ((pathname - (merge-pathnames (->pathname pathname) sf/default-externs-pathname))) + (let ((pathname (merge-pathnames pathname sf/default-externs-pathname))) (if (file-exists? pathname) (fasload pathname) - (begin (warn "Nonexistent externs file" (pathname->string pathname)) - '())))) + (begin + (warn "Nonexistent externs file" (->namestring pathname)) + '())))) (define (write-externs-file pathname externs) (cond ((not (null? externs)) @@ -283,27 +275,6 @@ Currently only the 68000 implementation needs this." ((file-exists? pathname) (delete-file pathname)))) -#| -;; This seems unused - -(define (print-spec identifier names) - (newline) - (newline) - (write-string "(") - (write identifier) - (let loop - ((names - (sort names - (lambda (x y) - (stringstring x) - (symbol->string y)))))) - (if (not (null? names)) - (begin (newline) - (write (car names)) - (loop (cdr names))))) - (write-string ")")) -|# - (define (wrapping-hook scode) scode) -- 2.25.1