Commit 84e17ea0 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

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