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

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
No related branches found
No related tags found
No related merge requests found
......@@ -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*
......
......@@ -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)))
......
......@@ -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
......
......@@ -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))
......@@ -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.
......
(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"))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment