Skip to content
Snippets Groups Projects
Commit 9ee02fc8 authored by Robert P. Goldman's avatar Robert P. Goldman
Browse files

Simpler FIND-SYSTEM patch by just not doing negative caching. Thanks to Fare.

parent 999cdd21
No related branches found
No related tags found
No related merge requests found
...@@ -21,11 +21,11 @@ ...@@ -21,11 +21,11 @@
#:clear-defined-system #:clear-defined-systems #:*defined-systems* #:clear-defined-system #:clear-defined-systems #:*defined-systems*
#:*immutable-systems* #:*immutable-systems*
;; defined in source-registry, but specially mentioned here: ;; defined in source-registry, but specially mentioned here:
#:sysdef-source-registry-search #:initialize-source-registry #:sysdef-source-registry-search))
))
(in-package :asdf/find-system) (in-package :asdf/find-system)
(with-upgradability () (with-upgradability ()
(declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference
(define-condition missing-component (system-definition-error) (define-condition missing-component (system-definition-error)
((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
...@@ -382,58 +382,53 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -382,58 +382,53 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(setf found-system found pathname nil)))) (setf found-system found pathname nil))))
(values foundp found-system pathname previous previous-time)))) (values foundp found-system pathname previous previous-time))))
(defun find-system-1 (name) (defmethod find-system ((name string) &optional (error-p t))
(with-asdf-cache (:key `(find-system ,name)) (with-asdf-cache (:key `(find-system ,name))
(let ((primary-name (primary-system-name name))) (let ((primary-name (primary-system-name name)))
(unless (equal name primary-name) (unless (equal name primary-name)
(find-system primary-name nil))) (find-system primary-name nil)))
(prog () (loop
(multiple-value-bind (foundp found-system pathname previous previous-time) (restart-case
(locate-system name) (multiple-value-bind (foundp found-system pathname previous previous-time)
(when (and found-system (eq found-system previous) (locate-system name)
(or (first (gethash `(find-system ,name) *asdf-cache*)) (when (and found-system (eq found-system previous)
(and *immutable-systems* (gethash name *immutable-systems*)))) (or (first (gethash `(find-system ,name) *asdf-cache*))
(return found-system)) (and *immutable-systems* (gethash name *immutable-systems*))))
(assert (eq foundp (and (or found-system pathname previous) t))) (return found-system))
(let ((previous-pathname (and previous (system-source-file previous))) (assert (eq foundp (and (or found-system pathname previous) t)))
(system (or previous found-system))) (let ((previous-pathname (and previous (system-source-file previous)))
(when (and found-system (not previous)) (system (or previous found-system)))
(register-system found-system)) (when (and found-system (not previous))
(when (and system pathname) (register-system found-system))
(setf (system-source-file system) pathname)) (when (and system pathname)
(when (and pathname (setf (system-source-file system) pathname))
(let ((stamp (get-file-stamp pathname))) (when (and pathname
(and stamp (let ((stamp (get-file-stamp pathname)))
(not (and previous (and stamp
(or (pathname-equal pathname previous-pathname) (not (and previous
(and pathname previous-pathname (or (pathname-equal pathname previous-pathname)
(pathname-equal (and pathname previous-pathname
(physicalize-pathname pathname) (pathname-equal
(physicalize-pathname previous-pathname)))) (physicalize-pathname pathname)
(stamp<= stamp previous-time)))))) (physicalize-pathname previous-pathname))))
;; only load when it's a pathname that is different or has newer content, and not an old asdf (stamp<= stamp previous-time))))))
(load-asd pathname :name name))) ;; only load when it's a pathname that is different or has newer content, and not an old asdf
(let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed (load-asd pathname :name name)))
(return (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
(when in-memory (return
(when pathname (cond
(setf (car in-memory) (get-file-stamp pathname))) (in-memory
(cdr in-memory)))))))) (when pathname
(setf (car in-memory) (get-file-stamp pathname)))
(cdr in-memory))
(error-p
(error 'missing-component :requires name))
(t ;; not found: don't keep negative cache
(unset-asdf-cache-entry `(locate-system ,name))
(return-from find-system nil))))))
(reinitialize-source-registry-and-retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
(unset-asdf-cache-entry `(locate-system ,name))
(initialize-source-registry)))))))
(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))
(t nil)))
(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)
(find-system name error-p)))))
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