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