Commit a5345448 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Replace *defined-systems* by *registered-systems*

Use a simple table *registered-systems* mapping name to system,
and remember timestamps in the COMPONENT-OPERATION-TIME for DEFINE-OP,
instead of the original *defined-systems* table mapping name to
cons of timestamp and system.
parent fe835596
...@@ -4,8 +4,9 @@ ...@@ -4,8 +4,9 @@
(uiop/package:define-package :asdf/backward-interface (uiop/package:define-package :asdf/backward-interface
(:recycle :asdf/backward-interface :asdf) (:recycle :asdf/backward-interface :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action :asdf/component :asdf/system :asdf/system-registry :asdf/operation :asdf/action
:asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations) :asdf/lisp-action :asdf/plan :asdf/operate
:asdf/find-system :asdf/parse-defsystem :asdf/output-translations)
(:export (:export
#:*asdf-verbose* #:*asdf-verbose*
#:operation-error #:compile-error #:compile-failed #:compile-warned #:operation-error #:compile-error #:compile-failed #:compile-warned
...@@ -15,7 +16,7 @@ ...@@ -15,7 +16,7 @@
#:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
#:component-property #:component-property
#:run-shell-command #:run-shell-command
#:system-definition-pathname #:system-definition-pathname #:system-registered-p
#:explain)) #:explain))
(in-package :asdf/backward-interface) (in-package :asdf/backward-interface)
...@@ -208,3 +209,14 @@ DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead.")) ...@@ -208,3 +209,14 @@ DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead."))
(define-convenience-action-methods explain (operation component))) (define-convenience-action-methods explain (operation component)))
(defmethod explain ((o operation) (c component)) (defmethod explain ((o operation) (c component))
(asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))) (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c))))
(with-asdf-deprecation (:style-warning "3.3")
(defun system-registered-p (name)
"DEPRECATED. Return a generalized boolean that is true if a system of given NAME was registered already.
NAME is a system designator, to be normalized by COERCE-NAME.
The value returned if true is a pair of a timestamp and a system object."
(if-let (system (registered-system name))
(cons (if-let (primary-system (registered-system (primary-system-name name)))
(component-operation-time 'define-op primary-system))
system))))
(uiop:define-package :detect-multiply-used-files (uiop:define-package :detect-multiply-used-files
(:nicknames :asdf/contrib/detect-multiply-used-files) (:nicknames :asdf/contrib/detect-multiply-used-files)
(:use :asdf :uiop :common-lisp) (:use :asdf/component :asdf/system-registry :uiop :common-lisp)
(:export #:find-fishy-components #:register-component-files #:*file-components*)) (:export #:find-fishy-components #:register-component-files #:*file-components*))
(in-package :detect-multiply-used-files) (in-package :detect-multiply-used-files)
...@@ -20,7 +20,7 @@ ...@@ -20,7 +20,7 @@
(defun find-fishy-components () (defun find-fishy-components ()
(clrhash *file-components*) (clrhash *file-components*)
(map () 'register-component-files (table-keys asdf::*defined-systems*)) (map () 'register-component-files (table-keys *registered-systems*))
(loop :for p :in (sort (table-keys *file-components*) 'string<) (loop :for p :in (sort (table-keys *file-components*) 'string<)
:for l = (gethash p *file-components*) :for l = (gethash p *file-components*)
:when (and (file-pathname-p p) (not (length=n-p l 1))) :when (and (file-pathname-p p) (not (length=n-p l 1)))
......
...@@ -41,7 +41,7 @@ ...@@ -41,7 +41,7 @@
(defun find-system-if-being-defined (name) (defun find-system-if-being-defined (name)
;; This function finds systems being defined *in the current ASDF session*, as embodied by ;; This function finds systems being defined *in the current ASDF session*, as embodied by
;; its session cache, even before they are fully defined and registered in *defined-systems*. ;; its session cache, even before they are fully defined and registered in *registered-systems*.
;; The purpose of this function is to prevent races between two files that might otherwise ;; The purpose of this function is to prevent races between two files that might otherwise
;; try overwrite each other's system objects, resulting in infinite loops and stack overflow. ;; try overwrite each other's system objects, resulting in infinite loops and stack overflow.
;; This function explicitly MUST NOT find definitions merely registered in previous sessions. ;; This function explicitly MUST NOT find definitions merely registered in previous sessions.
...@@ -199,10 +199,9 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -199,10 +199,9 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
;; and keeping a negative cache was a bug (see lp#1335323), which required ;; and keeping a negative cache was a bug (see lp#1335323), which required
;; explicit invalidation in clear-system and find-system (when unsucccessful). ;; explicit invalidation in clear-system and find-system (when unsucccessful).
(let* ((name (coerce-name name)) (let* ((name (coerce-name name))
(in-memory (system-registered-p name)) ; load from disk if absent or newer on disk (previous (registered-system name)) ; load from disk if absent or newer on disk
(previous (cdr in-memory)) (primary (registered-system (primary-system-name name)))
(previous (and (typep previous 'system) previous)) (previous-time (and previous primary (component-operation-time 'define-op primary)))
(previous-time (car in-memory))
(found (search-for-system-definition name)) (found (search-for-system-definition name))
(found-system (and (typep found 'system) found)) (found-system (and (typep found 'system) found))
(pathname (ensure-pathname (pathname (ensure-pathname
......
...@@ -159,7 +159,8 @@ ...@@ -159,7 +159,8 @@
#:clear-source-registry #:clear-source-registry
#:ensure-source-registry #:ensure-source-registry
#:process-source-registry #:process-source-registry
#:system-registered-p #:registered-systems #:already-loaded-systems #:system-registered-p ;; DEPRECATED
#:registered-system #:registered-systems #:already-loaded-systems
#:resolve-location #:resolve-location
#:asdf-message #:asdf-message
#:*user-cache* #:*user-cache*
......
...@@ -261,7 +261,7 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms.")) ...@@ -261,7 +261,7 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
(clrhash (asdf-cache)))))) (clrhash (asdf-cache))))))
;; Regardless, clear defined systems, since they might be invalid ;; Regardless, clear defined systems, since they might be invalid
;; after an incompatible ASDF upgrade. ;; after an incompatible ASDF upgrade.
(clear-defined-systems) (clear-registered-systems)
;; The configuration also may have to be upgraded. ;; The configuration also may have to be upgraded.
(upgrade-configuration) (upgrade-configuration)
;; If we were in the middle of an operation, be sure to restore the system being defined. ;; If we were in the middle of an operation, be sure to restore the system being defined.
......
...@@ -13,7 +13,8 @@ ...@@ -13,7 +13,8 @@
#:class-for-type #:*default-component-class* #:class-for-type #:*default-component-class*
#:determine-system-directory #:parse-component-form #:determine-system-directory #:parse-component-form
#:non-toplevel-system #:non-system-system #:bad-system-name #:non-toplevel-system #:non-system-system #:bad-system-name
#:sysdef-error-component #:check-component-input)) #:sysdef-error-component #:check-component-input
#:explain))
(in-package :asdf/parse-defsystem) (in-package :asdf/parse-defsystem)
;;; Pathname ;;; Pathname
...@@ -307,13 +308,11 @@ system names contained using COERCE-NAME. Return the result." ...@@ -307,13 +308,11 @@ system names contained using COERCE-NAME. Return the result."
:collect :it))) :collect :it)))
(load-systems* deps) (load-systems* deps)
dep-forms)) dep-forms))
(registered (system-registered-p name)) (system (or (find-system-if-being-defined name)
(registered! (if registered (if-let (registered (registered-system name))
(rplaca registered (get-file-stamp source-file)) (reset-system registered :name name :source-file source-file)
(register-system (register-system (make-instance 'undefined-system
(make-instance 'system :name name :source-file source-file)))) :name name :source-file source-file)))))
(system (reset-system (cdr registered!)
:name name :source-file source-file))
(component-options (component-options
(append (append
(remove-plist-keys '(:defsystem-depends-on :class) options) (remove-plist-keys '(:defsystem-depends-on :class) options)
......
...@@ -7,17 +7,16 @@ ...@@ -7,17 +7,16 @@
:asdf/session :asdf/component :asdf/system) :asdf/session :asdf/component :asdf/system)
(:export (:export
#:remove-entry-from-registry #:coerce-entry-to-directory #:remove-entry-from-registry #:coerce-entry-to-directory
#:system-registered-p #:registered-system #:register-system #:registered-system #:register-system
#:registered-systems* #:registered-systems #:registered-systems* #:registered-systems
#:clear-system #:map-systems #:clear-system #:map-systems
#:*system-definition-search-functions* #:search-for-system-definition #:*system-definition-search-functions* #:search-for-system-definition
#:*central-registry* #:probe-asd #:sysdef-central-registry-search #:*central-registry* #:probe-asd #:sysdef-central-registry-search
#:find-system-if-being-defined
#:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
#:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
#:mark-component-preloaded ;; forward reference to asdf/find-system #:find-system-if-being-defined #:mark-component-preloaded ;; forward references to asdf/find-system
#:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems* #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems*
#:*defined-systems* #:clear-defined-systems #:*registered-systems* #:clear-registered-systems
;; defined in source-registry, but specially mentioned here: ;; defined in source-registry, but specially mentioned here:
#:sysdef-source-registry-search)) #:sysdef-source-registry-search))
(in-package :asdf/system-registry) (in-package :asdf/system-registry)
...@@ -25,32 +24,22 @@ ...@@ -25,32 +24,22 @@
(with-upgradability () (with-upgradability ()
;;; Registry of Defined Systems ;;; Registry of Defined Systems
(defvar *defined-systems* (make-hash-table :test 'equal) (defvar *registered-systems* (make-hash-table :test 'equal)
"This is a hash table whose keys are strings -- the "This is a hash table whose keys are strings -- the names of systems --
names of systems -- and whose values are pairs, the first and whose values are systems.
element of which is a universal-time indicating when the A system is referred to as \"registered\" if it is present in this table.")
system definition was last updated, and the second element
of which is a system object.
A system is referred to as \"registered\" if it is present
in this table.")
(defun system-registered-p (name)
"Return a generalized boolean that is true if a system of given NAME was registered already.
NAME is a system designator, to be normalized by COERCE-NAME.
The value returned if true is a pair of a timestamp and a system object."
(gethash (coerce-name name) *defined-systems*))
(defun registered-system (name) (defun registered-system (name)
"Return a system of given NAME that was registered already, "Return a system of given NAME that was registered already,
if such a system exists. NAME is a system designator, to be if such a system exists. NAME is a system designator, to be
normalized by COERCE-NAME. The value returned is a system object, normalized by COERCE-NAME. The value returned is a system object,
or NIL if not found." or NIL if not found."
(cdr (system-registered-p name))) (gethash (coerce-name name) *registered-systems*))
(defun registered-systems* () (defun registered-systems* ()
"Return a list containing every registered system (as a system object)." "Return a list containing every registered system (as a system object)."
(loop :for registered :being :the :hash-values :of *defined-systems* (loop :for registered :being :the :hash-values :of *registered-systems*
:collect (cdr registered))) :collect registered))
(defun registered-systems () (defun registered-systems ()
"Return a list of the names of every registered system." "Return a list of the names of every registered system."
...@@ -62,18 +51,15 @@ or NIL if not found." ...@@ -62,18 +51,15 @@ or NIL if not found."
(let ((name (component-name system))) (let ((name (component-name system)))
(check-type name string) (check-type name string)
(asdf-message (compatfmt "~&~@<; ~@;Registering system ~3i~_~A~@:>~%") name) (asdf-message (compatfmt "~&~@<; ~@;Registering system ~3i~_~A~@:>~%") name)
(unless (eq system (registered-system name)) (setf (gethash name *registered-systems*) system)))
(setf (gethash name *defined-systems*)
(cons (ignore-errors (get-file-stamp (system-source-file system)))
system)))))
(defun map-systems (fn) (defun map-systems (fn)
"Apply FN to each defined system. "Apply FN to each defined system.
FN should be a function of one argument. It will be FN should be a function of one argument. It will be
called with an object of type asdf:system." called with an object of type asdf:system."
(loop :for registered :being :the :hash-values :of *defined-systems* (loop :for registered :being :the :hash-values :of *registered-systems*
:do (funcall fn (cdr registered)))) :do (funcall fn registered)))
;;; Preloaded systems: in the image even if you can't find source files backing them. ;;; Preloaded systems: in the image even if you can't find source files backing them.
...@@ -167,14 +153,14 @@ Returns T if system was or is now undefined, NIL if a new preloaded system was r ...@@ -167,14 +153,14 @@ Returns T if system was or is now undefined, NIL if a new preloaded system was r
;; a general such operation cannot be portably written, ;; a general such operation cannot be portably written,
;; considering how much CL relies on side-effects to global data structures. ;; considering how much CL relies on side-effects to global data structures.
(let ((name (coerce-name system))) (let ((name (coerce-name system)))
(remhash name *defined-systems*) (remhash name *registered-systems*)
(unset-asdf-cache-entry `(find-system ,name)) (unset-asdf-cache-entry `(find-system ,name))
(not (ensure-preloaded-system-registered name)))) (not (ensure-preloaded-system-registered name))))
(defun clear-defined-systems () (defun clear-registered-systems ()
"Clear all currently registered defined systems. "Clear all currently registered defined systems.
Preloaded systems (including immutable ones) will be reset, other systems will be de-registered." Preloaded systems (including immutable ones) will be reset, other systems will be de-registered."
(loop :for name :being :the :hash-keys :of *defined-systems* :do (clear-system name))) (map () 'clear-system (registered-systems)))
;;; Searching for system definitions ;;; Searching for system definitions
...@@ -211,7 +197,7 @@ with that name.") ...@@ -211,7 +197,7 @@ with that name.")
;; it is to be called by locate-system. ;; it is to be called by locate-system.
(defun search-for-system-definition (system) (defun search-for-system-definition (system)
;; Search for valid definitions of the system available in the current session. ;; Search for valid definitions of the system available in the current session.
;; Previous definitions as registered in *defined-systems* MUST NOT be considered; ;; Previous definitions as registered in *registered-systems* MUST NOT be considered;
;; they will be reconciled by locate-system then find-system. ;; they will be reconciled by locate-system then find-system.
;; There are two special treatments: first, specially search for objects being defined ;; There are two special treatments: first, specially search for objects being defined
;; in the current session, to avoid definition races between several files; ;; in the current session, to avoid definition races between several files;
......
...@@ -132,6 +132,7 @@ as a string by / slashes. A component designates its system." ...@@ -132,6 +132,7 @@ as a string by / slashes. A component designates its system."
(etypecase system-designator (etypecase system-designator
(string (if-let (p (position #\/ system-designator)) (string (if-let (p (position #\/ system-designator))
(subseq system-designator 0 p) system-designator)) (subseq system-designator 0 p) system-designator))
(symbol (primary-system-name (coerce-name system-designator)))
(component (primary-system-name (coerce-name (component-system system-designator)))))) (component (primary-system-name (coerce-name (component-system system-designator))))))
(defun primary-system-p (system) (defun primary-system-p (system)
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
(setf asdf::*asdf-session* nil) (setf asdf::*asdf-session* nil)
(setf *central-registry* nil) (setf *central-registry* nil)
(asdf::clear-defined-systems) (asdf::clear-registered-systems)
(assert-equal nil (find-system "test-asdf/force1" nil)) (assert-equal nil (find-system "test-asdf/force1" nil))
(errors missing-component (find-system "test-asdf/force1" t)) (errors missing-component (find-system "test-asdf/force1" t))
(defvar *tddoc* 0) (defvar *tddoc* 0)
(incf *tddoc*) (incf *tddoc*)
(format t "tddoc loaded ~D times.~%" *tddoc*) (format t "tddoc loaded ~D time~:P.~%" *tddoc*)
(if (= *tddoc* 1) (if (= *tddoc* 1)
(defsystem "test-defsystem-depends-on-change" (defsystem "test-defsystem-depends-on-change"
......
...@@ -10,7 +10,7 @@ ...@@ -10,7 +10,7 @@
(defparameter talc "test-asdf-location-change") (defparameter talc "test-asdf-location-change")
(defparameter asdf-user::*tddoc* 0) (defparameter asdf-user::*tddoc* 0)
(terpri)(terpri)
(DBG "Load the system, using xach-foo-1") (DBG "Load the system, using xach-foo-1")
(push (subpathname *test-directory* "xach-foo-1/") *central-registry*) (push (subpathname *test-directory* "xach-foo-1/") *central-registry*)
(clear-system tddoc) (clear-system tddoc)
...@@ -27,6 +27,8 @@ ...@@ -27,6 +27,8 @@
(subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd") (subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd")
(system-source-file talc)) (system-source-file talc))
(terpri)(terpri)
(DBG "Load it again: there should be no changes") (DBG "Load it again: there should be no changes")
(load-system "test-defsystem-depends-on-change") (load-system "test-defsystem-depends-on-change")
(assert-equal asdf-user::*tddoc* 1) (assert-equal asdf-user::*tddoc* 1)
......
...@@ -47,7 +47,7 @@ ...@@ -47,7 +47,7 @@
(reset-session) (reset-session)
(signals missing-dependency (def-test-system unloadable-system (signals missing-dependency (def-test-system unloadable-system
:defsystem-depends-on (nonexistent-system))) :defsystem-depends-on (nonexistent-system)))
(assert (not (system-registered-p "unloadable-system")))) (assert (not (registered-system "unloadable-system"))))
(progn (progn
(signals missing-dependency (signals missing-dependency
......
...@@ -26,42 +26,42 @@ ...@@ -26,42 +26,42 @@
(assert file1-date) (assert file1-date)
(reset-session-visited) (reset-session-visited)
(let ((plan (force-plan :force t))) (defparameter *plan* (force-plan :force t))
(DBG "Check that :force t forces the current system but not its dependencies" plan) (DBG "Check that :force t forces the current system but not its dependencies" *plan*)
(assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file4"))) (assert (asdf::plan-operates-on-p *plan* '("test-asdf/force" "file4")))
(assert (not (asdf::plan-operates-on-p plan '("file3-only" "file3")))) (assert (not (asdf::plan-operates-on-p *plan* '("file3-only" "file3"))))
(assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1"))))) (assert (not (asdf::plan-operates-on-p *plan* '("test-asdf/force1" "file1"))))
(reset-session-visited) (reset-session-visited)
(let ((plan (force-plan :force :all))) (defparameter *plan* (force-plan :force :all))
(DBG "Check that :force :all forces the current system and its dependencies" plan) (DBG "Check that :force :all forces the current system and its dependencies" *plan*)
(assert plan) (assert *plan*)
(assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file4"))) (assert (asdf::plan-operates-on-p *plan* '("test-asdf/force" "file4")))
(assert (asdf::plan-operates-on-p plan '("file3-only" "file3"))) (assert (asdf::plan-operates-on-p *plan* '("file3-only" "file3")))
(assert (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1")))) (assert (asdf::plan-operates-on-p *plan* '("test-asdf/force1" "file1")))
(reset-session-visited) (reset-session-visited)
(let ((plan (force-plan :force :all :force-not t))) (defparameter *plan* (force-plan :force :all :force-not t))
(DBG "Check that :force-not takes precedence over :force, with t means \"all but current system\"" plan) (DBG "Check that :force-not takes precedence over :force, with t means \"all but current system\"" *plan*)
(assert plan) (assert *plan*)
(assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file4"))) (assert (asdf::plan-operates-on-p *plan* '("test-asdf/force" "file4")))
(assert (not (asdf::plan-operates-on-p plan '("file3-only" "file3")))) (assert (not (asdf::plan-operates-on-p *plan* '("file3-only" "file3"))))
(assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1"))))) (assert (not (asdf::plan-operates-on-p *plan* '("test-asdf/force1" "file1"))))
(reset-session-visited) (reset-session-visited)
(let ((plan (force-plan :force-not :all))) (defparameter *plan* (force-plan :force-not :all))
(DBG "Check that :force-not :all means \"all systems\"" plan) (DBG "Check that :force-not :all means \"all systems\"" *plan*)
(assert (null plan))) (assert (null *plan*))
(reset-session-visited) (reset-session-visited)
(let ((plan (force-plan :force :all :force-not :all))) (defparameter *plan* (force-plan :force :all :force-not :all))
(DBG "Check that :force-not :all takes precedence over :force" plan) (DBG "Check that :force-not :all takes precedence over :force" *plan*)
(assert (null plan))) (assert (null *plan*))
(reset-session-visited) (reset-session-visited)
(let ((plan (force-plan :force :all :force-not '(:test-asdf/force :test-asdf/force1)))) (defparameter *plan* (force-plan :force :all :force-not '(:test-asdf/force :test-asdf/force1)))
(DBG "Check that :force-not with a list takes precedence over :force" plan) (DBG "Check that :force-not with a list takes precedence over :force" *plan*)
(assert (null plan))) (assert (null *plan*))
(reset-session-visited) (reset-session-visited)
(let* ((asdf::*immutable-systems* (list-to-hash-set '("test-asdf/force1"))) (let* ((asdf::*immutable-systems* (list-to-hash-set '("test-asdf/force1")))
......
...@@ -10,7 +10,7 @@ ...@@ -10,7 +10,7 @@
(DBG "Now let's register it as preloaded. Loading it will work!") (DBG "Now let's register it as preloaded. Loading it will work!")
(register-preloaded-system :this-system-does-not-exist :version "3.14") (register-preloaded-system :this-system-does-not-exist :version "3.14")
;; Eagerly registered since 3.1.7.20. See gitlab merge request 13 for the full story. ;; Eagerly registered since 3.1.7.20. See gitlab merge request 13 for the full story.
(assert (system-registered-p :this-system-does-not-exist)) (assert (registered-system :this-system-does-not-exist))
(load-system :this-system-does-not-exist) ;; We can load it indeed, though it's a NOP. (load-system :this-system-does-not-exist) ;; We can load it indeed, though it's a NOP.
...@@ -26,10 +26,10 @@ ...@@ -26,10 +26,10 @@
(DBG "Destroy the package, clear the system, and register it as immutable. Try loading it again.") (DBG "Destroy the package, clear the system, and register it as immutable. Try loading it again.")
(DBG "The package should NOT be back, because it's immutable thus it's NOT going to be loaded.") (DBG "The package should NOT be back, because it's immutable thus it's NOT going to be loaded.")
(delete-package :test-package) (clear-system :test-asdf/1) (delete-package :test-package) (clear-system :test-asdf/1)
(assert (null (system-registered-p :test-asdf/1))) ;; not registered as loaded (assert (null (registered-system :test-asdf/1))) ;; not registered as loaded
(register-immutable-system :test-asdf/1) (register-immutable-system :test-asdf/1)
(assert (system-registered-p :test-asdf/1)) ;; now it's registered as loaded (assert (registered-system :test-asdf/1)) ;; now it's registered as loaded
(load-system :test-asdf/1) (load-system :test-asdf/1)
(assert (system-registered-p :test-asdf/1)) ;; and it is "loaded" indeed! (assert (registered-system :test-asdf/1)) ;; and it is "loaded" indeed!
(assert (null (find-package :test-package))) ;; but the source code wasn't loaded (assert (null (find-package :test-package))) ;; but the source code wasn't loaded
...@@ -190,7 +190,7 @@ ...@@ -190,7 +190,7 @@
;; Prevent ASDF from finding the modules as ASDF systems on ECL, MKCL, SBCL (and maybe more). ;; Prevent ASDF from finding the modules as ASDF systems on ECL, MKCL, SBCL (and maybe more).
(setf asdf::*system-definition-search-functions* (setf asdf::*system-definition-search-functions*
(remove 'asdf::sysdef-source-registry-search asdf::*system-definition-search-functions*)) (remove 'asdf::sysdef-source-registry-search asdf::*system-definition-search-functions*))
(asdf::clear-defined-systems) (asdf::clear-registered-systems)
(reset-session) (reset-session)
......
...@@ -6,7 +6,9 @@ ...@@ -6,7 +6,9 @@
(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) (setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*))
(defun system-registered-time (name) (defun system-registered-time (name)
(car (asdf::system-registered-p name))) (asdf::component-operation-time
'asdf::define-op
(registered-system (primary-system-name name))))
(setf (asdf-upgraded-p *asdf-session*) t) (setf (asdf-upgraded-p *asdf-session*) t)
(defparameter test1.asd (nth-value 2 (locate-system :test1))) (defparameter test1.asd (nth-value 2 (locate-system :test1)))
......
;;; -*- Lisp -*- ;;; -*- Lisp -*-
;;; test system definition reloading if touched ;;; test system definition NOT reloaded if touched
;;; system that canNOT be found using *system-definition-search-functions* ;;; system that canNOT be found using *system-definition-search-functions*
(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) (setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*))
(defun system-registered-time (name) (defun system-registered-time (name)
(car (asdf::system-registered-p name))) (asdf::component-operation-time
'asdf::define-op
(registered-system (primary-system-name name))))
(defparameter test1.asd (nth-value 2 (locate-system :test1))) (asdf::clear-registered-systems)
(assert-pathname-equal test1.asd (test-source "test1.asd")) (defparameter test-asdf.asd (nth-value 2 (locate-system :test-asdf)))
(assert test1.asd) (assert-pathname-equal test-asdf.asd (test-source "test-asdf.asd"))
(assert (not (registered-system :test-asdf))) ;; not loaded
(asdf::clear-defined-systems) (asdf::clear-registered-systems)
(setf asdf:*central-registry* nil) (setf asdf:*central-registry* nil)
(load test1.asd) (load-asd test-asdf.asd)
(assert (find-system :test1)) (assert (registered-system :test-asdf))
(defparameter date1 (system-registered-time :test1)) (defparameter date1 (system-registered-time :test-asdf))
(assert date1) (assert date1)
(assert-equal 1 test-asdf-system::*times-loaded*)
(asdf::clear-defined-systems) (asdf::clear-registered-systems)
(touch-file test1.asd :timestamp date1 :offset +2) (touch-file test-asdf.asd :timestamp date1 :offset +2)
(load test1.asd) (load-asd test-asdf.asd)
(find-system :test1) (find-system :test-asdf)
(defparameter date2 (system-registered-time :test1)) (defparameter date2 (system-registered-time :test-asdf))
(assert date2) (assert date2)
(assert-compare (> date2 date1)) (assert-compare (> date2 date1))
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