diff --git a/backward-interface.lisp b/backward-interface.lisp index d088dda3368ef98e141947d08ba6ac20eae61866..7e9c95858d7391ed7c4aecdd715cd1265908e968 100644 --- a/backward-interface.lisp +++ b/backward-interface.lisp @@ -4,8 +4,9 @@ (uiop/package:define-package :asdf/backward-interface (:recycle :asdf/backward-interface :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session - :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action - :asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations) + :asdf/component :asdf/system :asdf/system-registry :asdf/operation :asdf/action + :asdf/lisp-action :asdf/plan :asdf/operate + :asdf/find-system :asdf/parse-defsystem :asdf/output-translations) (:export #:*asdf-verbose* #:operation-error #:compile-error #:compile-failed #:compile-warned @@ -15,7 +16,7 @@ #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings #:component-property #:run-shell-command - #:system-definition-pathname + #:system-definition-pathname #:system-registered-p #:explain)) (in-package :asdf/backward-interface) @@ -208,3 +209,14 @@ DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead.")) (define-convenience-action-methods explain (operation component))) (defmethod explain ((o operation) (c component)) (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)))) + diff --git a/contrib/detect-multiply-used-files.lisp b/contrib/detect-multiply-used-files.lisp index 8e5bf714d8f211a491ef19666d0a87a2836ed323..5720efe2519f943dfa7bb2db940e4eeebc312ab3 100644 --- a/contrib/detect-multiply-used-files.lisp +++ b/contrib/detect-multiply-used-files.lisp @@ -1,6 +1,6 @@ (uiop:define-package :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*)) (in-package :detect-multiply-used-files) @@ -20,7 +20,7 @@ (defun find-fishy-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<) :for l = (gethash p *file-components*) :when (and (file-pathname-p p) (not (length=n-p l 1))) diff --git a/find-system.lisp b/find-system.lisp index ede568c1689d8096c1c99804d3424262018df239..6a6d8cefb8f6fb752e46c466085220d775ce908f 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -41,7 +41,7 @@ (defun find-system-if-being-defined (name) ;; 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 ;; 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. @@ -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 ;; explicit invalidation in clear-system and find-system (when unsucccessful). (let* ((name (coerce-name name)) - (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk - (previous (cdr in-memory)) - (previous (and (typep previous 'system) previous)) - (previous-time (car in-memory)) + (previous (registered-system name)) ; load from disk if absent or newer on disk + (primary (registered-system (primary-system-name name))) + (previous-time (and previous primary (component-operation-time 'define-op primary))) (found (search-for-system-definition name)) (found-system (and (typep found 'system) found)) (pathname (ensure-pathname diff --git a/interface.lisp b/interface.lisp index fe17dd7987c4d8135f7cfbcb0256106b29e0bebf..6b55b5f846790483baa31a33289cc485b6a13824 100644 --- a/interface.lisp +++ b/interface.lisp @@ -159,7 +159,8 @@ #:clear-source-registry #:ensure-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 #:asdf-message #:*user-cache* diff --git a/operate.lisp b/operate.lisp index 5c81221280bb358410a895a7c188efacb1b88791..61ab57adfeaefdda3297a0b8ab58e134be4a4ddc 100644 --- a/operate.lisp +++ b/operate.lisp @@ -261,7 +261,7 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms.")) (clrhash (asdf-cache)))))) ;; Regardless, clear defined systems, since they might be invalid ;; after an incompatible ASDF upgrade. - (clear-defined-systems) + (clear-registered-systems) ;; The configuration also may have to be upgraded. (upgrade-configuration) ;; If we were in the middle of an operation, be sure to restore the system being defined. diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index 55843562e1d8a6cc57de0c582bc3033ddb3a460e..e298ff48422e223e45886fd3baa558dc78a7ef3d 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -13,7 +13,8 @@ #:class-for-type #:*default-component-class* #:determine-system-directory #:parse-component-form #: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) ;;; Pathname @@ -307,13 +308,11 @@ system names contained using COERCE-NAME. Return the result." :collect :it))) (load-systems* deps) dep-forms)) - (registered (system-registered-p name)) - (registered! (if registered - (rplaca registered (get-file-stamp source-file)) - (register-system - (make-instance 'system :name name :source-file source-file)))) - (system (reset-system (cdr registered!) - :name name :source-file source-file)) + (system (or (find-system-if-being-defined name) + (if-let (registered (registered-system name)) + (reset-system registered :name name :source-file source-file) + (register-system (make-instance 'undefined-system + :name name :source-file source-file))))) (component-options (append (remove-plist-keys '(:defsystem-depends-on :class) options) diff --git a/system-registry.lisp b/system-registry.lisp index c2c023d1e7f855d18cbfc7301dc460154b6838a8..71e286fd47def0d99b87c1a4ccbdc28fa9be475f 100644 --- a/system-registry.lisp +++ b/system-registry.lisp @@ -7,17 +7,16 @@ :asdf/session :asdf/component :asdf/system) (:export #:remove-entry-from-registry #:coerce-entry-to-directory - #:system-registered-p #:registered-system #:register-system + #:registered-system #:register-system #:registered-systems* #:registered-systems #:clear-system #:map-systems #:*system-definition-search-functions* #:search-for-system-definition #:*central-registry* #:probe-asd #:sysdef-central-registry-search - #:find-system-if-being-defined #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed #: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* - #:*defined-systems* #:clear-defined-systems + #:*registered-systems* #:clear-registered-systems ;; defined in source-registry, but specially mentioned here: #:sysdef-source-registry-search)) (in-package :asdf/system-registry) @@ -25,32 +24,22 @@ (with-upgradability () ;;; Registry of Defined Systems - (defvar *defined-systems* (make-hash-table :test 'equal) - "This is a hash table whose keys are strings -- the -names of systems -- and whose values are pairs, the first -element of which is a universal-time indicating when the -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*)) + (defvar *registered-systems* (make-hash-table :test 'equal) + "This is a hash table whose keys are strings -- the names of systems -- +and whose values are systems. +A system is referred to as \"registered\" if it is present in this table.") (defun registered-system (name) "Return a system of given NAME that was registered already, if such a system exists. NAME is a system designator, to be normalized by COERCE-NAME. The value returned is a system object, or NIL if not found." - (cdr (system-registered-p name))) + (gethash (coerce-name name) *registered-systems*)) (defun registered-systems* () "Return a list containing every registered system (as a system object)." - (loop :for registered :being :the :hash-values :of *defined-systems* - :collect (cdr registered))) + (loop :for registered :being :the :hash-values :of *registered-systems* + :collect registered)) (defun registered-systems () "Return a list of the names of every registered system." @@ -62,18 +51,15 @@ or NIL if not found." (let ((name (component-name system))) (check-type name string) (asdf-message (compatfmt "~&~@<; ~@;Registering system ~3i~_~A~@:>~%") name) - (unless (eq system (registered-system name)) - (setf (gethash name *defined-systems*) - (cons (ignore-errors (get-file-stamp (system-source-file system))) - system))))) + (setf (gethash name *registered-systems*) system))) (defun map-systems (fn) "Apply FN to each defined system. FN should be a function of one argument. It will be called with an object of type asdf:system." - (loop :for registered :being :the :hash-values :of *defined-systems* - :do (funcall fn (cdr registered)))) + (loop :for registered :being :the :hash-values :of *registered-systems* + :do (funcall fn registered))) ;;; 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 ;; a general such operation cannot be portably written, ;; considering how much CL relies on side-effects to global data structures. (let ((name (coerce-name system))) - (remhash name *defined-systems*) + (remhash name *registered-systems*) (unset-asdf-cache-entry `(find-system ,name)) (not (ensure-preloaded-system-registered name)))) - (defun clear-defined-systems () + (defun clear-registered-systems () "Clear all currently registered defined systems. 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 @@ -211,7 +197,7 @@ with that name.") ;; it is to be called by locate-system. (defun search-for-system-definition (system) ;; 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. ;; There are two special treatments: first, specially search for objects being defined ;; in the current session, to avoid definition races between several files; diff --git a/system.lisp b/system.lisp index d2e93514f5a3e6f7f01d871d3f80fb0d39d18c24..c09889d40e2d9c29d729b5bea8182182d6f0b7d2 100644 --- a/system.lisp +++ b/system.lisp @@ -132,6 +132,7 @@ as a string by / slashes. A component designates its system." (etypecase system-designator (string (if-let (p (position #\/ 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)))))) (defun primary-system-p (system) diff --git a/test/test-cache.script b/test/test-cache.script index f9798a4386c507211a50b7963329f742fe2f3110..a59361228ef6dcde2efd735ddd142aaef9002a7e 100644 --- a/test/test-cache.script +++ b/test/test-cache.script @@ -6,7 +6,7 @@ (setf asdf::*asdf-session* nil) (setf *central-registry* nil) -(asdf::clear-defined-systems) +(asdf::clear-registered-systems) (assert-equal nil (find-system "test-asdf/force1" nil)) (errors missing-component (find-system "test-asdf/force1" t)) diff --git a/test/test-defsystem-depends-on-change.asd b/test/test-defsystem-depends-on-change.asd index 7d5e46074ae8c4ccf9bc51d87aeadd6d13997a2d..bea4fe13d3a80e80f0391eeec64a828662818f41 100644 --- a/test/test-defsystem-depends-on-change.asd +++ b/test/test-defsystem-depends-on-change.asd @@ -1,6 +1,6 @@ (defvar *tddoc* 0) (incf *tddoc*) -(format t "tddoc loaded ~D times.~%" *tddoc*) +(format t "tddoc loaded ~D time~:P.~%" *tddoc*) (if (= *tddoc* 1) (defsystem "test-defsystem-depends-on-change" diff --git a/test/test-defsystem-depends-on-change.script b/test/test-defsystem-depends-on-change.script index b9e67992963e9a4f3ef2c9dd8532945cdc8d540f..bed60461058c326c6170d6cca1c3224805e2b926 100644 --- a/test/test-defsystem-depends-on-change.script +++ b/test/test-defsystem-depends-on-change.script @@ -10,7 +10,7 @@ (defparameter talc "test-asdf-location-change") (defparameter asdf-user::*tddoc* 0) - +(terpri)(terpri) (DBG "Load the system, using xach-foo-1") (push (subpathname *test-directory* "xach-foo-1/") *central-registry*) (clear-system tddoc) @@ -27,6 +27,8 @@ (subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd") (system-source-file talc)) + +(terpri)(terpri) (DBG "Load it again: there should be no changes") (load-system "test-defsystem-depends-on-change") (assert-equal asdf-user::*tddoc* 1) diff --git a/test/test-defsystem-depends-on.script b/test/test-defsystem-depends-on.script index c18880cc1cb5d12e391511d76ccc97e2e6a2f1e9..c83f13bab254798b6f444173b196fe99e7c7591b 100644 --- a/test/test-defsystem-depends-on.script +++ b/test/test-defsystem-depends-on.script @@ -47,7 +47,7 @@ (reset-session) (signals missing-dependency (def-test-system unloadable-system :defsystem-depends-on (nonexistent-system))) - (assert (not (system-registered-p "unloadable-system")))) + (assert (not (registered-system "unloadable-system")))) (progn (signals missing-dependency diff --git a/test/test-force.script b/test/test-force.script index f673f025bb29b1b4567261bd33501c6cb196e24e..586b30fa5148a89771ae2f64b9fe3f23709d9fcc 100644 --- a/test/test-force.script +++ b/test/test-force.script @@ -26,42 +26,42 @@ (assert file1-date) (reset-session-visited) -(let ((plan (force-plan :force t))) - (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 (not (asdf::plan-operates-on-p plan '("file3-only" "file3")))) - (assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1"))))) +(defparameter *plan* (force-plan :force t)) +(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 (not (asdf::plan-operates-on-p *plan* '("file3-only" "file3")))) +(assert (not (asdf::plan-operates-on-p *plan* '("test-asdf/force1" "file1")))) (reset-session-visited) -(let ((plan (force-plan :force :all))) - (DBG "Check that :force :all forces the current system and its dependencies" plan) - (assert plan) - (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 '("test-asdf/force1" "file1")))) +(defparameter *plan* (force-plan :force :all)) +(DBG "Check that :force :all forces the current system and its dependencies" *plan*) +(assert *plan*) +(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* '("test-asdf/force1" "file1"))) (reset-session-visited) -(let ((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) - (assert plan) - (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 '("test-asdf/force1" "file1"))))) +(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*) +(assert *plan*) +(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* '("test-asdf/force1" "file1")))) (reset-session-visited) -(let ((plan (force-plan :force-not :all))) - (DBG "Check that :force-not :all means \"all systems\"" plan) - (assert (null plan))) +(defparameter *plan* (force-plan :force-not :all)) +(DBG "Check that :force-not :all means \"all systems\"" *plan*) +(assert (null *plan*)) (reset-session-visited) -(let ((plan (force-plan :force :all :force-not :all))) - (DBG "Check that :force-not :all takes precedence over :force" plan) - (assert (null plan))) +(defparameter *plan* (force-plan :force :all :force-not :all)) +(DBG "Check that :force-not :all takes precedence over :force" *plan*) +(assert (null *plan*)) (reset-session-visited) -(let ((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) - (assert (null plan))) +(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*) +(assert (null *plan*)) (reset-session-visited) (let* ((asdf::*immutable-systems* (list-to-hash-set '("test-asdf/force1"))) diff --git a/test/test-preloaded.script b/test/test-preloaded.script index 3ab2c4649d3728ee904384b5fb07c3995fe3e1d4..c2d56f0e0d01c7ff375f5fac339839e9c2763d27 100644 --- a/test/test-preloaded.script +++ b/test/test-preloaded.script @@ -10,7 +10,7 @@ (DBG "Now let's register it as preloaded. Loading it will work!") (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. -(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. @@ -26,10 +26,10 @@ (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.") (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) -(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) -(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 diff --git a/test/test-require.script b/test/test-require.script index 3b449df2f93803a2a4b13a5e312e13613fd4b3e1..e5f708572adb88a4fff75477893b66a3043ba643 100644 --- a/test/test-require.script +++ b/test/test-require.script @@ -190,7 +190,7 @@ ;; Prevent ASDF from finding the modules as ASDF systems on ECL, MKCL, SBCL (and maybe more). (setf 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) diff --git a/test/test-touch-system-1.script b/test/test-touch-system-1.script index dc2dd541ff09a27b22bc2b497393f353a1a8dd11..2bb87412290b092680ac09d1fba859f8b2ebe9fb 100644 --- a/test/test-touch-system-1.script +++ b/test/test-touch-system-1.script @@ -6,7 +6,9 @@ (setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) (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) (defparameter test1.asd (nth-value 2 (locate-system :test1))) diff --git a/test/test-touch-system-2.script b/test/test-touch-system-2.script index 497f8e5521ffbf52078826760bef24a7850d5142..c7a6a7234abe70374ed46516b0f653e3b98bc06d 100644 --- a/test/test-touch-system-2.script +++ b/test/test-touch-system-2.script @@ -1,28 +1,32 @@ ;;; -*- Lisp -*- -;;; test system definition reloading if touched +;;; test system definition NOT reloaded if touched ;;; system that canNOT be found using *system-definition-search-functions* (setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) (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))) -(assert-pathname-equal test1.asd (test-source "test1.asd")) -(assert test1.asd) +(asdf::clear-registered-systems) +(defparameter test-asdf.asd (nth-value 2 (locate-system :test-asdf))) +(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) -(load test1.asd) -(assert (find-system :test1)) -(defparameter date1 (system-registered-time :test1)) +(load-asd test-asdf.asd) +(assert (registered-system :test-asdf)) +(defparameter date1 (system-registered-time :test-asdf)) (assert date1) +(assert-equal 1 test-asdf-system::*times-loaded*) -(asdf::clear-defined-systems) -(touch-file test1.asd :timestamp date1 :offset +2) -(load test1.asd) -(find-system :test1) -(defparameter date2 (system-registered-time :test1)) +(asdf::clear-registered-systems) +(touch-file test-asdf.asd :timestamp date1 :offset +2) +(load-asd test-asdf.asd) +(find-system :test-asdf) +(defparameter date2 (system-registered-time :test-asdf)) (assert date2) (assert-compare (> date2 date1))