From: Chris Hanson Date: Sat, 9 May 1987 23:22:58 +0000 (+0000) Subject: Implement new method for mapping pathnames to values. X-Git-Tag: 20090517-FFI~13526 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=96e51eb103335ab9300ef547302476de69f6de6d;p=mit-scheme.git Implement new method for mapping pathnames to values. --- diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm index 69f9c38f3..d5ebe017a 100644 --- 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. |# ;;;; 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))) (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)) ;;;; 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 145e10271..0a99c88a6 100644 --- 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. |# ;;;; 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))) (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)) ;;;; 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)))