From 069cd2a66bc64a38d87b083aca2cbddeee0127ed Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Wed, 3 Jan 2018 11:17:32 -0500 Subject: [PATCH] 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. --- find-system.lisp | 65 +++++++++++++++++++++++++----------------------- system.lisp | 26 +++++++++++++------ 2 files changed, 53 insertions(+), 38 deletions(-) diff --git a/find-system.lisp b/find-system.lisp index c39f1f02..be3c6d36 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -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) diff --git a/system.lisp b/system.lisp index 3325ee46..cdfc5723 100644 --- a/system.lisp +++ b/system.lisp @@ -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. -- GitLab