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 cf69a19a2c25a94e093883d2c3454cc06b5e76f7..9e66ed5becfcdd9f61936c97beb273b166cc8125 100644 (file)
--- 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 f261167519be42fe026229506f490482aedb7af2..258aa7812316a5c324efd51bc1925f210a26b530 100644 (file)
--- 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)))
 \f
 (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 7a42ea0cd6863b78308326fc02475b2dcaaec7bf..52ebcce952695c5cedad05cd8b7c40fd74a34422 100644 (file)
--- 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?))))
+\f
+(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 16b459f6713daaa18c60eb663337d30c47cd023f..9a3eac9140849ef1cb7a8546a298d2979c688e4c 100644 (file)
--- 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"))