Commit b86ab129 authored by Robert P. Goldman's avatar Robert P. Goldman
Browse files

Fix for bug where caching mistakenly overrides error flag in FIND-SYSTEM.

This required refactoring to move
REINITIALIZE-SOURCE-REGISTRY-AND-RESTART to correct location.

This shoudl also fix bug13353423, but we still need a better test.
parent 81134efb
Loading
Loading
Loading
Loading
+23 −4
Original line number Diff line number Diff line
@@ -7,7 +7,11 @@
           #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
           #:do-asdf-cache #:normalize-namestring
           #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*
           #:clear-asdf-cache))
           #:clear-asdf-cache
           #:reinitialize-source-registry-and-retry
           ;; defined in source-registry, but specially mentioned here:
           #:initialize-source-registry
           ))
(in-package :asdf/cache)

;;; This stamp cache is useful for:
@@ -16,6 +20,8 @@
;; * the ability to test with fake timestamps, without touching files

(with-upgradability ()
  (declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference

  (defvar *asdf-cache* nil)

  (defun set-asdf-cache-entry (key value-list)
@@ -26,7 +32,7 @@

  (defun clear-asdf-cache ()
    (when *asdf-cache*
      (setf *asdf-cache* (make-hash-table :test 'equal))))
      (setf *asdf-cache* (clrhash *asdf-cache*))))

  (defun unset-asdf-cache-entry (key)
    (when *asdf-cache*
@@ -47,8 +53,21 @@
    (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
      (if (and *asdf-cache* (not override))
          (funcall fun)
          (flet ((establish-cache-and-call ()
                   (let ((*asdf-cache* (make-hash-table :test 'equal)))
            (funcall fun)))))
                     (funcall fun))))
            (restart-case
                (establish-cache-and-call)
              (reinitialize-source-registry-and-retry ()
                :report (lambda (s)
                          (format s (compatfmt "~@<Retry ASDF operation after reinitializing the source-registry.~@:>")))
                ;; since you're reinitializing the source registry, an arbitrary
                ;; amount of the ASDF cache is invalidated, not just the entry
                ;; for the current NAME.
                (clear-asdf-cache)
                ;; (unset-asdf-cache-entry `(locate-system ,name))
                (initialize-source-registry)
                (establish-cache-and-call)))))))

  (defmacro with-asdf-cache ((&key key override) &body body)
    `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
+54 −53
Original line number Diff line number Diff line
@@ -21,13 +21,11 @@
   #:clear-defined-system #:clear-defined-systems #:*defined-systems*
   #:*immutable-systems*
   ;; defined in source-registry, but specially mentioned here:
   #:initialize-source-registry #:sysdef-source-registry-search
   #:reinitialize-source-registry-and-retry
   #:sysdef-source-registry-search
   ))
(in-package :asdf/find-system)

(with-upgradability ()
  (declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference

  (define-condition missing-component (system-definition-error)
    ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
@@ -384,13 +382,12 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
             (setf found-system found pathname nil))))
        (values foundp found-system pathname previous previous-time))))

  (defmethod find-system ((name string) &optional (error-p t))
  (defun find-system-1 (name)
    (with-asdf-cache (:key `(find-system ,name))
                             (let ((primary-name (primary-system-name name)))
                               (unless (equal name primary-name)
                                 (find-system primary-name nil)))
      (loop
        (restart-case
                             (prog ()
                                   (multiple-value-bind (foundp found-system pathname previous previous-time)
                                       (locate-system name)
                                     (when (and found-system (eq found-system previous)
@@ -418,21 +415,25 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
                                         (load-asd pathname :name name)))
                                     (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
                                       (return
                  (cond
                    (in-memory
                                        (when in-memory
                                          (when pathname
                                            (setf (car in-memory) (get-file-stamp pathname)))
                     (cdr in-memory))
                                          (cdr in-memory))))))))

  (defmethod find-system ((name string) &optional (error-p t))
    (restart-case
     (let ((ret (find-system-1 name)))
       (cond (ret ret)
             (error-p
                     (error 'missing-component :requires name))))))
              (error 'missing-component :requires name))
             (t nil)))
     (reinitialize-source-registry-and-retry ()
                                             :report (lambda (s)
                      (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
                                                       (format s (compatfmt "~@<Retry ASDF operation after reinitializing the source-registry.~@:>")))
                                             ;; since you're reinitializing the source registry, an arbitrary
                                             ;; amount of the ASDF cache is invalidated, not just the entry
                                             ;; for the current NAME.
                                             (clear-asdf-cache)
                                             ;; (unset-asdf-cache-entry `(locate-system ,name))
                                             (initialize-source-registry)
            (find-system name error-p)))))))
                                             (find-system name error-p)))))
+1 −0
Original line number Diff line number Diff line
@@ -5,6 +5,7 @@
(uiop/package:define-package :asdf/source-registry
  (:recycle :asdf/source-registry :asdf)
  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
  (:import-from :asdf/cache #:initialize-source-registry)
  (:export
   #:*source-registry-parameter* #:*default-source-registries*
   #:invalid-source-registry
+2 −0
Original line number Diff line number Diff line
@@ -160,6 +160,8 @@
    asdf/backward-interface:on-warnings
    asdf/find-system:contrib-sysdef-search
    asdf/find-system:sysdef-find-asdf
    ;; restart
    asdf/cache:reinitialize-source-registry-and-retry
    ))

(defun defined-symbol-p (symbol)