Loading cache.lisp +6 −1 Original line number Diff line number Diff line Loading @@ -4,7 +4,8 @@ (uiop/package:define-package :asdf/cache (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp #:set-asdf-cache-entry #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring #: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*)) (in-package :asdf/cache) Loading @@ -22,6 +23,10 @@ (setf (gethash key *asdf-cache*) value-list) value-list))) (defun unset-asdf-cache-entry (key) (when *asdf-cache* (remhash key *asdf-cache*))) (defun consult-asdf-cache (key &optional thunk) (if *asdf-cache* (multiple-value-bind (results foundp) (gethash key *asdf-cache*) Loading find-component.lisp +7 −2 Original line number Diff line number Diff line Loading @@ -3,7 +3,7 @@ (uiop/package:define-package :asdf/find-component (:recycle :asdf/find-component :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache :asdf/component :asdf/system :asdf/find-system) (:export #:find-component Loading Loading @@ -106,7 +106,12 @@ (or (null c) (and (typep c 'missing-dependency) (eq (missing-required-by c) component) (equal (missing-requires c) name)))))))) (equal (missing-requires c) name)))) (unless (component-parent component) (let ((name (coerce-name name))) (unset-asdf-cache-entry `(find-system ,name)) (unset-asdf-cache-entry `(locate-system ,name)))))))) (defun resolve-dependency-spec (component dep-spec) (let ((component (find-component () component))) Loading find-system.lisp +14 −10 Original line number Diff line number Diff line Loading @@ -18,7 +18,7 @@ #:find-system-if-being-defined #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* #:clear-defined-systems #:*defined-systems* #:clear-defined-system #:clear-defined-systems #:*defined-systems* #:*immutable-systems* ;; defined in source-registry, but specially mentioned here: #:initialize-source-registry #:sysdef-source-registry-search)) Loading Loading @@ -89,15 +89,18 @@ of which is a system object.") (get-file-stamp file)) system))))) (defun clear-defined-system (system) (let ((name (coerce-name system))) (remhash name *defined-systems*) (unset-asdf-cache-entry `(locate-system ,name)) (unset-asdf-cache-entry `(find-system ,name)) nil)) (defun clear-defined-systems () ;; Invalidate all systems but ASDF itself, if registered. (let ((asdf (cdr (system-registered-p :asdf)))) (setf *defined-systems* (make-hash-table :test 'equal)) (when asdf (setf (component-version asdf) *asdf-version*) (setf (builtin-system-p asdf) t) (register-system asdf))) (values)) (loop :for name :being :the :hash-keys :of *defined-systems* :unless (equal name "asdf") :do (clear-defined-system name))) (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil) Loading Loading @@ -256,7 +259,7 @@ Going forward, we recommend new users should be using the source-registry. (defun find-system-if-being-defined (name) ;; notable side effect: mark the system as being defined, to avoid infinite loops (values (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))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*)) ;; Tries to load system definition with canonical NAME from PATHNAME. Loading Loading @@ -389,7 +392,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (multiple-value-bind (foundp found-system pathname previous previous-time) (locate-system name) (when (and found-system (eq found-system previous) (or (gethash `(find-system ,name) *asdf-cache*) (or (first (gethash `(find-system ,name) *asdf-cache*)) (and *immutable-systems* (gethash name *immutable-systems*)))) (return found-system)) (assert (eq foundp (and (or found-system pathname previous) t))) Loading Loading @@ -423,5 +426,6 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (reinitialize-source-registry-and-retry () :report (lambda (s) (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name)) (unset-asdf-cache-entry `(locate-system ,name)) (initialize-source-registry))))))) test/make-hello-world.lisp +0 −1 Original line number Diff line number Diff line Loading @@ -23,4 +23,3 @@ (exe (asdf::output-file 'program-op :hello-world-example)) (dll-dest (subpathname exe dll-orig))) (copy-file dll-orig dll-dest))) test/test-program.script +25 −20 Original line number Diff line number Diff line Loading @@ -2,7 +2,7 @@ (DBG :foo (current-lisp-file-pathname)) (unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) gcl lispworks mkcl sbcl scl) t) (unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl scl) t) (DBG "Creating images is not supported on your CL implementation") (leave-test "Skipping test" 0)) Loading Loading @@ -38,19 +38,24 @@ 0) (assert (probe-file* img) () "Can't find image file ~S" img) (assert-equal (run-program (assert-equal (nest #+lispworks (last) (run-program (symbol-call :lisp-invocation :lisp-invocation-arglist :image-path (native-namestring img) :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)") :output :lines) :output :lines :error-output t)) '("hello, world")) (assert-equal (run-program #-(or lispworks scl) ;; These can't be passed arguments the normal way (assert-equal (run-program (symbol-call :lisp-invocation :lisp-invocation-arglist :image-path (native-namestring img) :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)" :arguments '("a" "b c" "d")) :output :lines) :output :lines :error-output t) '("hello, world" "You passed 3 arguments:" " \"a\"" Loading Loading @@ -80,10 +85,10 @@ (assert (probe-file* exe) () "Can't find executable file ~S" exe) (assert-equal (run-program `(,(native-namestring exe)) :output :lines) (assert-equal (run-program `(,(native-namestring exe)) :output :lines :error-output t) '("hello, world")) (assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines) (assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines :error-output t) '("hello, world" "You passed 3 arguments:" " \"a\"" Loading Loading
cache.lisp +6 −1 Original line number Diff line number Diff line Loading @@ -4,7 +4,8 @@ (uiop/package:define-package :asdf/cache (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp #:set-asdf-cache-entry #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring #: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*)) (in-package :asdf/cache) Loading @@ -22,6 +23,10 @@ (setf (gethash key *asdf-cache*) value-list) value-list))) (defun unset-asdf-cache-entry (key) (when *asdf-cache* (remhash key *asdf-cache*))) (defun consult-asdf-cache (key &optional thunk) (if *asdf-cache* (multiple-value-bind (results foundp) (gethash key *asdf-cache*) Loading
find-component.lisp +7 −2 Original line number Diff line number Diff line Loading @@ -3,7 +3,7 @@ (uiop/package:define-package :asdf/find-component (:recycle :asdf/find-component :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache :asdf/component :asdf/system :asdf/find-system) (:export #:find-component Loading Loading @@ -106,7 +106,12 @@ (or (null c) (and (typep c 'missing-dependency) (eq (missing-required-by c) component) (equal (missing-requires c) name)))))))) (equal (missing-requires c) name)))) (unless (component-parent component) (let ((name (coerce-name name))) (unset-asdf-cache-entry `(find-system ,name)) (unset-asdf-cache-entry `(locate-system ,name)))))))) (defun resolve-dependency-spec (component dep-spec) (let ((component (find-component () component))) Loading
find-system.lisp +14 −10 Original line number Diff line number Diff line Loading @@ -18,7 +18,7 @@ #:find-system-if-being-defined #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* #:clear-defined-systems #:*defined-systems* #:clear-defined-system #:clear-defined-systems #:*defined-systems* #:*immutable-systems* ;; defined in source-registry, but specially mentioned here: #:initialize-source-registry #:sysdef-source-registry-search)) Loading Loading @@ -89,15 +89,18 @@ of which is a system object.") (get-file-stamp file)) system))))) (defun clear-defined-system (system) (let ((name (coerce-name system))) (remhash name *defined-systems*) (unset-asdf-cache-entry `(locate-system ,name)) (unset-asdf-cache-entry `(find-system ,name)) nil)) (defun clear-defined-systems () ;; Invalidate all systems but ASDF itself, if registered. (let ((asdf (cdr (system-registered-p :asdf)))) (setf *defined-systems* (make-hash-table :test 'equal)) (when asdf (setf (component-version asdf) *asdf-version*) (setf (builtin-system-p asdf) t) (register-system asdf))) (values)) (loop :for name :being :the :hash-keys :of *defined-systems* :unless (equal name "asdf") :do (clear-defined-system name))) (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil) Loading Loading @@ -256,7 +259,7 @@ Going forward, we recommend new users should be using the source-registry. (defun find-system-if-being-defined (name) ;; notable side effect: mark the system as being defined, to avoid infinite loops (values (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))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*)) ;; Tries to load system definition with canonical NAME from PATHNAME. Loading Loading @@ -389,7 +392,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (multiple-value-bind (foundp found-system pathname previous previous-time) (locate-system name) (when (and found-system (eq found-system previous) (or (gethash `(find-system ,name) *asdf-cache*) (or (first (gethash `(find-system ,name) *asdf-cache*)) (and *immutable-systems* (gethash name *immutable-systems*)))) (return found-system)) (assert (eq foundp (and (or found-system pathname previous) t))) Loading Loading @@ -423,5 +426,6 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (reinitialize-source-registry-and-retry () :report (lambda (s) (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name)) (unset-asdf-cache-entry `(locate-system ,name)) (initialize-source-registry)))))))
test/make-hello-world.lisp +0 −1 Original line number Diff line number Diff line Loading @@ -23,4 +23,3 @@ (exe (asdf::output-file 'program-op :hello-world-example)) (dll-dest (subpathname exe dll-orig))) (copy-file dll-orig dll-dest)))
test/test-program.script +25 −20 Original line number Diff line number Diff line Loading @@ -2,7 +2,7 @@ (DBG :foo (current-lisp-file-pathname)) (unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) gcl lispworks mkcl sbcl scl) t) (unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl scl) t) (DBG "Creating images is not supported on your CL implementation") (leave-test "Skipping test" 0)) Loading Loading @@ -38,19 +38,24 @@ 0) (assert (probe-file* img) () "Can't find image file ~S" img) (assert-equal (run-program (assert-equal (nest #+lispworks (last) (run-program (symbol-call :lisp-invocation :lisp-invocation-arglist :image-path (native-namestring img) :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)") :output :lines) :output :lines :error-output t)) '("hello, world")) (assert-equal (run-program #-(or lispworks scl) ;; These can't be passed arguments the normal way (assert-equal (run-program (symbol-call :lisp-invocation :lisp-invocation-arglist :image-path (native-namestring img) :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)" :arguments '("a" "b c" "d")) :output :lines) :output :lines :error-output t) '("hello, world" "You passed 3 arguments:" " \"a\"" Loading Loading @@ -80,10 +85,10 @@ (assert (probe-file* exe) () "Can't find executable file ~S" exe) (assert-equal (run-program `(,(native-namestring exe)) :output :lines) (assert-equal (run-program `(,(native-namestring exe)) :output :lines :error-output t) '("hello, world")) (assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines) (assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines :error-output t) '("hello, world" "You passed 3 arguments:" " \"a\"" Loading