From 55b03394d9e491756bb8b756065edfd4dd44ba92 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 23 Apr 1996 21:19:40 +0000
Subject: [PATCH] Change CREF program so that it does not rewrite files unless
the files they were derived from have changed.
---
v7/src/cref/make.scm | 6 +-
v7/src/cref/redpkg.scm | 41 +++++++----
v7/src/cref/toplev.scm | 164 ++++++++++++++++++++++++-----------------
v7/src/edwin/edwin.sf | 10 +--
4 files changed, 132 insertions(+), 89 deletions(-)
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"))
--
2.25.1