Add CPH's changes to check the date/time of the last compilation, and

avoid if unnecessary.

diff --git a/v7/src/compiler/etc/xcbfdir.scm b/v7/src/compiler/etc/xcbfdir.scm
index 8f40099694c07dd760643a75379dd1528911658d..eec678e81a8c06f0f79aa1a2577480919cd8cea8 100644 (file)
--- a/v7/src/compiler/etc/xcbfdir.scm
+++ b/v7/src/compiler/etc/xcbfdir.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/etc/xcbfdir.scm,v 1.2 1990/04/04 19:47:29 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/etc/xcbfdir.scm,v 1.3 1990/10/10 02:03:40 jinx Rel $
 
 Copyright (c) 1989, 1990 Massachusetts Institute of Technology
 
@@ -36,35 +36,45 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 \f
-(define (process-directory dir processor extension)
+(define (process-directory directory processor extension)
   (for-each
    (lambda (pathname)
      (let ((one (pathname-new-type pathname extension))
           (two (pathname-new-type pathname "touch")))
-       ;; file-touch returns #T if the file did not exist,
-       ;; it returns #F if it did.
-       (and (file-touch two)
-           (if (file-exists? one)
-               (delete-file two)
-               (call-with-current-continuation
-                (lambda (here)
-                  (dynamic-wind
-                   (lambda () false)
-                   (lambda ()
-                     (bind-condition-handler
-                      '()
-                      (lambda (condition)
-                        (newline)
-                        (display ";; *** Aborting ***")
-                        (newline)
-                        (condition/write-report condition)
-                        (newline)
-                        (here 'next))
-                      (lambda ()
-                        (processor pathname))))
-                   (lambda ()
-                     (delete-file two)))))))))
-   (directory-read (string-append dir "/*.bin"))))
+       (call-with-current-continuation
+       (lambda (here)
+         (bind-condition-handler
+          '()
+          (lambda (condition)
+            (newline)
+            (display ";; *** Aborting ")
+            (display pathname)
+            (display " ***")
+            (newline)
+            (condition/write-report condition)
+            (newline)
+            (here 'next))
+          (lambda ()
+            (let ((touch-created-file?))
+              (dynamic-wind
+               (lambda ()
+                 ;; file-touch returns #T if the file did not exist,
+                 ;; it returns #F if it did.
+                 (set! touch-created-file?
+                       (file-touch two)))
+               (lambda ()
+                 (if (and touch-created-file?
+                          (let ((one-time (file-modification-time one)))
+                            (or (not one-time)
+                                (< one-time
+                                   (file-modification-time pathname)))))
+                     (processor pathname)))
+               (lambda ()
+                 (if touch-created-file?
+                     (delete-file two)))))))))))
+   (directory-read
+    (merge-pathnames (pathname-as-directory (->pathname directory))
+                    (->pathname "*.bin")))))
 
 (define (recompile-directory dir)
   (process-directory dir compile-bin-file "com"))

diff --git a/v8/src/compiler/etc/xcbfdir.scm b/v8/src/compiler/etc/xcbfdir.scm
index 2ccbd41b721a81baf0807791cc688e49eb370638..e1ad0a21510ed03f1f7147244ce4f18167f98bb3 100644 (file)
--- a/v8/src/compiler/etc/xcbfdir.scm
+++ b/v8/src/compiler/etc/xcbfdir.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/etc/xcbfdir.scm,v 1.2 1990/04/04 19:47:29 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/etc/xcbfdir.scm,v 1.3 1990/10/10 02:03:40 jinx Rel $
 
 Copyright (c) 1989, 1990 Massachusetts Institute of Technology
 
@@ -36,35 +36,45 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 \f
-(define (process-directory dir processor extension)
+(define (process-directory directory processor extension)
   (for-each
    (lambda (pathname)
      (let ((one (pathname-new-type pathname extension))
           (two (pathname-new-type pathname "touch")))
-       ;; file-touch returns #T if the file did not exist,
-       ;; it returns #F if it did.
-       (and (file-touch two)
-           (if (file-exists? one)
-               (delete-file two)
-               (call-with-current-continuation
-                (lambda (here)
-                  (dynamic-wind
-                   (lambda () false)
-                   (lambda ()
-                     (bind-condition-handler
-                      '()
-                      (lambda (condition)
-                        (newline)
-                        (display ";; *** Aborting ***")
-                        (newline)
-                        (condition/write-report condition)
-                        (newline)
-                        (here 'next))
-                      (lambda ()
-                        (processor pathname))))
-                   (lambda ()
-                     (delete-file two)))))))))
-   (directory-read (string-append dir "/*.bin"))))
+       (call-with-current-continuation
+       (lambda (here)
+         (bind-condition-handler
+          '()
+          (lambda (condition)
+            (newline)
+            (display ";; *** Aborting ")
+            (display pathname)
+            (display " ***")
+            (newline)
+            (condition/write-report condition)
+            (newline)
+            (here 'next))
+          (lambda ()
+            (let ((touch-created-file?))
+              (dynamic-wind
+               (lambda ()
+                 ;; file-touch returns #T if the file did not exist,
+                 ;; it returns #F if it did.
+                 (set! touch-created-file?
+                       (file-touch two)))
+               (lambda ()
+                 (if (and touch-created-file?
+                          (let ((one-time (file-modification-time one)))
+                            (or (not one-time)
+                                (< one-time
+                                   (file-modification-time pathname)))))
+                     (processor pathname)))
+               (lambda ()
+                 (if touch-created-file?
+                     (delete-file two)))))))))))
+   (directory-read
+    (merge-pathnames (pathname-as-directory (->pathname directory))
+                    (->pathname "*.bin")))))
 
 (define (recompile-directory dir)
   (process-directory dir compile-bin-file "com"))