From 00256418a056799e02e8fb514be7d3562827980a Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@gmail.com>
Date: Thu, 10 Jul 2014 14:39:15 -0500
Subject: [PATCH] Drop caching from LOCATE-SYSTEM.

Caching negative results here causes pervasive problems, and removing
negative caching only would be very messy, so we are removing caching
here altogether.

This required some modification to the test code, which was directly
using LOCATE-SYSTEM, and LOCATE-SYSTEM cannot be safely invoked unless
the ASDF-CACHE has been established.
---
 find-system.lisp         |  8 +++-----
 test/script-support.lisp | 20 +++++++++++---------
 2 files changed, 14 insertions(+), 14 deletions(-)

diff --git a/find-system.lisp b/find-system.lisp
index 9a3b1f191..b9c9464fd 100644
--- a/find-system.lisp
+++ b/find-system.lisp
@@ -358,8 +358,7 @@ 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."
-    (with-asdf-cache (:key `(locate-system ,name))
-      (let* ((name (coerce-name name))
+    (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))
@@ -380,7 +379,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
              (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))))
+        (values foundp found-system pathname previous previous-time)))
 
   (defmethod find-system ((name string) &optional (error-p t))
     (with-asdf-cache (:key `(find-system ,name))
@@ -423,6 +422,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 6b0a4069d..c85f209a1 100644
--- a/test/script-support.lisp
+++ b/test/script-support.lisp
@@ -552,16 +552,18 @@ 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~%")
-    (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~%~
+    (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~%~
                  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 ()
-- 
GitLab