From ecef7b091cb18dc81d3a54f907f72e04df29eab0 Mon Sep 17 00:00:00 2001
From: Daniel Barlow <>
Date: Mon, 20 May 2002 14:16:26 +0000
Subject: [PATCH] avoid reloading files that have already been loaded into the
 image.  based on a patch by Brian Seitz

---
 LICENCE           | 24 ------------------------
 asdf.lisp         | 36 +++++++++++++++++++++++++++++++-----
 test/test3.asd    |  1 +
 test/test4.script |  8 ++++++++
 4 files changed, 40 insertions(+), 29 deletions(-)
 delete mode 100644 LICENCE
 create mode 100644 test/test4.script

diff --git a/LICENCE b/LICENCE
deleted file mode 100644
index 57b0a067..00000000
--- a/LICENCE
+++ /dev/null
@@ -1,24 +0,0 @@
-
-(This is the MIT / X Consortium license as taken from 
- http://www.opensource.org/licenses/mit-license.html)
-
-Copyright (c) 2001, 2002 Daniel Barlow and contributors
-
-Permission is hereby granted, free of charge, to any person obtaining
-a copy of this software and associated documentation files (the
-"Software"), to deal in the Software without restriction, including
-without limitation the rights to use, copy, modify, merge, publish,
-distribute, sublicense, and/or sell copies of the Software, and to
-permit persons to whom the Software is furnished to do so, subject to
-the following conditions:
-
-The above copyright notice and this permission notice shall be
-included in all copies or substantial portions of the Software.
-
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
diff --git a/asdf.lisp b/asdf.lisp
index 40b768c6..d57c6919 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -107,7 +107,8 @@ and NIL NAME and TYPE components"
    (relative-pathname :initarg :pathname)
    ;; XXX we should provide some atomic interface for updating the
    ;; component properties
-   (properties :accessor component-properties :initarg :properties)))
+   (properties :accessor component-properties :initarg :properties
+	       :initform nil)))
   
 ;;;; methods: conditions
 
@@ -168,6 +169,17 @@ and NIL NAME and TYPE components"
   (let ((*default-pathname-defaults* (component-parent-pathname component)))
     (merge-pathnames (component-relative-pathname component))))
 
+(defmethod component-property ((c component) property)
+  (cdr (assoc property (slot-value c 'properties))))
+
+(defmethod (setf component-property) (new-value (c component) property)
+  (let ((a (assoc property (slot-value c 'properties))))
+    (if a
+	(setf (cdr a) new-value)
+	(setf (slot-value c 'properties)
+	      (acons property new-value (slot-value c 'properties))))))
+
+
 
 (defclass system (module)
   ((description :accessor system-description :initarg :description)
@@ -522,11 +534,13 @@ system."))
 ;;; perform is required to check output-files to find out where to put
 ;;; its answers, in case it has been overridden for site policy
 (defmethod perform ((operation compile-op) (c cl-source-file))
-  (let ((source-file (component-pathname c)))
+  (let ((source-file (component-pathname c))
+	(output-file (car (output-files operation c))))
     (multiple-value-bind (output warnings-p failure-p)
 	(compile-file source-file
-		      :output-file (car (output-files operation c)))
+		      :output-file output-file)
       (declare (ignore output))
+      (setf (component-property c 'last-compiled) (file-write-date output-file))
       (when warnings-p
 	(case (operation-on-warnings operation)
 	  (:warn (warn "COMPILE-FILE warned while performing ~A on ~A"
@@ -554,8 +568,10 @@ system."))
 (defclass load-op (operation) ())
 
 (defmethod perform ((o load-op) (c cl-source-file))
-  (let ((co (make-sub-operation o 'compile-op)))
-    (map nil #'load (output-files co c))))
+  (let* ((co (make-sub-operation o 'compile-op))
+	(output-files (output-files co c)))
+    (setf (component-property c 'last-loaded) (file-write-date (car output-files)))
+    (map nil #'load output-files)))
 
 (defmethod perform ((operation load-op) (c static-file))
   nil)
@@ -567,6 +583,16 @@ system."))
   (cons (list 'compile-op (component-name c))
         (call-next-method)))
 
+;;; This is arguably an abuse of component properties; transient stuff
+;;; like last-compiled-time is is not really what they're intended
+;;; for.  But I don't really have a better idea, and it's definitely 
+;;; useful functionality
+
+(defmethod operation-done-p ((o load-op) (c source-file))
+  (if (or (not (component-property c 'last-loaded))
+	  (> (or (component-property c 'last-compiled) 0)
+	     (component-property c 'last-loaded)))
+      nil t))
 
 
 
diff --git a/test/test3.asd b/test/test3.asd
index 59491a98..10f82c9c 100644
--- a/test/test3.asd
+++ b/test/test3.asd
@@ -1,5 +1,6 @@
 ;;; -*- Lisp -*-
 (asdf:defsystem test3
+    :properties ((:prop1 . "value"))
     :components
   ((:module "deps"
 	    :if-component-dep-fails :try-next
diff --git a/test/test4.script b/test/test4.script
new file mode 100644
index 00000000..e0ca8598
--- /dev/null
+++ b/test/test4.script
@@ -0,0 +1,8 @@
+;;; -*- Lisp -*-
+(load "../asdf")
+(setf asdf:*central-registry* '(*default-pathname-defaults*))
+(in-package :asdf)
+(assert (not (component-property (find-system 'test3) :foo)))
+(assert (equal (component-property (find-system 'test3) :prop1) "value"))
+(setf (component-property (find-system 'test3) :foo) "bar")
+(assert (equal (component-property (find-system 'test3) :foo) "bar"))
-- 
GitLab