diff --git a/find-component.lisp b/find-component.lisp index 19360783496a9d7f5cfbf16bd9abba444a32f293..01a68ff6298f9740cb9bfb649cfcc5c0d0a4ba91 100644 --- a/find-component.lisp +++ b/find-component.lisp @@ -50,36 +50,41 @@ ;;;; Finding components (with-upgradability () - (defgeneric* (find-component) (base path) + (defgeneric* (find-component) (base path &key registered) (:documentation "Find a component by resolving the PATH starting from BASE parent")) (defgeneric resolve-dependency-combination (component combinator arguments)) - (defmethod find-component ((base string) path) - (let ((s (find-system base nil))) - (and s (find-component s path)))) + (defmethod find-component ((base string) path &key registered) + (if-let ((s (if registered + (registered-system base) + (find-system base nil)))) + (find-component s path :registered registered))) - (defmethod find-component ((base symbol) path) + (defmethod find-component ((base symbol) path &key registered) (cond - (base (find-component (coerce-name base) path)) - (path (find-component path nil)) + (base (find-component (coerce-name base) path :registered registered)) + (path (find-component path nil :registered registered)) (t nil))) - (defmethod find-component ((base cons) path) - (find-component (car base) (cons (cdr base) path))) + (defmethod find-component ((base cons) path &key registered) + (find-component (car base) (cons (cdr base) path) :registered registered)) - (defmethod find-component ((parent parent-component) (name string)) - (compute-children-by-name parent :only-if-needed-p t) ;; SBCL may miss the u-i-f-r-c method!!! + (defmethod find-component ((parent parent-component) (name string) &key registered) + (declare (ignorable registered)) + (compute-children-by-name parent :only-if-needed-p t) (values (gethash name (component-children-by-name parent)))) - (defmethod find-component (base (name symbol)) + (defmethod find-component (base (name symbol) &key registered) (if name - (find-component base (coerce-name name)) + (find-component base (coerce-name name) :registered registered) base)) - (defmethod find-component ((c component) (name cons)) - (find-component (find-component c (car name)) (cdr name))) + (defmethod find-component ((c component) (name cons) &key registered) + (find-component (find-component c (car name) :registered registered) + (cdr name) :registered registered)) - (defmethod find-component ((base t) (actual component)) + (defmethod find-component ((base t) (actual component) &key registered) + (declare (ignorable registered)) actual) (defun resolve-dependency-name (component name &optional version) diff --git a/operate.lisp b/operate.lisp index 68e14c17ae688ced5387489937cb208a1316e761..53c4b68fbc88776d9c99c9722c089658e2472a29 100644 --- a/operate.lisp +++ b/operate.lisp @@ -167,7 +167,8 @@ to load it in current image." (defun component-loaded-p (component) "Has given COMPONENT been successfully loaded in the current image (yet)? Note that this returns true even if the component is not up to date." - (action-already-done-p nil (make-instance 'load-op) (find-component component ()))) + (if-let ((component (find-component component () :registered t))) + (action-already-done-p nil (make-instance 'load-op) component))) (defun already-loaded-systems () "return a list of the names of the systems that have been successfully loaded so far" @@ -176,7 +177,8 @@ Note that this returns true even if the component is not up to date." (defun require-system (system &rest keys &key &allow-other-keys) "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but skip any update to the system or its dependencies if they have already been loaded." - (apply 'load-system system :force-not (already-loaded-systems) keys))) + (unless (component-loaded-p system) + (apply 'load-system system :force-not (already-loaded-systems) keys)))) ;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible, diff --git a/test/test-force.script b/test/test-force.script index f760bdeb0dcff611a5e28d46299fee00bc4d6649..a03c4e691a767d7a5882acc314d2abbc29411d03 100644 --- a/test/test-force.script +++ b/test/test-force.script @@ -87,19 +87,17 @@ (setf test-package::*file3* :reset) -(DBG "Check that require-system of touched .asd will reload the asdf.") -(DBG "(That's what it does now, but if it could be fixed that'd be nice.)") +(DBG "Check that require-system called with touched .asd won't reload the asdf.") (unset-asdf-cache-entry '(find-system "test-asdf")) (unset-asdf-cache-entry '(find-system "test-asdf/force")) (touch-file "test-asdf.asd" :timestamp (+ 10000 (get-file-stamp file1))) (require-system 'test-asdf/force) -(assert-equal (asymval :*times-loaded* :test-asdf-system) 2) +(assert-equal (asymval :*times-loaded* :test-asdf-system) 1) (assert-equal test-package::*file3* :reset) -(DBG "Check that require-system of untouched .asd won't reload the asdf.") +(DBG "Check that require-system called with untouched .asd won't reload the asdf.") (require-system 'test-asdf/force) ;;; Somehow, it loads the system... -(with-expected-failure (t) - (assert-equal (asymval :*times-loaded* :test-asdf-system) 2) - (assert-equal test-package::*file3* :reset)) +(assert-equal (asymval :*times-loaded* :test-asdf-system) 1) +(assert-equal test-package::*file3* :reset)