Skip to content
Snippets Groups Projects
Commit 438e1a97 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

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