Commit ff4057b6 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.015.2: fix defsystem to avoid infinite loop in some cases.

Nikodemus reported on the list an infortunate interaction with quicklisp.
such if when you had a system installed both in quicklisp and outside
quicklisp, say flexi-streams, and the .asd defsystem'ed an auxiliary system,
say flexi-streams-test, and you tried to load the version outside quicklisp,
e.g. by putting it first in the *central-registry*, then ASDF would
start loading the non-quicklisp .asd; during parse-component-form for the
auxiliary system, find-system would be called and then locate the quicklisp
version, since it can't be found by file name, but quicklisp includes it
in its database; ASDF would then load the quicklisp .asd; during the
parse-component-form for the main system, it would call find-system,
and the non-quicklisp .asd would be found, and so on in an infinite loop.

This patch refactors defsystem to put all the work in a function
will a trivial macro-expansion. The function pushes the system being
currently defined into a list of such systems that is specially consulted
first by search-for-system-definition, hopefully avoiding any loop.
parent 997f0915
Loading
Loading
Loading
Loading
+1 −1
Original line number Diff line number Diff line
@@ -12,7 +12,7 @@
  :licence "MIT"
  :description "Another System Definition Facility"
  :long-description "ASDF builds Common Lisp software organized into defined systems."
  :version "2.015.1" ;; to be automatically updated by bin/bump-revision
  :version "2.015.2" ;; to be automatically updated by bin/bump-revision
  :depends-on ()
  :components
  ((:file "asdf")
+41 −31
Original line number Diff line number Diff line
;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.015.1: Another System Definition Facility.
;;; This is ASDF 2.015.2: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
@@ -104,7 +104,7 @@
         ;; "2.345.6" would be a development version in the official upstream
         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
         (asdf-version "2.015.1")
         (asdf-version "2.015.2")
         (existing-asdf (fboundp 'find-system))
         (existing-version *asdf-version*)
         (already-there (equal asdf-version existing-version)))
@@ -1403,7 +1403,7 @@ called with an object of type asdf:system."
(defun* search-for-system-definition (system)
  (let ((system-name (coerce-name system)))
    (some #'(lambda (x) (funcall x system-name))
          *system-definition-search-functions*)))
          (cons 'find-system-if-being-defined *system-definition-search-functions*))))

(defvar *central-registry* nil
"A list of 'system directory designators' ASDF uses to find systems.
@@ -1579,6 +1579,12 @@ Going forward, we recommend new users should be using the source-registry.
  ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
  (find-system-fallback name "asdf" :version *asdf-version*))

(defvar *systems-being-defined* ()
  "Systems currently being defined by defsystem")

(defun* find-system-if-being-defined (name)
  (find (coerce-name name) *systems-being-defined*
        :test 'equal :key 'component-name))

;;;; -------------------------------------------------------------------------
;;;; Finding components
@@ -2479,34 +2485,6 @@ details."
        directory-pathname
        (default-directory))))

(defmacro defsystem (name &body options)
  (setf name (coerce-name name))
  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
                            defsystem-depends-on &allow-other-keys)
      options
    (let ((component-options (remove-keys '(:class) options)))
      `(progn
         ;; system must be registered before we parse the body, otherwise
         ;; we recur when trying to find an existing system of the same name
         ;; to reuse options (e.g. pathname) from
         ,@(loop :for system :in defsystem-depends-on
             :collect `(load-system ',(coerce-name system)))
         (let ((s (system-registered-p ',name)))
           (cond ((and s (eq (type-of (cdr s)) ',class))
                  (setf (car s) (get-universal-time)))
                 (s
                  (change-class (cdr s) ',class))
                 (t
                  (register-system (make-instance ',class :name ',name))))
           (%set-system-source-file (load-pathname)
                                    (cdr (system-registered-p ',name))))
         (parse-component-form
          nil (list*
               :module (coerce-name ',name)
               :pathname
               ,(determine-system-pathname pathname pathname-arg-p)
               ',component-options))))))

(defun* class-for-type (parent type)
  (or (loop :for symbol :in (list
                             type
@@ -2675,6 +2653,38 @@ Returns the new tree (which probably shares structure with the old one)"
      (%refresh-component-inline-methods ret rest)
      ret)))

(defun* do-defsystem (name &rest options
                           &key (pathname nil pathname-arg-p) (class 'system)
                           defsystem-depends-on &allow-other-keys)
  ;; The system must be registered before we parse the body,
  ;; otherwise we recur when trying to find an existing system
  ;; 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*.
  (let* ((name (coerce-name name))
         (registered (system-registered-p name))
         (system (cdr (or registered
                          (register-system (make-instance 'system :name name)))))
         (*systems-being-defined* (cons system *systems-being-defined*))
         (component-options (remove-keys '(:class) options)))
    (%set-system-source-file (load-pathname) system)
    (when registered
      (setf (car registered) (get-universal-time)))
    (map () 'load-system defsystem-depends-on)
    ;; We change-class (when necessary) AFTER we load the defsystem-dep's
    ;; since the class might not be defined as part of those.
    (unless (eq (type-of system) class)
      (change-class system class))
    (parse-component-form
     nil (list*
          :module name
          :pathname (determine-system-pathname pathname pathname-arg-p)
          component-options))))

(defmacro defsystem (name &body options)
  `(apply 'do-defsystem ',name ',options))

;;;; ---------------------------------------------------------------------------
;;;; run-shell-command
;;;;
+3 −1
Original line number Diff line number Diff line
@@ -12,7 +12,9 @@
        (file4 (asdf:compile-file-pathname* "file4")))
   (setf asdf:*central-registry* `(*default-pathname-defaults* ,tmp))
   (assert (= 0 (asdf:run-shell-command
                 (format nil "/bin/ln -sf ~A ~A" asd asd2))))
                 (format nil "/bin/ln -sf ~A ~A"
                         (#-scl namestring #+scl ext:unix-namestring asd)
                         (#-scl namestring #+scl ext:unix-namestring asd2)))))
   (asdf:oos 'asdf:load-source-op 'test-multiple-too)
   (assert (symbol-value (find-symbol (string :*file3*) :test-package)))
   (asdf:load-system 'test-multiple-free)