Fix definition of FILE-MODIFICATION-TIME<?, and introduce new

procedure FILE-MODIFICATION-TIME<=?.

diff --git a/v7/src/cref/toplev.scm b/v7/src/cref/toplev.scm
index 52f59a5b4e94ef09a091ee0c0212fda5cbb54b44..bf21f0cda40971d034366fe3715298abc2c5ecb5 100644 (file)
--- a/v7/src/cref/toplev.scm
+++ b/v7/src/cref/toplev.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: toplev.scm,v 1.20 2003/02/14 18:28:10 cph Exp $
+$Id: toplev.scm,v 1.21 2003/09/05 20:51:44 cph Exp $
 
-Copyright (c) 1988-2002 Massachusetts Institute of Technology
+Copyright 1988,1989,1991,1993,1995,1996 Massachusetts Institute of Technology
+Copyright 1998,2000,2001,2002,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -76,18 +77,16 @@ USA.
 (define (write-external-descriptions pathname pmodel changes? os-type)
   (let ((package-set (package-set-pathname pathname os-type)))
     (if (or changes?
-           (not (file-modification-time<?
-                 (pathname-default-type pathname "pkg")
-                 package-set)))
+           (file-modification-time<? package-set
+                                     (pathname-default-type pathname "pkg")))
        (fasdump (construct-external-descriptions pmodel) package-set))))
 
 (define (write-cref pathname pmodel changes? os-type)
   (let ((cref-pathname
         (pathname-new-type (package-set-pathname pathname os-type) "crf")))
     (if (or changes?
-           (not (file-modification-time<?
-                 (pathname-default-type pathname "pkg")
-                 cref-pathname)))
+           (file-modification-time<? cref-pathname
+                                     (pathname-default-type pathname "pkg")))
        (with-output-to-file cref-pathname
          (lambda ()
            (format-packages pmodel))))))
@@ -96,9 +95,8 @@ USA.
   (let ((cref-pathname
         (pathname-new-type (package-set-pathname pathname os-type) "crf")))
     (if (or changes?
-           (not (file-modification-time<?
-                 (pathname-default-type pathname "pkg")
-                 cref-pathname)))
+           (file-modification-time<? cref-pathname
+                                     (pathname-default-type pathname "pkg")))
        (with-output-to-file cref-pathname
          (lambda ()
            (format-packages-unusual pmodel))))))
\ No newline at end of file

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index a499d1a5aa320a572e80c07bf2ebf33621ebe807..d0cc13fa668b013f404a4bcb925b3e724eb47f5d 100644 (file)
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 14.65 2003/02/14 18:28:33 cph Exp $
+$Id: load.scm,v 14.66 2003/09/05 20:51:14 cph Exp $
 
-Copyright (c) 1988-2002 Massachusetts Institute of Technology
+Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
+Copyright 1994,1999,2000,2001,2002,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -242,12 +243,17 @@ USA.
                                (lambda (exp&value) exp&value #f)))))))))
 
 (define (fasload/internal pathname suppress-loading-message?)
-  (let ((value
-        (loading-message suppress-loading-message? pathname
-          (lambda ()
-            ((ucode-primitive binary-fasload) (->namestring pathname))))))
-    (fasload/update-debugging-info! value pathname)
-    value))
+  (let ((namestring (->namestring pathname)))
+    (if (and (not suppress-loading-message?)
+            (file-modification-time<? pathname
+                                      (pathname-new-type pathname "scm")))
+       (warn "Source file newer than binary:" namestring))
+    (let ((value
+          (loading-message suppress-loading-message? pathname
+            (lambda ()
+              ((ucode-primitive binary-fasload) namestring)))))
+      (fasload/update-debugging-info! value pathname)
+      value)))
 
 (define (load-object-file pathname environment purify? load-noisily?)
   load-noisily?                ; ignored

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 5f8ab2020e9ae5b2f269e53411b2f69fec85f5ff..d7ab4898bed738a88455960225e9b6d9a9be4efa 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.454 2003/07/30 17:25:47 cph Exp $
+$Id: runtime.pkg,v 14.455 2003/09/05 20:51:01 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -426,6 +426,7 @@ USA.
          file-exists-direct?
          file-exists-indirect?
          file-exists?
+         file-modification-time<=?
          file-modification-time<?
          file-processed?
          file-readable?

diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm
index 338ca2296aba3655d76640c217abfbefeaff164f..d1d79d3e2a040cf1f0673b6ac3ef8b36f9c40ec7 100644 (file)
--- a/v7/src/runtime/sfile.scm
+++ b/v7/src/runtime/sfile.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: sfile.scm,v 14.34 2003/02/14 18:28:33 cph Exp $
+$Id: sfile.scm,v 14.35 2003/09/05 20:51:22 cph Exp $
 
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
+Copyright 1999,2001,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -168,16 +169,16 @@ USA.
              result))))))
 
 (define (file-processed? filename input-type output-type)
-  (file-modification-time<?
-   (pathname-default-type filename input-type)
-   (pathname-new-type filename output-type)))
-
-(define (file-modification-time<? source target)
-  (let ((source (file-modification-time-indirect source)))
-    (and source
-        (let ((target (file-modification-time-indirect target)))
-          (and target
-               (<= source target))))))
+  (file-modification-time<=? (pathname-default-type filename input-type)
+                            (pathname-new-type filename output-type)))
+
+(define (file-modification-time<? p1 p2)
+  (< (or (file-modification-time p1) -1)
+     (or (file-modification-time p2) -1)))
+
+(define (file-modification-time<=? p1 p2)
+  (<= (or (file-modification-time p1) -1)
+      (or (file-modification-time p2) -1)))
 \f
 (define (call-with-temporary-filename receiver)
   (call-with-temporary-file-pathname

diff --git a/v7/src/sf/butils.scm b/v7/src/sf/butils.scm
index fde3eb43c6f940391fd9a3eaa051cd5c29d91ba1..77aa0cc304ae9d79e74b82ae789500168dcf9dee 100644 (file)
--- a/v7/src/sf/butils.scm
+++ b/v7/src/sf/butils.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: butils.scm,v 4.13 2003/02/14 18:28:34 cph Exp $
+$Id: butils.scm,v 4.14 2003/09/05 20:51:56 cph Exp $
 
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright 1988,1989,1991,1992,1993,1996 Massachusetts Institute of Technology
+Copyright 2001,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -43,7 +44,7 @@ USA.
            (output-type (output-type)))
        (for-each (lambda (pathname)
                    (if (or force?
-                           (not (file-modification-time<?
+                           (not (file-modification-time<=?
                                  (pathname-default-type pathname input-type)
                                  (let ((output-pathname
                                         (pathname-new-type pathname
@@ -95,7 +96,7 @@ USA.
               (lambda () (sf/pathname-defaulting filename #f #f))
             (lambda (input output spec)
               spec
-              (cond ((not (file-modification-time<? input output))
+              (cond ((not (file-modification-time<=? input output))
                      (sf filename))
                     ((and (not (default-object? echo-up-to-date?))
                           echo-up-to-date?)