diff --git a/find-system.lisp b/find-system.lisp index da6949f8a3978c073bd15275259baaf3f146110c..58e25c2b6a1def5bed0eb0cdc69911b29d18ec6c 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -160,7 +160,6 @@ NIL if not cleared because the system was found to be immutable." (let ((name (coerce-name system))) (unless (and *immutable-systems* (gethash name *immutable-systems*)) (remhash (coerce-name name) *defined-systems*) - (unset-asdf-cache-entry `(locate-system ,name)) (unset-asdf-cache-entry `(find-system ,name)) t))) @@ -383,28 +382,31 @@ PATHNAME when not null is a path from which 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." - (let* ((name (coerce-name name)) - (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)) - (previous-time (car in-memory)) - (found (search-for-system-definition name)) - (found-system (and (typep found 'system) found)) - (pathname (ensure-pathname - (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous))) - :want-absolute t :resolve-symlinks *resolve-symlinks*)) - (foundp (and (or found-system pathname previous) t))) - (check-type found (or null pathname system)) - (unless (check-not-old-asdf-system name pathname) - (cond - (previous (setf found nil pathname nil)) - (t - (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))) + (with-asdf-cache () ;; NB: We don't cache the results. We once used to, but it wasn't useful, + ;; and keeping a negative cache was a bug (see lp#1335323), which required + ;; explicit invalidation in clear-system and find-system (when unsucccessful). + (let* ((name (coerce-name name)) + (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)) + (previous-time (car in-memory)) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (ensure-pathname + (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous))) + :want-absolute t :resolve-symlinks *resolve-symlinks*)) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (unless (check-not-old-asdf-system name pathname) + (cond + (previous (setf found nil pathname nil)) + (t + (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)))) (defmethod find-system ((name string) &optional (error-p t)) (with-asdf-cache (:key `(find-system ,name)) @@ -443,6 +445,5 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (cdr in-memory)) (error-p (error 'missing-component :requires name)) - (t ;; not found: don't keep negative cache, see lp#1335323 - (unset-asdf-cache-entry `(locate-system ,name)) + (t (return-from find-system nil))))))))) diff --git a/test/script-support.lisp b/test/script-support.lisp index 963db83788cb768b0730e0b8851ae87bf2b21d64..c6bba03cfa4e5f7cc11abdac92ce1b6b8eeae5d5 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -390,7 +390,7 @@ is bound, write a message and exit on an error. If (finish-outputs*) (unless *debug-asdf* (ignore-errors - (format *error-output* "~&Backtrace:~%") + (format *error-output* "~&Backtrace:~%") (acall :print-condition-backtrace c :count 69 :stream *error-output*)) (leave-test "Script failed" 1))))) @@ -619,18 +619,16 @@ is bound, write a message and exit on an error. If (when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*)) (when (and (asym :locate-system) (asym :pathname-directory-pathname) (asym :pathname-equal)) (format t "Comparing directories~%") - (acall :call-with-asdf-cache - #'(lambda () - (let ((x (acall :pathname-directory-pathname (nth-value 2 (acall :locate-system :test-asdf))))) - (assert-pathname-equal-helper ;; not always EQUAL (!) - '*test-directory* *test-directory* - '(:pathname-directory-pathname (nth-value 2 (:locate-system :test-asdf))) x) - (unless (equal *test-directory* x) - (format t "Interestingly, while *test-directory* has components~% ~S~%~ + (let ((x (acall :pathname-directory-pathname (nth-value 2 (acall :locate-system :test-asdf))))) + (assert-pathname-equal-helper ;; not always EQUAL (!) + '*test-directory* *test-directory* + '(:pathname-directory-pathname (nth-value 2 (:locate-system :test-asdf))) x) + (unless (equal *test-directory* x) + (format t "Interestingly, while *test-directory* has components~% ~S~%~ ASDF finds the ASDs in~% ~S~%Using the latter.~%" - (pathname-components *test-directory*) - (pathname-components x))) - (setf *test-directory* x))))) + (pathname-components *test-directory*) + (pathname-components x))) + (setf *test-directory* x))) t) (defun frob-packages () diff --git a/test/test-force.script b/test/test-force.script index d2dc5c27837ab816091a2bf1ff2e34d9e0804960..31f5c69c64345b25b1830803fe01f50a27863da9 100644 --- a/test/test-force.script +++ b/test/test-force.script @@ -89,7 +89,6 @@ (DBG "Check that require-system of touched .asd will reload the asdf.") (DBG "(That's what it does now, but if it could be fixed that'd be nice.)") -(unset-asdf-cache-entry '(locate-system "test-asdf")) (unset-asdf-cache-entry '(find-system "test-asdf")) (unset-asdf-cache-entry '(find-system "test-asdf/force")) (touch-file "test-asdf.asd" :timestamp (+ 10000 (get-file-stamp file1)))