Commit 1a357e1a authored by Robert Goldman's avatar Robert Goldman

Merge remote-tracking branch 'refs/remotes/origin/master'

parents fcdb823b 87965466
......@@ -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)
(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)
(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))
(defun resolve-dependency-name (component name &optional version)
This diff is collapsed.
......@@ -14,6 +14,14 @@
(in-package :asdf/footer)
;;;; Register ASDF itself and all its subsystems as preloaded.
(with-upgradability ()
(dolist (s '("asdf" "uiop" "asdf-defsystem" "asdf-package-system"))
;; Don't bother with these system names, no one relies on them anymore:
;; "asdf-utils" "asdf-bundle" "asdf-driver"
(register-preloaded-system s :version *asdf-version*)))
;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
#+(or abcl clasp clisp clozure cmucl ecl mkcl sbcl)
(with-upgradability ()
......@@ -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,
......@@ -251,6 +253,16 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
:when (eq (first k) 'find-system) :collect (second k))))
(clrhash *asdf-cache*)
(dolist (s l) (find-system s nil)))))
(register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
(register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf)
;; The following function's symbol is from asdf/find-system.
;; It is defined here to resolve what would otherwise be forward package references.
(defun mark-component-preloaded (component)
"Mark a component as preloaded."
;; Recurse to children, so asdf/plan will hopefully be happy.
(map () 'mark-component-preloaded (component-children component))
;; Mark the timestamps of the common lisp-action operations as 0.
(let ((times (component-operation-times component)))
(dolist (o '(load-op compile-op prepare-op))
(setf (gethash o times) 0)))))
......@@ -8,7 +8,7 @@
:asdf/cache :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action :asdf/lisp-action)
#:component-operation-time #:mark-operation-done
#:plan #:plan-traversal #:sequential-plan #:*default-plan-class*
#:planned-action-status #:plan-action-status #:action-already-done-p
#:circular-dependency #:circular-dependency-actions
......@@ -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)
......@@ -7,9 +7,9 @@
(DBG "Now let's register it as preloaded. Loading it will work!")
(register-preloaded-system :this-system-does-not-exist :version "3.14")
(assert (null (system-registered-p :this-system-does-not-exist))) ;; not yet registered as loaded
(load-system :this-system-does-not-exist) ;; but now we can load it
(assert (system-registered-p :this-system-does-not-exist)) ;; and it is loaded indeed!
;; Eagerly registered since See gitlab merge request 13 for the full story.
(assert (system-registered-p :this-system-does-not-exist))
(load-system :this-system-does-not-exist) ;; We can load it indeed, though it's a NOP.
(DBG "Now let's load a simple system. It should create a package.")
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