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

2.015.3: more general plumbing to prevent infinite recursion in defining systems.

A new exported macro with-system-definitions protects
operate (and through it oos, load-system and compile-system)
and find-system (and also its helper load-sysdef should it ever be exported)
and will hopefully complete the find-system-if-being-defined from 2.015.2
in preventing infinite recursions while defining systems that are defined
in a place different from the place where they are registered
(maybe there should be a warning for that?)
parent ff4057b6
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.2" ;; to be automatically updated by bin/bump-revision
  :version "2.015.3" ;; to be automatically updated by bin/bump-revision
  :depends-on ()
  :components
  ((:file "asdf")
+115 −101
Original line number Diff line number Diff line
;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.015.2: Another System Definition Facility.
;;; This is ASDF 2.015.3: 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.2")
         (asdf-version "2.015.3")
         (existing-asdf (fboundp 'find-system))
         (existing-version *asdf-version*)
         (already-there (equal asdf-version existing-version)))
@@ -230,7 +230,7 @@
            #:inherit-source-registry #:process-source-registry-directive)
           :export
           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
            #:system-definition-pathname
            #:system-definition-pathname #:with-system-definitions
            #:search-for-system-definition #:find-component ; miscellaneous
            #:compile-system #:load-system #:test-system #:clear-system
            #:compile-op #:load-op #:load-source-op
@@ -1514,8 +1514,25 @@ 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))

(defun load-sysdef (name pathname)
(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*
    (gethash (coerce-name name) *systems-being-defined*)))

(defun* call-with-system-definitions (thunk)
  (if *systems-being-defined*
      (funcall thunk)
      (let ((*systems-being-defined* (make-hash-table :test 'equal)))
        (funcall thunk))))

(defmacro with-system-definitions (() &body body)
  `(call-with-system-definitions #'(lambda () ,@body)))

(defun* load-sysdef (name pathname)
  ;; Tries to load system definition with canonical NAME from PATHNAME.
  (with-system-definitions ()
    (let ((package (make-temporary-package)))
      (unwind-protect
           (handler-bind
@@ -1527,9 +1544,10 @@ Going forward, we recommend new users should be using the source-registry.
               (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
                             pathname package)
               (load pathname)))
      (delete-package package))))
        (delete-package package)))))

(defmethod find-system ((name string) &optional (error-p t))
  (with-system-definitions ()
    (let* ((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))
@@ -1564,7 +1582,7 @@ Going forward, we recommend new users should be using the source-registry.
             (setf (car in-memory) (safe-file-write-date pathname)))
           (cdr in-memory))
          (error-p
         (error 'missing-component :requires name))))))
           (error 'missing-component :requires name)))))))

(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
  (setf fallback (coerce-name fallback)
@@ -1579,12 +1597,6 @@ 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
@@ -2386,6 +2398,7 @@ recursive calls to traverse.")
                    &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
                    &allow-other-keys)
  (declare (ignore force))
  (with-system-definitions ()
    (let* ((op (apply 'make-instance operation-class
                      :original-initargs args
                      args))
@@ -2410,7 +2423,7 @@ recursive calls to traverse.")
          (return-from operate
            (apply (find-symbol* 'operate :asdf) operation-class system args)))
        (perform-plan steps)
      (values op steps))))
        (values op steps)))))

(defun* oos (operation-class system &rest args &key force verbose version
            &allow-other-keys)
@@ -2662,13 +2675,14 @@ Returns the new tree (which probably shares structure with the old one)"
  ;; 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 ()
    (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)
      (setf (gethash name *systems-being-defined*) system)
      (when registered
        (setf (car registered) (get-universal-time)))
      (map () 'load-system defsystem-depends-on)
@@ -2680,7 +2694,7 @@ Returns the new tree (which probably shares structure with the old one)"
       nil (list*
            :module name
            :pathname (determine-system-pathname pathname pathname-arg-p)
          component-options))))
            component-options)))))

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