From: Chris Hanson Date: Tue, 23 Apr 1996 21:19:40 +0000 (+0000) Subject: Change CREF program so that it does not rewrite files unless the files X-Git-Tag: 20090517-FFI~5599 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=55b03394d9e491756bb8b756065edfd4dd44ba92;p=mit-scheme.git Change CREF program so that it does not rewrite files unless the files they were derived from have changed. --- diff --git a/v7/src/cref/make.scm b/v7/src/cref/make.scm index cf69a19a2..9e66ed5be 100644 --- a/v7/src/cref/make.scm +++ b/v7/src/cref/make.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: make.scm,v 1.14 1995/01/10 20:38:15 cph Exp $ +$Id: make.scm,v 1.15 1996/04/23 21:17:01 cph Exp $ -Copyright (c) 1988-95 Massachusetts Institute of Technology +Copyright (c) 1988-96 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -46,4 +46,4 @@ MIT in each case. |# (lambda () (load-option 'RB-TREE) (package/system-loader "cref" '() false))))) -(add-system! (make-system "CREF" 1 14 '())) \ No newline at end of file +(add-system! (make-system "CREF" 1 15 '())) \ No newline at end of file diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm index f26116751..258aa7812 100644 --- a/v7/src/cref/redpkg.scm +++ b/v7/src/cref/redpkg.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: redpkg.scm,v 1.8 1995/01/10 20:38:00 cph Exp $ +$Id: redpkg.scm,v 1.9 1996/04/23 21:16:54 cph Exp $ -Copyright (c) 1988-95 Massachusetts Institute of Technology +Copyright (c) 1988-96 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -97,12 +97,15 @@ MIT in each case. |# globals))) (define (read-file-analyses! pmodel) - (for-each (lambda (p&c) - (record-file-analysis! pmodel - (car p&c) - (analysis-cache/pathname (cdr p&c)) - (analysis-cache/data (cdr p&c)))) - (cache-file-analyses! pmodel))) + (call-with-values (lambda () (cache-file-analyses! pmodel)) + (lambda (analyses changes?) + (for-each (lambda (p&c) + (record-file-analysis! pmodel + (car p&c) + (analysis-cache/pathname (cdr p&c)) + (analysis-cache/data (cdr p&c)))) + analyses) + changes?))) (define-structure (analysis-cache (type vector) @@ -113,7 +116,8 @@ MIT in each case. |# (data false)) (define (cache-file-analyses! pmodel) - (let ((pathname (pathname-new-type (pmodel/pathname pmodel) "fre"))) + (let ((pathname (pathname-new-type (pmodel/pathname pmodel) "fre")) + (changes? (list #f))) (let ((result (let ((caches (if (file-exists? pathname) (fasload pathname) '()))) (append-map! (lambda (package) @@ -121,13 +125,15 @@ MIT in each case. |# (cons package (cache-file-analysis! pmodel caches - pathname))) + pathname + changes?))) (package/files package))) (pmodel/packages pmodel))))) - (fasdump (map cdr result) pathname) - result))) + (if (car changes?) + (fasdump (map cdr result) pathname)) + (values result (car changes?))))) -(define (cache-file-analysis! pmodel caches pathname) +(define (cache-file-analysis! pmodel caches pathname changes?) (let ((cache (analysis-cache/lookup caches pathname)) (full-pathname (merge-pathnames (pathname-new-type pathname "bin") @@ -140,9 +146,14 @@ MIT in each case. |# (if (> time (analysis-cache/time cache)) (begin (set-analysis-cache/data! cache (analyze-file full-pathname)) - (set-analysis-cache/time! cache time))) + (set-analysis-cache/time! cache time) + (set-car! changes? #t))) cache) - (make-analysis-cache pathname time (analyze-file full-pathname)))))) + (begin + (set-car! changes? #t) + (make-analysis-cache pathname + time + (analyze-file full-pathname))))))) (define (analysis-cache/lookup caches pathname) (let loop ((caches caches)) diff --git a/v7/src/cref/toplev.scm b/v7/src/cref/toplev.scm index 7a42ea0cd..52ebcce95 100644 --- a/v7/src/cref/toplev.scm +++ b/v7/src/cref/toplev.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: toplev.scm,v 1.9 1995/07/12 14:22:40 adams Exp $ +$Id: toplev.scm,v 1.10 1996/04/23 21:16:46 cph Exp $ -Copyright (c) 1988-95 Massachusetts Institute of Technology +Copyright (c) 1988-96 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -40,82 +40,114 @@ MIT in each case. |# (lambda (filename) (let ((pathname (merge-pathnames filename))) (let ((pmodel (read-package-model pathname))) - (read-file-analyses! pmodel) - (resolve-references! pmodel) - (kernel pathname pmodel))))) + (let ((changes? (read-file-analyses! pmodel))) + (resolve-references! pmodel) + (kernel pathname pmodel changes?)))))) (define (cref/generate-trivial-constructor filename) (let ((pathname (merge-pathnames filename))) - (write-constructor pathname (read-package-model pathname)))) + (write-constructor pathname (read-package-model pathname) #f))) (define cref/generate-cref (generate/common - (lambda (pathname pmodel) - (write-cref pathname pmodel)))) + (lambda (pathname pmodel changes?) + (write-cref pathname pmodel changes?)))) (define cref/generate-cref-unusual (generate/common - (lambda (pathname pmodel) - (write-cref-unusual pathname pmodel)))) + (lambda (pathname pmodel changes?) + (write-cref-unusual pathname pmodel changes?)))) (define cref/generate-constructors (generate/common - (lambda (pathname pmodel) - (write-cref-unusual pathname pmodel) - (write-globals pathname pmodel) - (write-constructor pathname pmodel) - (write-loader pathname pmodel)))) + (lambda (pathname pmodel changes?) + (write-cref-unusual pathname pmodel changes?) + (write-globals pathname pmodel changes?) + (write-constructor pathname pmodel changes?) + (write-loader pathname pmodel changes?)))) (define cref/generate-all (generate/common - (lambda (pathname pmodel) - (write-cref pathname pmodel) - (write-globals pathname pmodel) - (write-constructor pathname pmodel) - (write-loader pathname pmodel)))) - -(define (write-constructor pathname pmodel) - (let ((constructor (construct-constructor pmodel))) - (with-output-to-file (pathname-new-type pathname "con") - (lambda () - (fluid-let ((*unparser-list-breadth-limit* #F) - (*unparser-list-depth-limit* #F)) - (write-string ";;; -*-Scheme-*-") - (newline) - (write-string ";;; program to make package structure") - (for-each (lambda (expression) - (pp expression (current-output-port) true)) - constructor)))))) - -(define (write-loader pathname pmodel) - (let ((loader (construct-loader pmodel))) - (with-output-to-file (pathname-new-type pathname "ldr") - (lambda () - (fluid-let ((*unparser-list-breadth-limit* #F) - (*unparser-list-depth-limit* #F)) - (write-string ";;; -*-Scheme-*-") - (newline) - (write-string ";;; program to load package contents") - (for-each (lambda (expression) - (pp expression (current-output-port) true)) - loader)))))) - -(define (write-cref pathname pmodel) - (with-output-to-file (pathname-new-type pathname "crf") - (lambda () - (format-packages pmodel)))) - -(define (write-cref-unusual pathname pmodel) - (with-output-to-file (pathname-new-type pathname "crf") - (lambda () - (format-packages-unusual pmodel)))) - -(define (write-globals pathname pmodel) - (fasdump (map (lambda (package) - (cons (package/name package) - (map binding/name - (list-transform-positive - (package/sorted-bindings package) - binding/source-binding)))) - (pmodel/packages pmodel)) - (pathname-new-type pathname "glo"))) \ No newline at end of file + (lambda (pathname pmodel changes?) + (write-cref pathname pmodel changes?) + (write-globals pathname pmodel changes?) + (write-constructor pathname pmodel changes?) + (write-loader pathname pmodel changes?)))) + +(define (write-constructor pathname pmodel changes?) + (if (or changes? (not (file-processed? pathname "pkg" "con"))) + (let ((constructor (construct-constructor pmodel))) + (with-output-to-file (pathname-new-type pathname "con") + (lambda () + (fluid-let ((*unparser-list-breadth-limit* #F) + (*unparser-list-depth-limit* #F)) + (write-string ";;; -*-Scheme-*-") + (newline) + (write-string ";;; program to make package structure") + (for-each (lambda (expression) + (pp expression (current-output-port) true)) + constructor))))))) + +(define (write-loader pathname pmodel changes?) + changes? + (if (not (file-processed? pathname "pkg" "ldr")) + (let ((loader (construct-loader pmodel))) + (with-output-to-file (pathname-new-type pathname "ldr") + (lambda () + (fluid-let ((*unparser-list-breadth-limit* #F) + (*unparser-list-depth-limit* #F)) + (write-string ";;; -*-Scheme-*-") + (newline) + (write-string ";;; program to load package contents") + (for-each (lambda (expression) + (pp expression (current-output-port) true)) + loader))))))) + +(define (write-cref pathname pmodel changes?) + (if (or changes? (not (file-processed? pathname "pkg" "crf"))) + (with-output-to-file (pathname-new-type pathname "crf") + (lambda () + (format-packages pmodel))))) + +(define (write-cref-unusual pathname pmodel changes?) + (if (or changes? (not (file-processed? pathname "pkg" "crf"))) + (with-output-to-file (pathname-new-type pathname "crf") + (lambda () + (format-packages-unusual pmodel))))) + +(define (write-globals pathname pmodel changes?) + (if (or changes? (not (file-processed? pathname "pkg" "glo"))) + (let ((package-bindings + (map (lambda (package) + (cons package + (list-transform-positive + (package/sorted-bindings package) + binding/source-binding))) + (pmodel/packages pmodel))) + (exports '())) + (for-each (lambda (entry) + (for-each (lambda (binding) + (for-each (lambda (link) + (set! exports + (cons (link/destination link) + exports)) + unspecific) + (binding/links binding))) + (cdr entry))) + package-bindings) + (for-each (lambda (binding) + (let ((package (binding/package binding))) + (let ((entry (assq package package-bindings))) + (if entry + (set-cdr! entry (cons binding (cdr entry))) + (begin + (set! package-bindings + (cons (list package binding) + package-bindings)) + unspecific))))) + exports) + (fasdump (map (lambda (entry) + (cons (package/name (car entry)) + (map binding/name (cdr entry)))) + package-bindings) + (pathname-new-type pathname "glo"))))) \ No newline at end of file diff --git a/v7/src/edwin/edwin.sf b/v7/src/edwin/edwin.sf index 16b459f67..9a3eac914 100644 --- a/v7/src/edwin/edwin.sf +++ b/v7/src/edwin/edwin.sf @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: edwin.sf,v 1.18 1996/04/23 21:09:51 cph Exp $ +;;; $Id: edwin.sf,v 1.19 1996/04/23 21:19:40 cph Exp $ ;;; ;;; Copyright (c) 1991-96 Massachusetts Institute of Technology ;;; @@ -103,10 +103,10 @@ (let ((generate (in-package (->environment '(CROSS-REFERENCE)) (generate/common - (lambda (pathname pmodel) - (write-cref-unusual pathname pmodel) - (write-globals pathname pmodel) - (write-constructor pathname pmodel)))))) + (lambda (pathname pmodel changes?) + (write-cref-unusual pathname pmodel changes?) + (write-globals pathname pmodel changes?) + (write-constructor pathname pmodel changes?)))))) (generate package-name) (sf-conditionally (pathname-new-type package-name "con")) (if (and (file-exists? (pathname-new-type package-name "avd"))