diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo index 5e2cbbbc968e94c6b8f606e84db89ea61d5de776..78231c993cd88015941aa2eb4af85dede746b533 100644 --- a/doc/asdf.texinfo +++ b/doc/asdf.texinfo @@ -6249,24 +6249,17 @@ Here's the procedure for experimenting with tests in a REPL: ;; Load the test script support. (load "script-support.lisp") -;; Initialize the script support. -;; This will also change your *package* to asdf-test. +;; Initialize the script support for interaction. +;; This will also change your *package* to asdf-test +;; after frobbing the asdf-test package to make it usable. ;; NB: this function is also available from package cl-user, ;; and also available with the shorter name da in both packages. -(asdf-test::debug-asdf) - -;; In case you modified ASDF since you last tested it, -;; you need to update asdf.lisp itself by evaluating 'make' in a shell, -;; or (require "asdf") (asdf:load-system :asdf) in another CL REPL, -;; if not done in this REPL above. -;; *Then*, in this REPL, you need to evaluate: -;(asdf-test::compile-load-asdf) +(asdf-test:debug-asdf) ;; Now, you may experiment with test code from a .script file. ;; See the instructions given at the end of your failing test ;; to identify which form is needed, e.g. -(frob-packages) -(asdf::with-asdf-cache () (load "test-utilities.script")) +(run-test-script "test-utilities.script") @end example diff --git a/find-system.lisp b/find-system.lisp index c2ccb80562d4cfac2d42dd6658da8ddd2469604f..8f6fb845d29d3115bb9f4ba102fb6015d1819b98 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -393,7 +393,7 @@ Going forward, we recommend new users should be using the source-registry.") ;; This function explicitly MUST NOT find definitions merely registered in previous sessions. ;; NB: this function depends on a corresponding side-effect in parse-defsystem; ;; the precise protocol between the two functions may change in the future (or not). - (first (gethash `(find-system ,(coerce-name name)) *asdf-cache*))) + (first (gethash `(find-system ,(coerce-name name)) (asdf-cache)))) (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) @@ -402,7 +402,7 @@ Going forward, we recommend new users should be using the source-registry.") NAME if supplied is the name of a system expected to be defined in that file. Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." - (with-asdf-cache () + (with-asdf-session () (with-standard-io-syntax (let ((*package* (find-package :asdf-user)) ;; Note that our backward-compatible *readtable* is @@ -479,7 +479,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 () ;; NB: We don't cache the results. We once used to, but it wasn't useful, + (with-asdf-session () ;; 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)) @@ -507,7 +507,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ;; preloaded, with a previous configuration, or before filesystem changes), and ;; load a found .asd if appropriate. Finally, update registration table and return results. (defmethod find-system ((name string) &optional (error-p t)) - (with-asdf-cache (:key `(find-system ,name)) + (with-asdf-session (:key `(find-system ,name)) (let ((primary-name (primary-system-name name))) (unless (equal name primary-name) (find-system primary-name nil))) diff --git a/operate.lisp b/operate.lisp index 676468b496bd55bf71847b43c95235d4582b9ccf..003b07926a1549aa9596b81714a21687488f72c0 100644 --- a/operate.lisp +++ b/operate.lisp @@ -57,7 +57,7 @@ But do NOT depend on it, for this is deprecated behavior.")) (on-warnings *compile-file-warnings-behaviour*) (on-failure *compile-file-failure-behaviour*) &allow-other-keys) (nest - (with-asdf-cache ()) + (with-asdf-session ()) (let ((in-operate *in-operate*) (*in-operate* t) (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was) @@ -249,11 +249,11 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms.")) (defun restart-upgraded-asdf () ;; If we're in the middle of something, restart it. (let ((systems-being-defined - (when *asdf-cache* + (when *asdf-session* (prog1 - (loop :for k :being :the hash-keys :of *asdf-cache* + (loop :for k :being :the hash-keys :of (asdf-cache) :when (eq (first k) 'find-system) :collect (second k)) - (clrhash *asdf-cache*))))) + (clrhash (asdf-cache)))))) ;; Regardless, clear defined systems, since they might be invalid ;; after an incompatible ASDF upgrade. (clear-defined-systems) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index c535c17ffa4b0b82dc43bda19c98d6c7343dfbcd..ca675575479b4c6b9a193f26f6501b745abfb97a 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -288,7 +288,7 @@ system names contained using COERCE-NAME. Return the result." ;; that is registered to a different location to find-system, ;; we also need to remember it in the asdf-cache. (nest - (with-asdf-cache ()) + (with-asdf-session ()) (let* ((name (coerce-name name)) (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))))) (flet ((fix-case (x) (if (logical-pathname-p source-file) (string-downcase x) x)))) diff --git a/session.lisp b/session.lisp index d2a673ec30d9d45b92c03ea93bf2d0a5bbdfd911..f8cb89d3b8469ea53e8b279373c00533917ddeee 100644 --- a/session.lisp +++ b/session.lisp @@ -5,9 +5,10 @@ (:recycle :asdf/session :asdf/cache) (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp - #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache + #:asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring - #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache* + #:call-with-asdf-session #:with-asdf-session + #:*asdf-session* #:*asdf-session-class* #:caching-session #:clear-configuration-and-retry #:retry)) (in-package :asdf/session) @@ -20,29 +21,35 @@ ;; * Testability of ASDF with the ability to fake timestamps without actually touching files. (with-upgradability () - ;; The session cache variable. - ;; NIL when outside a session, an equal hash-table when inside a session. - (defvar *asdf-cache* nil) + ;; The session variable. + ;; NIL when outside a session. + (defvar *asdf-session* nil) + (defparameter* *asdf-session-class* 'caching-session) + (defclass caching-session () + ((cache :initform (make-hash-table :test 'equal) :reader session-cache))) + + (defun asdf-cache () + (session-cache *asdf-session*)) ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session. ;; Return those values. (defun set-asdf-cache-entry (key value-list) - (values-list (if *asdf-cache* - (setf (gethash key *asdf-cache*) value-list) + (values-list (if *asdf-session* + (setf (gethash key (asdf-cache)) value-list) value-list))) ;; Unset the session cache entry for KEY, when inside a session. (defun unset-asdf-cache-entry (key) - (when *asdf-cache* - (remhash key *asdf-cache*))) + (when *asdf-session* + (remhash key (session-cache *asdf-session*)))) ;; Consult the session cache entry for KEY if present and in a session; ;; if not present, compute it by calling the THUNK, ;; and set the session cache entry accordingly, if in a session. ;; Return the values from the cache and/or the thunk computation. (defun consult-asdf-cache (key &optional thunk) - (if *asdf-cache* - (multiple-value-bind (results foundp) (gethash key *asdf-cache*) + (if *asdf-session* + (multiple-value-bind (results foundp) (gethash key (session-cache *asdf-session*)) (if foundp (values-list results) (set-asdf-cache-entry key (multiple-value-list (call-function thunk))))) @@ -58,13 +65,13 @@ ;; Second, if a new session was started, establish restarts for retrying the overall computation. ;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache ;; entry isn't found, or just call the THUNK if no KEY was specified. - (defun call-with-asdf-cache (thunk &key override key) + (defun call-with-asdf-session (thunk &key override key) (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) - (if (and *asdf-cache* (not override)) + (if (and *asdf-session* (not override)) (funcall fun) (loop (restart-case - (let ((*asdf-cache* (make-hash-table :test 'equal))) + (let ((*asdf-session* (make-instance *asdf-session-class*))) (return (funcall fun))) (retry () :report (lambda (s) @@ -74,9 +81,9 @@ (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>"))) (clear-configuration))))))) - ;; Syntactic sugar for call-with-asdf-cache - (defmacro with-asdf-cache ((&key key override) &body body) - `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key)) + ;; Syntactic sugar for call-with-asdf-session + (defmacro with-asdf-session ((&key key override) &body body) + `(call-with-asdf-session #'(lambda () ,@body) :override ,override :key ,key)) ;;; Define specific accessor for file (date) stamp. diff --git a/test/asdf-pathname-test.script b/test/asdf-pathname-test.script index 7ec902a7dd61b9415a2cafbd9d692650bac93e53..2d1eb6131ab582970208814164f5c605183af0ff 100644 --- a/test/asdf-pathname-test.script +++ b/test/asdf-pathname-test.script @@ -169,7 +169,7 @@ (logical-pathname-p module-pathname)) (and (stringp file-pathname) (find #\. file-pathname))) (incf system-count) - (with-asdf-cache (:override t) + (with-asdf-session (:override t) (clear-system :test-system) (let* ((system (let ((*verbose-out* nil)) (eval system-definition))) diff --git a/test/run-tests.sh b/test/run-tests.sh index 97e7a9e9501d6d91995d21fb2582321edb58e39f..e3ed416185e1b20f1186aa3eee4584e31f9eb0da 100755 --- a/test/run-tests.sh +++ b/test/run-tests.sh @@ -156,7 +156,7 @@ do_tests () { echo "or more interactively (and maybe with rlwrap or in emacs), start with:" >&2 echo "(cd test ; $icmd )" >&2 echo "then copy/paste:" >&2 - echo "'(#.(load \"script-support.lisp\") #.(asdf-test::da) #.(load-asdf) #.(frob-packages) #.(asdf::with-asdf-cache () (load \"$i\")))" >&2 + echo "'(#.(load \"script-support.lisp\") #.(asdf-test::da) #.(load-asdf) #.(frob-packages) #.(asdf::with-asdf-session () (load \"$i\")))" >&2 fi echo >&2 echo >&2 diff --git a/test/script-support.lisp b/test/script-support.lisp index 5a88a2bab87e8d514b7f91231254f22c33cba28d..f0b1303d887ff832a220a96c250cc7b2558553f2 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -337,12 +337,12 @@ Some constraints: (assert-equal (file-write-date file) stamp)) ;; else (progn - (unless (asymval :*asdf-cache*) - (error "Trying to use *ASDF-CACHE* in TOUCH-FILE, but cache is not initialized.")) + (unless (asymval :*asdf-session*) + (error "Trying to use the ASDF session cache in TOUCH-FILE, but it is not initialized.")) (acall :register-file-stamp file stamp))))) (defun mark-file-deleted (file) - (unless (asymval :*asdf-cache*) (error "Y U NO use asdf cache?")) + (unless (asymval :*asdf-session*) (error "Y U NO use asdf session?")) (acall :register-file-stamp (acall :normalize-namestring file) nil)) (defun hash-table->alist (table) @@ -408,7 +408,7 @@ is bound, write a message and exit on an error. If (acall :print-condition-backtrace c :count 69 :stream *error-output*)) (leave-test "Script failed" 1))))) - (funcall (or (asym :call-with-asdf-cache) 'funcall) thunk) + (funcall (or (asym :call-with-asdf-session) 'funcall) thunk) (leave-test "Script succeeded" 0))))) (when *quit-when-done* (exit-lisp result)))) @@ -632,10 +632,10 @@ is bound, write a message and exit on an error. If (when (asym :*asdf-verbose*) (setf (asymval :*asdf-verbose*) t)) (when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*)) (funcall - ;; Old versions of ASDF don't always use with-asdf-cache in locate system, but need it. + ;; Old versions of ASDF don't always use with-asdf-session in locate system, but need it. ;; So we do it for them for the sake of testing upgrade from these old versions. - ;; Yet older versions of ASDF don't even have this cache, so then we don't. - (or (asym :call-with-asdf-cache) 'funcall) + ;; Yet older versions of ASDF don't even have this session cache, so then we don't. + (or (asym :call-with-asdf-session) (asym :call-with-asdf-cache) 'funcall) (lambda () (when (and (asym :locate-system) (asym :pathname-directory-pathname) (asym :pathname-equal)) (format t "Comparing directories~%") @@ -680,7 +680,7 @@ is bound, write a message and exit on an error. If (defun debug-asdf () (setf *debug-asdf* t) (setf *quit-when-done* nil) - (setf *package* (find-package :asdf-test))) + (frob-packages)) (defun just-load-asdf-fasl () (load-asdf-fasl)) @@ -748,7 +748,7 @@ is bound, write a message and exit on an error. If (defun clear-cache () ;; Or, should we preserve the timestamps? - (clrhash (asymval :*asdf-cache*))) + (clrhash (acall :asdf-cache))) ;; These are shorthands for interactive debugging of test scripts: (!a diff --git a/test/stamp-propagation/test-stamp-propagation.lisp b/test/stamp-propagation/test-stamp-propagation.lisp index 2e32d1723b06b71fba88df14857d41f1f9296f46..e5ae9319cff4cd74d87ef5d40d4bdc3e1b78bc9d 100644 --- a/test/stamp-propagation/test-stamp-propagation.lisp +++ b/test/stamp-propagation/test-stamp-propagation.lisp @@ -37,6 +37,7 @@ #+asdf :asdf)) (defvar *default-defsystem* (first *defsystems*)) (defvar asdf::*asdf-cache* nil) ;; if defparameter instead of defvar, disable any surrounding cache +(defvar asdf::*asdf-session* nil) ;; if defparameter instead of defvar, disable any surrounding cache (defun lisppath (filename) (asdf::subpathname *tsp* filename)) (defun faslpath (lisppath &optional (defsystem *default-defsystem*)) @@ -51,8 +52,11 @@ (defun use-cache-p (defsystem) (and (eq defsystem :asdf) - (asdf:version-satisfies (asdf:asdf-version) "2.27") - asdf::*asdf-cache*)) + (cond + ((asdf:version-satisfies (asdf:asdf-version) "3.1.7.30") + asdf::*asdf-session*) + ((asdf:version-satisfies (asdf:asdf-version) "2.27") + asdf::*asdf-cache*)))) #+allegro (excl:defsystem :test-stamp-propagation @@ -92,7 +96,6 @@ "file2.lisp")) (defun reload (&optional (defsystem *default-defsystem*)) - (format t "~&ASDF-CACHE before ~S~%" asdf::*asdf-cache*) (setf *eval-notes* nil) (setf *compile-verbose* t *load-verbose* t) (ecase defsystem @@ -118,7 +121,6 @@ #+allegro (excl:load-system :test-stamp-propagation) #+lispworks (scm:load-system :test-stamp-propagation) #+genera (sct:load-system :test-stamp-propagation))) - (format t "~&ASDF-CACHE after ~S~%" asdf::*asdf-cache*) (let ((n (eval-notes))) (format t "~&EVAL-NOTES ~S~%" n) n)) @@ -143,7 +145,7 @@ (defun clear-fasls (&optional (defsystem *default-defsystem*)) (loop :for file :in '("file1.lisp" "file2.lisp") :for faslpath = (faslpath file defsystem) - :do (if (and (eq defsystem :asdf) asdf::*asdf-cache*) + :do (if (use-cache-p defsystem) (mark-file-deleted faslpath) (delete-file-if-exists faslpath)))) @@ -153,7 +155,7 @@ :test 'equal :from-end t)) (defun adjust-stamp-cache (base l1 f1 l2 f2) - (clrhash asdf::*asdf-cache*) + (clrhash (asdf::asdf-cache)) (touch-file (lisppath "file1.lisp") :timestamp base :offset l1) (touch-file (faslpath "file1.lisp") :timestamp base :offset f1) (dolist (l (asdf:output-files 'asdf:compile-op '(:test-stamp-propagation "file1"))) diff --git a/test/test-asdf.script b/test/test-asdf.script index 2451fffec5246ae3417f7590e8f3df1e09cf10b7..655363925d3175e14592a87a5e840cb023d6f3c2 100644 --- a/test/test-asdf.script +++ b/test/test-asdf.script @@ -1,4 +1,4 @@ -(with-asdf-cache (:override t) +(with-asdf-session (:override t) (load-system "test-asdf/test-module-depend")) (defparameter *plan* (make-plan () 'load-op "test-asdf/test-module-depend")) diff --git a/test/test-encodings.script b/test/test-encodings.script index e93abff3571e1c6adac8510f6ae29691ac936ac5..3a921b8caaaf1c8978e296223ff86118b27bd366 100644 --- a/test/test-encodings.script +++ b/test/test-encodings.script @@ -21,7 +21,7 @@ (defmacro with-encoding-test ((encoding &key (op 'load-source-op) (path "lambda")) def-test-system &body body) (let ((sys (second def-test-system))) - `(with-asdf-cache (:override t) + `(with-asdf-session (:override t) (format t "~&Test ~A: should be ~A~%" ',sys ',encoding) (setf *lambda-string* nil) ,def-test-system diff --git a/test/test-logical-pathname.script b/test/test-logical-pathname.script index e24409fe654210a8aee01b5726e71bdbb4a1f89d..d3724aa52bd0b651fa5fdc29c33fd8336f703993 100644 --- a/test/test-logical-pathname.script +++ b/test/test-logical-pathname.script @@ -10,7 +10,7 @@ `(,*asdf-directory* "build/fasls" :implementation "logical-host-asdf") :wilden t)))) -(setf asdf/session:*asdf-cache* nil) +(setf asdf/session:*asdf-session* nil) (DBG :logical (logical-pathname-translations "ASDF") diff --git a/test/test-mutual-redefinition.script b/test/test-mutual-redefinition.script index 426525fbb3a6be32150756266e94d8731bf0e514..b1731403e2397e1599381bf924c14a86992f0471 100644 --- a/test/test-mutual-redefinition.script +++ b/test/test-mutual-redefinition.script @@ -3,7 +3,7 @@ (defun current-system-source-file (x) (system-source-file (asdf::registered-system x))) -(with-asdf-cache () +(with-asdf-session (:override t) (DBG "loading test-mutual-redefinition-1") (let ((warned-p nil)) (handler-bind ((bad-system-name (lambda (c) @@ -28,7 +28,7 @@ (test-source "test-mutual-redefinition-1.asd") (current-system-source-file "test-mutual-redefinition-2")) - (with-asdf-cache (:override t) + (with-asdf-session (:override t) (DBG "loading test-mutual-redefinition-2 in a different cache session") (load-system 'test-mutual-redefinition-2) (assert-pathname-equal diff --git a/test/test-retry-loading-component-1.script b/test/test-retry-loading-component-1.script index 63620a5fbefeff54a55288c4d184333f0e756ba7..50f41e594015bbaa505a16a46fcbfff51917da56 100644 --- a/test/test-retry-loading-component-1.script +++ b/test/test-retry-loading-component-1.script @@ -6,7 +6,7 @@ (defvar *caught-error* nil) (delete-file-if-exists (test-source "try-reloading-dependency.asd")) -(with-asdf-cache (:override t) +(with-asdf-session (:override t) (handler-bind ((error #'(lambda (c) (format t "~&Caught error ~s" c) diff --git a/test/test-try-refinding.script b/test/test-try-refinding.script index ff1c677b2ed7de0708cd36082d60f21f2adc7e30..227d5208c4729fcf60882824566ebe88c4acaed0 100644 --- a/test/test-try-refinding.script +++ b/test/test-try-refinding.script @@ -21,7 +21,7 @@ (DBG "Correctly failed to find system.") (defvar *attempts* 0) (assert - (with-asdf-cache (:override t) + (with-asdf-session (:override t) (handler-bind ((asdf:missing-component #'(lambda (c) @@ -45,12 +45,8 @@ (def-test-system test-missing-dependency :depends-on ("test-asdf/force1") :components ((:file "file2"))) -;; (trace find-system) -;; (trace find-component) -;; (trace asdf::component-find-path) -;; (trace operate) (setf *attempts* 0) -(with-asdf-cache (:override t) +(with-asdf-session (:override t) (flet ((handle-missing (c) (if (zerop *attempts*) (let ((missing (asdf::missing-requires c))) diff --git a/test/test-xach-update-bug.script b/test/test-xach-update-bug.script index 5a53171adf398a80fc1edae0631fea6b91461e4e..37255f26f4cbde8102e2016b6dcdb407dba3df19 100644 --- a/test/test-xach-update-bug.script +++ b/test/test-xach-update-bug.script @@ -1,6 +1,7 @@ ;;; -*- Lisp -*- -(setf asdf/session:*asdf-cache* nil) ;; disable cache between those two very different compilations. +;; Disable cache between those two very different compilations. +(setf asdf/session:*asdf-session* nil) #-(and ecl ecl-bytecmp) (setf asdf::*load-system-operation* 'load-bundle-op) ;; This triggers a bug on ECL no more!