From 84e17ea087a1707eb96d36f3ce7e0d8d1de73b69 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Thu, 20 Mar 2014 13:17:34 -0400
Subject: [PATCH] Fold *systems-being-defined* into the *asdf-cache*. Add
 regression test for no infinite loop when processing asd files that mutually
 define each other's systems. (Prompted by Robert Strandh inquiring about the
 bug fixed in 2.015.[23] after my mentioning an infinite loop in my ASDF3
 article.) Checked that removing the set-asdf-cache-entry in parse-defsystem
 triggers the bug.

---
 cache.lisp                           | 17 +++---
 find-system.lisp                     | 83 +++++++++++-----------------
 interface.lisp                       |  2 +-
 operate.lisp                         | 12 ++--
 parse-defsystem.lisp                 |  8 +--
 test/test-mutual-redefinition-1.asd  |  2 +
 test/test-mutual-redefinition-2.asd  |  2 +
 test/test-mutual-redefinition.script | 33 +++++++++++
 8 files changed, 89 insertions(+), 70 deletions(-)
 create mode 100644 test/test-mutual-redefinition-1.asd
 create mode 100644 test/test-mutual-redefinition-2.asd
 create mode 100644 test/test-mutual-redefinition.script

diff --git a/cache.lisp b/cache.lisp
index 4ca218f4..729a184e 100644
--- a/cache.lisp
+++ b/cache.lisp
@@ -4,7 +4,7 @@
 (uiop/package:define-package :asdf/cache
   (:use :uiop/common-lisp :uiop :asdf/upgrade)
   (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
-           #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring
+           #:set-asdf-cache-entry #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring
            #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
 (in-package :asdf/cache)
 
@@ -33,14 +33,15 @@
   (defmacro do-asdf-cache (key &body body)
     `(consult-asdf-cache ,key #'(lambda () ,@body)))
 
-  (defun call-with-asdf-cache (thunk &key override)
-    (if (and *asdf-cache* (not override))
-        (funcall thunk)
-        (let ((*asdf-cache* (make-hash-table :test 'equal)))
-          (funcall thunk))))
+  (defun call-with-asdf-cache (thunk &key override key)
+    (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
+      (if (and *asdf-cache* (not override))
+          (funcall fun)
+          (let ((*asdf-cache* (make-hash-table :test 'equal)))
+            (funcall fun)))))
 
-  (defmacro with-asdf-cache ((&key override) &body body)
-    `(call-with-asdf-cache #'(lambda () ,@body) :override ,override))
+  (defmacro with-asdf-cache ((&key key override) &body body)
+    `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
 
   (defun normalize-namestring (pathname)
     (let ((resolved (resolve-symlinks*
diff --git a/find-system.lisp b/find-system.lisp
index 564d1350..897eb995 100644
--- a/find-system.lisp
+++ b/find-system.lisp
@@ -4,18 +4,18 @@
 (uiop/package:define-package :asdf/find-system
   (:recycle :asdf/find-system :asdf)
   (:use :uiop/common-lisp :uiop :asdf/upgrade
-   :asdf/component :asdf/system :asdf/cache)
+    :asdf/cache :asdf/component :asdf/system)
   (:export
    #:remove-entry-from-registry #:coerce-entry-to-directory
    #:coerce-name #:primary-system-name #:coerce-filename
-   #:find-system #:locate-system #:load-asd #:with-system-definitions
+   #:find-system #:locate-system #:load-asd
    #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems
    #:missing-component #:missing-requires #:missing-parent
    #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error
    #:load-system-definition-error #:error-name #:error-pathname #:error-condition
    #:*system-definition-search-functions* #:search-for-system-definition
    #:*central-registry* #:probe-asd #:sysdef-central-registry-search
-   #:find-system-if-being-defined #:*systems-being-defined*
+   #: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*
    #:clear-defined-systems #:*defined-systems*
@@ -254,32 +254,13 @@ Going forward, we recommend new users should be using the source-registry.
   (defmethod find-system (name &optional (error-p t))
     (find-system (coerce-name name) error-p))
 
-  (defvar *systems-being-defined* nil
-    "A hash-table of systems currently being defined keyed by name, or NIL")
-
   (defun find-system-if-being-defined (name)
-    (when *systems-being-defined*
-      ;; notable side effect: mark the system as being defined, to avoid infinite loops
-      (ensure-gethash (coerce-name name) *systems-being-defined* nil)))
-
-  (defun call-with-system-definitions (thunk)
-    (if *systems-being-defined*
-        (call-with-asdf-cache thunk)
-        (let ((*systems-being-defined* (make-hash-table :test 'equal)))
-          (call-with-asdf-cache thunk))))
-
-  (defun clear-systems-being-defined ()
-    (when *systems-being-defined*
-      (clrhash *systems-being-defined*)))
-
-  (register-hook-function '*post-upgrade-cleanup-hook* 'clear-systems-being-defined)
-
-  (defmacro with-system-definitions ((&optional) &body body)
-    `(call-with-system-definitions #'(lambda () ,@body)))
+    ;; notable side effect: mark the system as being defined, to avoid infinite loops
+    (values (gethash `(find-system ,(coerce-name name)) *asdf-cache*)))
 
   (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
     ;; Tries to load system definition with canonical NAME from PATHNAME.
-    (with-system-definitions ()
+    (with-asdf-cache ()
       (with-standard-io-syntax
         (let ((*package* (find-package :asdf-user))
               ;; Note that our backward-compatible *readtable* is
@@ -374,41 +355,41 @@ PATHNAME when not null is a path from where 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."
-    (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))
-           (found (search-for-system-definition name))
-           (found-system (and (typep found 'system) found))
-           (pathname (ensure-pathname
-                      (or (and (typep found '(or pathname string)) (pathname found))
-                          (and found-system (system-source-file found-system))
-                          (and previous (system-source-file previous)))
-                     :want-absolute t :resolve-symlinks *resolve-symlinks*))
-           (foundp (and (or found-system pathname previous) t)))
-      (check-type found (or null pathname system))
-      (unless (check-not-old-asdf-system name pathname)
-        (cond
-          (previous (setf found nil pathname nil))
-          (t
-           (setf found (sysdef-preloaded-system-search "asdf"))
-           (assert (typep found 'system))
-           (setf found-system found pathname nil))))
-      (values foundp found-system pathname previous previous-time)))
+    (with-asdf-cache (:key `(locate-system ,name))
+      (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))
+             (found (search-for-system-definition name))
+             (found-system (and (typep found 'system) found))
+             (pathname (ensure-pathname
+                        (or (and (typep found '(or pathname string)) (pathname found))
+                            (and found-system (system-source-file found-system))
+                            (and previous (system-source-file previous)))
+                        :want-absolute t :resolve-symlinks *resolve-symlinks*))
+             (foundp (and (or found-system pathname previous) t)))
+        (check-type found (or null pathname system))
+        (unless (check-not-old-asdf-system name pathname)
+          (cond
+            (previous (setf found nil pathname nil))
+            (t
+             (setf found (sysdef-preloaded-system-search "asdf"))
+             (assert (typep found 'system))
+             (setf found-system found pathname nil))))
+        (values foundp found-system pathname previous previous-time))))
 
   (defmethod find-system ((name string) &optional (error-p t))
-    (with-system-definitions ()
+    (with-asdf-cache (:key `(find-system ,name))
       (let ((primary-name (primary-system-name name)))
-        (unless (or (equal name primary-name)
-                    (nth-value 1 (gethash primary-name *systems-being-defined*)))
+        (unless (equal name primary-name)
           (find-system primary-name nil)))
       (loop
         (restart-case
             (multiple-value-bind (foundp found-system pathname previous previous-time)
                 (locate-system name)
               (when (and found-system (eq found-system previous)
-                         (or (gethash name *systems-being-defined*)
+                         (or (gethash `(find-system ,name) *asdf-cache*)
                              (and *immutable-systems* (gethash name *immutable-systems*))))
                 (return found-system))
               (assert (eq foundp (and (or found-system pathname previous) t)))
diff --git a/interface.lisp b/interface.lisp
index 8f31c644..ce844ebc 100644
--- a/interface.lisp
+++ b/interface.lisp
@@ -18,7 +18,7 @@
   (:export
    #:defsystem #:find-system #:locate-system #:coerce-name #:primary-system-name
    #:oos #:operate #:make-plan #:perform-plan #:sequential-plan
-   #:system-definition-pathname #:with-system-definitions
+   #:system-definition-pathname
    #:search-for-system-definition #:find-component #:component-find-path
    #:compile-system #:load-system #:load-systems #:load-systems*
    #:require-system #:test-system #:clear-system
diff --git a/operate.lisp b/operate.lisp
index 79ac3f8e..4e040d58 100644
--- a/operate.lisp
+++ b/operate.lisp
@@ -3,7 +3,7 @@
 
 (uiop/package:define-package :asdf/operate
   (:recycle :asdf/operate :asdf)
-  (:use :uiop/common-lisp :uiop :asdf/upgrade
+  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
    :asdf/component :asdf/system :asdf/operation :asdf/action
    :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan)
   (:export
@@ -75,7 +75,7 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
                           :original-initargs operation-initargs operation-initargs)
                    component-path keys))))
       ;; Setup proper bindings around any operate call.
-      (with-system-definitions ()
+      (with-asdf-cache ()
         (let* ((*verbose-out* (and verbose *standard-output*))
                (*compile-file-warnings-behaviour* on-warnings)
                (*compile-file-failure-behaviour* on-failure))
@@ -209,11 +209,11 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
 (with-upgradability ()
   (defun restart-upgraded-asdf ()
     ;; If we're in the middle of something, restart it.
-    (when *systems-being-defined*
-      (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
-        (clrhash *systems-being-defined*)
+    (when *asdf-cache*
+      (let ((l (loop* :for (x y) :being :the hash-keys :of *asdf-cache*
+                      :when (eq x 'find-system) :collect y)))
+        (clrhash *asdf-cache*)
         (dolist (s l) (find-system s nil)))))
-
   (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
 
 
diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp
index 2cf2b02c..75d911b9 100644
--- a/parse-defsystem.lisp
+++ b/parse-defsystem.lisp
@@ -5,7 +5,7 @@
   (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf)
   (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares
   (:use :uiop/common-lisp :asdf/driver :asdf/upgrade
-   :asdf/component :asdf/system :asdf/cache
+   :asdf/cache :asdf/component :asdf/system
    :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
    :asdf/backward-internals)
   (:import-from :asdf/system #:depends-on #:weakly-depends-on)
@@ -245,8 +245,8 @@ system names contained using COERCE-NAME. Return the result."
     ;; of the same name to reuse options (e.g. pathname) from.
     ;; To avoid infinite recursion in cases where you defsystem a system
     ;; that is registered to a different location to find-system,
-    ;; we also need to remember it in a special variable *systems-being-defined*.
-    (with-system-definitions ()
+    ;; we also need to remember it in the asdf-cache.
+    (with-asdf-cache ()
       (let* ((name (coerce-name name))
              (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
              (registered (system-registered-p name))
@@ -265,7 +265,7 @@ system names contained using COERCE-NAME. Return the result."
           (setf component-options
                 (append `(:defsystem-depends-on ,(parse-dependency-defs defsystem-depends-on))
                         component-options)))
-        (setf (gethash name *systems-being-defined*) system)
+        (set-asdf-cache-entry `(find-system ,name) (list system))
         (load-systems* defsystem-dependencies)
         ;; We change-class AFTER we loaded the defsystem-depends-on
         ;; since the class might be defined as part of those.
diff --git a/test/test-mutual-redefinition-1.asd b/test/test-mutual-redefinition-1.asd
new file mode 100644
index 00000000..1e74af0e
--- /dev/null
+++ b/test/test-mutual-redefinition-1.asd
@@ -0,0 +1,2 @@
+(defsystem test-mutual-redefinition-1)
+(defsystem test-mutual-redefinition-2)
diff --git a/test/test-mutual-redefinition-2.asd b/test/test-mutual-redefinition-2.asd
new file mode 100644
index 00000000..1e74af0e
--- /dev/null
+++ b/test/test-mutual-redefinition-2.asd
@@ -0,0 +1,2 @@
+(defsystem test-mutual-redefinition-1)
+(defsystem test-mutual-redefinition-2)
diff --git a/test/test-mutual-redefinition.script b/test/test-mutual-redefinition.script
new file mode 100644
index 00000000..4f66c467
--- /dev/null
+++ b/test/test-mutual-redefinition.script
@@ -0,0 +1,33 @@
+;;-*- Lisp -*-
+
+(load-system 'test-mutual-redefinition-1)
+(defun current-system-source-file (x)
+  (system-source-file (cdr (gethash x asdf/find-system:*defined-systems*))))
+
+(with-asdf-cache ()
+  (DBG "loading test-mutual-redefinition-1")
+  (assert-pathname-equal
+   (test-source "test-mutual-redefinition-1.asd")
+   (current-system-source-file "test-mutual-redefinition-1"))
+  (assert-pathname-equal
+   (test-source "test-mutual-redefinition-1.asd")
+   (current-system-source-file "test-mutual-redefinition-2"))
+
+  (DBG "loading test-mutual-redefinition-2 in the same cache session")
+  (load-system 'test-mutual-redefinition-2)
+  (assert-pathname-equal
+   (test-source "test-mutual-redefinition-1.asd")
+   (current-system-source-file "test-mutual-redefinition-1"))
+  (assert-pathname-equal
+   (test-source "test-mutual-redefinition-1.asd")
+   (current-system-source-file "test-mutual-redefinition-2"))
+
+  (with-asdf-cache (:override t)
+    (DBG "loading test-mutual-redefinition-2 in a different cache session")
+    (load-system 'test-mutual-redefinition-2)
+    (assert-pathname-equal
+     (test-source "test-mutual-redefinition-2.asd")
+     (current-system-source-file "test-mutual-redefinition-1"))
+    (assert-pathname-equal
+     (test-source "test-mutual-redefinition-2.asd")
+     (current-system-source-file "test-mutual-redefinition-2"))))
-- 
GitLab