Commit 069cd2a6 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Better handle misnamed secondary systems

Distinguish between "syntactic" primariness ("foo" vs "foo/bar" names) and "semantic" primariness (system foo in foo.asd vs system foo in bar.asd), and use the right one at all right place: when checking if a system is up-to-date, what matters is that the old primary system is at the same place as before, and is up-to-date. Thinking about it, there is a lingering bug in case a definition-dependency are up-to-date, but were modified after the definition was read. What is really needed is a prepare-define-op. Sigh.
parent 5397c994
......@@ -82,11 +82,9 @@
;; TODO: could this file be refactored so that locate-system is merely
;; the cache-priming call to input-files here?
(defmethod input-files ((o define-op) (s system))
(assert (equal (coerce-name s) (primary-system-name s)))
(if-let ((asd (system-source-file s))) (list asd)))
(defmethod perform ((o define-op) (s system))
(assert (equal (coerce-name s) (primary-system-name s)))
(nest
(if-let ((pathname (first (input-files o s)))))
(let ((readtable *readtable*) ;; save outer syntax tables. TODO: proper syntax-control
......@@ -195,21 +193,25 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
(defun locate-system (name)
"Given a system NAME designator, try to locate where to load the system from.
Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
Returns six values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME PREVIOUS-PRIMARY
FOUNDP is true when a system was found,
either a new unregistered one or a previously registered one.
FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed.
PATHNAME when not null is a path from which to load the system,
either associated with FOUND-SYSTEM, or with the PREVIOUS system.
PREVIOUS when not null is a previously loaded SYSTEM object of same name.
PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
PREVIOUS-PRIMARY when not null is the primary system for the PREVIOUS system."
(with-asdf-session () ;; NB: We don't cache the results. We once used to, but it wasn't useful,
;; 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))
(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)))
(previous-primary-name (and previous (primary-system-name previous)))
(previous-primary-system (and previous-primary-name
(registered-system previous-primary-name)))
(previous-time (and previous-primary-system
(component-operation-time 'define-op previous-primary-system)))
(found (search-for-system-definition name))
(found-system (and (typep found 'system) found))
(pathname (ensure-pathname
......@@ -222,37 +224,38 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(unless (check-not-old-asdf-system name pathname)
(check-type previous system) ;; asdf is preloaded, so there should be a previous one.
(setf found-system nil pathname nil))
(values foundp found-system pathname previous previous-time))))
(values foundp found-system pathname previous previous-time previous-primary-system))))
;; TODO: make a prepare-define-op node for this
;; so we can properly cache the answer rather than recompute it.
(defun definition-dependencies-up-to-date-p (system)
(check-type system system)
(or (not (primary-system-p system))
(handler-case
(loop :with plan = (make-instance *plan-class*)
:for action :in (definition-dependency-list system)
:always (action-up-to-date-p
plan (action-operation action) (action-component action))
:finally
(let ((o (make-operation 'define-op)))
(multiple-value-bind (stamp done-p)
(compute-action-stamp plan o system)
(return (and (timestamp<= stamp (component-operation-time o system))
done-p)))))
(system-out-of-date () nil))))
;; Main method for find-system: first, make sure the computation is memoized in a session cache.
;; Unless the system is immutable, use locate-system to find the primary system;
;; reconcile the finding (if any) with any previous definition (in a previous session,
;; preloaded, with a previous configuration, or before filesystem changes), and
;; load a found .asd if appropriate. Finally, update registration table and return results.
(defun definition-dependencies-up-to-date-p (system)
(check-type system system)
(assert (primary-system-p system))
(handler-case
(loop :with plan = (make-instance *plan-class*)
:for action :in (definition-dependency-list system)
:always (action-up-to-date-p
plan (action-operation action) (action-component action))
:finally
(let ((o (make-operation 'define-op)))
(multiple-value-bind (stamp done-p)
(compute-action-stamp plan o system)
(return (and (timestamp<= stamp (component-operation-time o system))
done-p)))))
(system-out-of-date () nil)))
(defmethod find-system ((name string) &optional (error-p t))
(nest
(with-asdf-session (:key `(find-system ,name)))
(let ((name-primary-p (primary-system-p name)))
(unless name-primary-p (find-system (primary-system-name name) nil)))
(or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name)))
(multiple-value-bind (foundp found-system pathname previous previous-time)
(multiple-value-bind (foundp found-system pathname previous previous-time previous-primary)
(locate-system name)
(assert (eq foundp (and (or found-system pathname previous) t))))
(let ((previous-pathname (system-source-file previous))
......@@ -263,18 +266,18 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(setf (system-source-file system) pathname))
(if-let ((stamp (get-file-stamp pathname)))
(let ((up-to-date-p
(and previous
(and previous previous-primary
(or (pathname-equal pathname previous-pathname)
(and pathname previous-pathname
(pathname-equal
(physicalize-pathname pathname)
(physicalize-pathname previous-pathname))))
(timestamp<= stamp previous-time)
;; TODO: check that all dependencies are up-to-date.
;; This necessitates traversing them without triggering
;; the adding of nodes to the plan.
(or (not name-primary-p)
(definition-dependencies-up-to-date-p previous)))))
;; Check that all previous definition-dependencies are up-to-date,
;; traversing them without triggering the adding of nodes to the plan.
;; TODO: actually have a prepare-define-op, extract its timestamp,
;; and check that it is less than the stamp of the previous define-op ?
(definition-dependencies-up-to-date-p previous-primary))))
(unless up-to-date-p
(restart-case
(signal 'system-out-of-date :name name)
......
......@@ -126,21 +126,33 @@ a SYMBOL (designing its name, downcased), or a STRING (designing itself)."
(t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
(defun primary-system-name (system-designator)
"Given a system designator NAME, return the name of the corresponding primary system,
after which the .asd file is named. That's the first component when dividing the name
as a string by / slashes. A component designates its system."
"Given a system designator NAME, return the name of the corresponding
primary system, after which the .asd file in which it is defined is named.
If given a string or symbol (to downcase), do it syntactically
by stripping anything from the first slash on.
If given a component, do it semantically by extracting
the system-primary-system-name of 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))))))
(component (let* ((system (component-system system-designator))
(source-file (physicalize-pathname (system-source-file system))))
(and source-file
(equal (pathname-type source-file) "asd")
(pathname-name source-file))))))
(defun primary-system-p (system)
"Given a system designator SYSTEM, return T if it designates a primary system, or else NIL.
Also return NIL if system is neither a SYSTEM nor a string designating one."
(typecase system
If given a string, do it syntactically and return true if the name does not contain a slash.
If given a symbol, downcase to a string then fallback to previous case (NB: for NIL return T).
If given a component, do it semantically and return T if it's a SYSTEM and its primary-system-name
is the same as its component-name."
(etypecase system
(string (not (find #\/ system)))
(system (primary-system-p (coerce-name system)))))
(symbol (primary-system-p (coerce-name system)))
(component (and (typep system 'system)
(equal (component-name system) (primary-system-name system))))))
(defun coerce-filename (name)
"Coerce a system designator NAME into a string suitable as a filename component.
......
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