Commit 206c1248 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 897a142b
......@@ -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))))
(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)))
......
......@@ -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
......
......@@ -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*
......
......@@ -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.
......
......@@ -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)
......
......@@ -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;
......
......@@ -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)
......
......@@ -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))
(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"
......
......@@ -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)
......
......@@ -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
......
......@@ -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")))
......
......@@ -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
......@@ -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)
......
......@@ -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)))
......
;;; -*- 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))
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