Implement new method for mapping pathnames to values.

diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm
index 69f9c38f3452dc8c2f4a05cd172446cb193594f2..d5ebe017aede27780538efdd975c26ead5cee197 100644 (file)
--- a/v7/src/sf/toplev.scm
+++ b/v7/src/sf/toplev.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.2 1987/03/19 17:23:08 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.3 1987/05/09 23:22:58 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -38,13 +38,6 @@ MIT in each case. |#
 \f
 ;;;; User Interface
 
-(define generate-unfasl-files? false
-  "Set this non-false to cause unfasl files to be generated by default.")
-
-(define optimize-open-blocks? false
-  "Set this non-false to eliminate unreferenced auxiliary definitions.
-Currently this optimization is not implemented.")
-
 (define (integrate/procedure procedure declarations)
   (if (compound-procedure? procedure)
       (procedure-components procedure
@@ -75,50 +68,42 @@ Currently only the 68000 implementation needs this."
     (syntax-file input-string bin-string spec-string)))
 \f
 (define (sf/set-file-syntax-table! pathname syntax-table)
-  (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
-    (let ((association (find-file-info/assoc pathname)))
-      (if association
-         (set-cdr! association
-                   (transmit-values (cdr association)
-                     (lambda (ignore declarations)
-                       (return-2 syntax-table declarations))))
-         (set! file-info
-               (cons (cons pathname (return-2 syntax-table '()))
-                     file-info))))))
+  (pathname-map/insert! file-info/syntax-table
+                       (pathname/normalize pathname)
+                       syntax-table))
 
 (define (sf/add-file-declarations! pathname declarations)
-  (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
-    (let ((association (find-file-info/assoc pathname)))
-      (if association
-         (set-cdr! association
-                   (transmit-values (cdr association)
-                     (lambda (syntax-table declarations*)
-                       (return-2 syntax-table
-                                 (append! declarations*
-                                          (list-copy declarations))))))
-         (set! file-info
-               (cons (cons pathname (return-2 false declarations))
-                     file-info))))))
-
-(define file-info
-  '())
-
-(define (find-file-info pathname)
-  (let ((association
-        (find-file-info/assoc (pathname->absolute-pathname pathname))))
-    (if association
-       (cdr association)
-       (return-2 false '()))))
-
-(define (find-file-info/assoc pathname)
-  (list-search-positive file-info
-    (lambda (entry)
-      (pathname=? (car entry) pathname))))
-
-(define (pathname=? x y)
-  (and (equal? (pathname-device x) (pathname-device y))
-       (equal? (pathname-directory x) (pathname-directory y))
-       (equal? (pathname-name x) (pathname-name y))))
+  (let ((pathname (pathname/normalize pathname)))
+    (pathname-map/insert! file-info/declarations
+                         pathname
+                         (append! (file-info/get-declarations pathname)
+                                  (list-copy declarations)))))
+
+(define (file-info/find pathname)
+  (let ((pathname (pathname/normalize pathname)))
+    (return-2 (pathname-map/lookup file-info/syntax-table
+                                  pathname
+                                  identity-procedure
+                                  (lambda () false))
+             (file-info/get-declarations pathname))))
+
+(define (file-info/get-declarations pathname)
+  (pathname-map/lookup file-info/declarations
+                      pathname
+                      identity-procedure
+                      (lambda () '())))
+
+(define (pathname/normalize pathname)
+  (pathname-new-version
+   (merge-pathnames (pathname->absolute-pathname (->pathname pathname))
+                   sf/default-input-pathname)
+   false))
+
+(define file-info/syntax-table
+  (pathname-map/make))
+
+(define file-info/declarations
+  (pathname-map/make))
 \f
 ;;;; File Syntaxer
 
@@ -148,7 +133,7 @@ Currently only the 68000 implementation needs this."
                          (merge-pathnames (->pathname bin-string) bin-path)
                          bin-path))))
               (let ((spec-path
-                     (and (or spec-string generate-unfasl-files?)
+                     (and (or spec-string sfu?)
                           (let ((spec-path
                                  (pathname-new-type bin-path
                                                     sf/unfasl-pathname-type)))
@@ -178,7 +163,7 @@ Currently only the 68000 implementation needs this."
     (write-string " ")
     (write spec-filename)
     (transmit-values
-       (transmit-values (find-file-info input-pathname)
+       (transmit-values (file-info/find input-pathname)
          (lambda (syntax-table declarations)
            (integrate/file input-pathname syntax-table declarations
                            spec-pathname)))

diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm
index 145e10271e0cf0e0b72c9d8a30adc34b95740584..0a99c88a6a2e552ff24412b66d243a34f63fb2c3 100644 (file)
--- a/v8/src/sf/toplev.scm
+++ b/v8/src/sf/toplev.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.2 1987/03/19 17:23:08 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.3 1987/05/09 23:22:58 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -38,13 +38,6 @@ MIT in each case. |#
 \f
 ;;;; User Interface
 
-(define generate-unfasl-files? false
-  "Set this non-false to cause unfasl files to be generated by default.")
-
-(define optimize-open-blocks? false
-  "Set this non-false to eliminate unreferenced auxiliary definitions.
-Currently this optimization is not implemented.")
-
 (define (integrate/procedure procedure declarations)
   (if (compound-procedure? procedure)
       (procedure-components procedure
@@ -75,50 +68,42 @@ Currently only the 68000 implementation needs this."
     (syntax-file input-string bin-string spec-string)))
 \f
 (define (sf/set-file-syntax-table! pathname syntax-table)
-  (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
-    (let ((association (find-file-info/assoc pathname)))
-      (if association
-         (set-cdr! association
-                   (transmit-values (cdr association)
-                     (lambda (ignore declarations)
-                       (return-2 syntax-table declarations))))
-         (set! file-info
-               (cons (cons pathname (return-2 syntax-table '()))
-                     file-info))))))
+  (pathname-map/insert! file-info/syntax-table
+                       (pathname/normalize pathname)
+                       syntax-table))
 
 (define (sf/add-file-declarations! pathname declarations)
-  (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
-    (let ((association (find-file-info/assoc pathname)))
-      (if association
-         (set-cdr! association
-                   (transmit-values (cdr association)
-                     (lambda (syntax-table declarations*)
-                       (return-2 syntax-table
-                                 (append! declarations*
-                                          (list-copy declarations))))))
-         (set! file-info
-               (cons (cons pathname (return-2 false declarations))
-                     file-info))))))
-
-(define file-info
-  '())
-
-(define (find-file-info pathname)
-  (let ((association
-        (find-file-info/assoc (pathname->absolute-pathname pathname))))
-    (if association
-       (cdr association)
-       (return-2 false '()))))
-
-(define (find-file-info/assoc pathname)
-  (list-search-positive file-info
-    (lambda (entry)
-      (pathname=? (car entry) pathname))))
-
-(define (pathname=? x y)
-  (and (equal? (pathname-device x) (pathname-device y))
-       (equal? (pathname-directory x) (pathname-directory y))
-       (equal? (pathname-name x) (pathname-name y))))
+  (let ((pathname (pathname/normalize pathname)))
+    (pathname-map/insert! file-info/declarations
+                         pathname
+                         (append! (file-info/get-declarations pathname)
+                                  (list-copy declarations)))))
+
+(define (file-info/find pathname)
+  (let ((pathname (pathname/normalize pathname)))
+    (return-2 (pathname-map/lookup file-info/syntax-table
+                                  pathname
+                                  identity-procedure
+                                  (lambda () false))
+             (file-info/get-declarations pathname))))
+
+(define (file-info/get-declarations pathname)
+  (pathname-map/lookup file-info/declarations
+                      pathname
+                      identity-procedure
+                      (lambda () '())))
+
+(define (pathname/normalize pathname)
+  (pathname-new-version
+   (merge-pathnames (pathname->absolute-pathname (->pathname pathname))
+                   sf/default-input-pathname)
+   false))
+
+(define file-info/syntax-table
+  (pathname-map/make))
+
+(define file-info/declarations
+  (pathname-map/make))
 \f
 ;;;; File Syntaxer
 
@@ -148,7 +133,7 @@ Currently only the 68000 implementation needs this."
                          (merge-pathnames (->pathname bin-string) bin-path)
                          bin-path))))
               (let ((spec-path
-                     (and (or spec-string generate-unfasl-files?)
+                     (and (or spec-string sfu?)
                           (let ((spec-path
                                  (pathname-new-type bin-path
                                                     sf/unfasl-pathname-type)))
@@ -178,7 +163,7 @@ Currently only the 68000 implementation needs this."
     (write-string " ")
     (write spec-filename)
     (transmit-values
-       (transmit-values (find-file-info input-pathname)
+       (transmit-values (file-info/find input-pathname)
          (lambda (syntax-table declarations)
            (integrate/file input-pathname syntax-table declarations
                            spec-pathname)))