Commit ecef7b09 authored by Daniel Barlow's avatar Daniel Barlow
Browse files

avoid reloading files that have already been loaded into the image. based on...

avoid reloading files that have already been loaded into the image.  based on a patch by Brian Seitz
parent 19ebfec1
(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.
......@@ -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))
......
;;; -*- Lisp -*-
(asdf:defsystem test3
:properties ((:prop1 . "value"))
:components
((:module "deps"
:if-component-dep-fails :try-next
......
;;; -*- 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"))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment