From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 5 Sep 2003 20:51:56 +0000 (+0000)
Subject: Fix definition of FILE-MODIFICATION-TIME<?, and introduce new
X-Git-Tag: 20090517-FFI~1817
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=98aa5c2f521718aba67bf1dbc751fc7025318e1f;p=mit-scheme.git

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 52f59a5b4..bf21f0cda 100644
--- 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 a499d1a5a..d0cc13fa6 100644
--- 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 5f8ab2020..d7ab4898b 100644
--- 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 338ca2296..d1d79d3e2 100644
--- 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)))
 
 (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 fde3eb43c..77aa0cc30 100644
--- 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?)