Skip to content
Snippets Groups Projects
Commit 069cd2a6 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

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
No related branches found
No related tags found
No related merge requests found
...@@ -82,11 +82,9 @@ ...@@ -82,11 +82,9 @@
;; TODO: could this file be refactored so that locate-system is merely ;; TODO: could this file be refactored so that locate-system is merely
;; the cache-priming call to input-files here? ;; the cache-priming call to input-files here?
(defmethod input-files ((o define-op) (s system)) (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))) (if-let ((asd (system-source-file s))) (list asd)))
(defmethod perform ((o define-op) (s system)) (defmethod perform ((o define-op) (s system))
(assert (equal (coerce-name s) (primary-system-name s)))
(nest (nest
(if-let ((pathname (first (input-files o s))))) (if-let ((pathname (first (input-files o s)))))
(let ((readtable *readtable*) ;; save outer syntax tables. TODO: proper syntax-control (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." ...@@ -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) (defun locate-system (name)
"Given a system NAME designator, try to locate where to load the system from. "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, FOUNDP is true when a system was found,
either a new unregistered one or a previously registered one. 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. 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, PATHNAME when not null is a path from which to load the system,
either associated with FOUND-SYSTEM, or with the PREVIOUS 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 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, (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 ;; 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))
(previous (registered-system name)) ; load from disk if absent or newer on disk (previous (registered-system name)) ; load from disk if absent or newer on disk
(primary (registered-system (primary-system-name name))) (previous-primary-name (and previous (primary-system-name previous)))
(previous-time (and previous primary (component-operation-time 'define-op primary))) (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 (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
...@@ -222,37 +224,38 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -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) (unless (check-not-old-asdf-system name pathname)
(check-type previous system) ;; asdf is preloaded, so there should be a previous one. (check-type previous system) ;; asdf is preloaded, so there should be a previous one.
(setf found-system nil pathname nil)) (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. ;; 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; ;; 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, ;; reconcile the finding (if any) with any previous definition (in a previous session,
;; preloaded, with a previous configuration, or before filesystem changes), and ;; preloaded, with a previous configuration, or before filesystem changes), and
;; load a found .asd if appropriate. Finally, update registration table and return results. ;; 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)) (defmethod find-system ((name string) &optional (error-p t))
(nest (nest
(with-asdf-session (:key `(find-system ,name))) (with-asdf-session (:key `(find-system ,name)))
(let ((name-primary-p (primary-system-p name))) (let ((name-primary-p (primary-system-p name)))
(unless name-primary-p (find-system (primary-system-name name) nil))) (unless name-primary-p (find-system (primary-system-name name) nil)))
(or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name))) (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) (locate-system name)
(assert (eq foundp (and (or found-system pathname previous) t)))) (assert (eq foundp (and (or found-system pathname previous) t))))
(let ((previous-pathname (system-source-file previous)) (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. ...@@ -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)) (setf (system-source-file system) pathname))
(if-let ((stamp (get-file-stamp pathname))) (if-let ((stamp (get-file-stamp pathname)))
(let ((up-to-date-p (let ((up-to-date-p
(and previous (and previous previous-primary
(or (pathname-equal pathname previous-pathname) (or (pathname-equal pathname previous-pathname)
(and pathname previous-pathname (and pathname previous-pathname
(pathname-equal (pathname-equal
(physicalize-pathname pathname) (physicalize-pathname pathname)
(physicalize-pathname previous-pathname)))) (physicalize-pathname previous-pathname))))
(timestamp<= stamp previous-time) (timestamp<= stamp previous-time)
;; TODO: check that all dependencies are up-to-date. ;; Check that all previous definition-dependencies are up-to-date,
;; This necessitates traversing them without triggering ;; traversing them without triggering the adding of nodes to the plan.
;; the adding of nodes to the plan. ;; TODO: actually have a prepare-define-op, extract its timestamp,
(or (not name-primary-p) ;; and check that it is less than the stamp of the previous define-op ?
(definition-dependencies-up-to-date-p previous))))) (definition-dependencies-up-to-date-p previous-primary))))
(unless up-to-date-p (unless up-to-date-p
(restart-case (restart-case
(signal 'system-out-of-date :name name) (signal 'system-out-of-date :name name)
......
...@@ -126,21 +126,33 @@ a SYMBOL (designing its name, downcased), or a STRING (designing itself)." ...@@ -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)))) (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
(defun primary-system-name (system-designator) (defun primary-system-name (system-designator)
"Given a system designator NAME, return the name of the corresponding primary system, "Given a system designator NAME, return the name of the corresponding
after which the .asd file is named. That's the first component when dividing the name primary system, after which the .asd file in which it is defined is named.
as a string by / slashes. A component designates its system." 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 (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))) (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) (defun primary-system-p (system)
"Given a system designator SYSTEM, return T if it designates a primary system, or else NIL. "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." If given a string, do it syntactically and return true if the name does not contain a slash.
(typecase system 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))) (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) (defun coerce-filename (name)
"Coerce a system designator NAME into a string suitable as a filename component. "Coerce a system designator NAME into a string suitable as a filename component.
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment