From 51accff10a14f634285a33f2fd72a48f551c3340 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Sat, 19 Nov 2016 11:56:12 -0500
Subject: [PATCH] Add out-of-date detection for system definition

---
 action.lisp                                  |  89 ++++++++-------
 find-system.lisp                             | 109 ++++++++++++-------
 interface.lisp                               |   2 +-
 plan.lisp                                    |  45 +++++---
 system.lisp                                  |  14 ++-
 test/package-inferred-system-test.script     |   5 +-
 test/test-defsystem-depends-on-change.asd    |   1 +
 test/test-defsystem-depends-on-change.script |   5 +
 test/test-defsystem-depends-on.script        |   9 +-
 test/test-sysdef-asdf.script                 |  47 ++++----
 uiop/utility.lisp                            |   5 +-
 11 files changed, 192 insertions(+), 139 deletions(-)

diff --git a/action.lisp b/action.lisp
index 4f76099dc..bb95fc088 100644
--- a/action.lisp
+++ b/action.lisp
@@ -16,7 +16,7 @@
    #:input-files #:output-files #:output-file #:operation-done-p
    #:action-operation #:action-component #:make-action
    #:component-operation-time #:mark-operation-done #:compute-action-stamp
-   #:perform #:perform-with-restarts #:retry #:accept #:*action*
+   #:perform #:perform-with-restarts #:retry #:accept
    #:action-path #:find-action #:stamp #:done-p
    #:operation-definition-warning #:operation-definition-error ;; condition
    #:action-valid-p
@@ -50,9 +50,10 @@ and a class-name or class designates the canonical instance of the designated cl
 (with-upgradability ()
   (defun action-path (action)
     "A readable data structure that identifies the action."
-    (let ((o (action-operation action))
-          (c (action-component action)))
-      (cons (type-of o) (component-find-path c))))
+    (when action
+      (let ((o (action-operation action))
+            (c (action-component action)))
+        (cons (type-of o) (component-find-path c)))))
   (defun find-action (path)
     "Reconstitute an action from its action-path"
     (destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c)))))
@@ -110,7 +111,7 @@ and a class-name or class designates the canonical instance of the designated cl
                     ,if-no-component))))))))
 
 
-;;;; self-description
+;;;; Self-description
 (with-upgradability ()
   (defgeneric action-description (operation component)
     (:documentation "returns a phrase that describes performing this operation
@@ -128,6 +129,42 @@ Use it in FORMAT control strings as ~/asdf-action:format-action/"
       (princ (action-description operation component) stream))))
 
 
+;;;; Detection of circular dependencies
+(with-upgradability ()
+  (defun (action-valid-p) (operation component)
+    "Is this action valid to include amongst dependencies?"
+    ;; If either the operation or component was resolved to nil, the action is invalid.
+    ;; :if-feature will invalidate actions on components for which the features don't apply.
+    (and operation component
+         (if-let (it (component-if-feature component)) (featurep it) t)))
+
+  (define-condition circular-dependency (system-definition-error)
+    ((actions :initarg :actions :reader circular-dependency-actions))
+    (:report (lambda (c s)
+               (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
+                       (circular-dependency-actions c)))))
+
+  (defun call-while-visiting-action (operation component fun)
+    "Detect circular dependencies"
+    (with-asdf-session ()
+      (with-accessors ((action-set visiting-action-set)
+                       (action-list visiting-action-list)) *asdf-session*
+        (let ((action (cons operation component)))
+          (when (gethash action action-set)
+            (error 'circular-dependency :actions
+                   (member action (reverse action-list) :test 'equal)))
+          (setf (gethash action action-set) t)
+          (push action action-list)
+          (unwind-protect
+               (funcall fun)
+            (pop action-list)
+            (setf (gethash action action-set) nil))))))
+
+  ;; Syntactic sugar for call-while-visiting-action
+  (defmacro while-visiting-action ((o c) &body body)
+    `(call-while-visiting-action ,o ,c #'(lambda () ,@body))))
+
+
 ;;;; Dependencies
 (with-upgradability ()
   (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
@@ -410,11 +447,8 @@ Returns two values:
     (:documentation "PERFORM an action, consuming its input-files and building its output-files"))
   (define-convenience-action-methods perform (operation component))
 
-  (defvar *action* nil
-    "Action being performed")
   (defmethod perform :around ((o operation) (c component))
-    (let ((*action* (cons o c)))
-      (call-next-method)))
+    (while-visiting-action (o c) (call-next-method)))
   (defmethod perform :before ((o operation) (c component))
     (ensure-all-directories-exist (output-files o c)))
   (defmethod perform :after ((o operation) (c component))
@@ -452,40 +486,3 @@ Returns two values:
                     (action-description operation component)))
           (mark-operation-done operation component)
           (return))))))
-
-
-;;;; Detection of circular dependencies
-(with-upgradability ()
-  (defun (action-valid-p) (operation component)
-    "Is this action valid to include amongst dependencies?"
-    ;; If either the operation or component was resolved to nil, the action is invalid.
-    ;; :if-feature will invalidate actions on components for which the features don't apply.
-    (and operation component
-         (if-let (it (component-if-feature component)) (featurep it) t)))
-
-  (define-condition circular-dependency (system-definition-error)
-    ((actions :initarg :actions :reader circular-dependency-actions))
-    (:report (lambda (c s)
-               (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
-                       (circular-dependency-actions c)))))
-
-  (defun call-while-visiting-action (operation component fun)
-    "Detect circular dependencies"
-    (when (action-valid-p operation component)
-      (with-accessors ((action-set visiting-action-set)
-                       (action-list visiting-action-list)) *asdf-session*
-        (let ((action (cons operation component)))
-          (when (gethash action action-set)
-            (error 'circular-dependency :actions
-                   (member action (reverse action-list) :test 'equal)))
-          (setf (gethash action action-set) t)
-          (push action action-list)
-          (unwind-protect
-               (funcall fun)
-            (pop action-list)
-            (setf (gethash action action-set) nil))))))
-
-  ;; Syntactic sugar for call-while-visiting-action
-  (defmacro while-visiting-action ((o c) &body body)
-    `(call-while-visiting-action ,o ,c #'(lambda () ,@body))))
-
diff --git a/find-system.lisp b/find-system.lisp
index bf711eade..22114504b 100644
--- a/find-system.lisp
+++ b/find-system.lisp
@@ -8,7 +8,7 @@
         :asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate)
   (:export
    #:find-system #:locate-system #:load-asd #:define-op
-   #:load-system-definition-error #:error-name #:error-pathname #:error-condition))
+   #:load-system-definition-error #:error-name #:error-pathname #:error-condition #:system-out-of-date))
 (in-package :asdf/find-system)
 
 (with-upgradability ()
@@ -20,6 +20,13 @@
                (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
                        (error-name c) (error-pathname c) (error-condition c)))))
 
+  (define-condition system-out-of-date (condition)
+    ;; NB: not an error, not a warning, but a normal expected condition
+    ((name :initarg :name :reader component-name))
+    (:documentation "condition signaled when a system is detected as being out of date")
+    (:report (lambda (c s)
+               (format s "system ~A is out of date" (component-name c)))))
+
 
   ;;; Methods for find-system
 
@@ -50,13 +57,13 @@
                 (and (typep operation 'load-op)
                      (typep component 'system)
                      (equal "asdf" (coerce-name component))))
-      (when *action*
-        (let ((parent-operation (car *action*))
-              (parent-component (cdr *action*)))
+      (if-let ((action (first (visiting-action-list *asdf-session*))))
+        (let ((parent-operation (action-operation action))
+              (parent-component (action-component action)))
           (unless (and (typep parent-operation 'define-op) (typep parent-component 'system))
             (error "Invalid recursive use of (OPERATE ~S ~S) while visiting ~S ~
 - please use proper dependencies instead."
-                   operation component *action*))
+                   operation component action))
           (let ((action (cons operation component)))
             (unless (gethash action (definition-dependency-set parent-component))
               (push (cons operation component) (definition-dependency-list parent-component))
@@ -106,8 +113,8 @@
        (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
                      (coerce-name s) pathname)
        ;; dependencies will depend on what's loaded via definition-dependency-list
-       (unset-asdf-cache-entry `(component-depends-on ,o ,s))
-       (load* pathname :external-format (encoding-external-format (detect-encoding pathname))))))
+       (unset-asdf-cache-entry `(component-depends-on ,o ,s)))
+     (load* pathname :external-format (encoding-external-format (detect-encoding pathname)))))
 
   (defun load-asd (pathname &key name)
     "Load system definitions from PATHNAME.
@@ -123,7 +130,9 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
             (progn
               ;; We already determine this to be obsolete ---
               ;; or should we move some tests from find-system to check for up-to-date-ness here?
-              (setf (component-operation-time operation system) nil)
+              (setf (component-operation-time operation system) nil
+                    (definition-dependency-list system) nil
+                    (definition-dependency-set system) (list-to-hash-set nil))
               (do-it operation system))
             (let ((system (make-instance 'undefined-system
                                          :name primary-name :source-file pathname)))
@@ -214,38 +223,58 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
   ;; preloaded, with a previous configuration, or before filesystem changes), and
   ;; load a found .asd if appropriate. Finally, update registration table and return results.
   (defmethod find-system ((name string) &optional (error-p t))
-    (with-asdf-session (:key `(find-system ,name))
-      (let ((primary-name (primary-system-name name)))
-        (unless (equal name primary-name)
-          (find-system primary-name nil)))
-      (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name))
-          (multiple-value-bind (foundp found-system pathname previous previous-time)
-              (locate-system name)
-            (assert (eq foundp (and (or found-system pathname previous) t)))
-            (let ((previous-pathname (system-source-file previous))
-                  (system (or previous found-system)))
-              (when (and found-system (not previous))
-                (register-system found-system))
-              (when (and system pathname)
-                (setf (system-source-file system) pathname))
-              (if-let ((stamp (get-file-stamp pathname)))
-                (let ((up-to-date-p
-                       (and previous
-                            (or (pathname-equal pathname previous-pathname)
-                                (and pathname previous-pathname
-                                     (pathname-equal
-                                      (physicalize-pathname pathname)
-                                      (physicalize-pathname previous-pathname))))
-                            (stamp<= 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.
-                            )))
-                  (unless up-to-date-p
-                    (load-asd pathname :name name)))))
-            ;; Try again after having loaded from disk if needed
-            (or (registered-system name)
-                (when error-p (error 'missing-component :requires name)))))))
+    (nest
+     (with-asdf-session (:key `(find-system ,name)))
+     (let* ((name-primary-p (primary-system-p name))
+            (primary-system (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)
+         (locate-system name)
+       (assert (eq foundp (and (or found-system pathname previous) t))))
+     (let ((previous-pathname (system-source-file previous))
+           (system (or previous found-system)))
+       (when (and found-system (not previous))
+         (register-system found-system))
+       (when (and system pathname)
+         (setf (system-source-file system) pathname))
+       (if-let ((stamp (get-file-stamp pathname)))
+         (let ((up-to-date-p
+                (and previous
+                     (or (pathname-equal pathname previous-pathname)
+                         (and pathname previous-pathname
+                              (pathname-equal
+                               (physicalize-pathname pathname)
+                               (physicalize-pathname previous-pathname))))
+                     (stamp<= 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.
+                     (loop :with plan = (or (and *asdf-session*
+                                                 (session-plan *asdf-session*))
+                                            (make-instance *plan-class*))
+                       :for action :in (definition-dependency-list previous)
+                       :always (handler-bind
+                                   ((system-out-of-date
+                                     (lambda (c) (declare (ignore c)) (return nil))))
+                                 (action-up-to-date-p plan
+                                                      (action-operation action)
+                                                      (action-component action)))
+                       :finally
+                       (let ((o (make-operation 'define-op))
+                             (s (if name-primary-p previous primary-system)))
+                         (when s
+                           (multiple-value-bind (stamp done-p)
+                               (compute-action-stamp plan o s)
+                             (return (and (stamp<= stamp (component-operation-time o s))
+                                          done-p)))))))))
+           (unless up-to-date-p
+             (restart-case
+                 (signal 'system-out-of-date :name name)
+               (continue () :report "continue"))
+             (load-asd pathname :name name)))))
+     ;; Try again after having loaded from disk if needed
+     (or (registered-system name)
+         (when error-p (error 'missing-component :requires name)))))
 
   ;; Resolved forward reference for asdf/system-registry.
   (defun mark-component-preloaded (component)
diff --git a/interface.lisp b/interface.lisp
index d6e6ec7f0..f8a45374e 100644
--- a/interface.lisp
+++ b/interface.lisp
@@ -123,7 +123,7 @@
    #:missing-dependency
    #:missing-dependency-of-version
    #:circular-dependency        ; errors
-   #:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name
+   #:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name #:system-out-of-date
    #:package-inferred-system-missing-package-error
    #:operation-definition-warning #:operation-definition-error
 
diff --git a/plan.lisp b/plan.lisp
index edadac948..f3c3d2b88 100644
--- a/plan.lisp
+++ b/plan.lisp
@@ -18,7 +18,7 @@
    #:record-dependency
    #:normalize-forced-systems #:action-forced-p #:action-forced-not-p
    #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
-   #:compute-action-stamp #:traverse-action
+   #:compute-action-stamp #:traverse-action #:action-up-to-date-p
    #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p
    #:planned-p #:index #:forced #:forced-not
    #:plan-actions-r
@@ -73,6 +73,9 @@ in some previous image, or T if it needs to be done.")
         +action-status-out-of-date+
         (make-instance 'action-status :stamp stamp :done-p done-p :planned-p planned-p :index index)))
 
+  (defun action-status-out-of-date-p (status)
+    (eq (action-stamp status) t))
+
   (defmethod print-object ((status action-status) stream)
     (print-unreadable-object (status stream :type t)
       (with-slots (stamp done-p planned-p index) status
@@ -104,6 +107,7 @@ the action of OPERATION on COMPONENT in the PLAN"))
           (setf (gethash o times) (action-stamp new-status))))
     new-status))
 
+
 ;;;; forcing
 (with-upgradability ()
   (defgeneric action-forced-p (plan operation component)
@@ -346,8 +350,9 @@ initialized with SEED."
 
   (defun action-up-to-date-p (plan operation component)
     "Check whether a node is up-to-date, and mark it so if such. But don't add anything to the plan."
-    (while-visiting-action (operation component) ; maintain context, handle circularity.
-      (block nil
+    (block nil
+      (unless (action-valid-p operation component) (return nil))
+      (while-visiting-action (operation component) ; maintain context, handle circularity.
         ;; Do NOT record the dependency: it might be out of date.
         (let ((status (action-status plan operation component)))
           (when status
@@ -369,12 +374,13 @@ initialized with SEED."
           (not (eq (action-stamp status) t))))))
 
   (defmethod traverse-action (plan operation component needed-in-image-p)
-    (while-visiting-action (operation component) ; maintain context, handle circularity.
-      (block nil
-        ;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph,
-        ;; instead of just a dependency order as in vanilla ASDF.
-        ;; TODO: It is also needed to detect OPERATE-in-PERFORM.
-        (record-dependency plan operation component)
+    (block nil
+      (unless (action-valid-p operation component) (return nil))
+      ;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph,
+      ;; instead of just a dependency order as in vanilla ASDF.
+      ;; TODO: It is also needed to detect OPERATE-in-PERFORM.
+      (record-dependency plan operation component)
+      (while-visiting-action (operation component) ; maintain context, handle circularity.
         ;; needed-in-image distinguishes b/w things that must happen in the
         ;; current image and those things that simply need to have been done in a previous one.
         (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image
@@ -451,6 +457,8 @@ initialized with SEED."
     (with-asdf-session ()
       (let ((plan (apply 'make-instance (or plan-class *plan-class*)
                          :system (component-system c) keys)))
+        (when (and (null (session-plan *asdf-session*)) (plan-performable-p plan))
+          (setf (session-plan *asdf-session*) plan))
         (traverse-action plan o c t)
         plan)))
 
@@ -506,15 +514,16 @@ initialized with SEED."
         :collect (cons o c))))
 
   (defun collect-action-dependencies (plan operation component)
-    (while-visiting-action (operation component) ; maintain context, handle circularity.
-      (let ((action (make-action operation component)))
-        (unless (gethash action (visited-actions *asdf-session*))
-          (setf (gethash action (visited-actions *asdf-session*)) t)
-          (when (and (typep component (plan-component-type plan))
-                     (not (action-forced-not-p plan operation component)))
-            (map-direct-dependencies operation component
-                                     #'(lambda (o c) (collect-action-dependencies plan o c)))
-            (push action (plan-actions-r plan)))))))
+    (when (action-valid-p operation component)
+      (while-visiting-action (operation component) ; maintain context, handle circularity.
+        (let ((action (make-action operation component)))
+          (unless (gethash action (visited-actions *asdf-session*))
+            (setf (gethash action (visited-actions *asdf-session*)) t)
+            (when (and (typep component (plan-component-type plan))
+                       (not (action-forced-not-p plan operation component)))
+              (map-direct-dependencies operation component
+                                       #'(lambda (o c) (collect-action-dependencies plan o c)))
+              (push action (plan-actions-r plan))))))))
 
   (defgeneric collect-dependencies (operation component &key &allow-other-keys)
     (:documentation "Given an action, build a plan for all of its dependencies."))
diff --git a/system.lisp b/system.lisp
index 94f71a05c..d2e93514f 100644
--- a/system.lisp
+++ b/system.lisp
@@ -60,7 +60,14 @@ NB: This interface is subject to change. Please contact ASDF maintainers if you
   (defclass proto-system () ; slots to keep when resetting a system
     ;; To preserve identity for all objects, we'd need keep the components slots
     ;; but also to modify parse-component-form to reset the recycled objects.
-    ((name) (source-file))
+    ((name)
+     (source-file)
+     ;; These two slots contains the *inferred* dependencies of define-op,
+     ;; from loading the .asd file, as list and as set.
+     (definition-dependency-list
+         :initform nil :accessor definition-dependency-list)
+     (definition-dependency-set
+         :initform (list-to-hash-set nil) :accessor definition-dependency-set))
     (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when
 a SYSTEM is redefined and its class is modified."))
 
@@ -89,11 +96,6 @@ a SYSTEM is redefined and its class is modified."))
      ;; This slot contains the *declared* defsystem-depends-on dependencies
      (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on
                            :initform nil)
-     ;; These slots contains the *inferred* dependencies of define-op, as list and as set
-     (definition-dependency-list
-         :initform nil :accessor definition-dependency-list)
-     (definition-dependency-set
-         :initform (list-to-hash-set nil) :accessor definition-dependency-set)
      ;; these two are specially set in parse-component-form, so have no :INITARGs.
      (depends-on :reader system-depends-on :initform nil)
      (weakly-depends-on :reader system-weakly-depends-on :initform nil))
diff --git a/test/package-inferred-system-test.script b/test/package-inferred-system-test.script
index 6ff089171..cedbb612f 100644
--- a/test/package-inferred-system-test.script
+++ b/test/package-inferred-system-test.script
@@ -1,3 +1,5 @@
+;;-*- Lisp -*-
+
 (register-directory (subpathname *test-directory* "package-inferred-system-test/"))
 (load-system :package-inferred-system-test/a/x)
 (load-system :package-inferred-system-test/d)
@@ -5,7 +7,8 @@
 (signals package-inferred-system-missing-package-error (load-system :package-inferred-system-test/e))
 
 ;; No such file.
-(signals missing-component (load-system :package-inferred-system-test/f))
+(signals missing-component
+         (handler-bind ((system-out-of-date 'continue)) (load-system :package-inferred-system-test/f)))
 
 ;; Test that around-compile is inherited by inferred systems.
 (assert-equal 3 (symbol-call :package-inferred-system-test/a :add10 1)) ;; add10 must have been compiled in base 2
diff --git a/test/test-defsystem-depends-on-change.asd b/test/test-defsystem-depends-on-change.asd
index 3c17719c0..7d5e46074 100644
--- a/test/test-defsystem-depends-on-change.asd
+++ b/test/test-defsystem-depends-on-change.asd
@@ -1,5 +1,6 @@
 (defvar *tddoc* 0)
 (incf *tddoc*)
+(format t "tddoc loaded ~D times.~%" *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 1cd72686d..923974b6d 100644
--- a/test/test-defsystem-depends-on-change.script
+++ b/test/test-defsystem-depends-on-change.script
@@ -8,10 +8,12 @@
 
 (defparameter tddoc "test-defsystem-depends-on-change")
 (defparameter talc "test-asdf-location-change")
+(defparameter asdf-user::*tddoc* 0)
 
 
 (DBG "Load the system, using xach-foo-1")
 (push (subpathname *test-directory* "xach-foo-1/") *central-registry*)
+(clear-system tddoc)
 (load-system tddoc)
 (assert-equal asdf-user::*tddoc* 1)
 (assert-equal test-asdf-system::*times-loaded* 1)
@@ -39,9 +41,12 @@
  (subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd")
  (system-source-file talc))
 
+
 (DBG "Now, change a defsystem-depends-on dependency and try again")
 (setf (first *central-registry*) (subpathname *test-directory* "xach-foo-2/"))
+(DBG :before asdf-user::*tddoc* test-asdf-system::*times-loaded* test-asdf-system::*ta/dcc* test-asdf-system::*ta/dcd* test-asdf-system::*ta/dca*)
 (load-system "test-defsystem-depends-on-change")
+(DBG :after asdf-user::*tddoc* test-asdf-system::*times-loaded* test-asdf-system::*ta/dcc* test-asdf-system::*ta/dcd* test-asdf-system::*ta/dca*)
 (assert-equal asdf-user::*tddoc* 2)
 (assert-equal test-asdf-system::*times-loaded* 1) ;; from test-asdf.asd
 (assert-equal test-asdf-system::*ta/dcc* 2)
diff --git a/test/test-defsystem-depends-on.script b/test/test-defsystem-depends-on.script
index 2d64319a1..c18880cc1 100644
--- a/test/test-defsystem-depends-on.script
+++ b/test/test-defsystem-depends-on.script
@@ -31,7 +31,8 @@
   :components ((:file "file3")))
 
 (reset-session)
-(signals asdf::formatted-system-definition-error (make :test-defsystem-depends-on-3))
+(signals asdf::formatted-system-definition-error
+         (handler-bind ((system-out-of-date 'continue)) (make :test-defsystem-depends-on-3)))
 
 (defparameter *newsym* (gentemp (symbol-name 'feature) :keyword))
 
@@ -49,9 +50,11 @@
   (assert (not (system-registered-p "unloadable-system"))))
 
 (progn
-  (signals missing-dependency (find-system "test-defsystem-depends-on-missing-system"))
+  (signals missing-dependency
+           (handler-bind ((system-out-of-date 'continue)) (find-system "test-defsystem-depends-on-missing-system")))
   (assert (not (asdf::registered-system "test-defsystem-depends-on-missing-system"))))
 
 (progn
-  (signals asdf::system-definition-error (find-system "test-defsystem-depends-on-circular"))
+  (signals asdf::system-definition-error
+           (handler-bind ((system-out-of-date 'continue)) (find-system "test-defsystem-depends-on-circular")))
   (assert (not (asdf::registered-system "test-defsystem-depends-on-circular"))))
diff --git a/test/test-sysdef-asdf.script b/test/test-sysdef-asdf.script
index 07d7931e4..e611d2f78 100644
--- a/test/test-sysdef-asdf.script
+++ b/test/test-sysdef-asdf.script
@@ -2,16 +2,17 @@
 
 (format! t "~%Using ASDF ~A~%" (asdf-version))
 (assert (version< "3.0" (asdf-version))) ;; check that we have a recent enough ASDF
-
 (setf *asdf-session* nil)
 
+
 (DBG "Let's define some methods on input-files, to later check what an upgrade does to them.")
 (with-asdf-session (:override t)
   (def-test-system "fooey")
   (defparameter *ticks* 0)
   (defun tick () (incf *ticks*))
-  (defsystem "foo")
-  (defmethod input-files :after ((o load-op) (c system)) (tick))
+  (def-test-system "foo")
+  (defmethod input-files :after ((o load-op) (c system))
+    (tick))
   (assert-equal *ticks* 0)
   (input-files 'load-op "foo")
   (assert-equal *ticks* 1)
@@ -19,6 +20,7 @@
   (assert-equal *ticks* 1) ;; It was cached.
   (assert (find-system "fooey" nil)))
 
+
 (DBG "Try load ASDF with an empty configuration")
 (initialize-source-registry
  '(:source-registry :ignore-inherited-configuration))
@@ -26,15 +28,15 @@
 ;; We haven't found it, and got the fallback
 (assert-equal nil (system-source-file (find-system :asdf)))
 
+
+(DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore")
+(clear-system "asdf")
 ;; Bogus sysdef finding function, for the sake of testing no-load-old-version.
 (defun sysdef-bogus-test-search (system)
   (declare (ignore system))
   (subpathname *test-directory* "always-error.lisp"))
-
-(clear-system "asdf")
 (let ((*system-definition-search-functions* '(sysdef-bogus-test-search))
       (state "Didn't catch warning"))
-  (DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore")
   (handler-bind
       ((simple-warning
          #'(lambda (c)
@@ -43,8 +45,11 @@
                (setf state "Caught warning")))))
     (clear-system "asdf")
     (upgrade-asdf))
-  (assert-equal state "Caught warning")
-  (DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning")
+  (assert-equal state "Caught warning"))
+
+
+(DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning")
+(let ((*system-definition-search-functions* '(sysdef-bogus-test-search)))
   (handler-bind
       ((simple-warning
          #'(lambda (c)
@@ -53,6 +58,7 @@
     (upgrade-asdf)))
 (assert-equal nil (system-source-file (find-system :asdf)))
 
+
 (DBG "Load ASDF with proper configuration: should find asdf.asd from the source above")
 (initialize-source-registry
  `(:source-registry
@@ -60,18 +66,17 @@
    (:directory ,*uiop-directory*)
    :ignore-inherited-configuration))
 (clear-system "asdf")
-
 (with-asdf-session (:override t)
   (with-expected-failure (#+xcl t)    ;; expected-failure: XCL has trouble with the ASDF upgrade
     (load-system :asdf)
     (assert-pathname-equal (subpathname *asdf-directory* "asdf.asd")
                            (system-source-file (find-system :asdf))))
-
   (DBG "Loading from the same version shouldn't have reset methods")
   (setf *ticks* 2)
   (input-files 'load-op "foo")
   (assert-equal *ticks* 3))
 
+
 (DBG "Loading from an ancient version WILL reset methods")
 (assert (find-system "fooey" nil))
 (defparameter *current-version* (asdf-version))
@@ -79,7 +84,6 @@
 (assert (asdf/upgrade::upgrading-p))
 (clear-system "asdf")
 (reset-session)
-
 (with-expected-failure (#+xcl t)
   ;; expected-failure: XCL has trouble with the ASDF upgrade
   (load-system :asdf)
@@ -88,7 +92,7 @@
                          (system-source-file (find-system :asdf))))
 
 
-;; Upgrading from an old-enough version redefined away the input-files method!
+(DBG "Upgrading from an old-enough version should have redefined away the input-files method!")
 (setf *ticks* 4)
 (input-files 'load-op "asdf")
 (assert-equal *ticks* 4)
@@ -96,38 +100,37 @@
 (assert (not (find-system "fooey" nil)))
 
 
+(DBG "Actually upgrade, from a different but forward-compatible version")
 ;; The data-punting upgrade will mess up component identity, so clear the cache
 (reset-session)
-
 (setf asdf::*asdf-version* asdf/upgrade::*oldest-forward-compatible-asdf-version*)
 (clear-system "asdf")
 (def-test-system "fooey")
-(setf *ticks* 5)
-(defmethod input-files :after ((load-op operation) (c system))
+(setf *ticks* 10)
+(defmethod input-files :after ((o load-op) (c system))
+  (DBG :input-files o c)
   (incf *ticks*))
 (input-files 'load-op "uiop")
-(assert-equal *ticks* 8)
+(assert-equal *ticks* 11)
 (with-expected-failure (#+xcl t)
   ;; expected-failure: XCL has trouble with the ASDF upgrade
   (load-system :asdf))
 ;; Upgrading from a recent-enough version, the input-files method was preserved!
 ;; But we need to clear the cache for it not to be short-circuited.
 (reset-session)
-
 (assert (find-system "fooey" nil))
-
-(setf *ticks* 9)
+(setf *ticks* 20)
 (eval '(input-files 'load-op "uiop"))
-(assert-equal *ticks* 12)
+(assert-equal *ticks* 21)
+
 
+(DBG "Checking that the bootstrap script and asdf.asd are in synch")
 (defun bootstrap-lisp-files (file line-prefix)
   (with-input-file (input (subpathname *asdf-directory* file))
     (loop :for line = (read-line input)
       :when (string-prefix-p line-prefix line)
       :return (subseq line (length line-prefix))
       :finally (error "Didn't find ~a in ~a" line-prefix file))))
-
-(DBG "Checking that the bootstrap script and asdf.asd are in synch")
 (defun system-lisp-files (system)
   (loop :for f :in (input-files 'concatenate-source-op system)
     :collect (unix-namestring (enough-pathname f *asdf-directory*))))
diff --git a/uiop/utility.lisp b/uiop/utility.lisp
index eb9ebf54f..7869e5acc 100644
--- a/uiop/utility.lisp
+++ b/uiop/utility.lisp
@@ -82,8 +82,9 @@ to supersede any previous definition."
 (with-upgradability ()
   (defvar *uiop-debug-utility*
     '(or (ignore-errors
-          (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp"))
-      (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp"))
+           (probe-file (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp")))
+      (probe-file (symbol-call :uiop/pathname :subpathname
+                   (user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp")))
     "form that evaluates to the pathname to your favorite debugging utilities")
 
   (defmacro uiop-debug (&rest keys)
-- 
GitLab