#| -*-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
(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
#| -*-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
(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?
(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))
#| -*-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
(initialize-package! '(COMPILER DECLARATIONS)))
(add-system!
(make-system (string-append "Liar (" architecture-name ")")
- 4 88
+ 4 89
'())))
\ No newline at end of file
#| -*-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
(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
(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)
#| -*-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
(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)
#| -*-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
(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 '())
(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)
(make-pathname
false
false
- (make-list (length (pathname-directory pathname)) 'UP)
+ (cons 'RELATIVE
+ (make-list
+ (length (cdr (pathname-directory pathname)))
+ 'UP))
false
false
false)))
#| -*-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
(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 '())
(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)
(make-pathname
false
false
- (make-list (length (pathname-directory pathname)) 'UP)
+ (cons 'RELATIVE
+ (make-list
+ (length (cdr (pathname-directory pathname)))
+ 'UP))
false
false
false)))
#| -*-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
(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 '())
(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)
(make-pathname
false
false
- (make-list (length (pathname-directory pathname)) 'UP)
+ (cons 'RELATIVE
+ (make-list
+ (length (cdr (pathname-directory pathname)))
+ 'UP))
false
false
false)))
#| -*-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
(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 '())
(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)
(make-pathname
false
false
- (make-list (length (pathname-directory pathname)) 'UP)
+ (cons 'RELATIVE
+ (make-list
+ (length (cdr (pathname-directory pathname)))
+ 'UP))
false
false
false)))
#| -*-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
(if (null? files)
`(FALSE)
(map (lambda (file)
- `(LOAD ,(pathname->string file) ,environment))
+ `(LOAD ,(->namestring file) ,environment))
files))))
(define (package-definition name value)
#| -*-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
(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)))))
#| -*-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
(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
#| -*-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
(integrate-external "object"))
\f
(define (read-package-model filename)
- (let ((model-pathname (pathname->absolute-pathname (->pathname filename))))
+ (let ((model-pathname (merge-pathnames filename)))
(with-values
(lambda ()
(sort-descriptions
(lambda (pathname)
(for-each (let ((expression
(make-expression root-package
- (pathname->string pathname)
+ (->namestring pathname)
false)))
(lambda (name)
(bind! root-package name expression)))
(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))))
\f
(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)
(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))))
#| -*-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
\f
(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
#| -*-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
(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
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)))
\f
(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
#| -*-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
(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
#| -*-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
;;;; SCode Optimizer: Top Level
-(declare (usual-integrations)
- (automagic-integrations)
- (open-block-optimizations))
+(declare (usual-integrations))
\f
;;;; User Interface
(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))
(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))))))
\f
(define (sf/internal input-pathname bin-pathname spec-pathname
syntax-table declarations)
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
(begin
(newline)
(write-string "Writing ")
- (write spec-filename)))
+ (write (enough-namestring spec-pathname))))
(with-output-to-file spec-pathname
(lambda ()
(newline)
,(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)
(write-string " -- done")))))))))
\f
(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))
((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)
- (string<? (symbol->string x)
- (symbol->string y))))))
- (if (not (null? names))
- (begin (newline)
- (write (car names))
- (loop (cdr names)))))
- (write-string ")"))
-|#
-
(define (wrapping-hook scode)
scode)
#| -*-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
(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)
#| -*-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
(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
#| -*-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
;;;; SCode Optimizer: Top Level
-(declare (usual-integrations)
- (automagic-integrations)
- (open-block-optimizations))
+(declare (usual-integrations))
\f
;;;; User Interface
(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))
(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))))))
\f
(define (sf/internal input-pathname bin-pathname spec-pathname
syntax-table declarations)
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
(begin
(newline)
(write-string "Writing ")
- (write spec-filename)))
+ (write (enough-namestring spec-pathname))))
(with-output-to-file spec-pathname
(lambda ()
(newline)
,(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)
(write-string " -- done")))))))))
\f
(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))
((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)
- (string<? (symbol->string x)
- (symbol->string y))))))
- (if (not (null? names))
- (begin (newline)
- (write (car names))
- (loop (cdr names)))))
- (write-string ")"))
-|#
-
(define (wrapping-hook scode)
scode)
projects / mit-scheme.git / commitdiff