From 438e1a97c27c12663de7f1634cb7200e4cf322d3 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Mon, 12 Sep 2016 08:19:07 -0400
Subject: [PATCH] Have locate-system use with-asdf-cache but not cache its own
 results

This should make Daniel K happy.
Also remove obsolete cleaning of locate-system cached results,
for we haven't cached the result since 00256418 (3.1.2.9, 2014),
that this commit partly undoes, partly re-does
(due to merge conflict at the time).
---
 find-system.lisp         | 51 ++++++++++++++++++++--------------------
 test/script-support.lisp | 22 ++++++++---------
 test/test-force.script   |  1 -
 3 files changed, 36 insertions(+), 38 deletions(-)

diff --git a/find-system.lisp b/find-system.lisp
index da6949f8a..58e25c2b6 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 963db8378..c6bba03cf 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 d2dc5c278..31f5c69c6 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)))
-- 
GitLab