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

cache.lisp

+9 −8
Original line number Diff line number Diff line
@@ -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)

  (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 thunk)

          (funcall fun)

          (let ((*asdf-cache* (make-hash-table :test 'equal)))

          (funcall thunk))))

            (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*

find-system.lisp

+32 −51
Original line number Diff line number Diff line
@@ -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)))

    (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,6 +355,7 @@ 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."

    (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))
@@ -395,20 +377,19 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. 
             (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)))

        (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)))

interface.lisp

+1 −1
Original line number Diff line number Diff line
@@ -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

operate.lisp

+6 −6
Original line number Diff line number Diff line
@@ -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))

parse-defsystem.lisp

+4 −4
Original line number Diff line number Diff line
@@ -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.