diff --git a/.gitignore b/.gitignore index 98c7cce177bf8119a2d3bb030eb7bc28713123e2..c0ab4783534f8818dda6d4a0f18ace3fc8fa1c2f 100644 --- a/.gitignore +++ b/.gitignore @@ -48,6 +48,7 @@ lib/ test/try-reloading-dependency.asd test/fileMissing.lisp test/hello-world-example +test/test-include.asd build-stamp diff --git a/Makefile b/Makefile index f8a9fdfc8b335c7cdba110004e9983335dba3b27..8044095900858abac449460916a7c027144f29b8 100644 --- a/Makefile +++ b/Makefile @@ -80,13 +80,13 @@ XCL ?= xcl header_lisp := header.lisp driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp -defsystem_lisp := upgrade.lisp cache.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp output-translations.lisp source-registry.lisp package-inferred-system.lisp backward-interface.lisp backward-internals.lisp interface.lisp user.lisp footer.lisp +defsystem_lisp := upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.lisp forcing.lisp plan.lisp operate.lisp find-system.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp) print-% : ; @echo $* = $($*) # Making ASDF itself should be our first, default, target: -build/asdf.lisp: show-version $(all_lisp) +build/asdf.lisp: $(all_lisp) mkdir -p build rm -f $@ cat $(all_lisp) > $@ diff --git a/TODO b/TODO index 1899bc60b75bb8a4c7a0fe0cb48ed1844f9c268b..bb0303d6d7537686a80dfc2c7034f2db2f9abacb 100644 --- a/TODO +++ b/TODO @@ -1,6 +1,6 @@ * Decree that versions older than 2 years are not supported; - yet, keep supporting an upgrade from whatever vendors provide - — so push them to provide recent stuff. + yet, keep supporting an upgrade from whatever vendors provide + — so push them to provide recent stuff. ** Already, swank-asdf doesn't support anything older than 2.014.6 (as provided by the first 2011 iteration of Quicklisp), and I (fare) am pushing for swank-asdf to not support anything older @@ -17,7 +17,13 @@ ** Make tests stateless and/or make any modifications private, so that they can be run in parallel. -* Moving toward cross-compilation (ASDF 3.2? 4?) +* Testing support +** Replace test-op with run-test-op and test-report-op ? + +* Implement a style-checker, that will issue STYLE-WARNINGs + when you don't follow all the recommended guidelines. + +* Moving toward cross-compilation (ASDF 3.4? 4?) This would allow to get most of the benefits of XCVB (reproducibility, scalability, applicability to mobile platforms, etc.), except without the backward incompatibility of XCVB. @@ -112,14 +118,14 @@ make t l=cmucl t=test-encodings.script which was a different PCL bug from the above (without same workaround) but possibly also triggered by the non-standard declaim. -*** `#5(1 ,@`(2 3)))` returns #(1 2 3), - rather than #(1 2 3 2 3 2 3 2 3) or even better #(1 2 3 3 3). +*** `#5(1 ,@\`(2 3)))` returns `#(1 2 3)`, + rather than `#(1 2 3 2 3 2 3 2 3)` or even better `#(1 2 3 3 3)`. *** It purports to support Unicode, but it has only 16-bit characters. Note that (subtypep 'character 'base-char) says T -- everything is a base char(!) ** SCL has bugs: *** it doesn't like run-program from a modified directory? -*** it somehow pushes :non-base-chars-exist-p even though +non-base-chars-exist-p+ is NIL??? +*** it somehow pushes `:non-base-chars-exist-p` even though `+non-base-chars-exist-p+` is `NIL`??? ** XCL has bad bugs: *** make-pathname doesn't handle :type nil properly and @@ -140,6 +146,7 @@ (make-pathname :name "foo" :type :unspecific) ==> #P"foo." If bug is ever fixed, upgrade *unspecific-pathname-type* in uiop/pathname. *** XCL doesn't properly process files the name of which contains a * +*** XCL fails to recognize that specialized method parameters are implicitly ignorable. ** GCL is almost working again; but implementation bugs remain. See Francois-Rene Rideau's messages on gcl-devel starting November 2013. @@ -154,33 +161,33 @@ INTERNAL-SIMPLE-ERROR: The package named ASDF/INTERFACE, does not exist *** Another GCL compiler bug: when I changed the definition of getcwd from - (let ((*default-pathname-defaults* #p"")) (truename #p"")) to - (let ((*default-pathname-defaults* *nil-pathname*)) (truename *nil-pathname*)) + `(let ((*default-pathname-defaults* #p"")) (truename #p""))` to + `(let ((*default-pathname-defaults* *nil-pathname*)) (truename *nil-pathname*))` to guard against e.g. a logical-pathname context while loading asdf - and parsing #p"", calls to getcwd result in a segfault. + and parsing `#p""`, calls to `getcwd` result in a segfault. *** An another bug: gcl refuses dynamic-extent declaration on functions. - uiop/stream.lisp: #-gcl (declare (dynamic-extent ,@(when - before `(#',beforef)) ,@(when after `(#',afterf)))) -*** (typep p 'logical-pathname) should be T if p has a logical-pathname host. -*** apropos is case-sensitive and returns a same symbol many times + ```uiop/stream.lisp: #-gcl (declare (dynamic-extent ,@(when + before `(#',beforef)) ,@(when after `(#',afterf))))``` +*** `(typep p 'logical-pathname)` should be T if p has a logical-pathname host. +*** `apropos` is case-sensitive and returns a same symbol many times (presumably once per package where it is present, instead of just once for its home package) -*** compile-file fails to return proper secondary values in case of non-style WARNING. -*** (pathname-directory #p"foo/") is incorrectly ("foo") instead of (:RELATIVE "foo") +*** `compile-file` fails to return proper secondary values in case of non-style `WARNING`. +*** `(pathname-directory #p"foo/")` is incorrectly `("foo")` instead of `(:RELATIVE "foo")` *** Do whatever it takes to pass the asdf tests, add the above? -*** Trying to uiop:slurp-stream-forms from a stream with #+(or) :foo - (or read-file-forms from an file with same) results in an error, - rather than nil. This is probably a bug in #+ processing. +*** Trying to `uiop:slurp-stream-forms` from a stream with `#+(or) :foo` + (or `read-file-forms` from an file with same) results in an error, + rather than `nil`. This is probably a bug in `#+` processing. Unhappily, debian creates such a file in - /etc/common-lisp/asdf-output-translations.conf.d/01-common-lisp-controller.conf + `/etc/common-lisp/asdf-output-translations.conf.d/01-common-lisp-controller.conf` *** Tests that try to catch an error fail (but catching a warning succeeds), which suggests brokenness in handler-bind and/or error. -*** COMPILE-FILE* fails due to handler-bind error in - with-muffled-compiler-conditions or so. -*** `#5(1 ,@`(2 3)))` returns #(1 2 3), - rather than #(1 2 3 2 3 2 3 2 3) or even better #(1 2 3 3 3). -*** (DIRECTORY #p"*.*") fails to match files with pathname type NIL. -*** GCL doesn't properly process files the name of which contains a * +*** `COMPILE-FILE*` fails due to handler-bind error in + `with-muffled-compiler-conditions` or so. +*** `#5(1 ,@`(2 3)))` returns `#(1 2 3)`, + rather than `#(1 2 3 2 3 2 3 2 3)` or even better `#(1 2 3 3 3)`. +*** `(DIRECTORY #p"*.*")` fails to match files with pathname-type `NIL`. +*** GCL doesn't properly process files the name of which contains a `*` ** ABCL has a few bugs. *** ABCL fails the timestamp propagation test. @@ -243,12 +250,6 @@ ** Real solution: defer parsing and evaluation of defsystem forms? Or simply detect circularity and issue an appropriate error? -* Implement proper incrementality for defsystem-depends-on. -** For proper incremental redefinitions, systems probably need to - depend-on (load-asd-op . primary-system) which itself will - depend-on all the load-op of defsystem-depends-on in that file. - https://bugs.launchpad.net/asdf/+bug/1500578 - * Include some ABL test for stassats's (now obsolete?) thing: (asdf:enable-asdf-binary-locations-compatibility :centralize-lisp-binaries t :default-toplevel-directory *fasl-dir*) @@ -382,6 +383,20 @@ It looks like SWANK can be fixed soon, though, so we'll see. version * ASDF4: search for this tag, rename things (incompatibly, thus) and cleanup code. +** Migrate from component-depends-on to action-depends-on +*** I contend a future version of ASDF will replace +`(component-depends-on operation component)` +with `(action-depends-on plan operation component)`. +This allows for different normalization strategies for dependencies +(including strategies that avoid resolving things to NIL), +a reified context for featurep checks, etc. +*** Easy but long backward-compatible transition: +**** get all users to use the new gf and keep extending both new and old gf, + meanwhile the new gf has an around method that actually calls the old gf + except in testing mode and/or if we can check that they're using the new convention +**** when everyone has migrated, remove the old mode and the short-circuit. +*** However, we cannot deprecate component-depends-on yet — not until we have + some transition in place to a better interface. * Documentation ** See message from 2014-01-27 05:26:44 GMT for stuff to document. @@ -417,22 +432,6 @@ It looks like SWANK can be fixed soon, though, so we'll see. *** There again, a check that a forward-package is not backward would be very nice. -* Migrate from component-depends-on to action-depends-on -** I contend a future version of ASDF will replace - (component-depends-on operation component) - with (action-depends-on plan operation component). - This allows for different normalization strategies for dependencies - (including strategies that avoid resolving things to NIL), - a reified context for featurep checks, etc. -** Easy but long backward-compatible transition: -*** get all users to use the new gf and keep extending both new and old gf, - meanwhile the new gf has an around method that actually calls the old gf - except in testing mode and/or if we can check that they're using the new convention -*** when everyone has migrated, remove the old mode and the short-circuit. -** However, we cannot deprecate component-depends-on yet — not until we have - some transition in place to a better interface. - - * Faster source-registry: ** In addition and/or as a substitute to the .cl-source-registry.cache, that is meant to be semi-automatically managed, there could be @@ -457,10 +456,173 @@ It looks like SWANK can be fixed soon, though, so we'll see. * Properly deprecate all that needs to go ** Get lisa, readable, bourbaki to NOT include ASDF 1 anymore in their sources. ** Identify all the things in ASDF that we want to deprecate, and make - sure we deprecate them all in 3.2. + sure we deprecate them all in 3.4. ** Implement support for deprecating old packages, by having all functions and macros under the old package name be proxies to those in the new package name? (Exception: special variables can't be proxies, have to be imported.) ** Eradicate Quicklisp systems that depend on asdf-driver or asdf-package-system, make them depend on uiop and asdf3.1 instead. + +* Fix plan +** Goal: Implement proper incrementality for defsystem-depends-on. +Fix the bug wherein ASDF fails to properly handle incrementality for `defsystem-depends-on`. +https://bugs.launchpad.net/asdf/+bug/1500578 +Some discussion about ASDF at +http://ccl.clozure.com/irc-logs/lisp/lisp-2016-10.txt + +** DONE Items +*** Add `DEFINE-OP` for loading system definitions. +*** A `DEFINE-OP` will depend on other `DEFINE-OP`s +*** A `DEFINE-OP` depends on all `LOAD-OP` in the file. +Whether via defsystem-depends-on or manual `LOAD-OP`s. +*** Store timestamps in `DEFINE-OP` entries, not `*DEFINED-SYSTEMS*`. +*** In find-system, add condition that all dependencies are up-to-date. +*** This necessitates another layer of visit states, +that do not plan, just check planning... +*** `LOAD-ASD` calls `PERFORM DEFINE-OP` (not the other way around) +*** Systems probably need depend on `(DEFINE-OP . PRIMARY-SYSTEM)` +*** These dynamically-discovered dependencies are stored in a slot of `SYSTEM`. +*** Have a special kind of definition-depends-on dependency. +Before we reuse a node from a previous session, +we must make sure it is still properly defined. +This matters because we do reuse (at least *some* nodes, e.g. system nodes) +from previous sessions, and the control structure may have changed +(i.e. the system hasn't been redefined, but one of its defsystem-depends-on +dependencies has changed). +*** Handle incomplete definitions properly +Don't just let the incompletely parsed system be registered +in a false positive success as if it were an empty system. +Solution: It is registered, but considered out-of-date, +so next attempt to use it will cause a refresh attempt. +https://bugs.launchpad.net/asdf/+bug/1515372 +*** Handle nested calls to `OPERATE` +We must accept that ASDF isn't really plan-then-perform, +as the ASDF1 model claimed to be. +It's an arbitrary nesting of plan-and-perform, like a parenthesization +with plan (steps) as left parenthesis and perform (steps) as right parenthesis, +and with operate being a maximal balanced span of plan and perform steps. +*** What goes in a shared dynamic `*SESSION*`, what in a private lexical `PLAN`? +Memoization CACHE of various functions, Status of VISITED-NODES, FORCING parameters. +The session will contain not just the current `*CACHE*`, but also +all or most of the graph traversal, thus the `:force` options, etc. +The `*PLAN*` may or may not contain some work queueing. +But even, e.g. a table of "nodes still directly blocking us" +is shared at the shared traversal level. +*** It is an error for a nested `OPERATE` to contradict session flags. +This raises the question of `:force` and `:force-not` flags. +An actual operate cannot contradict them and cause things to be performed +with a wrong subset of dependencies loaded. +Yet, `REQUIRED-COMPONENTS` (that does cause anything to be performed — +except via nested `OPERATE` from `defsystem-depends-on`) +must be able to skip some dependencies +(though maybe only _in addition_ to the global ones). +*** What timestamp for `forced` and `forced-not` actions? +If an action is forced-not, it should be returned with an action stamp from this cache, +and not with `nil` as is currently wrongly done +(unless of course the cache entry is missing, +at which point `nil` is the correct answer). +Conversely, a force means the stamp should be `t` +(indicating it needs to be done in the future) +(that part asdf gets right). +*** Handle planning things that are now done but were done in a previous phase of the build, +so dependency on them should trigger the build. +*** Protocol to not re-perform an action twice +In PERFORM-PLAN, check that an action wasn't already DONE-P due to +being needed in a previous phase of recursively calling OPERATE, +before to PERFORM it. +To correctly propagate timestamps in across nested calls, +the graph traversal and timestamp propagation is shared at the session level +between all nested calls to `OPERATE`. +During a session and across phases, every action has a status made of +a stamp and three bits: KEEP-P, DONE-P, NEED-P. +The stamp also survives across sessions, in `COMPONENT-OPERATION-TIMES`. +*** Detect circularities across nested calls to `OPERATE` +This means the circularity detection data is part of the session. +Notably, the visiting list and set. +The top of the list can also serve to record the dependencies from `OPERATE` to `DEPEND-OP`. +*** In UIOP, RECORD-DEPENDENCY must not cross to an upper plan and/or it should +record the dependency in said upper plan (that matters because +parallel plans doing extra checking, and this is a problem +whereby some links to extra actions are left unresolved). +Maybe in the future, record the dependency in the session, not in a plan. + +** TODO items +*** find-system should probably cause a dependency on define-op, especially inside another define-op +*** Is it worth it trying to optimize away a dependency on a define-op +when an action already depends on another operation that "obviously" depends on that define-op? +*** Document DEFINE-OP and the design in asdf.texinfo and/or in some article. + +** Future developments +*** Grovel all .asd files in Quicklisp and collect all violations of declarativeness, +where declarativeness is having only defsystem forms. Specially classify in-package, +maybe also defpackage. Then we can assess the impact of requiring declarativeness. +*** Also grovel Quicklisp for all extensions to ASDF: +see if there are new methods on perform, input-files, output-files, operate, etc. +*** To allow defsystem-depends-on to another secondary system within the +same file, I can imagine some system to dynamically create a separate action +(DEFINE-OP foo/x) for each form defsystem foo/x, and have it depend on +all the preceding actions operated in the .asd file. +Plus a last action for dangling load-system or operate statements? +Or one action for every operate statement? +There would be no action of the entire load-asd, but a separate mechanism +to detect circularity? +What about dangling statements? They would be a bit like xcvb weakly-ordered +run-time dependencies that CAN have circularities? Ouch. Really ugly. +Each statement would need its own action? Ouch. +*** Have load-asd clear any invalidated previous secondary system +before loading, which supposes remembering what these systems are. +Then, you're not allowed to forward-reference a secondary system that +hasn't been defined yet while you're loading the .asd, whereas you +can load the asd if you aren't loading it yet. +*** Maybe split DEFINE-OP into PREPARE-DEFINE-OP and DEFINE-OP, so that +secondary systems can be properly loaded? +*** Add mapping from files to action that creates it and/or uses it? +Then we can detect conflict between multiple actions creating one file. +Forbid direct use of files not listed as inputs? What about transitive inputs? +Build in a container that has only the proper files... +*** What data structure for scheduling planned actions? +A doubly-linked to remove entire chunks of the plan after a sub-operate? +That won't do, because later-discovered defsystem dependency can refer to +systems that were planned but not performed, so there need be no contiguity +in the chunks that are performed by subcalls to operate. +Actually, if we otherwise forbid reference to another system +from non-system components, then we could move things with system granularity, +which is one thing; but we still need a general mechanism at the system level. +So, whether it's an explicit queue or an implicit traversal of the dependency graph, +we must check whether an action has already been done before we try to perform it. +And an implicit traversal has the advantage that you can avoid entire subtrees +when you find that the current node has already been performed during +a previous phase of the plan. +In conclusion: "just" traverse the graph at the last minute, and +perform things serially, and/or if you want some parallelism, +build a queue dynamically at the last minute for the "now" jobs +while keeping most of the plan as graph structures. + +*** Merging in parts of POIU? +ASDF internals are nothing to be proud of: +ASDF1 was optimized for "smallest code that kind of works in the usual case", +and ASDF3 was optimized for "smallest code that fixes ASDF1 in the general case +while mostly maintaining backward compatibility". + +Because of its optimization constraint, ASDF1 was using and abusing lists a lot, +rather than defining nice data structures. +ASDF3 uses somewhat more structured data, with a few more classes, and +algorithms that are O(n) instead of O(n**3) in simple cases and +exponential in carefully crafted examples; +yet it has shunned any definition of more advanced or general data structures. +By contrast, POIU has a dequeue to represent queued compilation jobs, and +a general graph representation for the action graph +(though the original POIU was also O(n**3) because it lacked PREPARE-OP). + +I could import the POIU queue and graph representations into ASDF, and +that would add about 100 lines of code to UIOP for the queue, and +200 lines to ASDF for the graph, maybe a bit more if the code is +generalized, commented and largely put in UIOP. + +Then, there's the support for actual forking and using forks, +that would be about 400 lines added to UIOP, and +the using it in ASDF to consume the plan, which would be under 200 lines. +But those parts are probably better left out of ASDF itself. +That said, it all was a lot when ASDF was < 1000 lines of code, +but isn't all that much now that it is > 12000 lines of code. diff --git a/action.lisp b/action.lisp index 9aae7abc7d76e01f06be11feccd2c813038ca5b1..6d68ffb7268cc8b99ba7d897e7f090cad9c5abbe 100644 --- a/action.lisp +++ b/action.lisp @@ -3,24 +3,26 @@ (uiop/package:define-package :asdf/action (:nicknames :asdf-action) - (:recycle :asdf/action :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade - :asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation) + (:recycle :asdf/action :asdf/plan :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/operation) (:import-from :asdf/operation #:check-operation-constructor) - #-clisp (:unintern #:required-components #:traverse-action #:traverse-sub-actions) + (:import-from :asdf/component #:%additional-input-files) (:export #:action #:define-convenience-action-methods - #:action-description - #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation + #:action-description #:format-action + #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation + #:non-propagating-operation #:component-depends-on #:input-files #:output-files #:output-file #:operation-done-p - #:action-status #:action-stamp #:action-done-p #:action-operation #:action-component #:make-action #:component-operation-time #:mark-operation-done #:compute-action-stamp #:perform #:perform-with-restarts #:retry #:accept - #:action-path #:find-action #:stamp #:done-p + #:action-path #:find-action #:operation-definition-warning #:operation-definition-error ;; condition - )) + #:action-valid-p + #:circular-dependency #:circular-dependency-actions + #:call-while-visiting-action #:while-visiting-action + #:additional-input-files)) (in-package :asdf/action) (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning @@ -49,9 +51,10 @@ and a class-name or class designates the canonical instance of the designated cl (with-upgradability () (defun action-path (action) "A readable data structure that identifies the action." - (let ((o (action-operation action)) - (c (action-component action))) - (cons (type-of o) (component-find-path c)))) + (when action + (let ((o (action-operation action)) + (c (action-component action))) + (cons (type-of o) (component-find-path c))))) (defun find-action (path) "Reconstitute an action from its action-path" (destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c))))) @@ -109,7 +112,7 @@ and a class-name or class designates the canonical instance of the designated cl ,if-no-component)))))))) -;;;; self-description +;;;; Self-description (with-upgradability () (defgeneric action-description (operation component) (:documentation "returns a phrase that describes performing this operation @@ -127,6 +130,42 @@ Use it in FORMAT control strings as ~/asdf-action:format-action/" (princ (action-description operation component) stream)))) +;;;; Detection of circular dependencies +(with-upgradability () + (defun (action-valid-p) (operation component) + "Is this action valid to include amongst dependencies?" + ;; If either the operation or component was resolved to nil, the action is invalid. + ;; :if-feature will invalidate actions on components for which the features don't apply. + (and operation component + (if-let (it (component-if-feature component)) (featurep it) t))) + + (define-condition circular-dependency (system-definition-error) + ((actions :initarg :actions :reader circular-dependency-actions)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (circular-dependency-actions c))))) + + (defun call-while-visiting-action (operation component fun) + "Detect circular dependencies" + (with-asdf-session () + (with-accessors ((action-set visiting-action-set) + (action-list visiting-action-list)) *asdf-session* + (let ((action (cons operation component))) + (when (gethash action action-set) + (error 'circular-dependency :actions + (member action (reverse action-list) :test 'equal))) + (setf (gethash action action-set) t) + (push action action-list) + (unwind-protect + (funcall fun) + (pop action-list) + (setf (gethash action action-set) nil)))))) + + ;; Syntactic sugar for call-while-visiting-action + (defmacro while-visiting-action ((o c) &body body) + `(call-while-visiting-action ,o ,c #'(lambda () ,@body)))) + + ;;;; Dependencies (with-upgradability () (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies @@ -269,7 +308,7 @@ The class needs to be updated for ASDF 3.1 and specify appropriate propagation m don't. In the future this functionality will be removed, and the default will be no propagation." (uiop/version::notify-deprecated-function (version-deprecation *asdf-version* :style-warning "3.2") - 'backward-compatible-depends-on) + `(backward-compatible-depends-on :for-operation ,o)) `(,@(sideway-operation-depends-on o c) ,@(when (typep c 'parent-component) (downward-operation-depends-on o c)))) @@ -341,10 +380,24 @@ They may rely on the order of the files to discriminate between inputs. (assert (length=n-p files 1)) (first files))) + (defgeneric additional-input-files (operation component) + (:documentation "Additional input files for the operation on this + component. These are files that are inferred, rather than + explicitly specified, and these are typically NOT files that + undergo operations directly. Instead, they are files that it is + important for ASDF to know about in order to compute operation times,etc.")) + (define-convenience-action-methods additional-input-files (operation component)) + (defmethod additional-input-files ((op operation) (comp component)) + (cdr (assoc op (%additional-input-files comp)))) + ;; Memoize input files. (defmethod input-files :around (operation component) (do-asdf-cache `(input-files ,operation ,component) - (call-next-method))) + ;; get the additional input files, if any + (append (call-next-method) + ;; must come after the first, for other code that + ;; assumes the first will be the "key" file + (additional-input-files operation component)))) ;; By default an action has no input-files. (defmethod input-files ((o operation) (c component)) @@ -377,7 +430,8 @@ They may rely on the order of the files to discriminate between inputs. Updates the action's COMPONENT-OPERATION-TIME to match the COMPUTE-ACTION-STAMP using the JUST-DONE flag.")) - (defgeneric compute-action-stamp (plan operation component &key just-done) + (defgeneric compute-action-stamp (plan- operation component &key just-done) + ;; NB: using plan- rather than plan above allows clisp to upgrade from 2.26(!) (:documentation "Has this action been successfully done already, and at what known timestamp has it been done at or will it be done at? * PLAN is a plan object modelling future effects of actions, @@ -393,29 +447,17 @@ Returns two values: * a boolean DONE-P that indicates whether the action has actually been done, and both its output-files and its in-image side-effects are up to date.")) - (defclass action-status () - ((stamp - :initarg :stamp :reader action-stamp - :documentation "STAMP associated with the ACTION if it has been completed already -in some previous image, or T if it needs to be done.") - (done-p - :initarg :done-p :reader action-done-p - :documentation "a boolean, true iff the action was already done (before any planned action).")) - (:documentation "Status of an action")) - - (defmethod print-object ((status action-status) stream) - (print-unreadable-object (status stream :type t) - (with-slots (stamp done-p) status - (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p)))) - (defmethod component-operation-time ((o operation) (c component)) (gethash o (component-operation-times c))) (defmethod (setf component-operation-time) (stamp (o operation) (c component)) + (assert stamp () "invalid null stamp for ~A" (action-description o c)) (setf (gethash o (component-operation-times c)) stamp)) (defmethod mark-operation-done ((o operation) (c component)) - (setf (component-operation-time o c) (compute-action-stamp nil o c :just-done t)))) + (let ((stamp (compute-action-stamp nil o c :just-done t))) + (assert stamp () "Failed to compute a stamp for completed action ~A" (action-description o c))1 + (setf (component-operation-time o c) stamp)))) ;;;; Perform @@ -424,6 +466,8 @@ in some previous image, or T if it needs to be done.") (:documentation "PERFORM an action, consuming its input-files and building its output-files")) (define-convenience-action-methods perform (operation component)) + (defmethod perform :around ((o operation) (c component)) + (while-visiting-action (o c) (call-next-method))) (defmethod perform :before ((o operation) (c component)) (ensure-all-directories-exist (output-files o c))) (defmethod perform :after ((o operation) (c component)) diff --git a/asdf.asd b/asdf.asd index 3fec667bff16c2c0fe63ca49e89bbac09df3cc7e..3410bfef9fd2f5b934a1b833d722116db98e3e67 100644 --- a/asdf.asd +++ b/asdf.asd @@ -21,7 +21,13 @@ #+asdf3 (defsystem "asdf/driver" - :depends-on ("uiop")) + ;; This is the same as "uiop", but used for transclusion in asdf.lisp. + ;; Because asdf.asd can't afford to depend on reading uiop.asd + ;; (which would cause circularity, since everything depends on reading asdf.asd), + ;; we can't "just" :depends-on ("uiop") like we used to do. + :pathname "uiop" + :around-compile call-without-redefinition-warnings ;; we need be the same as uiop + :components #.(getf (read-file-form (subpathname *load-pathname* "uiop/uiop.asd") :at 2) :components)) #+asdf3 (defsystem "asdf/defsystem" @@ -40,28 +46,31 @@ :build-operation monolithic-concatenate-source-op :build-pathname "build/asdf" ;; our target :around-compile call-without-redefinition-warnings ;; we need be the same as uiop - :depends-on ("asdf/prelude" "uiop") + :depends-on ("asdf/prelude" "asdf/driver") :encoding :utf-8 :components ((:file "upgrade") - (:file "cache" :depends-on ("upgrade")) - (:file "component" :depends-on ("upgrade")) + (:file "session" :depends-on ("upgrade")) + (:file "component" :depends-on ("session")) + (:file "operation" :depends-on ("session")) (:file "system" :depends-on ("component")) - (:file "find-system" :depends-on ("system" "cache")) - (:file "find-component" :depends-on ("find-system")) - (:file "operation" :depends-on ("find-system")) - (:file "action" :depends-on ("find-component" "operation")) + (:file "system-registry" :depends-on ("system")) + (:file "action" :depends-on ("session" "system" "operation")) (:file "lisp-action" :depends-on ("action")) - (:file "plan" :depends-on ("lisp-action")) + (:file "find-component" :depends-on ("component")) + (:file "forcing" :depends-on ("operation" "system-registry")) + (:file "plan" :depends-on ("lisp-action" "find-component" "forcing")) (:file "operate" :depends-on ("plan")) - (:file "parse-defsystem" :depends-on ("cache" "system" "lisp-action" "operate")) - (:file "bundle" :depends-on ("lisp-action" "operate" "parse-defsystem")) - (:file "concatenate-source" :depends-on ("plan" "parse-defsystem" "bundle")) + (:file "find-system" :depends-on ("system-registry" "operate")) + (:file "parse-defsystem" :depends-on ("system-registry" "lisp-action" "operate" + "find-system")) + (:file "bundle" :depends-on ("lisp-action" "parse-defsystem")) + (:file "concatenate-source" :depends-on ("bundle")) + (:file "package-inferred-system" :depends-on ("parse-defsystem")) (:file "output-translations" :depends-on ("operate")) (:file "source-registry" :depends-on ("find-system")) - (:file "package-inferred-system" :depends-on ("system" "find-system" "parse-defsystem")) - (:file "backward-interface" :depends-on ("operate" "output-translations")) (:file "backward-internals" :depends-on ("find-system" "parse-defsystem")) + (:file "backward-interface" :depends-on ("output-translations")) (:file "interface" :depends-on ("parse-defsystem" "concatenate-source" "output-translations" "source-registry" "package-inferred-system" @@ -85,4 +94,3 @@ #+asdf3 :builtin-system-p #+asdf3 t :components ((:module "build" :components ((:file "asdf")))) :in-order-to (#+asdf3 (prepare-op (monolithic-concatenate-source-op "asdf/defsystem")))) - diff --git a/backward-interface.lisp b/backward-interface.lisp index 9a0959e3bbd7ffef06f6dbdda5fa21ec485df7cf..7eb94fd7186735f82e44979d6d481db31f6ca8db 100644 --- a/backward-interface.lisp +++ b/backward-interface.lisp @@ -3,9 +3,10 @@ (uiop/package:define-package :asdf/backward-interface (:recycle :asdf/backward-interface :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade - :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action - :asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session + :asdf/component :asdf/system :asdf/system-registry :asdf/operation :asdf/action + :asdf/lisp-action :asdf/plan :asdf/operate + :asdf/find-system :asdf/parse-defsystem :asdf/output-translations :asdf/bundle) (:export #:*asdf-verbose* #:operation-error #:compile-error #:compile-failed #:compile-warned @@ -15,13 +16,14 @@ #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings #:component-property #:run-shell-command - #:system-definition-pathname - #:explain)) + #:system-definition-pathname #:system-registered-p #:require-system + #:explain + #+ecl #:make-build)) (in-package :asdf/backward-interface) ;; NB: the warning status of these functions may have to be distinguished later, ;; as some get removed faster than the others in client code. -(with-asdf-deprecation (:style-warning "3.2") +(with-asdf-deprecation (:style-warning "3.2" :warning "3.4") ;; These conditions from ASDF 1 and 2 are used by many packages in Quicklisp; ;; but ASDF3 replaced them with somewhat different variants of uiop:compile-condition @@ -208,3 +210,69 @@ DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead.")) (define-convenience-action-methods explain (operation component))) (defmethod explain ((o operation) (c component)) (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))) + +(with-asdf-deprecation (:style-warning "3.3") + (defun system-registered-p (name) + "DEPRECATED. Return a generalized boolean that is true if a system of given NAME was registered already. +NAME is a system designator, to be normalized by COERCE-NAME. +The value returned if true is a pair of a timestamp and a system object." + (if-let (system (registered-system name)) + (cons (if-let (primary-system (registered-system (primary-system-name name))) + (component-operation-time 'define-op primary-system)) + system))) + + (defun require-system (system &rest keys &key &allow-other-keys) + "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but do not update the +system or its dependencies if it has already been loaded." + (declare (ignore keys)) + (unless (component-loaded-p system) + (load-system system)))) + +;;; This function is for backward compatibility with ECL only. +#+ecl +(with-asdf-deprecation (:style-warning "3.2" :warning "9999") + (defun make-build (system &rest args + &key (monolithic nil) (type :fasl) (move-here nil move-here-p) + prologue-code epilogue-code no-uiop + prefix-lisp-object-files postfix-lisp-object-files extra-object-files + &allow-other-keys) + (let* ((operation (asdf/bundle::select-bundle-operation type monolithic)) + (move-here-path (if (and move-here + (typep move-here '(or pathname string))) + (ensure-pathname move-here :namestring :lisp :ensure-directory t) + (system-relative-pathname system "asdf-output/"))) + (extra-build-args (remove-plist-keys + '(:monolithic :type :move-here + :prologue-code :epilogue-code :no-uiop + :prefix-lisp-object-files :postfix-lisp-object-files + :extra-object-files) + args)) + (build-system (if (subtypep operation 'image-op) + (eval `(defsystem "asdf.make-build" + :class program-system + :source-file nil + :pathname ,(system-source-directory system) + :build-operation ,operation + :build-pathname ,(subpathname move-here-path + (file-namestring (first (output-files operation system)))) + :depends-on (,(coerce-name system)) + :prologue-code ,prologue-code + :epilogue-code ,epilogue-code + :no-uiop ,no-uiop + :prefix-lisp-object-files ,prefix-lisp-object-files + :postfix-lisp-object-files ,postfix-lisp-object-files + :extra-object-files ,extra-object-files + :extra-build-args ,extra-build-args)) + system)) + (files (output-files operation build-system))) + (operate operation build-system) + (if (or move-here + (and (null move-here-p) (member operation '(program-op image-op)))) + (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path)) + :for f :in files + :for new-f = (make-pathname :name (pathname-name f) + :type (pathname-type f) + :defaults dest-path) + :do (rename-file-overwriting-target f new-f) + :collect new-f) + files)))) diff --git a/backward-internals.lisp b/backward-internals.lisp index ac178336c5986bcfc264d9c3f983d002bb225a9a..b5960c0eecf2e0af07528a52842f1c92c98613cf 100644 --- a/backward-internals.lisp +++ b/backward-internals.lisp @@ -7,7 +7,7 @@ (:export #:load-sysdef)) (in-package :asdf/backward-internals) -(with-asdf-deprecation (:style-warning "3.2") +(with-asdf-deprecation (:style-warning "3.2" :warning "3.4") (defun load-sysdef (name pathname) (declare (ignore name pathname)) ;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older. diff --git a/bundle.lisp b/bundle.lisp index 20c1abc0e8e004914b0b77b69ad368a3b6bfda46..0ed08cb601e0846e58c573950feaf80d040bee35 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -4,8 +4,9 @@ (uiop/package:define-package :asdf/bundle (:recycle :asdf/bundle :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade - :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation - :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem) + :asdf/component :asdf/system :asdf/operation + :asdf/find-component ;; used by ECL + :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/parse-defsystem) (:export #:bundle-op #:bundle-type #:program-system #:bundle-system #:bundle-pathname-type #:direct-dependency-files @@ -323,9 +324,9 @@ or of opaque libraries shipped along the source code.")) ;; your component-depends-on method must gather the correct dependencies in the correct order. (while-collecting (collect) (map-direct-dependencies - t o c #'(lambda (sub-o sub-c) - (loop :for f :in (funcall key sub-o sub-c) - :when (funcall test f) :do (collect f)))))) + o c #'(lambda (sub-o sub-c) + (loop :for f :in (funcall key sub-o sub-c) + :when (funcall test f) :do (collect f)))))) (defun pathname-type-equal-function (type) #'(lambda (p) (equalp (pathname-type p) type))) @@ -441,7 +442,7 @@ or of opaque libraries shipped along the source code.")) :keep-operation 'basic-load-op)) (while-collecting (x) ;; resolve the sideway-dependencies of s (map-direct-dependencies - t 'load-op s + 'load-op s #'(lambda (o c) (when (and (typep o 'load-op) (typep c 'system)) (x c))))))) @@ -496,7 +497,6 @@ which is probably not what you want; you probably need to tweak your output tran (perform-lisp-load-fasl o s)) (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system)) - #+xcl (declare (ignorable o)) `((load-op ,s) ,@(call-next-method)))) #| ;; Example use: @@ -527,7 +527,7 @@ which is probably not what you want; you probably need to tweak your output tran (defun linkable-system (x) (or (if-let (s (find-system x)) - (and (system-source-file x) s)) + (and (output-files 'lib-op s) s)) (if-let (p (system-module-pathname (coerce-name x))) (make-prebuilt-system x p)))) @@ -544,7 +544,8 @@ which is probably not what you want; you probably need to tweak your output tran `((lib-op ,@(unless (no-uiop c) (list (linkable-system "cmp") - (unless (or (gethash "uiop" deps) (gethash "asdf" deps)) + (unless (or (and (gethash "uiop" deps) (linkable-system "uiop")) + (and (gethash "asdf" deps) (linkable-system "asdf"))) (or (linkable-system "uiop") (linkable-system "asdf") "asdf"))))) diff --git a/cache.lisp b/cache.lisp deleted file mode 100644 index 06427f1652328a00c561c34929b131721d3da403..0000000000000000000000000000000000000000 --- a/cache.lisp +++ /dev/null @@ -1,108 +0,0 @@ -;;;; ------------------------------------------------------------------------- -;;;; Session cache - -(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 #:unset-asdf-cache-entry #:consult-asdf-cache - #:do-asdf-cache #:normalize-namestring - #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache* - #:clear-configuration-and-retry #:retry)) -(in-package :asdf/cache) - -;;; The ASDF session cache is used to memoize some computations. It is instrumental in achieving: -;; * Consistency in the view of the world relied on by ASDF within a given session. -;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops -;; (a.k.a. stack overflows) and other erratic behavior. -;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and -;; no expensive recomputations of transitive dependencies for some input-files or output-files. -;; * 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) - - ;; 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) - 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*))) - - ;; 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 foundp - (values-list results) - (set-asdf-cache-entry key (multiple-value-list (call-function thunk))))) - (call-function thunk))) - - ;; Syntactic sugar for consult-asdf-cache - (defmacro do-asdf-cache (key &body body) - `(consult-asdf-cache ,key #'(lambda () ,@body))) - - ;; Compute inside a ASDF session with a cache. - ;; First, make sure an ASDF session is underway, by binding the session cache variable - ;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true). - ;; 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) - (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) - (if (and *asdf-cache* (not override)) - (funcall fun) - (loop - (restart-case - (let ((*asdf-cache* (make-hash-table :test 'equal))) - (return (funcall fun))) - (retry () - :report (lambda (s) - (format s (compatfmt "~@")))) - (clear-configuration-and-retry () - :report (lambda (s) - (format s (compatfmt "~@"))) - (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)) - - - ;;; Define specific accessor for file (date) stamp. - - ;; Normalize a namestring for use as a key in the session cache. - (defun normalize-namestring (pathname) - (let ((resolved (resolve-symlinks* - (ensure-absolute-pathname - (physicalize-pathname pathname) - 'get-pathname-defaults)))) - (with-pathname-defaults () (namestring resolved)))) - - ;; Compute the file stamp for a normalized namestring - (defun compute-file-stamp (normalized-namestring) - (with-pathname-defaults () - (safe-file-write-date normalized-namestring))) - - ;; Override the time STAMP associated to a given FILE in the session cache. - ;; If no STAMP is specified, recompute a new one from the filesystem. - (defun register-file-stamp (file &optional (stamp nil stampp)) - (let* ((namestring (normalize-namestring file)) - (stamp (if stampp stamp (compute-file-stamp namestring)))) - (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp)))) - - ;; Get or compute a memoized stamp for given FILE from the session cache. - (defun get-file-stamp (file) - (when file - (let ((namestring (normalize-namestring file))) - (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring)))))) - diff --git a/component.lisp b/component.lisp index 53d6d041d1463b631344b351634b446f246c7a08..f6890b9614c66a70a39dfb8e0d159a7eb0fbf3a0 100644 --- a/component.lisp +++ b/component.lisp @@ -2,10 +2,11 @@ ;;;; Components (uiop/package:define-package :asdf/component - (:recycle :asdf/component :asdf/defsystem :asdf/find-system :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade) + (:recycle :asdf/component :asdf/find-component :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session) (:export #:component #:component-find-path + #:find-component ;; methods defined in find-component #:component-name #:component-pathname #:component-relative-pathname #:component-parent #:component-system #:component-parent-pathname #:child-component #:parent-component #:module @@ -29,7 +30,6 @@ #:sub-components ;; conditions - #:system-definition-error ;; top level, moved here because this is the earliest place for it. #:duplicate-names ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes @@ -81,15 +81,6 @@ or NIL for top-level components (a.k.a. systems)")) (defgeneric source-file-type (component system) (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead.")) - (define-condition system-definition-error (error) () - ;; [this use of :report should be redundant, but unfortunately it's not. - ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function - ;; over print-object; this is always conditions::%print-condition for - ;; condition objects, which in turn does inheritance of :report options at - ;; run-time. fortunately, inheritance means we only need this kludge here in - ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] - #+cmucl (:report print-object)) - (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) (:report (lambda (c s) @@ -147,9 +138,15 @@ or NIL for top-level components (a.k.a. systems)")) ;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it. (parent :initarg :parent :initform nil :reader component-parent) (build-operation - :initarg :build-operation :initform nil :reader component-build-operation)) + :initarg :build-operation :initform nil :reader component-build-operation) + ;; Cache for ADDITIONAL-INPUT-FILES function. + (additional-input-files :accessor %additional-input-files :initform nil)) (:documentation "Base class for all components of a build")) + (defgeneric find-component (base path &key registered) + (:documentation "Find a component by resolving the PATH starting from BASE parent. +If REGISTERED is true, only search currently registered systems.")) + (defun component-find-path (component) "Return a path from a root system to the COMPONENT. The return value is a list of component NAMES; a list of strings." diff --git a/concatenate-source.lisp b/concatenate-source.lisp index 8540678cd0d43e1a59b3b31cd0dbf81c52b12429..da2322dacdfbd7122f2965df70382b30b23faaa6 100644 --- a/concatenate-source.lisp +++ b/concatenate-source.lisp @@ -5,7 +5,7 @@ (:recycle :asdf/concatenate-source :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/operation - :asdf/system :asdf/find-system + :asdf/system :asdf/action :asdf/lisp-action :asdf/plan :asdf/bundle) (:export #:concatenate-source-op diff --git a/contrib/debug-plan.lisp b/contrib/debug-plan.lisp index 4966c43e380633fd78677b2d22c0effc6ef98bba..f488b289409090bc6f65236a37c391c7c9c4987d 100644 --- a/contrib/debug-plan.lisp +++ b/contrib/debug-plan.lisp @@ -1,5 +1,11 @@ +(defpackage :asdf/contrib/plan (:use :cl)) ;; dummy, for use as package-inferred-system + (in-package :asdf/plan) +;; NB: Whenever compute-action-stamp is changed, this file must be updated +;; to insert the let-and-DBG statements in the current version of the function. +;; So if you find this file not working, it might be out of date. + (uiop:uiop-debug) (progn @@ -8,106 +14,130 @@ ;; or if it has just been done, return the time that it has. ;; Returns two values: ;; 1- the TIMESTAMP of the action if it has already been done and is up to date, - ;; or T is either hasn't been done or is out of date. + ;; or NIL is either hasn't been done or is out of date. + ;; (An ASDF extension could use a cryptographic digest instead.) ;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done ;; in the current image, or NIL if it hasn't. ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but - ;; hasn't been done in the current image yet, then it can have a non-T timestamp, - ;; yet a NIL done-in-image-p flag. + ;; hasn't been done in the current image yet, then it can have a non-NIL timestamp, + ;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded, + ;; i.e. that of the input-files. + ;; If just-done is NIL, these values return are the notional fields of + ;; a KEEP, REDO or TODO status (VOID is possible, but probably an error). + ;; If just-done is T, they are the notional fields of DONE status + ;; (or, if something went wrong, TODO). (nest (block ()) - (let ((dep-stamp ; collect timestamp from dependencies (or T if forced or out-of-date) + (let* ((dep-status ; collect timestamp from dependencies (or T if forced or out-of-date) (reduce-direct-dependencies - plan o c - #'(lambda (o c stamp) - (if-let (it (plan-action-status plan o c)) - (latest-stamp stamp (action-stamp it)) - t)) - nil))) - ;; out-of-date dependency: don't bother expensively querying the filesystem - (when (and (eq dep-stamp t) (not just-done)) - (let ((outdated-deps - (reduce-direct-dependencies - plan o c - #'(lambda (o c deps) - (if (if-let (it (plan-action-status plan o c)) - (not (eq t (action-stamp it)))) - deps - (cons (cons o c) deps))) - nil))) - (DBG "compute-action-stamp: forced by out of date dependency" - (cons o c) - outdated-deps)) - (return (values t nil)))) - ;; collect timestamps from inputs, and exit early if any is missing - (let* ((in-files (input-files o c)) + o c + #'(lambda (do dc status) + ;; out-of-date dependency: don't bother looking further + (let ((action-status (action-status plan do dc))) + (cond + ((and action-status (or (status-keep-p action-status) + (and just-done (status-stamp action-status)))) + (merge-action-status action-status status)) + (just-done + ;; It's OK to lose some ASDF action stamps during self-upgrade + (unless (equal "asdf" (primary-system-name dc)) + (warn "Computing just-done stamp in plan ~S for action ~S, but dependency ~S wasn't done yet!" + plan + (action-path (make-action o c)) + (action-path (make-action do dc)))) + status) + (t + (DBG "compute-action-stamp: forced by out of date dependency" (action-path (make-action o c)) (action-path (make-action do dc)) action-status) + (return (values nil nil)))))) + +status-good+)) + (dep-stamp (status-stamp dep-status))) + ;; DBG + (when (null dep-stamp) + (let* ((action-path (action-path (cons o c))) + (dep-statuses (loop for action in (direct-dependencies o c) for (o . c) = action collect + (list (action-path action) (action-status plan o c))))) + (DBG :nds action-path dep-statuses)))) + (let* (;; collect timestamps from inputs, and exit early if any is missing + (in-files (input-files o c)) (in-stamps (mapcar #'get-file-stamp in-files)) (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) (latest-in (stamps-latest (cons dep-stamp in-stamps)))) (when (and missing-in (not just-done)) - (DBG "compute-action-stamp: missing inputs" - (cons o c) - missing-in) - (return (values t nil)))) - ;; collect timestamps from outputs, and exit early if any is missing - (let* ((out-files (remove-if 'null (output-files o c))) + (DBG "compute-action-stamp: missing inputs" (cons o c) missing-in) + (return (values nil nil)))) + (let* (;; collect timestamps from outputs, and exit early if any is missing + (out-files (remove-if 'null (output-files o c))) (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) (earliest-out (stamps-earliest out-stamps))) (when (and missing-out (not just-done)) - (DBG "compute-action-stamp: missing outputs" - (cons o c) - missing-out) - (return (values t nil)))) - (let* (;; There are three kinds of actions: - (out-op (and out-files t)) ; those that create files on the filesystem - ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image - ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing - ;; When was the thing last actually done? (Now, or ask.) - (op-time (or just-done (component-operation-time o c))) - ;; Time stamps from the files at hand, and whether any is missing - (all-present (not (or missing-in missing-out))) - ;; Has any input changed since we last generated the files? - (up-to-date-p (stamp<= latest-in earliest-out)) - ;; If everything is up to date, the latest of inputs and outputs is our stamp - (done-stamp (stamps-latest (cons latest-in out-stamps)))) + (DBG "compute-action-stamp: missing outputs" (cons o c) missing-out) + (return (values nil nil)))) + (let (;; Time stamps from the files at hand, and whether any is missing + (all-present (not (or missing-in missing-out))) + ;; Has any input changed since we last generated the files? + ;; Note that we use stamp<= instead of stamp< to play nice with generated files. + ;; Any race condition is intrinsic to the limited timestamp resolution. + (up-to-date-p (stamp<= latest-in earliest-out)) + ;; If everything is up to date, the latest of inputs and outputs is our stamp + (done-stamp (stamps-latest (cons latest-in out-stamps)))) ;; Warn if some files are missing: ;; either our model is wrong or some other process is messing with our files. (when (and just-done (not all-present)) + ;; Shouldn't that be an error instead? (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" (action-description o c) missing-in (length missing-in) (and missing-in missing-out) - missing-out (length missing-out))) - (let ((already-done-p (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c)))) - (matching-stamp-p (and op-time (eql op-time done-stamp)))) - (DBG "compute-action-stamp" - (cons o c) - in-files - in-stamps - dep-stamp - out-files - out-stamps - latest-in - earliest-out - up-to-date-p - op-time - done-stamp - ;; (eql op-time done-stamp) - all-present - already-done-p - just-done - out-op - matching-stamp-p))) - ;; Note that we use stamp<= instead of stamp< to play nice with generated files. - ;; Any race condition is intrinsic to the limited timestamp resolution. + missing-out (length missing-out)))) + (let (;; There are three kinds of actions: + (out-op (and out-files t)) ; those that create files on the filesystem + ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image + ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing + )) + ;; Status of the action as previously performed in the image + (progn ;; DBG + (multiple-value-bind (perform-stamp perform-done-p) + (if just-done + (values done-stamp t) + (component-operation-time o c)) + (let* ((forced (action-forced-p (forcing (or plan *asdf-session*)) o c)) + (already-done-p (and all-present up-to-date-p (operation-done-p o c) + (not forced))) + (matching-stamp-p (and perform-done-p (eql perform-stamp done-stamp))) + (action-path (action-path (cons o c)))) + (DBG "compute-action-stamp" + action-path + in-files + in-stamps + dep-stamp + out-files + out-stamps + latest-in + earliest-out + up-to-date-p + perform-stamp + perform-done-p + done-stamp + all-present + forced + already-done-p + just-done + out-op + matching-stamp-p)))) (if (or just-done ;; The done-stamp is valid: if we're just done, or - ;; if all filesystem effects are up-to-date and there's no invalidating reason. - (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c)))) + (and all-present ;; if all filesystem effects are up-to-date + up-to-date-p + (operation-done-p o c) ;; and there's no invalidating reason. + (not (action-forced-p (forcing (or plan *asdf-session*)) o c)))) (values done-stamp ;; return the hard-earned timestamp (or just-done - out-op ;; a file-creating op is done when all files are up to date - ;; a image-effecting a placeholder op is done when it was actually run, - (and op-time (eql op-time done-stamp)))) ;; with the matching stamp + out-op ;; A file-creating op is done when all files are up to date. + ;; An image-effecting operation is done when + (and (status-done-p dep-status) ;; all the dependencies were done, and + (multiple-value-bind (perform-stamp perform-done-p) + (component-operation-time o c) + (and perform-done-p ;; the op was actually run, + (equal perform-stamp done-stamp)))))) ;; with a matching stamp. ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet - (values t nil))))) + (values nil nil))))) diff --git a/contrib/detect-multiply-used-files.lisp b/contrib/detect-multiply-used-files.lisp index 8e5bf714d8f211a491ef19666d0a87a2836ed323..5720efe2519f943dfa7bb2db940e4eeebc312ab3 100644 --- a/contrib/detect-multiply-used-files.lisp +++ b/contrib/detect-multiply-used-files.lisp @@ -1,6 +1,6 @@ (uiop:define-package :detect-multiply-used-files (:nicknames :asdf/contrib/detect-multiply-used-files) - (:use :asdf :uiop :common-lisp) + (:use :asdf/component :asdf/system-registry :uiop :common-lisp) (:export #:find-fishy-components #:register-component-files #:*file-components*)) (in-package :detect-multiply-used-files) @@ -20,7 +20,7 @@ (defun find-fishy-components () (clrhash *file-components*) - (map () 'register-component-files (table-keys asdf::*defined-systems*)) + (map () 'register-component-files (table-keys *registered-systems*)) (loop :for p :in (sort (table-keys *file-components*) 'string<) :for l = (gethash p *file-components*) :when (and (file-pathname-p p) (not (length=n-p l 1))) diff --git a/contrib/wild-modules.lisp b/contrib/wild-modules.lisp index cdb0232e984a3df2683b60f3771a964640ed0aa7..c6b2c342455d6f3f0f4d39cac61d48b9b487b888 100644 --- a/contrib/wild-modules.lisp +++ b/contrib/wild-modules.lisp @@ -30,4 +30,7 @@ use a wild pathname instead." module))) (compute-children-by-name self) (values))) +(defmethod input-files ((o compile-op) (c wild-module)) ()) +(defmethod input-files ((o load-op) (c wild-module)) ()) + (export 'wild-module) diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo index 5e2cbbbc968e94c6b8f606e84db89ea61d5de776..3339ab825a477589a152147fddcf2058da3f858c 100644 --- a/doc/asdf.texinfo +++ b/doc/asdf.texinfo @@ -1490,6 +1490,12 @@ simple-component-name := string pathname-specifier := pathname | string | symbol +version-specifier := string + | (:read-file-form ?) + | (:read-file-line ?) +line-specifier := :at integer # base zero +form-specifier := :at [ integer | ( integer+ )] + method-form := (operation-name qual lambda-list @Arest{} body) qual := method qualifier? @@ -1689,12 +1695,17 @@ Instead of a string representing the version, the @code{:version} argument can be an expression that is resolved to such a string using the following trivial domain-specific language: in addition to being a literal string, it can be an expression of the form -@code{(:read-file-form :at )}, -which will be resolved by reading a form in the specified pathname -(read as a subpathname of the current system if relative or a unix-namestring). +@code{(:read-file-form [:at )}, +or @code{(:read-file-line [:at +)}. +As the name suggests, the former will be resolved by reading a form in the specified pathname +(read as a subpathname of the current system if relative or a +unix-namestring), and the latter by reading a line. You may use a @code{uiop:access-at} specifier -with the (optional) @code{:at} keyword, -by default the specifier is @code{0}, meaning the first form is returned; +with the @code{:at} keyword, +by default the specifier is @code{0}, meaning the first form/line is +returned. +For @code{:read-file-form}, subforms can also be specified, with e.g. @code{(1 2 2)} specifying ``the third subform (index 2) of the third subform (index 2) of the second form (index 1)'' in the file (mind the off-by-one error in the English language). @@ -6249,24 +6260,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-component.lisp b/find-component.lisp index 52d38e248b35db95158ac010f13443ccf9873892..53fa65d30f8957d1434b0ea54e188969a53e151c 100644 --- a/find-component.lisp +++ b/find-component.lisp @@ -2,15 +2,15 @@ ;;;; Finding components (uiop/package:define-package :asdf/find-component - (:recycle :asdf/find-component :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache - :asdf/component :asdf/system :asdf/find-system) + (:recycle :asdf/find-component :asdf/find-system :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session + :asdf/component :asdf/system :asdf/system-registry) (:export #:find-component #:resolve-dependency-name #:resolve-dependency-spec #:resolve-dependency-combination ;; Conditions - #:missing-component #:missing-component-of-version #:retry + #:missing-component #:missing-requires #:missing-parent #:missing-component-of-version #:retry #:missing-dependency #:missing-dependency-of-version #:missing-requires #:missing-parent #:missing-required-by #:missing-version)) @@ -19,6 +19,10 @@ ;;;; Missing component conditions (with-upgradability () + (define-condition missing-component (system-definition-error) + ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) + (parent :initform nil :reader missing-parent :initarg :parent))) + (define-condition missing-component-of-version (missing-component) ((version :initform nil :reader missing-version :initarg :version))) @@ -50,9 +54,6 @@ ;;;; Finding components (with-upgradability () - (defgeneric find-component (base path &key registered) - (:documentation "Find a component by resolving the PATH starting from BASE parent. -If REGISTERED is true, only search currently registered systems.")) (defgeneric resolve-dependency-combination (component combinator arguments) (:documentation "Return a component satisfying the dependency specification (COMBINATOR . ARGUMENTS) in the context of COMPONENT")) diff --git a/find-system.lisp b/find-system.lisp index e502762a13a2c278411240917c2d8c474e2bab6a..0a6ae6b516b9a95e373c4332ddd69065c844ba33 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -4,42 +4,15 @@ (uiop/package:define-package :asdf/find-system (:recycle :asdf/find-system :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade - :asdf/cache :asdf/component :asdf/system) + :asdf/session :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/lisp-action + :asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate) + (:import-from #:asdf/component #:%additional-input-files) (:export - #:remove-entry-from-registry #:coerce-entry-to-directory - #:coerce-name #:primary-system-name #:coerce-filename - #:find-system #:locate-system #:load-asd - #:system-registered-p #:registered-system #:register-system - #:registered-systems* #:registered-systems - #:clear-system #:map-systems - #:missing-component #:missing-requires #:missing-parent - #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error - #:load-system-definition-error #:error-name #:error-pathname #:error-condition - #:*system-definition-search-functions* #:search-for-system-definition - #:*central-registry* #:probe-asd #:sysdef-central-registry-search - #: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* - #:mark-component-preloaded ;; forward reference to asdf/operate - #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems* - #:*defined-systems* #:clear-defined-systems - ;; defined in source-registry, but specially mentioned here: - #:initialize-source-registry #:sysdef-source-registry-search)) + #:find-system #:locate-system #:load-asd #:define-op + #:load-system-definition-error #:error-name #:error-pathname #:error-condition)) (in-package :asdf/find-system) (with-upgradability () - (declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference - - (define-condition missing-component (system-definition-error) - ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) - (parent :initform nil :reader missing-parent :initarg :parent))) - - (define-condition formatted-system-definition-error (system-definition-error) - ((format-control :initarg :format-control :reader format-control) - (format-arguments :initarg :format-arguments :reader format-arguments)) - (:report (lambda (c s) - (apply 'format s (format-control c) (format-arguments c))))) - (define-condition load-system-definition-error (system-definition-error) ((name :initarg :name :reader error-name) (pathname :initarg :pathname :reader error-pathname) @@ -48,331 +21,6 @@ (format s (compatfmt "~@") (error-name c) (error-pathname c) (error-condition c))))) - (defun sysdef-error (format &rest arguments) - (error 'formatted-system-definition-error :format-control - format :format-arguments arguments)) - - - ;;; Canonicalizing system names - - (defun coerce-name (name) - "Given a designator for a component NAME, return the name as a string. -The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component), -a SYMBOL (designing its name, downcased), or a STRING (designing itself)." - (typecase name - (component (component-name name)) - (symbol (string-downcase name)) - (string name) - (t (sysdef-error (compatfmt "~@") name)))) - - (defun primary-system-name (name) - "Given a system designator NAME, return the name of the corresponding primary system, -after which the .asd file is named. That's the first component when dividing the name -as a string by / slashes." - (first (split-string (coerce-name name) :separator "/"))) - - (defun coerce-filename (name) - "Coerce a system designator NAME into a string suitable as a filename component. -The (current) transformation is to replace characters /:\\ each by --, -the former being forbidden in a filename component. -NB: The onus is unhappily on the user to avoid clashes." - (frob-substrings (coerce-name name) '("/" ":" "\\") "--")) - - - ;;; Registry of Defined Systems - - (defvar *defined-systems* (make-hash-table :test 'equal) - "This is a hash table whose keys are strings -- the -names of systems -- and whose values are pairs, the first -element of which is a universal-time indicating when the -system definition was last updated, and the second element -of which is a system object. - A system is referred to as \"registered\" if it is present -in this table.") - - (defun system-registered-p (name) - "Return a generalized boolean that is true if a system of given NAME was registered already. -NAME is a system designator, to be normalized by COERCE-NAME. -The value returned if true is a pair of a timestamp and a system object." - (gethash (coerce-name name) *defined-systems*)) - - (defun registered-system (name) - "Return a system of given NAME that was registered already, -if such a system exists. NAME is a system designator, to be -normalized by COERCE-NAME. The value returned is a system object, -or NIL if not found." - (cdr (system-registered-p name))) - - (defun registered-systems* () - "Return a list containing every registered system (as a system object)." - (loop :for registered :being :the :hash-values :of *defined-systems* - :collect (cdr registered))) - - (defun registered-systems () - "Return a list of the names of every registered system." - (mapcar 'coerce-name (registered-systems*))) - - (defun register-system (system) - "Given a SYSTEM object, register it." - (check-type system system) - (let ((name (component-name system))) - (check-type name string) - (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) - (unless (eq system (registered-system name)) - (setf (gethash name *defined-systems*) - (cons (ignore-errors (get-file-stamp (system-source-file system))) - system))))) - - (defun map-systems (fn) - "Apply FN to each defined system. - -FN should be a function of one argument. It will be -called with an object of type asdf:system." - (loop :for registered :being :the :hash-values :of *defined-systems* - :do (funcall fn (cdr registered)))) - - - ;;; Preloaded systems: in the image even if you can't find source files backing them. - - (defvar *preloaded-systems* (make-hash-table :test 'equal) - "Registration table for preloaded systems.") - - (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/operate - - (defun make-preloaded-system (name keys) - "Make a preloaded system of given NAME with build information from KEYS" - (let ((system (apply 'make-instance (getf keys :class 'system) - :name name :source-file (getf keys :source-file) - (remove-plist-keys '(:class :name :source-file) keys)))) - (mark-component-preloaded system) - system)) - - (defun sysdef-preloaded-system-search (requested) - "If REQUESTED names a system registered as preloaded, return a new system -with its registration information." - (let ((name (coerce-name requested))) - (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) - (when foundp - (make-preloaded-system name keys))))) - - (defun ensure-preloaded-system-registered (name) - "If there isn't a registered _defined_ system of given NAME, -and a there is a registered _preloaded_ system of given NAME, -then define and register said preloaded system." - (if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name))) - (register-system system))) - - (defun register-preloaded-system (system-name &rest keys &key (version t) &allow-other-keys) - "Register a system as being preloaded. If the system has not been loaded from the filesystem -yet, or if its build information is later cleared with CLEAR-SYSTEM, a dummy system will be -registered without backing filesystem information, based on KEYS (e.g. to provide a VERSION). -If VERSION is the default T, and a system was already loaded, then its version will be preserved." - (let ((name (coerce-name system-name))) - (when (eql version t) - (if-let (system (registered-system name)) - (setf (getf keys :version) (component-version system)))) - (setf (gethash name *preloaded-systems*) keys) - (ensure-preloaded-system-registered system-name))) - - - ;;; Immutable systems: in the image and can't be reloaded from source. - - (defvar *immutable-systems* nil - "A hash-set (equal hash-table mapping keys to T) of systems that are immutable, -i.e. already loaded in memory and not to be refreshed from the filesystem. -They will be treated specially by find-system, and passed as :force-not argument to make-plan. - -For instance, to can deliver an image with many systems precompiled, that *will not* check the -filesystem for them every time a user loads an extension, what more risk a problematic upgrade - or catastrophic downgrade, before you dump an image, you may use: - (map () 'asdf:register-immutable-system (asdf:already-loaded-systems)) - -Note that direct access to this variable from outside ASDF is not supported. -Please call REGISTER-IMMUTABLE-SYSTEM to add new immutable systems, and -contact maintainers if you need a stable API to do more than that.") - - (defun sysdef-immutable-system-search (requested) - (let ((name (coerce-name requested))) - (when (and *immutable-systems* (gethash name *immutable-systems*)) - (or (registered-system requested) - (error 'formatted-system-definition-error - :format-control "Requested system ~A registered as an immutable-system, ~ -but not even registered as defined" - :format-arguments (list name)))))) - - (defun register-immutable-system (system-name &rest keys) - "Register SYSTEM-NAME as preloaded and immutable. -It will automatically be considered as passed to FORCE-NOT in a plan." - (let ((system-name (coerce-name system-name))) - (apply 'register-preloaded-system system-name keys) - (unless *immutable-systems* - (setf *immutable-systems* (list-to-hash-set nil))) - (setf (gethash system-name *immutable-systems*) t))) - - - ;;; Making systems undefined. - - (defun clear-system (system) - "Clear the entry for a SYSTEM in the database of systems previously defined. -However if the system was registered as PRELOADED (which it is if it is IMMUTABLE), -then a new system with the same name will be defined and registered in its place -from which build details will have been cleared. -Note that this does NOT in any way cause any of the code of the system to be unloaded. -Returns T if system was or is now undefined, NIL if a new preloaded system was redefined." - ;; There is no "unload" operation in Common Lisp, and - ;; a general such operation cannot be portably written, - ;; considering how much CL relies on side-effects to global data structures. - (let ((name (coerce-name system))) - (remhash name *defined-systems*) - (unset-asdf-cache-entry `(find-system ,name)) - (not (ensure-preloaded-system-registered name)))) - - (defun clear-defined-systems () - "Clear all currently registered defined systems. -Preloaded systems (including immutable ones) will be reset, other systems will be de-registered." - (loop :for name :being :the :hash-keys :of *defined-systems* - :unless (member name '("asdf" "uiop") :test 'equal) :do (clear-system name))) - - - ;;; Searching for system definitions - - ;; For the sake of keeping things reasonably neat, we adopt a convention that - ;; only symbols are to be pushed to this list (rather than e.g. function objects), - ;; which makes upgrade easier. Also, the name of these symbols shall start with SYSDEF- - (defvar *system-definition-search-functions* '() - "A list that controls the ways that ASDF looks for system definitions. -It contains symbols to be funcalled in order, with a requested system name as argument, -until one returns a non-NIL result (if any), which must then be a fully initialized system object -with that name.") - - ;; Initialize and/or upgrade the *system-definition-search-functions* - ;; so it doesn't contain obsolete symbols, and does contain the current ones. - (defun cleanup-system-definition-search-functions () - (setf *system-definition-search-functions* - (append - ;; Remove known-incompatible sysdef functions from old versions of asdf. - ;; Order matters, so we can't just use set-difference. - (let ((obsolete - '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search))) - (remove-if #'(lambda (x) (member x obsolete)) *system-definition-search-functions*)) - ;; Tuck our defaults at the end of the list if they were absent. - ;; This is imperfect, in case they were removed on purpose, - ;; but then it will be the responsibility of whoever removes these symmbols - ;; to upgrade asdf before he does such a thing rather than after. - (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) - '(sysdef-central-registry-search - sysdef-source-registry-search))))) - (cleanup-system-definition-search-functions) - - ;; This (private) function does the search for a system definition using *s-d-s-f*; - ;; it is to be called by locate-system. - (defun search-for-system-definition (system) - ;; Search for valid definitions of the system available in the current session. - ;; Previous definitions as registered in *defined-systems* MUST NOT be considered; - ;; they will be reconciled by locate-system then find-system. - ;; There are two special treatments: first, specially search for objects being defined - ;; in the current session, to avoid definition races between several files; - ;; second, specially search for immutable systems, so they cannot be redefined. - ;; Finally, use the search functions specified in *system-definition-search-functions*. - (let ((name (coerce-name system))) - (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x)))) - (try 'find-system-if-being-defined) - (try 'sysdef-immutable-system-search) - (map () #'try *system-definition-search-functions*)))) - - - ;;; The legacy way of finding a system: the *central-registry* - - ;; This variable contains a list of directories to be lazily searched for the requested asd - ;; by sysdef-central-registry-search. - (defvar *central-registry* nil - "A list of 'system directory designators' ASDF uses to find systems. - -A 'system directory designator' is a pathname or an expression -which evaluates to a pathname. For example: - - (setf asdf:*central-registry* - (list '*default-pathname-defaults* - #p\"/home/me/cl/systems/\" - #p\"/usr/share/common-lisp/systems/\")) - -This variable is for backward compatibility. -Going forward, we recommend new users should be using the source-registry.") - - ;; Function to look for an asd file of given NAME under a directory provided by DEFAULTS. - ;; Return the truename of that file if it is found and TRUENAME is true. - ;; Return NIL if the file is not found. - ;; On Windows, follow shortcuts to .asd files. - (defun probe-asd (name defaults &key truename) - (block nil - (when (directory-pathname-p defaults) - (if-let (file (probe-file* - (ensure-absolute-pathname - (parse-unix-namestring name :type "asd") - #'(lambda () (ensure-absolute-pathname defaults 'get-pathname-defaults nil)) - nil) - :truename truename)) - (return file)) - #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) - (os-cond - ((os-windows-p) - (when (physical-pathname-p defaults) - (let ((shortcut - (make-pathname - :defaults defaults :case :local - :name (strcat name ".asd") - :type "lnk"))) - (when (probe-file* shortcut) - (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native))))))))) - - ;; Function to push onto *s-d-s-f* to use the *central-registry* - (defun sysdef-central-registry-search (system) - (let ((name (primary-system-name system)) - (to-remove nil) - (to-replace nil)) - (block nil - (unwind-protect - (dolist (dir *central-registry*) - (let ((defaults (eval dir)) - directorized) - (when defaults - (cond ((directory-pathname-p defaults) - (let* ((file (probe-asd name defaults :truename *resolve-symlinks*))) - (when file - (return file)))) - (t - (restart-case - (let* ((*print-circle* nil) - (message - (format nil - (compatfmt "~@") - system dir defaults))) - (error message)) - (remove-entry-from-registry () - :report "Remove entry from *central-registry* and continue" - (push dir to-remove)) - (coerce-entry-to-directory () - :test (lambda (c) (declare (ignore c)) - (and (not (directory-pathname-p defaults)) - (directory-pathname-p - (setf directorized - (ensure-directory-pathname defaults))))) - :report (lambda (s) - (format s (compatfmt "~@") - directorized dir)) - (push (cons dir directorized) to-replace)))))))) - ;; cleanup - (dolist (dir to-remove) - (setf *central-registry* (remove dir *central-registry*))) - (dolist (pair to-replace) - (let* ((current (car pair)) - (new (cdr pair)) - (position (position current *central-registry*))) - (setf *central-registry* - (append (subseq *central-registry* 0 position) - (list new) - (subseq *central-registry* (1+ position)))))))))) - ;;; Methods for find-system @@ -387,42 +35,108 @@ Going forward, we recommend new users should be using the source-registry.") (defun find-system-if-being-defined (name) ;; This function finds systems being defined *in the current ASDF session*, as embodied by - ;; its session cache, even before they are fully defined and registered in *defined-systems*. + ;; its session cache, even before they are fully defined and registered in *registered-systems*. ;; The purpose of this function is to prevent races between two files that might otherwise ;; try overwrite each other's system objects, resulting in infinite loops and stack overflow. ;; 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*))) - - (defun load-asd (pathname - &key name (external-format (encoding-external-format (detect-encoding pathname))) - &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*)) + (first (gethash `(find-system ,(coerce-name name)) (asdf-cache)))) + + (defclass define-op (non-propagating-operation) () + (:documentation "An operation to record dependencies on loading a .asd file.")) + + (defmethod record-dependency ((plan null) (operation t) (component t)) + (unless (or (typep operation 'define-op) + (and (typep operation 'load-op) + (typep component 'system) + (equal "asdf" (coerce-name component)))) + (if-let ((action (first (visiting-action-list *asdf-session*)))) + (let ((parent-operation (action-operation action)) + (parent-component (action-component action))) + (cond + ((and (typep parent-operation 'define-op) + (typep parent-component 'system)) + (let ((action (cons operation component))) + (unless (gethash action (definition-dependency-set parent-component)) + (push (cons operation component) (definition-dependency-list parent-component)) + (setf (gethash action (definition-dependency-set parent-component)) t)))) + (t + (warn 'recursive-operate + :operation operation :component component :action action))))))) + + (defmethod component-depends-on ((o define-op) (s system)) + `(;;NB: 1- ,@(system-defsystem-depends-on s)) ; Should be already included in the below. + ;; 2- We don't call-next-method to avoid other methods + ,@(loop* :for (o . c) :in (definition-dependency-list s) :collect (list o c)))) + + (defmethod component-depends-on ((o operation) (s system)) + `(,@(when (and (not (typep o 'define-op)) + (or (system-source-file s) (definition-dependency-list s))) + `((define-op ,(primary-system-name s)))) + ,@(call-next-method))) + + (defmethod perform ((o operation) (c undefined-system)) + (sysdef-error "Trying to use undefined or incompletely defined system ~A" (coerce-name c))) + + ;; TODO: could this file be refactored so that locate-system is merely + ;; the cache-priming call to input-files here? + (defmethod input-files ((o define-op) (s system)) + (assert (equal (coerce-name s) (primary-system-name s))) + (if-let ((asd (system-source-file s))) (list asd))) + + (defmethod perform ((o define-op) (s system)) + (assert (equal (coerce-name s) (primary-system-name s))) + (nest + (if-let ((pathname (first (input-files o s))))) + (with-standard-io-syntax) + (let ((*print-readably* nil) + ;; Note that our backward-compatible *readtable* is + ;; a global readtable that gets globally side-effected. Ouch. + ;; Same for the *print-pprint-dispatch* table. + ;; We should do something about that for ASDF3 if possible, or else ASDF4. + (*readtable* *readtable*) + (*print-pprint-dispatch* *print-pprint-dispatch*) + (*package* (find-package :asdf-user)) + (*default-pathname-defaults* + ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. + (pathname-directory-pathname (physicalize-pathname pathname))))) + (handler-bind + (((and error (not missing-component)) + #'(lambda (condition) + (error 'load-system-definition-error + :name (coerce-name s) :pathname pathname :condition condition)))) + (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") + (coerce-name s) pathname) + ;; dependencies will depend on what's loaded via definition-dependency-list + (unset-asdf-cache-entry `(component-depends-on ,o ,s)) + (unset-asdf-cache-entry `(input-files ,o ,s))) + (load* pathname :external-format (encoding-external-format (detect-encoding pathname))))) + + (defun load-asd (pathname &key name) "Load system definitions from PATHNAME. 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-standard-io-syntax - (let ((*package* (find-package :asdf-user)) - ;; Note that our backward-compatible *readtable* is - ;; a global readtable that gets globally side-effected. Ouch. - ;; Same for the *print-pprint-dispatch* table. - ;; We should do something about that for ASDF3 if possible, or else ASDF4. - (*readtable* readtable) - (*print-pprint-dispatch* print-pprint-dispatch) - (*print-readably* nil) - (*default-pathname-defaults* - ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. - (pathname-directory-pathname (physicalize-pathname pathname)))) - (handler-bind - (((and error (not missing-component)) - #'(lambda (condition) - (error 'load-system-definition-error - :name name :pathname pathname :condition condition)))) - (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") - name pathname) - (load* pathname :external-format external-format)))))) + (with-asdf-session () + ;; TODO: use OPERATE, so we consult the cache and only load once per session. + (flet ((do-it (o c) (operate o c))) + (let ((primary-name (primary-system-name (or name (pathname-name pathname)))) + (operation (make-operation 'define-op))) + (if-let (system (registered-system primary-name)) + (progn + ;; We already determine this to be obsolete --- + ;; or should we move some tests from find-system to check for up-to-date-ness here? + (setf (component-operation-time operation system) t + (definition-dependency-list system) nil + (definition-dependency-set system) (list-to-hash-set nil)) + (do-it operation system)) + (let ((system (make-instance 'undefined-system + :name primary-name :source-file pathname))) + (register-system system) + (unwind-protect (do-it operation system) + (when (typep system 'undefined-system) + (clear-system system))))))))) (defvar *old-asdf-systems* (make-hash-table :test 'equal)) @@ -430,21 +144,25 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." ;; Returns T if everything went right, NIL if the system was an ASDF of the same or older version, ;; that shall not be loaded. Also issue a warning if it was a strictly older version of ASDF. (defun check-not-old-asdf-system (name pathname) - (or (not (equal name "asdf")) + (or (not (member name '("asdf" "uiop") :test 'equal)) (null pathname) - (let* ((version-pathname (subpathname pathname "version.lisp-expr")) + (let* ((asdfp (equal name "asdf")) ;; otherwise, it's uiop + (version-pathname + (subpathname pathname "version" :type (if asdfp "lisp-expr" "lisp"))) (version (and (probe-file* version-pathname :truename nil) - (read-file-form version-pathname))) + (read-file-form version-pathname :at (if asdfp '(0) '(2 2 2))))) (old-version (asdf-version))) (cond - ((version< old-version version) t) ;; newer version: good! - ((equal old-version version) nil) ;; same version: don't load, but don't warn + ;; Don't load UIOP of the exact same version: we already loaded it as part of ASDF. + ((and (equal old-version version) (equal name "uiop")) nil) + ((version<= old-version version) t) ;; newer or same version: Good! (t ;; old version: bad (ensure-gethash (list (namestring pathname) version) *old-asdf-systems* #'(lambda () - (let ((old-pathname (system-source-file (registered-system "asdf")))) - (warn "~@<~ + (let ((old-pathname (system-source-file (registered-system "asdf")))) + (if asdfp + (warn "~@<~ You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~ or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~ ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~ @@ -466,7 +184,11 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." then you might indeed want to either install and register a more recent version, ~ or use :ignore-inherited-configuration to avoid registering the old one. ~ Please consult ASDF documentation and/or experts.~@:>~%" - old-version old-pathname version pathname)))) + old-version old-pathname version pathname) + ;; NB: for UIOP, don't warn, just ignore. + (warn "ASDF ~A (from ~A), UIOP ~A (from ~A)" + old-version old-pathname version pathname) + )))) nil))))) ;; only issue the warning the first time, but always return nil (defun locate-system (name) @@ -479,14 +201,13 @@ 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)) - (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)) + (previous (registered-system name)) ; load from disk if absent or newer on disk + (primary (registered-system (primary-system-name name))) + (previous-time (and previous primary (component-operation-time 'define-op primary))) (found (search-for-system-definition name)) (found-system (and (typep found 'system) found)) (pathname (ensure-pathname @@ -502,45 +223,73 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (values foundp found-system pathname previous previous-time)))) ;; Main method for find-system: first, make sure the computation is memoized in a session cache. - ;; unless the system is immutable, use locate-system to find the primary system; + ;; Unless the system is immutable, use locate-system to find the primary system; ;; reconcile the finding (if any) with any previous definition (in a previous session, ;; preloaded, with a previous configuration, or before filesystem changes), and ;; load a found .asd if appropriate. Finally, update registration table and return results. + + (defun definition-dependencies-up-to-date-p (system) + (check-type system system) + (assert (primary-system-p system)) + (handler-case + (loop :with plan = (make-instance *plan-class*) + :for action :in (definition-dependency-list system) + :always (action-up-to-date-p + plan (action-operation action) (action-component action)) + :finally + (let ((o (make-operation 'define-op))) + (multiple-value-bind (stamp done-p) + (compute-action-stamp plan o system) + (return (and (stamp<= stamp (component-operation-time o system)) + done-p))))) + (system-out-of-date () nil))) + (defmethod find-system ((name string) &optional (error-p t)) - (with-asdf-cache (:key `(find-system ,name)) - (let ((primary-name (primary-system-name name))) - (unless (equal name primary-name) - (find-system primary-name nil))) - (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name)) - (multiple-value-bind (foundp found-system pathname previous previous-time) - (locate-system name) - (assert (eq foundp (and (or found-system pathname previous) t))) - (let ((previous-pathname (system-source-file previous)) - (system (or previous found-system))) - (when (and found-system (not previous)) - (register-system found-system)) - (when (and system pathname) - (setf (system-source-file system) pathname)) - (when (and pathname - (let ((stamp (get-file-stamp pathname))) - (and stamp - (not (and previous - (or (pathname-equal pathname previous-pathname) - (and pathname previous-pathname - (pathname-equal - (physicalize-pathname pathname) - (physicalize-pathname previous-pathname)))) - (stamp<= stamp previous-time)))))) - ;; Only load when it's a pathname that is different or has newer content. - (load-asd pathname :name name))) - ;; Try again after having loaded from disk if needed - (let ((in-memory (system-registered-p name))) - (cond - (in-memory - (when pathname - (setf (car in-memory) (get-file-stamp pathname))) - (cdr in-memory)) - (error-p - (error 'missing-component :requires name)) - (t - (return-from find-system nil))))))))) + (nest + (with-asdf-session (:key `(find-system ,name))) + (let ((name-primary-p (primary-system-p name))) + (unless name-primary-p (find-system (primary-system-name name) nil))) + (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name))) + (multiple-value-bind (foundp found-system pathname previous previous-time) + (locate-system name) + (assert (eq foundp (and (or found-system pathname previous) t)))) + (let ((previous-pathname (system-source-file previous)) + (system (or previous found-system))) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and system pathname) + (setf (system-source-file system) pathname)) + (if-let ((stamp (get-file-stamp pathname))) + (let ((up-to-date-p + (and previous + (or (pathname-equal pathname previous-pathname) + (and pathname previous-pathname + (pathname-equal + (physicalize-pathname pathname) + (physicalize-pathname previous-pathname)))) + (stamp<= stamp previous-time) + ;; TODO: check that all dependencies are up-to-date. + ;; This necessitates traversing them without triggering + ;; the adding of nodes to the plan. + (or (not name-primary-p) + (definition-dependencies-up-to-date-p previous))))) + (unless up-to-date-p + (restart-case + (signal 'system-out-of-date :name name) + (continue () :report "continue")) + (load-asd pathname :name name))))) + ;; Try again after having loaded from disk if needed + (or (registered-system name) + (when error-p (error 'missing-component :requires name))))) + + ;; Resolved forward reference for asdf/system-registry. + (defun mark-component-preloaded (component) + "Mark a component as preloaded." + (let ((component (find-component component nil :registered t))) + ;; Recurse to children, so asdf/plan will hopefully be happy. + (map () 'mark-component-preloaded (component-children component)) + ;; Mark the timestamps of the common lisp-action operations as 0. + (let ((cot (component-operation-times component))) + (dolist (o `(,@(when (primary-system-p component) '(define-op)) + prepare-op compile-op load-op)) + (setf (gethash (make-operation o) cot) 0)))))) diff --git a/footer.lisp b/footer.lisp index 12c213c4f2c88a596370bdeb9685ac94ef4b3728..3d1978252e7572ae381c00bd2498906ddfab1f2c 100644 --- a/footer.lisp +++ b/footer.lisp @@ -4,7 +4,8 @@ (uiop/package:define-package :asdf/footer (:recycle :asdf/footer :asdf) (:use :uiop/common-lisp :uiop - :asdf/upgrade :asdf/find-system :asdf/operate :asdf/bundle) + :asdf/system ;; used by ECL + :asdf/upgrade :asdf/system-registry :asdf/operate :asdf/bundle) ;; Happily, all those implementations all have the same module-provider hook interface. #+(or abcl clasp cmucl clozure ecl mkcl sbcl) (:import-from #+abcl :sys #+(or clasp cmucl ecl) :ext #+clozure :ccl #+mkcl :mk-ext #+sbcl sb-ext @@ -67,7 +68,7 @@ (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*)) ;; Advertise the features we provide. - (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf3.2 :asdf-package-system)) (pushnew f *features*)) + (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf3.2 :asdf3.3)) (pushnew f *features*)) ;; Provide both lowercase and uppercase, to satisfy more people, especially LispWorks users. (provide "asdf") (provide "ASDF") diff --git a/forcing.lisp b/forcing.lisp new file mode 100644 index 0000000000000000000000000000000000000000..848bbad10779ce213cf2cf81e08674ca2d45b49e --- /dev/null +++ b/forcing.lisp @@ -0,0 +1,135 @@ +;;;; ------------------------------------------------------------------------- +;;;; Forcing + +(uiop/package:define-package :asdf/forcing + (:recycle :asdf/forcing :asdf/plan :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session + :asdf/component :asdf/operation :asdf/system :asdf/system-registry) + (:export + #:forcing #:make-forcing #:forced #:forced-not #:performable-p + #:normalize-forced-systems #:normalize-forced-not-systems + #:action-forced-p #:action-forced-not-p)) +(in-package :asdf/forcing) + +;;;; Forcing +(with-upgradability () + (defclass forcing () + (;; Can plans using this forcing be PERFORMed? A plan that has different force and force-not + ;; settings than the session can only be used for read-only queries that do not cause the + ;; status of any action to be raised. + (performable-p :initform nil :initarg :performable-p :reader performable-p) + ;; Parameters + (parameters :initform nil :initarg :parameters :reader parameters) + ;; Table of systems specified via :force arguments + (forced :initarg :forced :reader forced) + ;; Table of systems specified via :force-not argument (and/or immutable) + (forced-not :initarg :forced-not :reader forced-not))) + + (defgeneric action-forced-p (forcing operation component) + (:documentation "Is this action forced to happen in this plan?")) + (defgeneric action-forced-not-p (forcing operation component) + (:documentation "Is this action forced to not happen in this plan? +Takes precedence over action-forced-p.")) + + (defun normalize-forced-systems (force system) + "Given a SYSTEM on which operate is called and the specified FORCE argument, +extract a hash-set of systems that are forced, or a predicate on system names, +or NIL if none are forced, or :ALL if all are." + (etypecase force + ((or (member nil :all) hash-table function) force) + (cons (list-to-hash-set (mapcar #'coerce-name force))) + ((eql t) (when system (list-to-hash-set (list (coerce-name system))))))) + + (defun normalize-forced-not-systems (force-not system) + "Given a SYSTEM on which operate is called, the specified FORCE-NOT argument, +and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not, +or predicate on system names, or NIL if none are forced, or :ALL if all are." + (let ((requested + (etypecase force-not + ((or (member nil :all) hash-table function) force-not) + (cons (list-to-hash-set (mapcar #'coerce-name force-not))) + ((eql t) (if system (let ((name (coerce-name system))) + #'(lambda (x) (not (equal x name)))) + :all))))) + (if (and *immutable-systems* requested) + #'(lambda (x) (or (call-function requested x) + (call-function *immutable-systems* x))) + (or *immutable-systems* requested)))) + + ;; TODO: shouldn't we be looking up the primary system name, rather than the system name? + (defun action-override-p (forcing operation component override-accessor) + "Given a plan, an action, and a function that given the plan accesses a set of overrides, +i.e. force or force-not, see if the override applies to the current action." + (declare (ignore operation)) + (call-function (funcall override-accessor forcing) + (coerce-name (component-system (find-component () component))))) + + (defmethod action-forced-p (forcing operation component) + (and + ;; Did the user ask us to re-perform the action? + (action-override-p forcing operation component 'forced) + ;; You really can't force a builtin system and :all doesn't apply to it. + (not (builtin-system-p (component-system component))))) + + (defmethod action-forced-not-p (forcing operation component) + ;; Did the user ask us to not re-perform the action? + ;; NB: force-not takes precedence over force, as it should + (action-override-p forcing operation component 'forced-not)) + + ;; Null forcing means no forcing either way + (defmethod action-forced-p ((forcing null) (operation operation) (component component)) + nil) + (defmethod action-forced-not-p ((forcing null) (operation operation) (component component)) + nil) + + (defun or-function (fun1 fun2) + (cond + ((or (null fun2) (eq fun1 :all)) fun1) + ((or (null fun1) (eq fun2 :all)) fun2) + (t #'(lambda (x) (or (call-function fun1 x) (call-function fun2 x)))))) + + (defun make-forcing (&key performable-p system + (force nil force-p) (force-not nil force-not-p) &allow-other-keys) + (let* ((session-forcing (when *asdf-session* (forcing *asdf-session*))) + (system (and system (coerce-name system))) + (forced (normalize-forced-systems force system)) + (forced-not (normalize-forced-not-systems force-not system)) + (parameters `(,@(when force `(:force ,force)) + ,@(when force-not `(:force-not ,force-not)) + ,@(when (or (eq force t) (eq force-not t)) `(:system ,system)) + ,@(when performable-p `(:performable-p t)))) + forcing) + (cond + ((not session-forcing) + (setf forcing (make-instance 'forcing + :performable-p performable-p :parameters parameters + :forced forced :forced-not forced-not)) + (when (and performable-p *asdf-session*) + (setf (forcing *asdf-session*) forcing))) + (performable-p + (when (and (not (equal parameters (parameters session-forcing))) + (or force-p force-not-p)) + (parameter-error "~*~S and ~S arguments not allowed in a nested call to ~3:*~S ~ +unless identically to toplevel" + (find-symbol* :operate :asdf) :force :force-not)) + (setf forcing session-forcing)) + (t + (setf forcing (make-instance 'forcing + ;; Combine force and force-not with values from the toplevel-plan + :parameters `(,@parameters :on-top-of ,(parameters session-forcing)) + :forced (or-function (forced session-forcing) forced) + :forced-not (or-function (forced-not session-forcing) forced-not))))) + forcing)) + + (defmethod print-object ((forcing forcing) stream) + (print-unreadable-object (forcing stream :type t) + (format stream "~{~S~^ ~}" (parameters forcing)))) + + ;; During upgrade, the *asdf-session* may legitimately be NIL, so we must handle that case. + (defmethod forcing ((x null)) + (if-let (session (toplevel-asdf-session)) + (forcing session) + (make-forcing :performable-p t))) + + ;; When performing a plan that is a list of actions, use the toplevel asdf sesssion forcing. + (defmethod forcing ((x cons)) (forcing (toplevel-asdf-session)))) diff --git a/interface.lisp b/interface.lisp index 611318c238d994d416a16a12d109b5f0ea4f2001..a1a79e2d86820c1b3461908801f5b6686ba93b0c 100644 --- a/interface.lisp +++ b/interface.lisp @@ -7,11 +7,12 @@ (:unintern #:loaded-systems ; makes for annoying SLIME completion #:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache - :asdf/component :asdf/system :asdf/find-system :asdf/find-component + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session + :asdf/component :asdf/system :asdf/system-registry :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/output-translations :asdf/source-registry - :asdf/plan :asdf/operate :asdf/parse-defsystem :asdf/bundle :asdf/concatenate-source + :asdf/forcing :asdf/plan :asdf/operate :asdf/find-system :asdf/parse-defsystem + :asdf/bundle :asdf/concatenate-source :asdf/backward-internals :asdf/backward-interface :asdf/package-inferred-system) ;; Note: (1) we are NOT automatically reexporting everything from previous packages. ;; (2) we only reexport UIOP functionality when backward-compatibility requires it. @@ -27,13 +28,14 @@ #:non-propagating-operation #:build-op #:make #:load-op #:prepare-op #:compile-op - #:prepare-source-op #:load-source-op #:test-op + #:prepare-source-op #:load-source-op #:test-op #:define-op #:feature #:version #:version-satisfies #:upgrade-asdf #:implementation-identifier #:implementation-type #:hostname - #:input-files #:output-files #:output-file #:perform #:perform-with-restarts + #:component-depends-on ; backward-compatible name rather than action-depends-on + #:input-files #:additional-input-files + #:output-files #:output-file #:perform #:perform-with-restarts #:operation-done-p #:explain #:action-description #:component-sideway-dependencies #:needed-in-image-p - #:component-load-dependencies #:run-shell-command ; deprecated, do not use #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system #:program-system #:basic-compile-bundle-op #:prepare-bundle-op @@ -51,20 +53,15 @@ #:operation-monolithic-p #:required-components #:component-loaded-p - #:component #:parent-component #:child-component #:system #:module #:file-component #:source-file #:c-source-file #:java-source-file #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp #:static-file #:doc-file #:html-file #:file-type #:source-file-type - #:register-preloaded-system #:sysdef-preloaded-system-search #:register-immutable-system #:sysdef-immutable-system-search - #:package-inferred-system #:register-system-packages - #:package-system ;; backward-compatibility during migration, to be removed in a further release. - - #:component-children ; component accessors + #:component-children #:component-children-by-name #:component-pathname #:component-relative-pathname @@ -74,13 +71,6 @@ #:component-system #:component-encoding #:component-external-format - - #:component-depends-on ; backward-compatible name rather than action-depends-on - #:module-components ; backward-compatibility - #:operation-on-warnings #:operation-on-failure ; backward-compatibility - #:component-property ; backward-compatibility - #:traverse ; backward-compatibility - #:system-description #:system-long-description #:system-author @@ -99,20 +89,15 @@ #:system-defsystem-depends-on #:system-depends-on #:system-weakly-depends-on - #:*system-definition-search-functions* ; variables #:*central-registry* #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*resolve-symlinks* - #:*asdf-verbose* ;; unused. For backward-compatibility only. #:*verbose-out* - #:asdf-version - #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error #:compile-warned-warning #:compile-failed-warning - #:operation-error #:compile-failed #:compile-warned #:compile-error ;; backward compatibility #:error-name #:error-pathname #:load-system-definition-error @@ -123,23 +108,19 @@ #:missing-dependency #:missing-dependency-of-version #:circular-dependency ; errors - #:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name + #:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name #:system-out-of-date #:package-inferred-system-missing-package-error #:operation-definition-warning #:operation-definition-error - #:try-recompiling ; restarts #:retry #:accept #:coerce-entry-to-directory #:remove-entry-from-registry #:clear-configuration-and-retry - - #:*encoding-detection-hook* #:*encoding-external-format-hook* #:*default-encoding* #:*utf-8-external-format* - #:clear-configuration #:*output-translations-parameter* #:initialize-output-translations @@ -158,7 +139,7 @@ #:clear-source-registry #:ensure-source-registry #:process-source-registry - #:system-registered-p #:registered-systems #:already-loaded-systems + #:registered-system #:registered-systems #:already-loaded-systems #:resolve-location #:asdf-message #:*user-cache* @@ -170,5 +151,11 @@ #:system-source-registry #:user-source-registry-directory #:system-source-registry-directory - )) + ;; The symbols below are all DEPRECATED, do not use. To be removed in a further release. + #:*asdf-verbose* #:run-shell-command + #:component-load-dependencies #:system-registered-p #:package-system + #+ecl #:make-build + #:operation-on-warnings #:operation-on-failure #:operation-error + #:compile-failed #:compile-warned #:compile-error + #:module-components #:component-property #:traverse)) diff --git a/lisp-action.lisp b/lisp-action.lisp index 9c1fa5a8d5b3d22394d587e1f6ffed1b1fc0278f..8bdeb3bfc51c86856d821db639844ee196f34c45 100644 --- a/lisp-action.lisp +++ b/lisp-action.lisp @@ -3,9 +3,8 @@ (uiop/package:define-package :asdf/lisp-action (:recycle :asdf/lisp-action :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache - :asdf/component :asdf/system :asdf/find-component :asdf/find-system - :asdf/operation :asdf/action) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session + :asdf/component :asdf/system :asdf/operation :asdf/action) (:export #:try-recompiling #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp @@ -174,7 +173,7 @@ an OPERATION and a COMPONENT." (defmethod input-files ((o compile-op) (c system)) (when (and *warnings-file-type* (not (builtin-system-p c))) ;; The most correct way to do it would be to use: - ;; (traverse-sub-actions o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file) + ;; (collect-dependencies o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file) ;; but it's expensive and we don't care too much about file order or ASDF extensions. (loop :for sub :in (sub-components c :type 'cl-source-file) :nconc (remove-if-not 'warnings-file-p (output-files o sub))))) diff --git a/make-asdf.bat b/make-asdf.bat index 321ed65f8d3f3080b8ea8b2c227b2f598ff5e805..523fbe71da6ecbcd067f3acc86e43e27737647a3 100644 --- a/make-asdf.bat +++ b/make-asdf.bat @@ -5,7 +5,7 @@ set here=%~dp0 set header_lisp=header.lisp set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\version.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\launch-program.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp -set defsystem_lisp=upgrade.lisp + cache.lisp + component.lisp + system.lisp + find-system.lisp + find-component.lisp + operation.lisp + action.lisp + lisp-action.lisp + plan.lisp + operate.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + output-translations.lisp + source-registry.lisp + package-inferred-system.lisp + backward-interface.lisp + backward-internals.lisp + interface.lisp + user.lisp + footer.lisp +set defsystem_lisp=upgrade.lisp + session.lisp + component.lisp + operation.lisp + system.lisp + system-registry.lisp + action.lisp + lisp-action.lisp + find-component.lisp + forcing.lisp + plan.lisp + operate.lisp + find-system.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + package-inferred-system.lisp + output-translations.lisp + source-registry.lisp + backward-internals.lisp + backward-interface.lisp + interface.lisp + user.lisp + footer.lisp %~d0 cd "%~p0" diff --git a/make-asdf.sh b/make-asdf.sh index 2a894a9167afadbee0bf977aeefc5a3f111d3fc3..ec429fd2f01ad9d9ab8dbefb4232bb90773c37ea 100755 --- a/make-asdf.sh +++ b/make-asdf.sh @@ -6,7 +6,7 @@ here="$(dirname $0)" header_lisp="header.lisp" driver_lisp="uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp" -defsystem_lisp="upgrade.lisp cache.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp output-translations.lisp source-registry.lisp package-inferred-system.lisp backward-interface.lisp backward-internals.lisp interface.lisp user.lisp footer.lisp" +defsystem_lisp="upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.lisp forcing.lisp plan.lisp operate.lisp find-system.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp" all () { # Default action: bootstrap asdf.lisp diff --git a/operate.lisp b/operate.lisp index fee7325286da98b4f90f9df73485c0b805a38373..ccd66561a4cc1c403f58a57ba7b975041d5fef18 100644 --- a/operate.lisp +++ b/operate.lisp @@ -3,20 +3,19 @@ (uiop/package:define-package :asdf/operate (:recycle :asdf/operate :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache - :asdf/component :asdf/system :asdf/operation :asdf/action - :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session + :asdf/component :asdf/system :asdf/system-registry :asdf/find-component + :asdf/operation :asdf/action :asdf/lisp-action :asdf/forcing :asdf/plan) (:export - #:operate #:oos - #:build-op #:make + #:operate #:oos #:build-op #:make #:load-system #:load-systems #:load-systems* - #:compile-system #:test-system #:require-system - #:module-provide-asdf - #:component-loaded-p #:already-loaded-systems)) + #:compile-system #:test-system #:require-system #:module-provide-asdf + #:component-loaded-p #:already-loaded-systems + #:recursive-operate)) (in-package :asdf/operate) (with-upgradability () - (defgeneric operate (operation component &key &allow-other-keys) + (defgeneric operate (operation component &key) (:documentation "Operate does mainly four things for the user: @@ -31,6 +30,7 @@ The entire computation is wrapped in WITH-COMPILATION-UNIT and error handling co If a VERSION argument is supplied, then operate also ensures that the system found satisfies it using the VERSION-SATISFIES method. If a PLAN-CLASS argument is supplied, that class is used for the plan. +If a PLAN-OPTIONS argument is supplied, the options are passed to the plan. The :FORCE or :FORCE-NOT argument to OPERATE can be: T to force the inside of the specified system to be rebuilt (resp. not), @@ -46,52 +46,60 @@ But do NOT depend on it, for this is deprecated behavior.")) (define-convenience-action-methods operate (operation component &key) :if-no-component (error 'missing-component :requires component)) - (defvar *in-operate* nil - "Are we in operate?") - ;; This method ensures that an ASDF upgrade is attempted as the very first thing, ;; with suitable state preservation in case in case it actually happens, ;; and that a few suitable dynamic bindings are established. (defmethod operate :around (operation component &rest keys &key verbose (on-warnings *compile-file-warnings-behaviour*) - (on-failure *compile-file-failure-behaviour*) &allow-other-keys) + (on-failure *compile-file-failure-behaviour*)) (nest - (with-asdf-cache ()) - (let ((in-operate *in-operate*) - (*in-operate* t) - (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was) - (etypecase operation - (operation (let ((name (type-of operation))) - #'(lambda () (make-operation name)))) - ((or symbol string) (constantly operation)))) - (component-path (typecase component ;; to remake the component after ASDF upgrade - (component (component-find-path component)) - (t component))))) - ;; Before we operate on any system, make sure ASDF is up-to-date, - ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble. - (progn - (unless in-operate + (with-asdf-session ()) + (let* ((operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was) + (etypecase operation + (operation (let ((name (type-of operation))) + #'(lambda () (make-operation name)))) + ((or symbol string) (constantly operation)))) + (component-path (typecase component ;; to remake the component after ASDF upgrade + (component (component-find-path component)) + (t component))) + (system-name (labels ((first-name (x) + (etypecase x + ((or string symbol) x) ; NB: includes the NIL case. + (cons (or (first-name (car x)) (first-name (cdr x))))))) + (coerce-name (first-name component-path))))) + (apply 'make-forcing :performable-p t :system system-name keys) + ;; Before we operate on any system, make sure ASDF is up-to-date, + ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble. + (unless (asdf-upgraded-p (toplevel-asdf-session)) + (setf (asdf-upgraded-p (toplevel-asdf-session)) t) (when (upgrade-asdf) ;; If we were upgraded, restart OPERATE the hardest of ways, for ;; its function may have been redefined. (return-from operate - (apply 'operate (funcall operation-remaker) component-path keys))))) + (with-asdf-session (:override t :override-cache t) + (apply 'operate (funcall operation-remaker) component-path keys)))))) ;; Setup proper bindings around any operate call. (let* ((*verbose-out* (and verbose *standard-output*)) (*compile-file-warnings-behaviour* on-warnings) - (*compile-file-failure-behaviour* on-failure)) - (call-next-method)))) + (*compile-file-failure-behaviour* on-failure))) + (unwind-protect + (progn + (incf (operate-level)) + (call-next-method)) + (decf (operate-level))))) (defmethod operate :before ((operation operation) (component component) - &key version &allow-other-keys) + &key version) (unless (version-satisfies component version) - (error 'missing-component-of-version :requires component :version version))) + (error 'missing-component-of-version :requires component :version version)) + (record-dependency nil operation component)) (defmethod operate ((operation operation) (component component) - &rest keys &key plan-class &allow-other-keys) - (let ((plan (apply 'make-plan plan-class operation component keys))) - (apply 'perform-plan plan keys) + &key plan-class plan-options) + (let ((plan (apply 'make-plan plan-class operation component + :forcing (forcing *asdf-session*) plan-options))) + (perform-plan plan) (values operation plan))) (defun oos (operation component &rest args &key &allow-other-keys) @@ -99,8 +107,19 @@ But do NOT depend on it, for this is deprecated behavior.")) (setf (documentation 'oos 'function) (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" - (documentation 'operate 'function)))) - + (documentation 'operate 'function))) + + (define-condition recursive-operate (warning) + ((operation :initarg :operation :reader condition-operation) + (component :initarg :component :reader condition-component) + (action :initarg :action :reader condition-action)) + (:report (lambda (c s) + (format s (compatfmt "~@") + 'operate + (type-of (condition-operation c)) + (component-find-path (condition-component c)) + (action-path (condition-action c))))))) ;;;; Common operations (when-upgrading () @@ -160,17 +179,11 @@ defaults to LOAD-OP, to load it in current image." "Has the given COMPONENT been successfully loaded in the current image (yet)? Note that this returns true even if the component is not up to date." (if-let ((component (find-component component () :registered t))) - (action-already-done-p nil (make-operation 'load-op) component))) + (nth-value 1 (component-operation-time (make-operation 'load-op) component)))) (defun already-loaded-systems () "return a list of the names of the systems that have been successfully loaded so far" - (mapcar 'coerce-name (remove-if-not 'component-loaded-p (registered-systems*)))) - - (defun require-system (system &rest keys &key &allow-other-keys) - "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but do not update the -system or its dependencies if they have already been loaded." - (unless (component-loaded-p system) - (apply 'load-system system :force-not (already-loaded-systems) keys)))) + (mapcar 'coerce-name (remove-if-not 'component-loaded-p (registered-systems*))))) ;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible, @@ -229,7 +242,7 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms.")) (let ((*modules-being-required* (cons module-name *modules-being-required*)) #+sbcl (sb-impl::*requiring* (remove module-name sb-impl::*requiring* :test 'equal))) (handler-bind - ((style-warning #'muffle-warning) + (((or style-warning recursive-operate) #'muffle-warning) (missing-component (constantly nil)) (fatal-condition #'(lambda (e) @@ -238,7 +251,11 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms.")) (let ((*verbose-out* (make-broadcast-stream))) (let ((system (find-system system-name nil))) (when system - (require-system system-name :verbose nil) + ;; Do not use require-system after all, use load-system: + ;; on the one hand, REQUIRE already uses *MODULES* not to load something twice, + ;; on the other hand, REQUIRE-SYSTEM uses FORCE-NOT which may conflict with + ;; the toplevel session forcing settings. + (load-system system :verbose nil) t))))))))) @@ -247,29 +264,16 @@ 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) + (clear-registered-systems) ;; The configuration also may have to be upgraded. (upgrade-configuration) ;; If we were in the middle of an operation, be sure to restore the system being defined. (dolist (s systems-being-defined) (find-system s nil)))) - (register-hook-function '*post-upgrade-cleanup-hook* 'restart-upgraded-asdf) - - ;; The following function's symbol is from asdf/find-system. - ;; It is defined here to resolve what would otherwise be forward package references. - (defun mark-component-preloaded (component) - "Mark a component as preloaded." - (let ((component (find-component component nil :registered t))) - ;; Recurse to children, so asdf/plan will hopefully be happy. - (map () 'mark-component-preloaded (component-children component)) - ;; Mark the timestamps of the common lisp-action operations as 0. - (let ((times (component-operation-times component))) - (dolist (o '(load-op compile-op prepare-op)) - (setf (gethash (make-operation o) times) 0)))))) - + (register-hook-function '*post-upgrade-cleanup-hook* 'restart-upgraded-asdf)) diff --git a/operation.lisp b/operation.lisp index dbac55545f677055e6ff220bfb236b3723572258..b03c0466138ee25cfafd228eb7a70b06123f39d3 100644 --- a/operation.lisp +++ b/operation.lisp @@ -3,7 +3,7 @@ (uiop/package:define-package :asdf/operation (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5. - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session) (:export #:operation #:*operations* #:make-operation #:find-operation diff --git a/package-inferred-system.lisp b/package-inferred-system.lisp index 2dbc427bd387e92c08be62319003ddb6977c529c..c1a649c1ebecb213b0ed7a88256f18586a8cade5 100644 --- a/package-inferred-system.lisp +++ b/package-inferred-system.lisp @@ -4,8 +4,9 @@ (uiop:define-package :asdf/package-inferred-system (:recycle :asdf/package-inferred-system :asdf/package-system :asdf) (:use :uiop/common-lisp :uiop - :asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility - :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action) + :asdf/upgrade :asdf/session + :asdf/component :asdf/system :asdf/system-registry :asdf/lisp-action + :asdf/parse-defsystem) (:export #:package-inferred-system #:sysdef-package-inferred-system-search #:package-system ;; backward compatibility only. To be removed. diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index 101ecef5be68061ef2e17d9f6bd21c06a0f5b8fc..8894bd042f814771e29420bf97d64ad1f4250496 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -5,15 +5,20 @@ (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf) (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares (:use :uiop/common-lisp :asdf/driver :asdf/upgrade - :asdf/cache :asdf/component :asdf/system - :asdf/find-system :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate) + :asdf/session :asdf/component :asdf/system :asdf/system-registry + :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate) (:import-from :asdf/system #:depends-on #:weakly-depends-on) + ;; these needed for record-additional-system-input-file + (:import-from :asdf/operation #:make-operation) + (:import-from :asdf/component #:%additional-input-files) + (:import-from :asdf/find-system #:define-op) (:export #:defsystem #:register-system-definition #:class-for-type #:*default-component-class* #:determine-system-directory #:parse-component-form #:non-toplevel-system #:non-system-system #:bad-system-name - #:sysdef-error-component #:check-component-input)) + #:sysdef-error-component #:check-component-input + #:explain)) (in-package :asdf/parse-defsystem) ;;; Pathname @@ -101,6 +106,27 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~ (sysdef-error-component ":components must be NIL or a list of components." type name components))) + + (defun record-additional-system-input-file (pathname component parent) + (let* ((record-on (if parent + (loop :with retval + :for par = parent :then (component-parent par) + :while par + :do (setf retval par) + :finally (return retval)) + component)) + (comp (if (typep record-on 'component) + record-on + ;; at this point there will be no parent for RECORD-ON + (find-component record-on nil))) + (op (make-operation 'define-op)) + (cell (or (assoc op (%additional-input-files comp)) + (let ((new-cell (list op))) + (push new-cell (%additional-input-files comp)) + new-cell)))) + (pushnew pathname (cdr cell) :test 'pathname-equal) + (values))) + ;; Given a form used as :version specification, in the context of a system definition ;; in a file at PATHNAME, for given COMPONENT with given PARENT, normalize the form ;; to an acceptable ASDF-format version. @@ -121,12 +147,16 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~ (case (first form) ((:read-file-form) (destructuring-bind (subpath &key (at 0)) (rest form) - (safe-read-file-form (subpathname pathname subpath) - :at at :package :asdf-user))) + (let ((path (subpathname pathname subpath))) + (record-additional-system-input-file path component parent) + (safe-read-file-form path + :at at :package :asdf-user)))) ((:read-file-line) (destructuring-bind (subpath &key (at 0)) (rest form) - (safe-read-file-line (subpathname pathname subpath) - :at at))) + (let ((path (subpathname pathname subpath))) + (record-additional-system-input-file path component parent) + (safe-read-file-line (subpathname pathname subpath) + :at at)))) (otherwise (invalid)))) (t @@ -288,7 +318,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)))) @@ -307,13 +337,12 @@ system names contained using COERCE-NAME. Return the result." :collect :it))) (load-systems* deps) dep-forms)) - (registered (system-registered-p name)) - (registered! (if registered - (rplaca registered (get-file-stamp source-file)) - (register-system - (make-instance 'system :name name :source-file source-file)))) - (system (reset-system (cdr registered!) - :name name :source-file source-file)) + (system (or (find-system-if-being-defined name) + (if-let (registered (registered-system name)) + (reset-system-class registered 'undefined-system + :name name :source-file source-file) + (register-system (make-instance 'undefined-system + :name name :source-file source-file))))) (component-options (append (remove-plist-keys '(:defsystem-depends-on :class) options) @@ -329,7 +358,7 @@ system names contained using COERCE-NAME. Return the result." (unless (subtypep class 'system) (error 'non-system-system :name name :class-name (class-name class))) (unless (eq (type-of system) class) - (change-class system class))) + (reset-system-class system class))) (parse-component-form nil (list* :module name :pathname directory component-options)))) (defmacro defsystem (name &body options) diff --git a/plan.lisp b/plan.lisp index 5a8e7ee636763590ad7bee26de81a831d4696b31..3f9bf2b40cab14cf2b67fc2b38f1e9bd8e3fdeec 100644 --- a/plan.lisp +++ b/plan.lisp @@ -4,32 +4,23 @@ (uiop/package:define-package :asdf/plan ;; asdf/action below is needed for required-components, traverse-action and traverse-sub-actions ;; that used to live there before 3.2.0. - (:recycle :asdf/plan :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade - :asdf/component :asdf/operation :asdf/system - :asdf/cache :asdf/find-system :asdf/find-component - :asdf/operation :asdf/action :asdf/lisp-action) + (:recycle :asdf/plan :asdf/action :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session + :asdf/component :asdf/operation :asdf/action :asdf/lisp-action + :asdf/system :asdf/system-registry :asdf/find-component :asdf/forcing) (:export - #:component-operation-time - #:plan #:plan-traversal #:sequential-plan #:*default-plan-class* - #:planned-action-status #:plan-action-status #:action-already-done-p + #:plan #:plan-traversal #:sequential-plan #:*plan-class* + #:action-status #:status-stamp #:status-index #:status-done-p #:status-keep-p #:status-need-p + #:action-already-done-p + #:+status-good+ #:+status-todo+ #:+status-void+ + #:system-out-of-date #:action-up-to-date-p #:circular-dependency #:circular-dependency-actions #:needed-in-image-p - #:action-index #:action-planned-p #:action-valid-p - #:plan-record-dependency - #:normalize-forced-systems #:action-forced-p #:action-forced-not-p #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies - #:compute-action-stamp #:traverse-action - #:circular-dependency #:circular-dependency-actions - #:call-while-visiting-action #:while-visiting-action - #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p - #:planned-p #:index #:forced #:forced-not #:total-action-count - #:planned-action-count #:planned-output-action-count #:visited-actions - #:visiting-action-set #:visiting-action-list #:plan-actions-r + #:compute-action-stamp #:traverse-action #:record-dependency + #:make-plan #:plan-actions #:plan-actions-r #:perform-plan #:mark-as-done #:required-components #:filtered-sequential-plan - #:plan-system - #:plan-action-filter #:plan-component-type #:plan-keep-operation #:plan-keep-component - #:traverse-actions #:traverse-sub-actions)) + #:plan-component-type #:plan-keep-operation #:plan-keep-component)) (in-package :asdf/plan) ;;;; Generic plan traversal class @@ -37,146 +28,179 @@ (defclass plan () () (:documentation "Base class for a plan based on which ASDF can build a system")) (defclass plan-traversal (plan) - (;; The system for which the plan is computed - (system :initform nil :initarg :system :accessor plan-system) - ;; Table of systems specified via :force arguments - (forced :initform nil :initarg :force :accessor plan-forced) - ;; Table of systems specified via :force-not argument (and/or immutable) - (forced-not :initform nil :initarg :force-not :accessor plan-forced-not) - ;; Counts of total actions in plan - (total-action-count :initform 0 :accessor plan-total-action-count) - ;; Count of actions that need to be performed - (planned-action-count :initform 0 :accessor plan-planned-action-count) - ;; Count of actions that need to be performed that have a non-empty list of output-files. - (planned-output-action-count :initform 0 :accessor plan-planned-output-action-count) - ;; Table that to actions already visited while walking the dependencies associates status - (visited-actions :initform (make-hash-table :test 'equal) :accessor plan-visited-actions) - ;; Actions that depend on those being currently walked through, to detect circularities - (visiting-action-set ;; as a set - :initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set) - (visiting-action-list :initform () :accessor plan-visiting-action-list)) ;; as a list - (:documentation "Base class for plans that simply traverse dependencies"))) + (;; The forcing parameters for this plan. Also indicates whether the plan is performable, + ;; in which case the forcing is the same as for the entire session. + (forcing :initform (forcing (toplevel-asdf-session)) :initarg :forcing :reader forcing)) + (:documentation "Base class for plans that simply traverse dependencies")) + ;; Sequential plans (the default) + (defclass sequential-plan (plan-traversal) + ((actions-r :initform nil :accessor plan-actions-r)) + (:documentation "Simplest, default plan class, accumulating a sequence of actions")) + (defgeneric plan-actions (plan) + (:documentation "Extract from a plan a list of actions to perform in sequence")) + (defmethod plan-actions ((plan list)) + plan) + (defmethod plan-actions ((plan sequential-plan)) + (reverse (plan-actions-r plan))) -;;;; Planned action status -(with-upgradability () - (defgeneric plan-action-status (plan operation component) - (:documentation "Returns the ACTION-STATUS associated to -the action of OPERATION on COMPONENT in the PLAN")) + (defgeneric record-dependency (plan operation component) + (:documentation "Record an action as a dependency in the current plan")) + + ;; No need to record a dependency to build a full graph, just accumulate nodes in order. + (defmethod record-dependency ((plan sequential-plan) (o operation) (c component)) + (values))) + +(when-upgrading (:version "3.2.1") + (defmethod initialize-instance :after ((plan plan-traversal) &key &allow-other-keys))) - (defgeneric (setf plan-action-status) (new-status plan operation component) - (:documentation "Sets the ACTION-STATUS associated to -the action of OPERATION on COMPONENT in the PLAN")) - (defclass planned-action-status (action-status) - ((planned-p - :initarg :planned-p :reader action-planned-p - :documentation "a boolean, true iff the action was included in the plan.") +;;;; Planned action status +(with-upgradability () + (defclass action-status () + ((bits + :type fixnum :initarg :bits :reader status-bits + :documentation "bitmap describing the status of the action.") + (stamp + :type (or integer boolean) :initarg :stamp :reader status-stamp + :documentation "STAMP associated with the ACTION if it has been completed already in some +previous session or image, T if it was done and builtin the image, or NIL if it needs to be done.") + (level + :type fixnum :initarg :level :initform 0 :reader status-level + :documentation "the highest (operate-level) at which the action was needed") (index - :initarg :index :reader action-index - :documentation "an integer, counting all traversed actions in traversal order.")) + :type (or integer null) :initarg :index :initform nil :reader status-index + :documentation "INDEX associated with the ACTION in the current session, +or NIL if no the status is considered outside of a specific plan.")) (:documentation "Status of an action in a plan")) - (defmethod print-object ((status planned-action-status) stream) - (print-unreadable-object (status stream :type t :identity nil) - (with-slots (stamp done-p planned-p index) status - (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p :index index)))) - - (defmethod action-planned-p ((action-status t)) - t) ; default method for non planned-action-status objects + ;; STAMP KEEP-P DONE-P NEED-P symbol bitmap previously currently + ;; not-nil T T T => GOOD 7 up-to-date done (e.g. file previously loaded) + ;; not-nil T T NIL => HERE 6 up-to-date unplanned yet done + ;; not-nil T NIL T => REDO 5 up-to-date planned (e.g. file to load) + ;; not-nil T NIL NIL => SKIP 4 up-to-date unplanned (e.g. file compiled) + ;; not-nil NIL T T => DONE 3 out-of-date done + ;; not-nil NIL T NIL => WHAT 2 out-of-date unplanned yet done(?) + ;; NIL NIL NIL T => TODO 1 out-of-date planned + ;; NIL NIL NIL NIL => VOID 0 out-of-date unplanned + ;; + ;; Note that a VOID status cannot happen as part of a transitive dependency of a wanted node + ;; while traversing a node with TRAVERSE-ACTION; it can only happen while checking whether an + ;; action is up-to-date with ACTION-UP-TO-DATE-P. + ;; + ;; When calling TRAVERSE-ACTION, the +need-bit+ is set, + ;; unless the action is up-to-date and not needed-in-image (HERE, SKIP). + ;; When PERFORMing an action, the +done-bit+ is set. + ;; When the +need-bit+ is set but not the +done-bit+, the level slot indicates which level of + ;; OPERATE it was last marked needed for; if it happens to be needed at a higher-level, then + ;; its urgency (and that of its transitive dependencies) must be escalated so that it will be + ;; done before the end of this level of operate. + ;; + ;; Also, when no ACTION-STATUS is associated to an action yet, NIL serves as a bottom value. + ;; + (defparameter +keep-bit+ 4) + (defparameter +done-bit+ 2) + (defparameter +need-bit+ 1) + (defparameter +good-bits+ 7) + (defparameter +todo-bits+ 1) + (defparameter +void-bits+ 0) + + (defparameter +status-good+ + (make-instance 'action-status :bits +good-bits+ :stamp t)) + (defparameter +status-todo+ + (make-instance 'action-status :bits +todo-bits+ :stamp nil)) + (defparameter +status-void+ + (make-instance 'action-status :bits +void-bits+ :stamp nil))) - (defun action-already-done-p (plan operation component) - "According to this plan, is this action already done and up to date?" - (action-done-p (plan-action-status plan operation component))) +(with-upgradability () + (defun make-action-status (&key bits stamp (level 0) index) + (check-type bits (integer 0 7)) + (check-type stamp (or integer boolean)) + (check-type level (integer 0 #.most-positive-fixnum)) + (check-type index (or integer null)) + (assert (eq (null stamp) (zerop (logand bits #.(logior +keep-bit+ +done-bit+)))) () + "Bad action-status :bits ~S :stamp ~S" bits stamp) + (block nil + (when (and (null index) (zerop level)) + (case bits + (#.+void-bits+ (return +status-void+)) + (#.+todo-bits+ (return +status-todo+)) + (#.+good-bits+ (when (eq stamp t) (return +status-good+))))) + (make-instance 'action-status :bits bits :stamp stamp :level level :index index))) + + (defun status-keep-p (status) + (plusp (logand (status-bits status) #.+keep-bit+))) + (defun status-done-p (status) + (plusp (logand (status-bits status) #.+done-bit+))) + (defun status-need-p (status) + (plusp (logand (status-bits status) #.+need-bit+))) + + (defun merge-action-status (status1 status2) ;; status-and + "Return the earliest status later than both status1 and status2" + (make-action-status + :bits (logand (status-bits status1) (status-bits status2)) + :stamp (latest-stamp (status-stamp status1) (status-stamp status2)) + :level (min (status-level status1) (status-level status2)) + :index (or (status-index status1) (status-index status2)))) + + (defun mark-status-needed (status &optional (level (operate-level))) ;; limited status-or + "Return the same status but with the need bit set, for the given level" + (if (and (status-need-p status) + (>= (status-level status) level)) + status + (make-action-status + :bits (logior (status-bits status) +need-bit+) + :level (max level (status-level status)) + :stamp (status-stamp status) + :index (status-index status)))) + + (defmethod print-object ((status action-status) stream) + (print-unreadable-object (status stream :type t) + (with-slots (bits stamp level index) status + (format stream "~{~S~^ ~}" `(:bits ,bits :stamp ,stamp :level ,level :index ,index))))) + + (defgeneric action-status (plan operation component) + (:documentation "Returns the ACTION-STATUS associated to the action of OPERATION on COMPONENT +in the PLAN, or NIL if the action wasn't visited yet as part of the PLAN.")) + + (defgeneric (setf action-status) (new-status plan operation component) + (:documentation "Sets the ACTION-STATUS associated to +the action of OPERATION on COMPONENT in the PLAN")) - (defmethod plan-action-status ((plan null) (o operation) (c component)) + (defmethod action-status ((plan null) (o operation) (c component)) (multiple-value-bind (stamp done-p) (component-operation-time o c) - (make-instance 'action-status :stamp stamp :done-p done-p))) + (if done-p + (make-action-status :bits #.+keep-bit+ :stamp stamp) + +status-void+))) - (defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component)) + (defmethod (setf action-status) (new-status (plan null) (o operation) (c component)) (let ((times (component-operation-times c))) - (if (action-done-p new-status) - (remhash o times) - (setf (gethash o times) (action-stamp new-status)))) - new-status)) - + (if (status-done-p new-status) + (setf (gethash o times) (status-stamp new-status)) + (remhash o times))) + new-status) + + ;; Handle FORCED-NOT: it makes an action return its current timestamp as status + (defmethod action-status ((p plan) (o operation) (c component)) + ;; TODO: should we instead test something like: + ;; (action-forced-not-p plan operation (primary-system component)) + (or (gethash (make-action o c) (visited-actions *asdf-session*)) + (when (action-forced-not-p (forcing p) o c) + (let ((status (action-status nil o c))) + (setf (gethash (make-action o c) (visited-actions *asdf-session*)) + (make-action-status + :bits +good-bits+ + :stamp (or (and status (status-stamp status)) t) + :index (incf (total-action-count *asdf-session*)))))))) + + (defmethod (setf action-status) (new-status (p plan) (o operation) (c component)) + (setf (gethash (make-action o c) (visited-actions *asdf-session*)) new-status)) + + (defmethod (setf action-status) :after + (new-status (p sequential-plan) (o operation) (c component)) + (unless (status-done-p new-status) + (push (make-action o c) (plan-actions-r p))))) -;;;; forcing -(with-upgradability () - (defgeneric action-forced-p (plan operation component) - (:documentation "Is this action forced to happen in this plan?")) - (defgeneric action-forced-not-p (plan operation component) - (:documentation "Is this action forced to not happen in this plan? -Takes precedence over action-forced-p.")) - - (defun normalize-forced-systems (force system) - "Given a SYSTEM on which operate is called and the specified FORCE argument, -extract a hash-set of systems that are forced, or a predicate on system names, -or NIL if none are forced, or :ALL if all are." - (etypecase force - ((or (member nil :all) hash-table function) force) - (cons (list-to-hash-set (mapcar #'coerce-name force))) - ((eql t) (when system (list-to-hash-set (list (coerce-name system))))))) - - (defun normalize-forced-not-systems (force-not system) - "Given a SYSTEM on which operate is called, the specified FORCE-NOT argument, -and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not, -or predicate on system names, or NIL if none are forced, or :ALL if all are." - (let ((requested - (etypecase force-not - ((or (member nil :all) hash-table function) force-not) - (cons (list-to-hash-set (mapcar #'coerce-name force-not))) - ((eql t) (if system (let ((name (coerce-name system))) - #'(lambda (x) (not (equal x name)))) - :all))))) - (if (and *immutable-systems* requested) - #'(lambda (x) (or (call-function requested x) - (call-function *immutable-systems* x))) - (or *immutable-systems* requested)))) - - ;; TODO: shouldn't we be looking up the primary system name, rather than the system name? - (defun action-override-p (plan operation component override-accessor) - "Given a plan, an action, and a function that given the plan accesses a set of overrides -(i.e. force or force-not), see if the override applies to the current action." - (declare (ignore operation)) - (call-function (funcall override-accessor plan) - (coerce-name (component-system (find-component () component))))) - - (defmethod action-forced-p (plan operation component) - (and - ;; Did the user ask us to re-perform the action? - (action-override-p plan operation component 'plan-forced) - ;; You really can't force a builtin system and :all doesn't apply to it, - ;; except if it's the specifically the system currently being built. - (not (let ((system (component-system component))) - (and (builtin-system-p system) - (not (eq system (plan-system plan)))))))) - - (defmethod action-forced-not-p (plan operation component) - ;; Did the user ask us to not re-perform the action? - ;; NB: force-not takes precedence over force, as it should - (action-override-p plan operation component 'plan-forced-not)) - - (defmethod action-forced-p ((plan null) (operation operation) (component component)) - nil) - - (defmethod action-forced-not-p ((plan null) (operation operation) (component component)) - nil)) - - -;;;; action-valid-p -(with-upgradability () - (defgeneric action-valid-p (plan operation component) - (:documentation "Is this action valid to include amongst dependencies?")) - ;; :if-feature will invalidate actions on components for which the features don't apply. - (defmethod action-valid-p ((plan t) (o operation) (c component)) - (if-let (it (component-if-feature c)) (featurep it) t)) - ;; If either the operation or component was resolved to nil, the action is invalid. - (defmethod action-valid-p ((plan t) (o null) (c t)) nil) - (defmethod action-valid-p ((plan t) (o t) (c null)) nil) - ;; If the plan is null, i.e., we're looking at reality, - ;; then any action with actual operation and component objects is valid. - (defmethod action-valid-p ((plan null) (o operation) (c component)) t)) ;;;; Is the action needed in this image? (with-upgradability () @@ -194,29 +218,28 @@ to be meaningful, or could it just as well have been done in another Lisp image? ;;;; Visiting dependencies of an action and computing action stamps (with-upgradability () - (defun* (map-direct-dependencies) (plan operation component fun) + (defun* (map-direct-dependencies) (operation component fun) "Call FUN on all the valid dependencies of the given action in the given plan" (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component) - :for dep-o = (find-operation operation dep-o-spec) - :when dep-o - :do (loop :for dep-c-spec :in dep-c-specs - :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec)) - :when (and dep-c (action-valid-p plan dep-o dep-c)) - :do (funcall fun dep-o dep-c)))) - - (defun* (reduce-direct-dependencies) (plan operation component combinator seed) + :for dep-o = (find-operation operation dep-o-spec) + :when dep-o + :do (loop :for dep-c-spec :in dep-c-specs + :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec)) + :when (action-valid-p dep-o dep-c) + :do (funcall fun dep-o dep-c)))) + + (defun* (reduce-direct-dependencies) (operation component combinator seed) "Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR for each dependency action on the dependency's operation and component and an accumulator initialized with SEED." (map-direct-dependencies - plan operation component - #'(lambda (dep-o dep-c) - (setf seed (funcall combinator dep-o dep-c seed)))) + operation component + #'(lambda (dep-o dep-c) (setf seed (funcall combinator dep-o dep-c seed)))) seed) - (defun* (direct-dependencies) (plan operation component) + (defun* (direct-dependencies) (operation component) "Compute a list of the direct dependencies of the action within the plan" - (reverse (reduce-direct-dependencies plan operation component #'acons nil))) + (reverse (reduce-direct-dependencies operation component #'acons nil))) ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp ;; shall also be parametrized by the plan, or by a second model object, @@ -229,256 +252,205 @@ initialized with SEED." ;; or if it has just been done, return the time that it has. ;; Returns two values: ;; 1- the TIMESTAMP of the action if it has already been done and is up to date, - ;; or T is either hasn't been done or is out of date. + ;; or NIL is either hasn't been done or is out of date. + ;; (An ASDF extension could use a cryptographic digest instead.) ;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done ;; in the current image, or NIL if it hasn't. ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but - ;; hasn't been done in the current image yet, then it can have a non-T timestamp, + ;; hasn't been done in the current image yet, then it can have a non-NIL timestamp, ;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded, ;; i.e. that of the input-files. + ;; If just-done is NIL, these values return are the notional fields of + ;; a KEEP, REDO or TODO status (VOID is possible, but probably an error). + ;; If just-done is T, they are the notional fields of DONE status + ;; (or, if something went wrong, TODO). (nest (block ()) - (let ((dep-stamp ; collect timestamp from dependencies (or T if forced or out-of-date) + (let* ((dep-status ; collect timestamp from dependencies (or T if forced or out-of-date) (reduce-direct-dependencies - plan o c - #'(lambda (o c stamp) - (if-let (it (plan-action-status plan o c)) - (latest-stamp stamp (action-stamp it)) - t)) - nil))) - ;; out-of-date dependency: don't bother expensively querying the filesystem - (when (and (eq dep-stamp t) (not just-done)) (return (values t nil)))) - ;; collect timestamps from inputs, and exit early if any is missing - (let* ((in-files (input-files o c)) + o c + #'(lambda (do dc status) + ;; out-of-date dependency: don't bother looking further + (let ((action-status (action-status plan do dc))) + (cond + ((and action-status (or (status-keep-p action-status) + (and just-done (status-stamp action-status)))) + (merge-action-status action-status status)) + (just-done + ;; It's OK to lose some ASDF action stamps during self-upgrade + (unless (equal "asdf" (primary-system-name dc)) + (warn "Computing just-done stamp in plan ~S for action ~S, but dependency ~S wasn't done yet!" + plan + (action-path (make-action o c)) + (action-path (make-action do dc)))) + status) + (t + (return (values nil nil)))))) + +status-good+)) + (dep-stamp (status-stamp dep-status)))) + (let* (;; collect timestamps from inputs, and exit early if any is missing + (in-files (input-files o c)) (in-stamps (mapcar #'get-file-stamp in-files)) (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) (latest-in (stamps-latest (cons dep-stamp in-stamps)))) - (when (and missing-in (not just-done)) (return (values t nil)))) - ;; collect timestamps from outputs, and exit early if any is missing - (let* ((out-files (remove-if 'null (output-files o c))) + (when (and missing-in (not just-done)) (return (values nil nil)))) + (let* (;; collect timestamps from outputs, and exit early if any is missing + (out-files (remove-if 'null (output-files o c))) (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) (earliest-out (stamps-earliest out-stamps))) - (when (and missing-out (not just-done)) (return (values t nil)))) - (let* (;; There are three kinds of actions: - (out-op (and out-files t)) ; those that create files on the filesystem - ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image - ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing - ;; When was the thing last actually done? (Now, or ask.) - (op-time (or just-done (component-operation-time o c))) - ;; Time stamps from the files at hand, and whether any is missing - (all-present (not (or missing-in missing-out))) - ;; Has any input changed since we last generated the files? - (up-to-date-p (stamp<= latest-in earliest-out)) - ;; If everything is up to date, the latest of inputs and outputs is our stamp - (done-stamp (stamps-latest (cons latest-in out-stamps)))) + (when (and missing-out (not just-done)) (return (values nil nil)))) + (let (;; Time stamps from the files at hand, and whether any is missing + (all-present (not (or missing-in missing-out))) + ;; Has any input changed since we last generated the files? + ;; Note that we use stamp<= instead of stamp< to play nice with generated files. + ;; Any race condition is intrinsic to the limited timestamp resolution. + (up-to-date-p (stamp<= latest-in earliest-out)) + ;; If everything is up to date, the latest of inputs and outputs is our stamp + (done-stamp (stamps-latest (cons latest-in out-stamps)))) ;; Warn if some files are missing: ;; either our model is wrong or some other process is messing with our files. (when (and just-done (not all-present)) + ;; Shouldn't that be an error instead? (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" (action-description o c) missing-in (length missing-in) (and missing-in missing-out) missing-out (length missing-out)))) - ;; Note that we use stamp<= instead of stamp< to play nice with generated files. - ;; Any race condition is intrinsic to the limited timestamp resolution. + (let (;; There are three kinds of actions: + (out-op (and out-files t)) ; those that create files on the filesystem + ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image + ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing + )) (if (or just-done ;; The done-stamp is valid: if we're just done, or - ;; if all filesystem effects are up-to-date and there's no invalidating reason. - (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c)))) + (and all-present ;; if all filesystem effects are up-to-date + up-to-date-p + (operation-done-p o c) ;; and there's no invalidating reason. + (not (action-forced-p (forcing (or plan *asdf-session*)) o c)))) (values done-stamp ;; return the hard-earned timestamp (or just-done - out-op ;; a file-creating op is done when all files are up to date - ;; a image-effecting a placeholder op is done when it was actually run, - (and op-time (eql op-time done-stamp)))) ;; with the matching stamp + out-op ;; A file-creating op is done when all files are up to date. + ;; An image-effecting operation is done when + (and (status-done-p dep-status) ;; all the dependencies were done, and + (multiple-value-bind (perform-stamp perform-done-p) + (component-operation-time o c) + (and perform-done-p ;; the op was actually run, + (equal perform-stamp done-stamp)))))) ;; with a matching stamp. ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet - (values t nil))))) + (values nil nil))))) -;;;; Generic support for plan-traversal +;;;; The four different actual traversals: +;; * TRAVERSE-ACTION o c T: Ensure all dependencies are either up-to-date in-image, or planned +;; * TRAVERSE-ACTION o c NIL: Ensure all dependencies are up-to-date or planned, in-image or not +;; * ACTION-UP-TO-DATE-P: Check whether some (defsystem-depends-on ?) dependencies are up to date +;; * COLLECT-ACTION-DEPENDENCIES: Get the dependencies (filtered), don't change any status (with-upgradability () - (defmethod initialize-instance :after ((plan plan-traversal) - &key force force-not system - &allow-other-keys) - (with-slots (forced forced-not) plan - (setf forced (normalize-forced-systems force system)) - (setf forced-not (normalize-forced-not-systems force-not system)))) - - (defgeneric plan-actions (plan) - (:documentation "Extract from a plan a list of actions to perform in sequence")) - (defmethod plan-actions ((plan list)) - plan) - - (defmethod (setf plan-action-status) (new-status (p plan-traversal) (o operation) (c component)) - (setf (gethash (cons o c) (plan-visited-actions p)) new-status)) - (defmethod plan-action-status ((p plan-traversal) (o operation) (c component)) - (or (and (action-forced-not-p p o c) (plan-action-status nil o c)) - (values (gethash (cons o c) (plan-visited-actions p))))) - - (defmethod action-valid-p ((p plan-traversal) (o operation) (s system)) - (and (not (action-forced-not-p p o s)) (call-next-method))) - - (defgeneric plan-record-dependency (plan operation component) - (:documentation "Record an action as a dependency in the current plan"))) - - -;;;; Detection of circular dependencies -(with-upgradability () - (define-condition circular-dependency (system-definition-error) - ((actions :initarg :actions :reader circular-dependency-actions)) - (:report (lambda (c s) - (format s (compatfmt "~@") - (circular-dependency-actions c))))) - - (defgeneric call-while-visiting-action (plan operation component function) - (:documentation "Detect circular dependencies")) - - (defmethod call-while-visiting-action ((plan plan-traversal) operation component fun) - (with-accessors ((action-set plan-visiting-action-set) - (action-list plan-visiting-action-list)) plan - (let ((action (make-action operation component))) - (when (gethash action action-set) - (error 'circular-dependency :actions - (member action (reverse action-list) :test 'equal))) - (setf (gethash action action-set) t) - (push action action-list) - (unwind-protect - (funcall fun) - (pop action-list) - (setf (gethash action action-set) nil))))) - - ;; Syntactic sugar for call-while-visiting-action - (defmacro while-visiting-action ((p o c) &body body) - `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body)))) - - -;;;; Actual traversal: traverse-action -(with-upgradability () - (defgeneric traverse-action (plan operation component needed-in-image-p)) + ;; Compute the action status for a newly visited action. + (defun compute-action-status (plan operation component need-p) + (multiple-value-bind (stamp done-p) + (compute-action-stamp plan operation component) + (assert (or stamp (not done-p))) + (make-action-status + :bits (logior (if stamp #.+keep-bit+ 0) + (if done-p #.+done-bit+ 0) + (if need-p #.+need-bit+ 0)) + :stamp stamp + :level (operate-level) + :index (incf (total-action-count *asdf-session*))))) ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data, ;; visits the action defined by its OPERATION and COMPONENT arguments, ;; and all its transitive dependencies (unless already visited), ;; in the context of the action being (or not) NEEDED-IN-IMAGE-P, ;; i.e. needs to be done in the current image vs merely have been done in a previous image. - ;; For actions that are up-to-date, it returns a STAMP identifying the state of the action - ;; (that's timestamp, but it could be a cryptographic digest in some ASDF extension), - ;; or T if the action needs to be done again. + ;; + ;; TRAVERSE-ACTION updates the VISITED-ACTIONS entries for the action and for all its + ;; transitive dependencies (that haven't been sufficiently visited so far). + ;; It does not return any usable value. ;; ;; Note that for an XCVB-like plan with one-image-per-file-outputting-action, ;; the below method would be insufficient, since it assumes a single image ;; to traverse each node at most twice; non-niip actions would be traversed only once, ;; but niip nodes could be traversed once per image, i.e. once plus once per non-niip action. - (defmethod traverse-action (plan operation component needed-in-image-p) + (defun traverse-action (plan operation component needed-in-image-p) (block nil - ;; ACTION-VALID-P among other things, handles forcing logic, including FORCE-NOT, - ;; and IF-FEATURE filtering. - (unless (action-valid-p plan operation component) (return nil)) - ;; the following hook is needed by POIU, which tracks a full dependency graph, - ;; instead of just a dependency order as in vanilla ASDF - (plan-record-dependency plan operation component) - ;; needed in image distinguishes b/w things that must happen in the - ;; current image and those things that simply need to have been done in a previous one. - (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image - ;; effective niip: meaningful for the action and required by the plan as traversed - (eniip (and aniip needed-in-image-p)) - ;; status: have we traversed that action previously, and if so what was its status? - (status (plan-action-status plan operation component))) - (when (and status (or (action-done-p status) (action-planned-p status) (not eniip))) - (return (action-stamp status))) ; Already visited with sufficient need-in-image level! - (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T - (map-direct-dependencies ; recursively traverse dependencies - plan operation component #'(lambda (o c) (traverse-action plan o c niip))) - (multiple-value-bind (stamp done-p) ; AFTER dependencies have been traversed, - (compute-action-stamp plan operation component) ; compute action stamp - (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p))))) + (unless (action-valid-p operation component) (return)) + ;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph, + ;; instead of just a dependency order as in vanilla ASDF. + ;; TODO: It is also needed to detect OPERATE-in-PERFORM. + (record-dependency plan operation component) + (while-visiting-action (operation component) ; maintain context, handle circularity. + ;; needed-in-image distinguishes b/w things that must happen in the + ;; current image and those things that simply need to have been done in a previous one. + (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image + ;; effective niip: meaningful for the action and required by the plan as traversed + (eniip (and aniip needed-in-image-p)) + ;; status: have we traversed that action previously, and if so what was its status? + (status (action-status plan operation component)) + (level (operate-level))) + (when (and status + (or (status-done-p status) ;; all done + (and (status-need-p status) (<= level (status-level status))) ;; already visited + (and (status-keep-p status) (not eniip)))) ;; up-to-date and not eniip + (return)) ; Already visited with sufficient need-in-image level! + (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T + (map-direct-dependencies ; recursively traverse dependencies + operation component #'(lambda (o c) (traverse-action plan o c niip))) + ;; AFTER dependencies have been traversed, compute action stamp + (let* ((status (if status + (mark-status-needed status level) + (compute-action-status plan operation component t))) + (out-of-date-p (not (status-keep-p status))) + (to-perform-p (or out-of-date-p (and niip (not (status-done-p status)))))) (cond ; it needs be done if it's out of date or needed in image but absent - ((and add-to-plan-p (not niip)) ; if we need to do it, + ((and out-of-date-p (not niip)) ; if we need to do it, (visit-action t)) ; then we need to do it *in the (current) image*! (t - (setf (plan-action-status plan operation component) ; update status: - (make-instance - 'planned-action-status - :stamp stamp ; computed stamp - :done-p (and done-p (not add-to-plan-p)) ; done *and* up-to-date? - :planned-p add-to-plan-p ; included in list of things to be done? - :index (if status ; index of action amongst all nodes in traversal - (action-index status) ;; if already visited, keep index - (incf (plan-total-action-count plan))))) ; else new index - (when (and done-p (not add-to-plan-p)) - (setf (component-operation-time operation component) stamp)) - (when add-to-plan-p ; if it needs to be added to the plan, - (incf (plan-planned-action-count plan)) ; count it - (unless aniip ; if it's output-producing, - (incf (plan-planned-output-action-count plan)))) ; count it - stamp)))))) ; return the stamp - (while-visiting-action (plan operation component) ; maintain context, handle circularity. - (visit-action eniip))))))) ; visit the action - - -;;;; Sequential plans (the default) -(with-upgradability () - (defclass sequential-plan (plan-traversal) - ((actions-r :initform nil :accessor plan-actions-r)) - (:documentation "Simplest, default plan class, accumulating a sequence of actions")) - - (defmethod plan-actions ((plan sequential-plan)) - (reverse (plan-actions-r plan))) - - ;; No need to record a dependency to build a full graph, just accumulate nodes in order. - (defmethod plan-record-dependency ((plan sequential-plan) (o operation) (c component)) - (values)) - - (defmethod (setf plan-action-status) :after - (new-status (p sequential-plan) (o operation) (c component)) - (when (action-planned-p new-status) - (push (make-action o c) (plan-actions-r p))))) - - -;;;; High-level interface: traverse, perform-plan, plan-operates-on-p -(with-upgradability () - (defgeneric make-plan (plan-class operation component &key &allow-other-keys) - (:documentation "Generate and return a plan for performing OPERATION on COMPONENT.")) - (define-convenience-action-methods make-plan (plan-class operation component &key)) - - (defgeneric perform-plan (plan &key) - (:documentation "Actually perform a plan and build the requested actions")) - (defgeneric plan-operates-on-p (plan component) - (:documentation "Does this PLAN include any operation on given COMPONENT?")) - - (defvar *default-plan-class* 'sequential-plan - "The default plan class to use when building with ASDF") - - (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys) - (let ((plan (apply 'make-instance (or plan-class *default-plan-class*) - :system (component-system c) keys))) - (traverse-action plan o c t) - plan)) - - (defmethod perform-plan :around ((plan t) &key) - #+xcl (declare (ignorable plan)) - (let ((*package* *package*) - (*readtable* *readtable*)) - (with-compilation-unit () ;; backward-compatibility. - (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build. - - (defmethod perform-plan ((plan t) &rest keys &key &allow-other-keys) - (apply 'perform-plan (plan-actions plan) keys)) - - (defmethod perform-plan ((steps list) &key force &allow-other-keys) - (loop* :for action :in steps - :as o = (action-operation action) - :as c = (action-component action) - :when (or force (not (nth-value 1 (compute-action-stamp nil o c)))) - :do (perform-with-restarts o c))) - - (defmethod plan-operates-on-p ((plan plan-traversal) (component-path list)) - (plan-operates-on-p (plan-actions plan) component-path)) + (setf (action-status plan operation component) status) + (when (status-done-p status) + (setf (component-operation-time operation component) + (status-stamp status))) + (when to-perform-p ; if it needs to be added to the plan, count it + (incf (planned-action-count *asdf-session*)) + (unless aniip ; if it's output-producing, count it + (incf (planned-output-action-count *asdf-session*))))))))) + (visit-action eniip)))))) ; visit the action + + ;; NB: This is not an error, not a warning, but a normal expected condition, + ;; to be to signaled by FIND-SYSTEM when it detects an out-of-date system, + ;; *before* it tries to replace it with a new definition. + (define-condition system-out-of-date (condition) + ((name :initarg :name :reader component-name)) + (:documentation "condition signaled when a system is detected as being out of date") + (:report (lambda (c s) + (format s "system ~A is out of date" (component-name c))))) - (defmethod plan-operates-on-p ((plan list) (component-path list)) - (find component-path (mapcar 'action-component plan) - :test 'equal :key 'component-find-path))) + (defun action-up-to-date-p (plan operation component) + "Check whether an action was up-to-date at the beginning of the session. +Update the VISITED-ACTIONS table with the known status, but don't add anything to the PLAN." + (block nil + (unless (action-valid-p operation component) (return t)) + (while-visiting-action (operation component) ; maintain context, handle circularity. + ;; Do NOT record the dependency: it might be out of date. + (let ((status (or (action-status plan operation component) + (setf (action-status plan operation component) + (let ((dependencies-up-to-date-p + (handler-case + (block nil + (map-direct-dependencies + operation component + #'(lambda (o c) + (unless (action-up-to-date-p plan o c) + (return nil)))) + t) + (system-out-of-date () nil)))) + (if dependencies-up-to-date-p + (compute-action-status plan operation component nil) + +status-void+)))))) + (and (status-keep-p status) (status-stamp status))))))) ;;;; Incidental traversals @@ -487,60 +459,110 @@ initialized with SEED." ;;; files required by a bundling operation. (with-upgradability () (defclass filtered-sequential-plan (sequential-plan) - ((action-filter :initform t :initarg :action-filter :reader plan-action-filter) - (component-type :initform t :initarg :component-type :reader plan-component-type) + ((component-type :initform t :initarg :component-type :reader plan-component-type) (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation) (keep-component :initform t :initarg :keep-component :reader plan-keep-component)) (:documentation "A variant of SEQUENTIAL-PLAN that only records a subset of actions.")) (defmethod initialize-instance :after ((plan filtered-sequential-plan) - &key force force-not - other-systems) - (declare (ignore force force-not)) + &key system other-systems) ;; Ignore force and force-not, rely on other-systems: ;; force traversal of what we're interested in, i.e. current system or also others; ;; force-not traversal of what we're not interested in, i.e. other systems unless other-systems. - (with-slots (forced forced-not action-filter system) plan - (setf forced (normalize-forced-systems (if other-systems :all t) system)) - (setf forced-not (normalize-forced-not-systems (if other-systems nil t) system)) - (setf action-filter (ensure-function action-filter)))) - - (defmethod action-valid-p ((plan filtered-sequential-plan) o c) - (and (funcall (plan-action-filter plan) o c) - (typep c (plan-component-type plan)) - (call-next-method))) - - (defun* (traverse-actions) (actions &rest keys &key plan-class &allow-other-keys) - "Given a list of actions, build a plan with these actions as roots." - (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys))) - (loop* :for action :in actions - :as o = (action-operation action) - :as c = (action-component action) - :do (traverse-action plan o c t)) - plan)) - - (defgeneric traverse-sub-actions (operation component &key &allow-other-keys)) - (define-convenience-action-methods traverse-sub-actions (operation component &key)) - (defmethod traverse-sub-actions ((operation operation) (component component) - &rest keys &key &allow-other-keys) - (apply 'traverse-actions (direct-dependencies t operation component) - :system (component-system component) keys)) + (setf (slot-value plan 'forcing) + (make-forcing :system system :force :all :force-not (if other-systems nil t)))) (defmethod plan-actions ((plan filtered-sequential-plan)) (with-slots (keep-operation keep-component) plan - (loop* :for action :in (call-next-method) - :as o = (action-operation action) - :as c = (action-component action) - :when (and (typep o keep-operation) (typep c keep-component)) - :collect (make-action o c)))) + (loop :for action :in (call-next-method) + :as o = (action-operation action) + :as c = (action-component action) + :when (and (typep o keep-operation) (typep c keep-component)) + :collect (make-action o c)))) + + (defun collect-action-dependencies (plan operation component) + (when (action-valid-p operation component) + (while-visiting-action (operation component) ; maintain context, handle circularity. + (let ((action (make-action operation component))) + (unless (nth-value 1 (gethash action (visited-actions *asdf-session*))) + (setf (gethash action (visited-actions *asdf-session*)) nil) + (when (and (typep component (plan-component-type plan)) + (not (action-forced-not-p (forcing plan) operation component))) + (map-direct-dependencies operation component + #'(lambda (o c) (collect-action-dependencies plan o c))) + (push action (plan-actions-r plan)))))))) + + (defgeneric collect-dependencies (operation component &key &allow-other-keys) + (:documentation "Given an action, build a plan for all of its dependencies.")) + (define-convenience-action-methods collect-dependencies (operation component &key)) + (defmethod collect-dependencies ((operation operation) (component component) + &rest keys &key &allow-other-keys) + (let ((plan (apply 'make-instance 'filtered-sequential-plan + :system (component-system component) keys))) + (loop :for action :in (direct-dependencies operation component) + :do (collect-action-dependencies plan (action-operation action) (action-component action))) + (plan-actions plan))) (defun* (required-components) (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) "Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and return a list of the components involved in building the desired action." - (remove-duplicates - (mapcar 'action-component - (plan-actions - (apply 'traverse-sub-actions goal-operation system - (remove-plist-key :goal-operation keys)))) - :from-end t))) + (with-asdf-session (:override t) + (remove-duplicates + (mapcar 'action-component + (apply 'collect-dependencies goal-operation system + (remove-plist-key :goal-operation keys))) + :from-end t)))) + +;;;; High-level interface: make-plan, perform-plan +(with-upgradability () + (defgeneric make-plan (plan-class operation component &key &allow-other-keys) + (:documentation "Generate and return a plan for performing OPERATION on COMPONENT.")) + (define-convenience-action-methods make-plan (plan-class operation component &key)) + + (defgeneric mark-as-done (plan-class operation component) + (:documentation "Mark an action as done in a plan, after performing it.")) + (define-convenience-action-methods mark-as-done (plan-class operation component)) + + (defgeneric perform-plan (plan &key) + (:documentation "Actually perform a plan and build the requested actions")) + + (defparameter* *plan-class* 'sequential-plan + "The default plan class to use when building with ASDF") + + (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys) + (with-asdf-session () + (let ((plan (apply 'make-instance (or plan-class *plan-class*) keys))) + (traverse-action plan o c t) + plan))) + + (defmethod perform-plan :around ((plan t) &key) + (assert (performable-p (forcing plan)) () "plan not performable") + (let ((*package* *package*) + (*readtable* *readtable*)) + (with-compilation-unit () ;; backward-compatibility. + (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build. + + (defun action-already-done-p (plan operation component) + (if-let (status (action-status plan operation component)) + (status-done-p status))) + + (defmethod perform-plan ((plan t) &key) + (loop :for action :in (plan-actions plan) + :as o = (action-operation action) + :as c = (action-component action) :do + (unless (action-already-done-p plan o c) + (perform-with-restarts o c) + (mark-as-done plan o c)))) + + (defmethod mark-as-done ((plan plan) (o operation) (c component)) + (let ((plan-status (action-status plan o c)) + (perform-status (action-status nil o c))) + (assert (and (status-stamp perform-status) (status-keep-p perform-status)) () + "Just performed ~A but failed to mark it done" (action-description o c)) + (setf (action-status plan o c) + (make-action-status + :bits (logior (status-bits plan-status) +done-bit+) + :stamp (status-stamp perform-status) + :level (status-level plan-status) + :index (status-index plan-status)))))) diff --git a/session.lisp b/session.lisp new file mode 100644 index 0000000000000000000000000000000000000000..d69fdf2ed8c69879feb2bd0d6a5d3dde7a64a830 --- /dev/null +++ b/session.lisp @@ -0,0 +1,198 @@ +;;;; ------------------------------------------------------------------------- +;;;; Session + +(uiop/package:define-package :asdf/session + (:recycle :asdf/session :asdf/cache :asdf/component + :asdf/action :asdf/find-system :asdf/plan :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade) + (:export + #:get-file-stamp #:compute-file-stamp #:register-file-stamp + #:asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache + #:do-asdf-cache #:normalize-namestring + #:call-with-asdf-session #:with-asdf-session + #:*asdf-session* #:*asdf-session-class* #:session #:toplevel-asdf-session + #:session-cache #:forcing #:asdf-upgraded-p + #:visited-actions #:visiting-action-set #:visiting-action-list + #:total-action-count #:planned-action-count #:planned-output-action-count + #:clear-configuration-and-retry #:retry + #:operate-level + ;; conditions + #:system-definition-error ;; top level, moved here because this is the earliest place for it. + #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error)) +(in-package :asdf/session) + + +(with-upgradability () + ;; The session variable. + ;; NIL when outside a session. + (defvar *asdf-session* nil) + (defparameter* *asdf-session-class* 'session + "The default class for sessions") + + (defclass session () + (;; The ASDF session cache is used to memoize some computations. + ;; It is instrumental in achieving: + ;; * Consistency in the view of the world relied on by ASDF within a given session. + ;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops + ;; (a.k.a. stack overflows) and other erratic behavior. + ;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and + ;; no expensive recomputations of transitive dependencies for input-files or output-files. + ;; * Testability of ASDF with the ability to fake timestamps without actually touching files. + (ancestor + :initform nil :initarg :ancestor :reader session-ancestor + :documentation "Top level session that this is part of") + (session-cache + :initform (make-hash-table :test 'equal) :initarg :session-cache :reader session-cache + :documentation "Memoize expensive computations") + (operate-level + :initform 0 :initarg :operate-level :accessor session-operate-level + :documentation "Number of nested calls to operate we're under (for toplevel session only)") + ;; shouldn't the below be superseded by the session-wide caching of action-status + ;; for (load-op "asdf") ? + (asdf-upgraded-p + :initform nil :initarg :asdf-upgraded-p :accessor asdf-upgraded-p + :documentation "Was ASDF already upgraded in this session - only valid for toplevel-asdf-session.") + (forcing + :initform nil :initarg :forcing :accessor forcing + :documentation "Forcing parameters for the session") + ;; Table that to actions already visited while walking the dependencies associates status + (visited-actions :initform (make-hash-table :test 'equal) :accessor visited-actions) + ;; Actions that depend on those being currently walked through, to detect circularities + (visiting-action-set ;; as a set + :initform (make-hash-table :test 'equal) :accessor visiting-action-set) + (visiting-action-list :initform () :accessor visiting-action-list) ;; as a list + ;; Counts of total actions in plan + (total-action-count :initform 0 :accessor total-action-count) + ;; Count of actions that need to be performed + (planned-action-count :initform 0 :accessor planned-action-count) + ;; Count of actions that need to be performed that have a non-empty list of output-files. + (planned-output-action-count :initform 0 :accessor planned-output-action-count)) + (:documentation "An ASDF session with a cache to memoize some computations")) + + (defun toplevel-asdf-session () + (when *asdf-session* (or (session-ancestor *asdf-session*) *asdf-session*))) + + (defun operate-level () + (session-operate-level (toplevel-asdf-session))) + + (defun (setf operate-level) (new-level) + (setf (session-operate-level (toplevel-asdf-session)) new-level)) + + (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-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-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-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))))) + (call-function thunk))) + + ;; Syntactic sugar for consult-asdf-cache + (defmacro do-asdf-cache (key &body body) + `(consult-asdf-cache ,key #'(lambda () ,@body))) + + ;; Compute inside a ASDF session with a cache. + ;; First, make sure an ASDF session is underway, by binding the session cache variable + ;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true). + ;; 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-session (thunk &key override key override-cache override-forcing) + (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) + (if (and (not override) *asdf-session*) + (funcall fun) + (loop + (restart-case + (let ((*asdf-session* + (apply 'make-instance *asdf-session-class* + (when *asdf-session* + `(:ancestor ,(toplevel-asdf-session) + ,@(unless override-forcing + `(:forcing ,(forcing *asdf-session*))) + ,@(unless override-cache + `(:session-cache ,(session-cache *asdf-session*)))))))) + (return (funcall fun))) + (retry () + :report (lambda (s) + (format s (compatfmt "~@")))) + (clear-configuration-and-retry () + :report (lambda (s) + (format s (compatfmt "~@"))) + (clrhash (session-cache *asdf-session*)) + (clear-configuration))))))) + + ;; Syntactic sugar for call-with-asdf-session + (defmacro with-asdf-session ((&key key override override-cache override-forcing) &body body) + `(call-with-asdf-session + #'(lambda () ,@body) + :override ,override :key ,key + :override-cache ,override-cache :override-forcing ,override-forcing)) + + + ;;; Define specific accessor for file (date) stamp. + + ;; Normalize a namestring for use as a key in the session cache. + (defun normalize-namestring (pathname) + (let ((resolved (resolve-symlinks* + (ensure-absolute-pathname + (physicalize-pathname pathname) + 'get-pathname-defaults)))) + (with-pathname-defaults () (namestring resolved)))) + + ;; Compute the file stamp for a normalized namestring + (defun compute-file-stamp (normalized-namestring) + (with-pathname-defaults () + (or (safe-file-write-date normalized-namestring) t))) + + ;; Override the time STAMP associated to a given FILE in the session cache. + ;; If no STAMP is specified, recompute a new one from the filesystem. + (defun register-file-stamp (file &optional (stamp nil stampp)) + (let* ((namestring (normalize-namestring file)) + (stamp (if stampp stamp (compute-file-stamp namestring)))) + (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp)))) + + ;; Get or compute a memoized stamp for given FILE from the session cache. + (defun get-file-stamp (file) + (when file + (let ((namestring (normalize-namestring file))) + (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))) + + + ;;; Conditions + + (define-condition system-definition-error (error) () + ;; [this use of :report should be redundant, but unfortunately it's not. + ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function + ;; over print-object; this is always conditions::%print-condition for + ;; condition objects, which in turn does inheritance of :report options at + ;; run-time. fortunately, inheritance means we only need this kludge here in + ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] + #+cmucl (:report print-object)) + + (define-condition formatted-system-definition-error (system-definition-error) + ((format-control :initarg :format-control :reader format-control) + (format-arguments :initarg :format-arguments :reader format-arguments)) + (:report (lambda (c s) + (apply 'format s (format-control c) (format-arguments c))))) + + (defun sysdef-error (format &rest arguments) + (error 'formatted-system-definition-error :format-control + format :format-arguments arguments))) diff --git a/source-registry.lisp b/source-registry.lisp index 0e070d01aeee1ea57ef892d67fcbdeb28a7e9fd0..ec3eec371a6fe17fd38e74ddac853e91b0d76b00 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -3,8 +3,9 @@ ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 (uiop/package:define-package :asdf/source-registry - (:recycle :asdf/source-registry :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) + ;; NB: asdf/find-system allows upgrade from <=3.2.1 that have initialize-source-registry there + (:recycle :asdf/source-registry :asdf/find-system :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/system :asdf/system-registry) (:export #:*source-registry-parameter* #:*default-source-registries* #:invalid-source-registry diff --git a/system-registry.lisp b/system-registry.lisp new file mode 100644 index 0000000000000000000000000000000000000000..71e286fd47def0d99b87c1a4ccbdc28fa9be475f --- /dev/null +++ b/system-registry.lisp @@ -0,0 +1,304 @@ +;;;; ------------------------------------------------------------------------- +;;;; Finding systems + +(uiop/package:define-package :asdf/system-registry + (:recycle :asdf/system-registry :asdf/find-system :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade + :asdf/session :asdf/component :asdf/system) + (:export + #:remove-entry-from-registry #:coerce-entry-to-directory + #:registered-system #:register-system + #:registered-systems* #:registered-systems + #:clear-system #:map-systems + #:*system-definition-search-functions* #:search-for-system-definition + #:*central-registry* #:probe-asd #:sysdef-central-registry-search + #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed + #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* + #:find-system-if-being-defined #:mark-component-preloaded ;; forward references to asdf/find-system + #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems* + #:*registered-systems* #:clear-registered-systems + ;; defined in source-registry, but specially mentioned here: + #:sysdef-source-registry-search)) +(in-package :asdf/system-registry) + +(with-upgradability () + ;;; Registry of Defined Systems + + (defvar *registered-systems* (make-hash-table :test 'equal) + "This is a hash table whose keys are strings -- the names of systems -- +and whose values are systems. +A system is referred to as \"registered\" if it is present in this table.") + + (defun registered-system (name) + "Return a system of given NAME that was registered already, +if such a system exists. NAME is a system designator, to be +normalized by COERCE-NAME. The value returned is a system object, +or NIL if not found." + (gethash (coerce-name name) *registered-systems*)) + + (defun registered-systems* () + "Return a list containing every registered system (as a system object)." + (loop :for registered :being :the :hash-values :of *registered-systems* + :collect registered)) + + (defun registered-systems () + "Return a list of the names of every registered system." + (mapcar 'coerce-name (registered-systems*))) + + (defun register-system (system) + "Given a SYSTEM object, register it." + (check-type system system) + (let ((name (component-name system))) + (check-type name string) + (asdf-message (compatfmt "~&~@<; ~@;Registering system ~3i~_~A~@:>~%") name) + (setf (gethash name *registered-systems*) system))) + + (defun map-systems (fn) + "Apply FN to each defined system. + +FN should be a function of one argument. It will be +called with an object of type asdf:system." + (loop :for registered :being :the :hash-values :of *registered-systems* + :do (funcall fn registered))) + + + ;;; Preloaded systems: in the image even if you can't find source files backing them. + + (defvar *preloaded-systems* (make-hash-table :test 'equal) + "Registration table for preloaded systems.") + + (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/find-system + + (defun make-preloaded-system (name keys) + "Make a preloaded system of given NAME with build information from KEYS" + (let ((system (apply 'make-instance (getf keys :class 'system) + :name name :source-file (getf keys :source-file) + (remove-plist-keys '(:class :name :source-file) keys)))) + (mark-component-preloaded system) + system)) + + (defun sysdef-preloaded-system-search (requested) + "If REQUESTED names a system registered as preloaded, return a new system +with its registration information." + (let ((name (coerce-name requested))) + (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) + (when foundp + (make-preloaded-system name keys))))) + + (defun ensure-preloaded-system-registered (name) + "If there isn't a registered _defined_ system of given NAME, +and a there is a registered _preloaded_ system of given NAME, +then define and register said preloaded system." + (if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name))) + (register-system system))) + + (defun register-preloaded-system (system-name &rest keys &key (version t) &allow-other-keys) + "Register a system as being preloaded. If the system has not been loaded from the filesystem +yet, or if its build information is later cleared with CLEAR-SYSTEM, a dummy system will be +registered without backing filesystem information, based on KEYS (e.g. to provide a VERSION). +If VERSION is the default T, and a system was already loaded, then its version will be preserved." + (let ((name (coerce-name system-name))) + (when (eql version t) + (if-let (system (registered-system name)) + (setf (getf keys :version) (component-version system)))) + (setf (gethash name *preloaded-systems*) keys) + (ensure-preloaded-system-registered system-name))) + + + ;;; Immutable systems: in the image and can't be reloaded from source. + + (defvar *immutable-systems* nil + "A hash-set (equal hash-table mapping keys to T) of systems that are immutable, +i.e. already loaded in memory and not to be refreshed from the filesystem. +They will be treated specially by find-system, and passed as :force-not argument to make-plan. + +For instance, to can deliver an image with many systems precompiled, that *will not* check the +filesystem for them every time a user loads an extension, what more risk a problematic upgrade + or catastrophic downgrade, before you dump an image, you may use: + (map () 'asdf:register-immutable-system (asdf:already-loaded-systems)) + +Note that direct access to this variable from outside ASDF is not supported. +Please call REGISTER-IMMUTABLE-SYSTEM to add new immutable systems, and +contact maintainers if you need a stable API to do more than that.") + + (defun sysdef-immutable-system-search (requested) + (let ((name (coerce-name requested))) + (when (and *immutable-systems* (gethash name *immutable-systems*)) + (or (registered-system requested) + (error 'formatted-system-definition-error + :format-control "Requested system ~A registered as an immutable-system, ~ +but not even registered as defined" + :format-arguments (list name)))))) + + (defun register-immutable-system (system-name &rest keys) + "Register SYSTEM-NAME as preloaded and immutable. +It will automatically be considered as passed to FORCE-NOT in a plan." + (let ((system-name (coerce-name system-name))) + (apply 'register-preloaded-system system-name keys) + (unless *immutable-systems* + (setf *immutable-systems* (list-to-hash-set nil))) + (setf (gethash system-name *immutable-systems*) t))) + + + ;;; Making systems undefined. + + (defun clear-system (system) + "Clear the entry for a SYSTEM in the database of systems previously defined. +However if the system was registered as PRELOADED (which it is if it is IMMUTABLE), +then a new system with the same name will be defined and registered in its place +from which build details will have been cleared. +Note that this does NOT in any way cause any of the code of the system to be unloaded. +Returns T if system was or is now undefined, NIL if a new preloaded system was redefined." + ;; There is no "unload" operation in Common Lisp, and + ;; a general such operation cannot be portably written, + ;; considering how much CL relies on side-effects to global data structures. + (let ((name (coerce-name system))) + (remhash name *registered-systems*) + (unset-asdf-cache-entry `(find-system ,name)) + (not (ensure-preloaded-system-registered name)))) + + (defun clear-registered-systems () + "Clear all currently registered defined systems. +Preloaded systems (including immutable ones) will be reset, other systems will be de-registered." + (map () 'clear-system (registered-systems))) + + + ;;; Searching for system definitions + + ;; For the sake of keeping things reasonably neat, we adopt a convention that + ;; only symbols are to be pushed to this list (rather than e.g. function objects), + ;; which makes upgrade easier. Also, the name of these symbols shall start with SYSDEF- + (defvar *system-definition-search-functions* '() + "A list that controls the ways that ASDF looks for system definitions. +It contains symbols to be funcalled in order, with a requested system name as argument, +until one returns a non-NIL result (if any), which must then be a fully initialized system object +with that name.") + + ;; Initialize and/or upgrade the *system-definition-search-functions* + ;; so it doesn't contain obsolete symbols, and does contain the current ones. + (defun cleanup-system-definition-search-functions () + (setf *system-definition-search-functions* + (append + ;; Remove known-incompatible sysdef functions from old versions of asdf. + ;; Order matters, so we can't just use set-difference. + (let ((obsolete + '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search))) + (remove-if #'(lambda (x) (member x obsolete)) *system-definition-search-functions*)) + ;; Tuck our defaults at the end of the list if they were absent. + ;; This is imperfect, in case they were removed on purpose, + ;; but then it will be the responsibility of whoever removes these symmbols + ;; to upgrade asdf before he does such a thing rather than after. + (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) + '(sysdef-central-registry-search + sysdef-source-registry-search))))) + (cleanup-system-definition-search-functions) + + ;; This (private) function does the search for a system definition using *s-d-s-f*; + ;; it is to be called by locate-system. + (defun search-for-system-definition (system) + ;; Search for valid definitions of the system available in the current session. + ;; Previous definitions as registered in *registered-systems* MUST NOT be considered; + ;; they will be reconciled by locate-system then find-system. + ;; There are two special treatments: first, specially search for objects being defined + ;; in the current session, to avoid definition races between several files; + ;; second, specially search for immutable systems, so they cannot be redefined. + ;; Finally, use the search functions specified in *system-definition-search-functions*. + (let ((name (coerce-name system))) + (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x)))) + (try 'find-system-if-being-defined) + (try 'sysdef-immutable-system-search) + (map () #'try *system-definition-search-functions*)))) + + + ;;; The legacy way of finding a system: the *central-registry* + + ;; This variable contains a list of directories to be lazily searched for the requested asd + ;; by sysdef-central-registry-search. + (defvar *central-registry* nil + "A list of 'system directory designators' ASDF uses to find systems. + +A 'system directory designator' is a pathname or an expression +which evaluates to a pathname. For example: + + (setf asdf:*central-registry* + (list '*default-pathname-defaults* + #p\"/home/me/cl/systems/\" + #p\"/usr/share/common-lisp/systems/\")) + +This variable is for backward compatibility. +Going forward, we recommend new users should be using the source-registry.") + + ;; Function to look for an asd file of given NAME under a directory provided by DEFAULTS. + ;; Return the truename of that file if it is found and TRUENAME is true. + ;; Return NIL if the file is not found. + ;; On Windows, follow shortcuts to .asd files. + (defun probe-asd (name defaults &key truename) + (block nil + (when (directory-pathname-p defaults) + (if-let (file (probe-file* + (ensure-absolute-pathname + (parse-unix-namestring name :type "asd") + #'(lambda () (ensure-absolute-pathname defaults 'get-pathname-defaults nil)) + nil) + :truename truename)) + (return file)) + #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) + (os-cond + ((os-windows-p) + (when (physical-pathname-p defaults) + (let ((shortcut + (make-pathname + :defaults defaults :case :local + :name (strcat name ".asd") + :type "lnk"))) + (when (probe-file* shortcut) + (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native))))))))) + + ;; Function to push onto *s-d-s-f* to use the *central-registry* + (defun sysdef-central-registry-search (system) + (let ((name (primary-system-name system)) + (to-remove nil) + (to-replace nil)) + (block nil + (unwind-protect + (dolist (dir *central-registry*) + (let ((defaults (eval dir)) + directorized) + (when defaults + (cond ((directory-pathname-p defaults) + (let* ((file (probe-asd name defaults :truename *resolve-symlinks*))) + (when file + (return file)))) + (t + (restart-case + (let* ((*print-circle* nil) + (message + (format nil + (compatfmt "~@") + system dir defaults))) + (error message)) + (remove-entry-from-registry () + :report "Remove entry from *central-registry* and continue" + (push dir to-remove)) + (coerce-entry-to-directory () + :test (lambda (c) (declare (ignore c)) + (and (not (directory-pathname-p defaults)) + (directory-pathname-p + (setf directorized + (ensure-directory-pathname defaults))))) + :report (lambda (s) + (format s (compatfmt "~@") + directorized dir)) + (push (cons dir directorized) to-replace)))))))) + ;; cleanup + (dolist (dir to-remove) + (setf *central-registry* (remove dir *central-registry*))) + (dolist (pair to-replace) + (let* ((current (car pair)) + (new (cdr pair)) + (position (position current *central-registry*))) + (setf *central-registry* + (append (subseq *central-registry* 0 position) + (list new) + (subseq *central-registry* (1+ position))))))))))) + diff --git a/system.lisp b/system.lisp index 8c71e5ba7cd85d3956c229fe9ac8c6a9524c938a..3325ee46ec2d62c2e4f6d9a542badc8cd163c453 100644 --- a/system.lisp +++ b/system.lisp @@ -2,15 +2,15 @@ ;;;; Systems (uiop/package:define-package :asdf/system - (:recycle :asdf :asdf/system) - (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component) + (:recycle :asdf :asdf/system :asdf/find-system) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component) (:export - #:system #:proto-system + #:system #:proto-system #:undefined-system #:reset-system-class #:system-source-file #:system-source-directory #:system-relative-pathname - #:reset-system #:system-description #:system-long-description #:system-author #:system-maintainer #:system-licence #:system-license - #:system-defsystem-depends-on #:system-depends-on #:system-weakly-depends-on + #:definition-dependency-list #:definition-dependency-set #:system-defsystem-depends-on + #:system-depends-on #:system-weakly-depends-on #:component-build-pathname #:build-pathname #:component-entry-point #:entry-point #:homepage #:system-homepage @@ -18,6 +18,7 @@ #:mailto #:system-mailto #:long-name #:system-long-name #:source-control #:system-source-control + #:coerce-name #:primary-system-name #:primary-system-p #:coerce-filename #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system (in-package :asdf/system) @@ -59,7 +60,14 @@ NB: This interface is subject to change. Please contact ASDF maintainers if you (defclass proto-system () ; slots to keep when resetting a system ;; To preserve identity for all objects, we'd need keep the components slots ;; but also to modify parse-component-form to reset the recycled objects. - ((name) (source-file) #|(children) (children-by-names)|#) + ((name) + (source-file) + ;; These two slots contains the *inferred* dependencies of define-op, + ;; from loading the .asd file, as list and as set. + (definition-dependency-list + :initform nil :accessor definition-dependency-list) + (definition-dependency-set + :initform (list-to-hash-set nil) :accessor definition-dependency-set)) (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when a SYSTEM is redefined and its class is modified.")) @@ -85,6 +93,7 @@ a SYSTEM is redefined and its class is modified.")) (entry-point :initform nil :initarg :entry-point :accessor component-entry-point) (source-file :initform nil :initarg :source-file :accessor system-source-file) + ;; This slot contains the *declared* defsystem-depends-on dependencies (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on :initform nil) ;; these two are specially set in parse-component-form, so have no :INITARGs. @@ -93,14 +102,54 @@ a SYSTEM is redefined and its class is modified.")) (:documentation "SYSTEM is the base class for top-level components that users may request ASDF to build.")) + (defclass undefined-system (system) () + (:documentation "System that was not defined yet.")) - (defun reset-system (system &rest keys &key &allow-other-keys) + (defun reset-system-class (system new-class &rest keys &key &allow-other-keys) "Erase any data from a SYSTEM except its basic identity, then reinitialize it based on supplied KEYS." - (change-class (change-class system 'proto-system) 'system) + (change-class (change-class system 'proto-system) new-class) (apply 'reinitialize-instance system keys))) +;;; Canonicalizing system names + +(with-upgradability () + (defun coerce-name (name) + "Given a designator for a component NAME, return the name as a string. +The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component), +a SYMBOL (designing its name, downcased), or a STRING (designing itself)." + (typecase name + (component (component-name name)) + (symbol (string-downcase name)) + (string name) + (t (sysdef-error (compatfmt "~@") name)))) + + (defun primary-system-name (system-designator) + "Given a system designator NAME, return the name of the corresponding primary system, +after which the .asd file is named. That's the first component when dividing the name +as a string by / slashes. A component designates its system." + (etypecase system-designator + (string (if-let (p (position #\/ system-designator)) + (subseq system-designator 0 p) system-designator)) + (symbol (primary-system-name (coerce-name system-designator))) + (component (primary-system-name (coerce-name (component-system system-designator)))))) + + (defun primary-system-p (system) + "Given a system designator SYSTEM, return T if it designates a primary system, or else NIL. +Also return NIL if system is neither a SYSTEM nor a string designating one." + (typecase system + (string (not (find #\/ system))) + (system (primary-system-p (coerce-name system))))) + + (defun coerce-filename (name) + "Coerce a system designator NAME into a string suitable as a filename component. +The (current) transformation is to replace characters /:\\ each by --, +the former being forbidden in a filename component. +NB: The onus is unhappily on the user to avoid clashes." + (frob-substrings (coerce-name name) '("/" ":" "\\") "--"))) + + ;;;; Pathnames (with-upgradability () 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/defsystem-depends-on/defsystem-dependency.asd b/test/defsystem-depends-on/defsystem-dependency.asd new file mode 100644 index 0000000000000000000000000000000000000000..e6059ad0e7d42337138c8ef5f03c86915e49b321 --- /dev/null +++ b/test/defsystem-depends-on/defsystem-dependency.asd @@ -0,0 +1,4 @@ +(defsystem "defsystem-dependency" + :depends-on ("overlapping-dependency") + :components ((:file "defsystem-dependency")) + :in-order-to ((test-op (test-op "test-system")))) diff --git a/test/defsystem-depends-on/defsystem-dependency.lisp b/test/defsystem-depends-on/defsystem-dependency.lisp new file mode 100644 index 0000000000000000000000000000000000000000..c5f34a143cbfc7def1f9c01bfa9984b2e5383420 --- /dev/null +++ b/test/defsystem-depends-on/defsystem-dependency.lisp @@ -0,0 +1,11 @@ +(in-package :asdf-test) +(defvar *dd* 0) +(incf *dd*) +(format t "Loaded defsystem-dependency.lisp ~d time~(~:*~p~)~%" *dd*) +(setf (find-class 'asdf::my-cl-source-file) (find-class 'cl-source-file)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *cdd* 0)) + +(eval-when (:compile-toplevel :execute) + (incf *cdd*)) diff --git a/test/defsystem-depends-on/intermediate-dependency.asd b/test/defsystem-depends-on/intermediate-dependency.asd new file mode 100644 index 0000000000000000000000000000000000000000..dbb020e4533c2b0121905178adad004322370678 --- /dev/null +++ b/test/defsystem-depends-on/intermediate-dependency.asd @@ -0,0 +1,3 @@ +(defsystem "intermediate-dependency" + :defsystem-depends-on ("defsystem-dependency") + :components ((:my-cl-source-file "intermediate-dependency"))) diff --git a/test/defsystem-depends-on/intermediate-dependency.lisp b/test/defsystem-depends-on/intermediate-dependency.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b8c6b4de2810a5c213a9a52d002c25eaa96865e8 --- /dev/null +++ b/test/defsystem-depends-on/intermediate-dependency.lisp @@ -0,0 +1,3 @@ +(in-package :asdf-test) +(defvar *id* 0) +(incf *id*) diff --git a/test/defsystem-depends-on/main-system.asd b/test/defsystem-depends-on/main-system.asd new file mode 100644 index 0000000000000000000000000000000000000000..8b24a7f467b06ceab1589d77e6f012bc96b2d0c8 --- /dev/null +++ b/test/defsystem-depends-on/main-system.asd @@ -0,0 +1,3 @@ +(defsystem "main-system" + :depends-on ("overlapping-dependency" "intermediate-dependency") + :components ((:file "main-system"))) diff --git a/test/defsystem-depends-on/main-system.lisp b/test/defsystem-depends-on/main-system.lisp new file mode 100644 index 0000000000000000000000000000000000000000..bd64ac113fb9fb541d5c83e66391399347dfbb67 --- /dev/null +++ b/test/defsystem-depends-on/main-system.lisp @@ -0,0 +1,3 @@ +(in-package :asdf-test) +(defvar *ms* 0) +(incf *ms*) diff --git a/test/defsystem-depends-on/overlapping-dependency.asd b/test/defsystem-depends-on/overlapping-dependency.asd new file mode 100644 index 0000000000000000000000000000000000000000..fbf1aee213289d4ac4e1e0477fcf4ec9d5c3ce1d --- /dev/null +++ b/test/defsystem-depends-on/overlapping-dependency.asd @@ -0,0 +1,5 @@ +(in-package :asdf-test) +(defvar *od* 0) +(defsystem "overlapping-dependency" + ;;:perform (load-op (o c) (incf *od*)) ;; Now done in the file. + :components ((:file "overlapping-dependency"))) diff --git a/test/defsystem-depends-on/overlapping-dependency.lisp b/test/defsystem-depends-on/overlapping-dependency.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a923080f11d4ba883c823b26def6558893f2411c --- /dev/null +++ b/test/defsystem-depends-on/overlapping-dependency.lisp @@ -0,0 +1,9 @@ +(in-package :asdf-test) +(defvar *od* 0) +(incf *od*) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *cod* 0)) + +(eval-when (:compile-toplevel :execute) + (incf *cod*)) diff --git a/test/defsystem-depends-on/test-system.asd b/test/defsystem-depends-on/test-system.asd new file mode 100644 index 0000000000000000000000000000000000000000..9d3b24b5c3636358c5dc09c7f211c66def58bc59 --- /dev/null +++ b/test/defsystem-depends-on/test-system.asd @@ -0,0 +1,4 @@ +(defsystem "test-system" + :defsystem-depends-on ("defsystem-dependency") + :components ((:my-cl-source-file "test-system")) + :perform (test-op (o c) (symbol-call :asdf-test :run-test))) diff --git a/test/defsystem-depends-on/test-system.lisp b/test/defsystem-depends-on/test-system.lisp new file mode 100644 index 0000000000000000000000000000000000000000..814acde71afc57076456960217426dc899c134a0 --- /dev/null +++ b/test/defsystem-depends-on/test-system.lisp @@ -0,0 +1,7 @@ +(in-package :asdf-test) + +(setf *dd* 10) + +(defun run-test () + (format t "Running tests...") + t) diff --git a/test/ecl-make-image/readme.lisp b/test/ecl-make-image/readme.lisp index 30746edf7f6c928e5e9f486b312c008d93bd5c94..4fd41de832a01f77b0bd7c958f12679bd9211bfb 100644 --- a/test/ecl-make-image/readme.lisp +++ b/test/ecl-make-image/readme.lisp @@ -49,6 +49,8 @@ :defaults *load-truename*) asdf:*central-registry*) +;; Create hellow using program-op +(delete-file-if-exists +standalone-exe+) (asdf:make "hellow") ;; @@ -57,11 +59,37 @@ (format t " ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; TESTING A STANDALONE EXECUTABLE +;;; TESTING A STANDALONE EXECUTABLE. Also test :no-uiop t ;;; ") -(uiop:run-program (format nil "./~A" +standalone-exe+) :output *standard-output*) +(assert-equal + (uiop:run-program (format nil "./~A" +standalone-exe+) :output :lines) + '("Good morning sunshine!" "Hello world!" "Good bye sunshine.")) + + +(format t " +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; AGAIN USING MAKE-BUILD. Also test uiop. +;;; + +") +;;; Now create an executable using the legacy make-build interface +(delete-file +standalone-exe+) +(asdf:make-build :hellow + :type :program + :move-here "./" + :prologue-code "printf(\"In the beginning, there was nothing.\\n\");fflush(stdout);" + :epilogue-code '(progn + (uiop:format! t "~%The end.~%") + (uiop:quit 0)) + ;;:no-uiop t + :ld-flags + (list (namestring (compile-file-pathname "hello_aux.c" :type :object)))) +(assert-equal + (uiop:run-program (format nil "./~A" +standalone-exe+) :output :lines) + '("In the beginning, there was nothing." "Hello world!" "The end.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; diff --git a/test/file3-only.asd b/test/file3-only.asd index aea6aaa2bbcee1e4adc0f0837cc0f08e026ca42f..4b3b716ef6e78f7526b9bc263bcf1ee8cb41dc44 100644 --- a/test/file3-only.asd +++ b/test/file3-only.asd @@ -1,3 +1,6 @@ ;;; -*- Lisp -*- -(asdf:defsystem file3-only - :components ((:file "file3"))) +(defsystem file3-only + :components ((:file "file3"))) + +(defvar *file3-only-asd-loaded* 0) +(incf *file3-only-asd-loaded*) diff --git a/test/file4.lisp b/test/file4.lisp index 45a709a86f00a64dbbee3a8e9055c98dc7f40efa..267c0060fb287b4861dfbd740258c800655b2ede 100644 --- a/test/file4.lisp +++ b/test/file4.lisp @@ -1,2 +1,4 @@ (in-package :test-package) (assert *file3*) +(defparameter *file4* t) + diff --git a/test/make-hello-world.lisp b/test/make-hello-world.lisp index 7e528194b772af1ce1bad4c2b909ada1269b48a2..ab97471ad5b98a8cdfc97ca994508323ece1cc20 100644 --- a/test/make-hello-world.lisp +++ b/test/make-hello-world.lisp @@ -28,7 +28,6 @@ (defun make-hello-bundle (operation) - (operate 'load-bundle-op :hello-world-example) (operate operation :hello-world-example) #+mkcl (add-mkcl-dll (asdf::output-file operation :hello-world-example)) (quit 0)) diff --git a/test/package-inferred-system-test.script b/test/package-inferred-system-test.script index 6ff089171dc51afad89ccc9820f991b846b29c24..cedbb612f3959fad65dcec78a82b742085c6efeb 100644 --- a/test/package-inferred-system-test.script +++ b/test/package-inferred-system-test.script @@ -1,3 +1,5 @@ +;;-*- Lisp -*- + (register-directory (subpathname *test-directory* "package-inferred-system-test/")) (load-system :package-inferred-system-test/a/x) (load-system :package-inferred-system-test/d) @@ -5,7 +7,8 @@ (signals package-inferred-system-missing-package-error (load-system :package-inferred-system-test/e)) ;; No such file. -(signals missing-component (load-system :package-inferred-system-test/f)) +(signals missing-component + (handler-bind ((system-out-of-date 'continue)) (load-system :package-inferred-system-test/f))) ;; Test that around-compile is inherited by inferred systems. (assert-equal 3 (symbol-call :package-inferred-system-test/a :add10 1)) ;; add10 must have been compiled in base 2 diff --git a/test/run-tests.sh b/test/run-tests.sh index 97e7a9e9501d6d91995d21fb2582321edb58e39f..e1079cc9dc2faea43ac54c3250adc45b2c6bf6c0 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) #.(load \"$i\"))" >&2 fi echo >&2 echo >&2 diff --git a/test/script-support.lisp b/test/script-support.lisp index 510c078867fe28b12b2ea9e73734d068cef01f22..936055d7db815d585b11770d42d828887c9efb80 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -32,7 +32,7 @@ Some constraints: #:action-name #:in-plan-p #:test-source #:test-fasl #:resolve-output #:output-location #:quietly #:join-namestrings - #:clear-cache)) + #:reset-session #:reset-session-visited)) (in-package :asdf-test) @@ -55,6 +55,8 @@ Some constraints: )) (defvar *debug-asdf* nil) +(defvar *print-backtrace* t) + (defvar *quit-when-done* t) (defun verbose (&optional (verbose t) (print verbose)) @@ -337,12 +339,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) @@ -403,12 +405,13 @@ is bound, write a message and exit on an error. If (format *error-output* "~&TEST ABORTED: ~A~&" c)) (finish-outputs*) (unless *debug-asdf* - (ignore-errors - (format *error-output* "~&Backtrace:~%") - (acall :print-condition-backtrace - c :count 69 :stream *error-output*)) + (when *print-backtrace* + (ignore-errors + (format *error-output* "~&Backtrace:~%") + (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 thunk) (leave-test "Script succeeded" 0))))) (when *quit-when-done* (exit-lisp result)))) @@ -446,7 +449,7 @@ is bound, write a message and exit on an error. If (quietly (load (asdf-fasl tag)))) (defun register-directory (dir) - (pushnew dir (symbol-value (asym :*central-registry*)))) + (pushnew dir (symbol-value (asym :*central-registry*)) :test #'equal)) (defun load-asdf-system (&rest keys) (quietly @@ -613,7 +616,8 @@ is bound, write a message and exit on an error. If (format t "Configuring ASDF~%") (when (asym :getenvp) (format t "Enabling debugging~%") - (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST")))) + (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST"))) + (setf *print-backtrace* (not (acall :getenvp "NO_ASDF_BACKTRACE")))) (when *trace-symbols* (format t "Tracing~{ ~A~}~%" *trace-symbols*) (eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s))))) @@ -631,31 +635,38 @@ is bound, write a message and exit on an error. If (format t "Being a bit verbose~%") (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. - ;; 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) - (lambda () - (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~%~ - ASDF finds the ASDs in~% ~S~%Using the latter.~%" - (pathname-components *test-directory*) - (pathname-components x))) - (setf *test-directory* x))))) + (when (and (asym :locate-system) (asym :pathname-directory-pathname) (asym :pathname-equal)) + (format t "Comparing directories~%") + (let ((x (acall + :pathname-directory-pathname + ;; Some old versions of ASDF want locate-system to be surrounded by with-asdf-cache + ;; 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 session cache, so then we don't. + ;; Newer versions of ASDF implicitly use with-asdf-session (successor of the cache) + ;; without our having to wrap it. + (funcall + (or (asym :call-with-asdf-cache) 'funcall) + (lambda () (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))) t) (defun frob-packages () - (format t "Frob packages~%") - (use-package :asdf :asdf-test) - (when (find-package :uiop) (use-package :uiop :asdf-test)) - (when (find-package :asdf/cache) (use-package :asdf/cache :asdf-test)) + (cond + ((find-package :asdf) + (format t "Frob packages~%") + (use-package :asdf :asdf-test) + (when (find-package :uiop) (use-package :uiop :asdf-test)) + (when (find-package :asdf/session) (use-package :asdf/session :asdf-test))) + (t + (format t "NB: No packages to frob, because ASDF not loaded yet."))) (setf *package* (find-package :asdf-test)) t) @@ -666,12 +677,17 @@ is bound, write a message and exit on an error. If (and (member :asdf2 *features*) (acall :version-satisfies (acall :asdf-version) "2.11.4")))) (leave-test "UIOP will break ASDF < 2.011.4 - skipping test." 0)) (configure-asdf) - (register-directory *asdf-directory*) + ;; do NOT include *asdf-directory*, which would defeat the purpose by causing an upgrade (register-directory *uiop-directory*) (register-directory *test-directory*) + (format t "CR ~S~%" (symbol-value (asym :*central-registry*))) + (format t "loading uiop~%") (quietly (acall :oos (asym :load-op) :uiop)) - (acall :oos (asym :load-op) :test-module-depend)) + (format t "CR ~S~%" (symbol-value (asym :*central-registry*))) + (format t "loading test-module-depend~%") + (acall :oos (asym :load-op) :test-module-depend) + (format t "done loading~%")) (defun load-asdf (&optional tag) (load-asdf-fasl tag) @@ -680,7 +696,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)) @@ -741,14 +757,14 @@ is bound, write a message and exit on an error. If (assert (asymval '#:*file3* :test-package)))) (defun join-namestrings (namestrings) - (with-output-to-string (s) - (loop :with separator = (acall :inter-directory-separator) - :for (n . morep) :on namestrings - :do (format s "~A~@[~C~]" n (and morep separator))))) - -(defun clear-cache () - ;; Or, should we preserve the timestamps? - (clrhash (asymval :*asdf-cache*))) + (format nil (format nil "~~{~~A~~^~A~~}" (acall :inter-directory-separator)) namestrings)) + +(defun reset-session () + (set (asym :*asdf-session*) nil)) + +(defun reset-session-visited () + (clrhash (acall '#:visited-actions (asymval '#:*asdf-session*)))) + ;; These are shorthands for interactive debugging of test scripts: (!a diff --git a/test/show-progress.lisp b/test/show-progress.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a60ccdbefcbd39c38d162e6c01edf18eae54a7ae --- /dev/null +++ b/test/show-progress.lisp @@ -0,0 +1,20 @@ +(defpackage :show-progress (:use :cl)) +(in-package :show-progress) + +(eval-when (:load-toplevel) (defparameter *time* :load-toplevel)) +(eval-when (:compile-toplevel) (defparameter *time* :compile-toplevel)) +(eval-when (:execute) (defparameter *time* :execute)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (format t "It's ~A time!~%" *time*) + (defvar *times* '()) + (push *time* *times*)) + +(defun foo (x) + (format t "~S~%" x)) + +(defmacro m1 () '(foo 1)) +(defmacro m2 () '(foo 2)) +(defmacro me () (error "Failing at compile-time")) + +(defmacro mb () '(me)) +(defmacro mc () '(m1)) diff --git a/test/stamp-propagation/test-stamp-propagation.lisp b/test/stamp-propagation/test-stamp-propagation.lisp index 2e32d1723b06b71fba88df14857d41f1f9296f46..bda3bc394318afb0eed19906dec9e108f82a60b3 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"))) @@ -201,18 +203,23 @@ (DBG "cleaning up") (clear-fasls defsystem)) +;; The test should work on ASDF3 and later: +;; (this is THE bug that motivated the rewrite from ASDF 2 to ASDF 3). +(nest + #-asdf3 (signals error) + ;; TODO: figure out why ABCL and XCL require this with-asdf-session. + #+(and asdf3.3 (or abcl xcl)) (with-asdf-session () (load-system "asdf")) + (test-defsystem :asdf)) -(cond - #+asdf3 ;; TODO: figure out why ABCL and XCL fail to recompile anything. - ((and #+(or abcl xcl) (use-cache-p :asdf)) - (test-defsystem :asdf)) - (t (signals error (test-defsystem :asdf)))) - +;; Genera's and Lispworks' defsystem have a bug fix, though +;; users need to manually specify non-default dependencies #+(or genera lispworks) (test-defsystem :native) +;; Allegro's defsystem has the bug #+(or allegro) (signals error (test-defsystem :native)) -#+mkdefsystem +;; MK-DEFSYSTEM has the bug +#+mk-defsystem (signals error (test-defsystem :mk-defsystem)) diff --git a/test/test-asdf.asd b/test/test-asdf.asd index 1c54687cb28d305a074b2c62ca523921d815bf79..a1d036a4902777672d578d54ef386c56d88e9f4b 100644 --- a/test/test-asdf.asd +++ b/test/test-asdf.asd @@ -1,9 +1,10 @@ (defpackage :test-asdf-system - (:use :cl :asdf)) + (:use :cl :asdf :uiop)) (in-package :test-asdf-system) (defvar *times-loaded* 0) (incf *times-loaded*) +;;(format! t "Times that test-asdf.asd was loaded: ~D~%" *times-loaded*) (defsystem :test-asdf :class package-inferred-system) @@ -75,7 +76,30 @@ (defsystem :test-asdf/force :depends-on (:test-asdf/force1) - :components ((:file "file3"))) + :components ((:file "file4"))) (defsystem :test-asdf/force1 + ;; Importantly, this depends on a system that is NOT defined in the same file, + ;; so that we can check that forcing causes one file to be reloaded but not the other. + :depends-on (:file3-only) :components ((:file "file1"))) + +;; These are used by test-defsystem-depends-on-change.asd, test-defsystem-depends-on-change.script +(defvar *ta/dcc* 0) +(defsystem "test-asdf/dep-can-change" + :depends-on ("test-asdf-location-change" "test-asdf/dep-forced") + :components ((:file "show-progress")) + :perform (load-op (o c) (incf *ta/dcc*))) + +(defsystem "test-asdf/dep-forced" + :components ((:file "file1"))) + +(defvar *ta/dcd* 0) +(defsystem "test-asdf/dep-can-disappear" + :depends-on ("test-asdf-location-change") + :perform (load-op (o c) (incf *ta/dcd*))) + +(defvar *ta/dca* 0) +(defsystem "test-asdf/dep-can-appear" + :depends-on ("test-asdf-location-change") + :perform (load-op (o c) (incf *ta/dca*))) 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-builtin-source-file-type.script b/test/test-builtin-source-file-type.script index 058a251050520e163fddc48f3d2652db1e457a40..5997c96a19d9bb8c3f50b766b004faa7d95cce0b 100644 --- a/test/test-builtin-source-file-type.script +++ b/test/test-builtin-source-file-type.script @@ -1,51 +1,45 @@ ;;; -*- Lisp -*- - - -;;(trace source-file-type) - -(progn - (format t "~D~%" (asdf:asdf-version)) - - (def-test-system test-builtin-source-file-type-1 - :default-component-class cl-source-file.cl - :serial t - :components ((:cl-source-file "file1") ; for the package - (:file "test-tmp"))) - (load-system 'test-builtin-source-file-type-1 :verbose t) - (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) - (assert-equal - (mapcar #'pathname-type - (mapcar #'asdf:component-pathname (asdf:module-components (asdf:find-system :test-source-file-type-1)))) - '("lisp" "cl")) - (delete-package :test-package) - - (def-test-system - test-builtin-source-file-type-2 - :default-component-class cl-source-file.cl - :serial t - :components ((:file "file1" :type "lisp") ; for package - (:file "test-tmp"))) - (asdf:load-system 'test-builtin-source-file-type-2 :verbose t) - (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) - - (def-test-system test-builtin-source-file-type-3 - :default-component-class cl-source-file.lsp - :serial t - :components ((:cl-source-file "file1") ; for the package - (:file "test-tmp"))) - (asdf:load-system 'test-builtin-source-file-type-3 :verbose t) - (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) - (assert-equal - (mapcar #'pathname-type - (mapcar #'asdf:component-pathname (asdf:module-components (asdf:find-system :test-source-file-type-1)))) - '("lisp" "cl")) - (delete-package :test-package) - - (def-test-system test-builtin-source-file-type-4 - :default-component-class cl-source-file.lsp - :serial t - :components ((:file "file1" :type "lisp") ; for package - (:file "test-tmp"))) - (asdf:load-system 'test-builtin-source-file-type-4 :verbose t) - (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))) +(format t "~D~%" (asdf:asdf-version)) + +(def-test-system test-builtin-source-file-type-1 + :default-component-class cl-source-file.cl + :serial t + :components ((:cl-source-file "file1") ; for the package + (:file "test-tmp"))) +(load-system 'test-builtin-source-file-type-1 :verbose t) +(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) +(assert-equal + (mapcar #'pathname-type + (mapcar #'asdf:component-pathname (asdf:module-components (asdf:find-system :test-source-file-type-1)))) + '("lisp" "cl")) +(delete-package :test-package) + +(def-test-system "test-builtin-source-file-type-2" + :default-component-class cl-source-file.cl + :serial t + :components ((:file "file1" :type "lisp") ; for package + (:file "test-tmp"))) +(load-system 'test-builtin-source-file-type-2 :verbose t) +(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) + +(def-test-system test-builtin-source-file-type-3 + :default-component-class cl-source-file.lsp + :serial t + :components ((:cl-source-file "file1") ; for the package + (:file "test-tmp"))) +(load-system 'test-builtin-source-file-type-3 :verbose t) +(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) +(assert-equal + (mapcar #'pathname-type + (mapcar #'asdf:component-pathname (asdf:module-components (asdf:find-system :test-source-file-type-1)))) + '("lisp" "cl")) +(delete-package :test-package) + +(def-test-system test-builtin-source-file-type-4 + :default-component-class cl-source-file.lsp + :serial t + :components ((:file "file1" :type "lisp") ; for package + (:file "test-tmp"))) +(load-system 'test-builtin-source-file-type-4 :verbose t) +(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) diff --git a/test/test-cache.script b/test/test-cache.script index 15ce3e5fae58ec80cf07dbb5112184e4b926fdb0..a59361228ef6dcde2efd735ddd142aaef9002a7e 100644 --- a/test/test-cache.script +++ b/test/test-cache.script @@ -1,34 +1,12 @@ ;;; -*- Lisp -*- -;;; test to check that the cache doesn't upset error signaling from FIND-SYSTEM +;;; Test to check that the cache doesn't upset error signaling from FIND-SYSTEM (in-package :asdf-test) -(defparameter *all-systems* - (list - "test-asdf" - "test-asdf/all" - "test-asdf/1" - "test-asdf/2" - "test-asdf/4" - "test-asdf/test9-1" - "test-asdf/test-module-depend" - "test-asdf/test9-2" - "test-asdf/test9-3" - "test-asdf/test-source-directory-1" - "test-asdf/test-source-directory-2" - "test-asdf/bundle-1" - "test-asdf/bundle-2" - "test-asdf/force" - "test-asdf/force1")) +(setf asdf::*asdf-session* nil) +(setf *central-registry* nil) +(asdf::clear-registered-systems) -(defun clear-caches-and-search () - (setf asdf:*central-registry* nil) - (mapc #'clear-system *all-systems*)) - -(clear-caches-and-search) -(assert (not (asdf:find-system "test-asdf/force1" nil))) -(multiple-value-bind (ret cond) - (ignore-errors (asdf:find-system "test-asdf/force1" t)) - (assert (not ret)) - (assert (typep cond 'asdf:missing-component))) +(assert-equal nil (find-system "test-asdf/force1" nil)) +(errors missing-component (find-system "test-asdf/force1" t)) diff --git a/test/test-compile-file-failure.script b/test/test-compile-file-failure.script index bab990f3a6cbc06404d7f21ac0914057f568725b..7c94e8b841205471a1f7afc186e0fe0a089384b6 100644 --- a/test/test-compile-file-failure.script +++ b/test/test-compile-file-failure.script @@ -1,5 +1,4 @@ ;;; -*- Lisp -*- - (def-test-system test-compile-file-failure :components ((:file "test-compile-file-failure"))) @@ -9,6 +8,8 @@ t) (compile-file-error () nil))) +(reset-session) + (with-expected-failure (#+gcl "GCL failure to report compile-file error") (assert (handler-case (let ((*compile-file-failure-behaviour* :error)) diff --git a/test/test-deferred-warnings.script b/test/test-deferred-warnings.script index c90850900eac7deec494eb214a9516509640b2de..2a95c78efbe0dad4388a50d778c1624c21e49fb1 100644 --- a/test/test-deferred-warnings.script +++ b/test/test-deferred-warnings.script @@ -2,7 +2,6 @@ (in-package :asdf-test) -(uiop:uiop-debug) (enable-deferred-warnings-check) (def-test-system :unintern-foo @@ -45,15 +44,18 @@ (let ((*compile-file-warnings-behaviour* :ignore)) (load-system :use-foo-only :force t))) +(reset-session) (handler-bind ((error (lambda (c) (DBG :cfwbi-ufww c)))) (load-system :use-foo-with-wrapper :force t)) +(reset-session) (handler-bind ((error (lambda (c) (DBG :cfwbi-usfo c)))) (let ((*compile-file-warnings-behaviour* :ignore)) (load-system :use-setf-foo-only :force t))) +(reset-session) (DBG :tdw1 *warnings-file-type*) (assert (handler-case @@ -67,6 +69,7 @@ (unless *warnings-file-type* (leave-test "Your Lisp does not support deferred-warnings" 0)) +(reset-session) (assert (handler-case (let ((*compile-file-warnings-behaviour* :error)) @@ -74,6 +77,7 @@ nil) (compile-warned-error () t))) +(reset-session) (assert (handler-case (let ((*compile-file-warnings-behaviour* :error)) @@ -81,16 +85,19 @@ nil) (compile-warned-error () t))) +(reset-session) (let ((*compile-file-warnings-behaviour* :error)) (load-system :use-then-defun-foo)) (setf *compile-file-warnings-behaviour* :error) +(reset-session) (load-system :use-setf-then-defun-foo) ;; FIXME: on CCL, the defmacro warning is found while loading the defmacro fasl. ;; We should probably beef up the detection in reify-deferred-warnings, ;; possibly file a bug. +(reset-session) (with-expected-failure (#+clozure "CCL warns while loading, not compiling") (assert (handler-case @@ -99,6 +106,7 @@ ;;(t (c) (DBG :utdf0 c)) (:no-error (&rest values) (DBG :utdf1 values) nil)))) +(reset-session) (with-expected-failure (#+clozure "CCL warns while loading, not compiling") (assert (handler-case @@ -107,11 +115,14 @@ ;;(t (c) (DBG :ustdf0 c)) (:no-error (&rest values) (DBG :ustdf1 values) nil)))) +(reset-session) (errors #+(or allegro clozure) compile-file-error #+(or cmucl scl) compile-warned-error #+sbcl compile-failed-error (let ((*compile-file-warnings-behaviour* :error)) (load-system :undefined-variables :force t))) + +(reset-session) (errors #+(or allegro clozure) compile-file-error #+(or cmucl scl) null #+sbcl compile-failed-error diff --git a/test/test-defsystem-depends-on-change.asd b/test/test-defsystem-depends-on-change.asd new file mode 100644 index 0000000000000000000000000000000000000000..bea4fe13d3a80e80f0391eeec64a828662818f41 --- /dev/null +++ b/test/test-defsystem-depends-on-change.asd @@ -0,0 +1,9 @@ +(defvar *tddoc* 0) +(incf *tddoc*) +(format t "tddoc loaded ~D time~:P.~%" *tddoc*) + +(if (= *tddoc* 1) + (defsystem "test-defsystem-depends-on-change" + :defsystem-depends-on ("test-asdf/dep-can-change" "test-asdf/dep-can-disappear")) + (defsystem "test-defsystem-depends-on-change" + :defsystem-depends-on ("test-asdf/dep-can-change" "test-asdf/dep-can-appear"))) diff --git a/test/test-defsystem-depends-on-change.script b/test/test-defsystem-depends-on-change.script new file mode 100644 index 0000000000000000000000000000000000000000..bed60461058c326c6170d6cca1c3224805e2b926 --- /dev/null +++ b/test/test-defsystem-depends-on-change.script @@ -0,0 +1,62 @@ +;;; -*- Lisp -*- +;; Testing proper stratification of defsystem-depends-on changes. + +(DBG "Test that when a defsystem-depends-on (indirect) dependency changes, the system is recompiled, yet that dependencies of the old definition that are not dependencies of the new definition are not recompiled.") + +;; disable cache between those compilations. +(setf asdf/session:*asdf-session* nil) + +(defparameter tddoc "test-defsystem-depends-on-change") +(defparameter talc "test-asdf-location-change") +(defparameter asdf-user::*tddoc* 0) + +(terpri)(terpri) +(DBG "Load the system, using xach-foo-1") +(push (subpathname *test-directory* "xach-foo-1/") *central-registry*) +(clear-system tddoc) +(load-system tddoc) +(assert-equal asdf-user::*tddoc* 1) +(assert-equal test-asdf-system::*times-loaded* 1) +(assert-equal test-asdf-system::*ta/dcc* 1) +(assert-equal test-asdf-system::*ta/dcd* 1) +(assert-equal test-asdf-system::*ta/dca* 0) +(assert-pathname-equal + (subpathname *test-directory* "test-defsystem-depends-on-change.asd") + (system-source-file tddoc)) +(assert-pathname-equal + (subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd") + (system-source-file talc)) + + +(terpri)(terpri) +(DBG "Load it again: there should be no changes") +(load-system "test-defsystem-depends-on-change") +(assert-equal asdf-user::*tddoc* 1) +(assert-equal test-asdf-system::*times-loaded* 1) +(assert-equal test-asdf-system::*ta/dcc* 1) +(assert-equal test-asdf-system::*ta/dcd* 1) +(assert-equal test-asdf-system::*ta/dca* 0) +(assert-pathname-equal + (subpathname *test-directory* "test-defsystem-depends-on-change.asd") + (system-source-file tddoc)) +(assert-pathname-equal + (subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd") + (system-source-file talc)) + + +(DBG "Now, change a defsystem-depends-on dependency and try again") +(setf (first *central-registry*) (subpathname *test-directory* "xach-foo-2/")) +(DBG :before asdf-user::*tddoc* test-asdf-system::*times-loaded* test-asdf-system::*ta/dcc* test-asdf-system::*ta/dcd* test-asdf-system::*ta/dca*) +(load-system "test-defsystem-depends-on-change" :force '("test-asdf/dep-forced")) +(DBG :after asdf-user::*tddoc* test-asdf-system::*times-loaded* test-asdf-system::*ta/dcc* test-asdf-system::*ta/dcd* test-asdf-system::*ta/dca*) +(assert-equal asdf-user::*tddoc* 2) +(assert-equal test-asdf-system::*times-loaded* 1) ;; from test-asdf.asd +(assert-equal test-asdf-system::*ta/dcc* 2) +(assert-equal test-asdf-system::*ta/dcd* 1) +(assert-equal test-asdf-system::*ta/dca* 1) +(assert-pathname-equal + (subpathname *test-directory* "test-defsystem-depends-on-change.asd") + (system-source-file tddoc)) +(assert-pathname-equal + (subpathname *test-directory* "xach-foo-2/test-asdf-location-change.asd") + (system-source-file talc)) diff --git a/test/test-defsystem-depends-on-circular.asd b/test/test-defsystem-depends-on-circular.asd new file mode 100644 index 0000000000000000000000000000000000000000..f056fcc1fea38f699f613e13da8b02995bba315e --- /dev/null +++ b/test/test-defsystem-depends-on-circular.asd @@ -0,0 +1,3 @@ +;;; -*- Lisp -*- +(defsystem "test-defsystem-depends-on-circular" + :defsystem-depends-on ("test-defsystem-depends-on-circular")) diff --git a/test/test-defsystem-depends-on-phase-overlap.script b/test/test-defsystem-depends-on-phase-overlap.script new file mode 100644 index 0000000000000000000000000000000000000000..8c8cb112452501aee9a945956f53187f8dcc2dd6 --- /dev/null +++ b/test/test-defsystem-depends-on-phase-overlap.script @@ -0,0 +1,66 @@ +;;-*- Lisp -*- + +(in-package :asdf-test) + +(setf *central-registry* (list (subpathname *test-directory* "defsystem-depends-on/"))) + +(defvar *od* 0) +(defvar *dd* 0) +(defvar *id* 0) +(defvar *ms* 0) +(defvar *cod* 0) +(defvar *cdd* 0) +(defun reset-vars (&optional (x 0)) + (setf *od* x *dd* x *id* x *ms* x *cod* x *cdd* x)) +(assert-equal (list *od* *dd* *id* *ms* *cod* *cdd*) '(0 0 0 0 0 0)) + +(DBG "Finding main-system doesn't load defsystem-dependency") +(reset-vars) +(find-system "main-system") +(assert-equal (list *od* *dd* *id* *ms* *cod* *cdd*) '(0 0 0 0 0 0)) + +(DBG "Finding intermediate-dependency does load defsystem-dependency") +(reset-vars) +(find-system "intermediate-dependency") +(assert-equal (list *od* *dd* *id* *ms*) '(1 1 0 0)) + +(DBG "Loading main-system doesn't reload defsystem-dependency or overlapping-dependency") +(reset-vars) +(load-system "main-system") +(assert-equal (list *od* *dd* *id* *ms* *cod* *cdd*) '(0 0 1 1 0 0)) + +(DBG "Loading main-system a second time doesn't reload anything") +(reset-vars) +(load-system "main-system") +(assert-equal (list *od* *dd* *id* *ms* *cod* *cdd*) '(0 0 0 0 0 0)) + +(DBG "Loading main-system in a different session loads but doesn't recompile") +(reset-vars) +(asdf::clear-registered-systems) +(load-system "main-system") +(assert-equal (list *od* *dd* *id* *ms* *cod* *cdd*) '(1 1 1 1 0 0)) + +(DBG :foo + (component-sideway-dependencies (find-system "intermediate-dependency")) + (asdf::direct-dependencies 'prepare-op "intermediate-dependency") + (asdf::direct-dependencies 'load-op "intermediate-dependency") + (asdf::direct-dependencies 'compile-op "intermediate-dependency")) + +(DBG "Forcing overlapping-dependency causes a complete reload, but overlapping-dependency is only loaded once") +(reset-vars) +(with-asdf-session (:override t) + (load-system "main-system" :force '("overlapping-dependency"))) +(assert-equal (list *od* *dd* *id* *ms*) '(1 1 1 1)) + +(DBG "actions marked as needed at one level should still be planned if needed at a higher level") +(reset-vars) +(setf (find-class 'asdf::my-cl-source-file) nil) +(asdf::clear-registered-systems) +(assert-equal *dd* 0) +(with-asdf-session (:override t) + ;; get this (and asdf) out of the way, for simpler traces when tracing what matters. + (load-system "overlapping-dependency") + ;; This is what causes an issue without phase escalation: + (test-system "defsystem-dependency")) +(assert-equal *dd* 10) + diff --git a/test/test-defsystem-depends-on.script b/test/test-defsystem-depends-on.script index 1daca58e3bf7f8262569df1376683d20a7b6bf9c..c83f13bab254798b6f444173b196fe99e7c7591b 100644 --- a/test/test-defsystem-depends-on.script +++ b/test/test-defsystem-depends-on.script @@ -20,6 +20,7 @@ (assert-equal 0 l-operation:*x*) +(reset-session) (make :test-defsystem-depends-on-2) (assert-equal 2 l-operation:*x*) ;; perform called twice, on file and on system. @@ -29,10 +30,13 @@ :build-operation "does-not-exist" :components ((:file "file3"))) -(signals asdf::formatted-system-definition-error (make :test-defsystem-depends-on-3)) +(reset-session) +(signals asdf::formatted-system-definition-error + (handler-bind ((system-out-of-date 'continue)) (make :test-defsystem-depends-on-3))) (defparameter *newsym* (gentemp (symbol-name 'feature) :keyword)) +(reset-session) ;;; FIXME: the following form triggers bug https://bugs.launchpad.net/asdf/+bug/1445638 (eval `(def-test-system test-defsystem-depends-on-4 :defsystem-depends-on ((:feature ,*newsym* "test-defsystem-depends-on-3")))) @@ -40,10 +44,17 @@ (assert (find-system "test-defsystem-depends-on-4")) (progn - (signals asdf:missing-dependency (def-test-system unloadable-system - :defsystem-depends-on (nonexistent-system))) - (assert (not (system-registered-p "unloadable-system")))) + (reset-session) + (signals missing-dependency (def-test-system unloadable-system + :defsystem-depends-on (nonexistent-system))) + (assert (not (registered-system "unloadable-system")))) (progn - (signals asdf:missing-dependency (find-system "test-defsystem-depends-on-missing-system")) - (assert (not (system-registered-p "test-defsystem-depends-on-missing-system")))) + (signals missing-dependency + (handler-bind ((system-out-of-date 'continue)) (find-system "test-defsystem-depends-on-missing-system"))) + (assert (not (asdf::registered-system "test-defsystem-depends-on-missing-system")))) + +(progn + (signals asdf::system-definition-error + (handler-bind ((system-out-of-date 'continue)) (find-system "test-defsystem-depends-on-circular"))) + (assert (not (asdf::registered-system "test-defsystem-depends-on-circular")))) 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-force.script b/test/test-force.script index 9c786d6f8e7fc2ceeebd4105a0fb6f949b58b9b3..fbba14e063fa0663b15dba8073662f9fb474fab6 100644 --- a/test/test-force.script +++ b/test/test-force.script @@ -1,57 +1,102 @@ ;;; -*- Lisp -*- +(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) +(chdir *test-directory*) +;;(setf *defaut-pathname-defaults* *test-directory*) + (clear-system 'test-asdf/force) (assert (not (component-loaded-p 'test-asdf/force))) -(require-system 'test-asdf/force) +(defun force-plan (&rest forcing-options) + (asdf::make-plan nil 'load-op 'test-asdf/force + :forcing (apply 'asdf::make-forcing :system 'test-asdf/force forcing-options))) + +(defvar *plan* nil) + +(defun component-out-of-date-p (component) + (not + (asdf::action-up-to-date-p + *plan* + (make-operation 'load-op) + (find-component component nil :registered t)))) + +(defun plan-loads-p (component) + (member (asdf::make-action (make-operation 'load-op) (find-component () component :registered t)) + (asdf::plan-actions *plan*) :test 'equal)) + +(with-asdf-session (:override t :override-forcing t) + (load-system 'test-asdf/force)) (assert (component-loaded-p 'test-asdf/force)) (assert-equal (asymval :*file3* :test-package) t) +(assert-equal (asymval :*file4* :test-package) t) (assert-equal (asymval :*times-loaded* :test-asdf-system) 1) +(assert-equal (asymval :*file3-only-asd-loaded* :asdf-user) 1) (defparameter file1 (test-fasl "file1")) (defparameter file1-date (file-write-date file1)) (defparameter date1 (- file1-date 600)) (defparameter date2 (- file1-date 300)) - (assert file1) (assert file1-date) -(let ((plan (traverse 'load-op 'test-asdf/force :force t))) - (DBG "Check that :force t forces the current system but not its dependencies" plan) - (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file3"))) - (assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1"))))) - -(let ((plan (traverse 'load-op 'test-asdf/force :force :all))) - (DBG "Check that :force :all forces the current system and its dependencies" plan) - (assert plan) - (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file3"))) - (assert (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1")))) - -(let ((plan (traverse 'load-op 'test-asdf/force :force :all :force-not t))) - (DBG "Check that :force-not takes precedence over :force, with t means \"all but current system\"" plan) - (assert plan) - (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file3"))) - (assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1"))))) - -(let ((plan (traverse 'load-op 'test-asdf/force :force-not :all))) - (DBG "Check that :force-not :all means \"all systems\"" plan) - (assert (null plan))) - -(let ((plan (traverse 'load-op 'test-asdf/force :force :all :force-not :all))) - (DBG "Check that :force-not :all takes precedence over :force" plan) - (assert (null plan))) - -(let ((plan (traverse 'load-op 'test-asdf/force :force :all - :force-not '(:test-asdf/force :test-asdf/force1)))) - (DBG "Check that :force-not :all takes precedence over :force" plan) - (assert (null plan))) - -(let* ((*immutable-systems* (list-to-hash-set '("test-asdf/force1"))) - (plan (traverse 'load-op 'test-asdf/force :force :all :force-not t))) - (DBG "Check that immutable-systems will block forcing" plan) - (assert plan) - (assert (asdf::plan-operates-on-p plan '("test-asdf/force" "file3"))) - (assert (not (asdf::plan-operates-on-p plan '("test-asdf/force1" "file1"))))) +(reset-session-visited) +(defparameter *plan* (force-plan :force t)) +(DBG "Check that :force t forces the current system but not its dependencies" *plan*) +(assert (component-out-of-date-p '("test-asdf/force" "file4"))) +(assert (not (component-out-of-date-p '("file3-only" "file3")))) +(assert (not (component-out-of-date-p '("test-asdf/force1" "file1")))) + +(reset-session-visited) +(defparameter *plan* (force-plan :force :all)) +(DBG "Check that :force :all forces the current system and its dependencies" *plan*) +(assert (asdf::plan-actions *plan*)) +(assert (component-out-of-date-p '("test-asdf/force" "file4"))) +(assert (component-out-of-date-p '("file3-only" "file3"))) +(assert (component-out-of-date-p '("test-asdf/force1" "file1"))) + +(reset-session-visited) +(defparameter *plan* (force-plan :force :all :force-not t)) +(DBG "Check that :force-not takes precedence over :force, with t means \"all but current system\"" *plan*) +(assert (asdf::plan-actions *plan*)) +(assert (component-out-of-date-p '("test-asdf/force" "file4"))) +(assert (not (component-out-of-date-p '("file3-only" "file3")))) +(assert (not (component-out-of-date-p '("test-asdf/force1" "file1")))) + +(reset-session-visited) +(defparameter *plan* (force-plan :force-not :all)) +(DBG "Check that :force-not :all means \"all systems\"" *plan*) +(assert (null (asdf::plan-actions *plan*))) + +(reset-session-visited) +(defparameter *plan* (force-plan :force :all :force-not :all)) +(DBG "Check that :force-not :all takes precedence over :force" *plan*) +(assert (null (asdf::plan-actions *plan*))) + +(reset-session-visited) +(defparameter *plan* (force-plan :force :all :force-not '(:test-asdf/force))) +(DBG "Check that :force-not with a list takes precedence over :force" *plan*) +(assert (null (asdf::plan-actions *plan*))) + +(reset-session-visited) +(defparameter *plan* (force-plan :force :all :force-not '(:test-asdf/force1))) +(DBG "Check that :force-not with a list takes precedence over :force, 2" *plan*) +(assert (asdf::plan-actions *plan*)) +(assert (component-out-of-date-p '("test-asdf/force" "file4"))) +;; transitively included via test-asdf/force1 test-asdf/only, which blocks the traversal +(assert (not (plan-loads-p '("file3-only" "file3")))) +(assert (component-out-of-date-p '("file3-only" "file3"))) +(assert (not (component-out-of-date-p '("test-asdf/force1" "file1")))) + +(reset-session-visited) +(let* ((asdf::*immutable-systems* (list-to-hash-set '("test-asdf/force1"))) + (*plan* (force-plan :force :all))) + (DBG "Check that immutable-systems will block forcing" *plan*) + (assert (asdf::plan-actions *plan*)) + (assert (component-out-of-date-p '("test-asdf/force" "file4"))) + ;; transitively included via force1 test-asdf/only, which blocks the traversal + (assert (not (plan-loads-p '("file3-only" "file3")))) + (assert (component-out-of-date-p '("file3-only" "file3"))) + (assert (not (component-out-of-date-p '("test-asdf/force1" "file1"))))) ;; unforced, date should stay same (touch-file "test-asdf.asd" :timestamp date1) @@ -63,42 +108,63 @@ (assert-equal (get-file-stamp "file1.lisp") date1) (assert-equal (get-file-stamp file1) date2) + (DBG "Check that require-system won't reload") -(require-system 'test-asdf/force1) +(reset-session-visited) +(with-asdf-session (:override t :override-forcing t) + (require-system 'test-asdf/force1)) (assert-equal (get-file-stamp file1) date2) (assert-equal test-package::*file1* :modified) +;;; So far, only loaded things once +(assert-equal test-asdf-system::*times-loaded* 1) + (DBG "Check that load-system will reload") -(load-system 'test-asdf/force1) -;; FIXME: It is unclear why this fails (at least on mkcl even randomly) -#-mkcl -(with-expected-failure (#+(or clasp clisp (and ecl (not ecl-bytecmp))) t) - (assert-equal (get-file-stamp file1) date2) - (assert-equal test-package::*file1* t)) +(reset-session-visited) +(setf test-package::*file1* nil) +(setf test-asdf-system::*times-loaded* 10) +(assert (not test-package::*file1*)) +(with-asdf-session (:override t :override-forcing t) + (load-system 'test-asdf/force1)) +(assert test-package::*file1*) +;;; This caused a second loading +;; NB: Somehow this is only 1 when using asdf-tools??? WTF? +;; running from asdf with test/ in paths vs running from test/ with no path prefix. +;;(assert-equal (asymval :*times-loaded* :test-asdf-system) 11) +;;TODO: understand what's going on above! + ;; forced, it should be later (DBG "Check that force reloading loads again") +(setf test-asdf-system::*times-loaded* 20) +(reset-session-visited) (setf test-package::*file3* :reset) -(load-system 'test-asdf/force :force :all) -(assert-compare (>= (get-file-stamp file1) file1-date)) +(with-asdf-session (:override t :override-forcing t) + (load-system 'test-asdf/force :force :all)) +(assert-compare (>= (- (get-file-stamp file1) file1-date) 0)) (assert-equal test-package::*file3* t) +(DBG "Check that test-asdf.asd was loaded each time it was forced") +(assert-equal test-asdf-system::*times-loaded* 21) +(DBG "Check that file3-only.asd was loaded only twice, with the :force :all") +(assert-equal asdf-user::*file3-only-asd-loaded* 2) -(DBG "Check that test-asdf was loaded only once all along") -(assert-equal (asymval :*times-loaded* :test-asdf-system) 1) - -(setf test-package::*file3* :reset) (DBG "Check that require-system called with touched .asd won't reload the 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))) -(require-system 'test-asdf/force) -(assert-equal (asymval :*times-loaded* :test-asdf-system) 1) +(setf test-asdf-system::*times-loaded* 30) +(setf test-package::*file3* :reset) +(reset-session-visited) +(with-asdf-session (:override t :override-forcing t) + (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))) + (require-system 'test-asdf/force)) +(assert-equal test-asdf-system::*times-loaded* 30) (assert-equal test-package::*file3* :reset) (DBG "Check that require-system called with untouched .asd won't reload the asdf.") -(require-system 'test-asdf/force) - -;;; Somehow, it loads the system... -(assert-equal (asymval :*times-loaded* :test-asdf-system) 1) +(reset-session-visited) +(with-asdf-session (:override t :override-forcing t) + (require-system 'test-asdf/force)) +;; Somehow, it loads the system... +(assert-equal test-asdf-system::*times-loaded* 30) (assert-equal test-package::*file3* :reset) diff --git a/test/test-include1.asd b/test/test-include1.asd new file mode 100644 index 0000000000000000000000000000000000000000..6d09426a1b10519c9917183a4a59bbf783012824 --- /dev/null +++ b/test/test-include1.asd @@ -0,0 +1,10 @@ +;;;--------------------------------------------------------------------------- +;;; Sample system to test inclusion of lines from other files and +;;; correct reasoning about system modifications. +;;;--------------------------------------------------------------------------- + +(defsystem test-include + :version (:read-file-form "../build/random-version.lisp-expr") + :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) + (load-op (load-op "file1")))) + (:file "file1"))) \ No newline at end of file diff --git a/test/test-include2.asd b/test/test-include2.asd new file mode 100644 index 0000000000000000000000000000000000000000..0cf2c0879d7d473aaa87c957fca60863567f6394 --- /dev/null +++ b/test/test-include2.asd @@ -0,0 +1,10 @@ +;;;--------------------------------------------------------------------------- +;;; Sample system to test inclusion of lines from other files and +;;; correct reasoning about system modifications. +;;;--------------------------------------------------------------------------- + +(defsystem test-include + :version (:read-file-form "../build/random-version2.lisp-expr") + :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) + (load-op (load-op "file1")))) + (:file "file1"))) \ No newline at end of file diff --git a/test/test-logical-pathname.script b/test/test-logical-pathname.script index fc4f8aae7f456fcd333b6202daca804082b812fd..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/cache:*asdf-cache* nil) +(setf asdf/session:*asdf-session* nil) (DBG :logical (logical-pathname-translations "ASDF") diff --git a/test/test-module-depend.script b/test/test-module-depend.script index 1eaca67bd8bdc8fe0a45ec81af85ae9afabb9d79..3396fdcd52180a46136cb7ec53fa062fe1dc45f9 100644 --- a/test/test-module-depend.script +++ b/test/test-module-depend.script @@ -1,5 +1,7 @@ ;;; -*- Lisp -*- +(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) + (load-system 'test-module-depend) ;; test that it compiled @@ -27,7 +29,8 @@ (touch-file file1.fasl :timestamp (- file3-date 90)) (touch-file file2.fasl :timestamp (- file3-date 30)) (touch-file file3.fasl :timestamp (- file3-date 15)) +(reset-session-visited) (load-system 'test-module-depend) -(assert-compare (>= (get-file-stamp file2.fasl) file3-date)) +(assert-compare (>= (- (get-file-stamp file2.fasl) file3-date) 0)) ;; does this properly go to the second level? -(assert-compare (>= (get-file-stamp file3.fasl) file3-date)) +(assert-compare (>= (- (get-file-stamp file3.fasl) file3-date) 0)) diff --git a/test/test-module-excessive-depend.script b/test/test-module-excessive-depend.script index f3187f9a622959de7c3e86781860b4c3d7059238..807b1f08b3ec382bd92b5ed3f31f3d3ab3292852 100644 --- a/test/test-module-excessive-depend.script +++ b/test/test-module-excessive-depend.script @@ -12,6 +12,8 @@ ;;; and reloading of "file2," but /not/ of system Y. ;;;--------------------------------------------------------------------------- +(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) + (def-test-system :test-module-excessive-depend :components ((:file "file1") (:module "quux" diff --git a/test/test-mutual-redefinition.script b/test/test-mutual-redefinition.script index 426525fbb3a6be32150756266e94d8731bf0e514..8665c1fffbb335746877830889b2b585c863220b 100644 --- a/test/test-mutual-redefinition.script +++ b/test/test-mutual-redefinition.script @@ -1,15 +1,21 @@ ;;-*- Lisp -*- +(setf *asdf-session* nil) + (defun current-system-source-file (x) (system-source-file (asdf::registered-system x))) -(with-asdf-cache () - (DBG "loading test-mutual-redefinition-1") +#+abcl (setf jvm::*resignal-compiler-warnings* t) + +(with-asdf-session (:override t) + (terpri) + (DBG "Loading test-mutual-redefinition-1") (let ((warned-p nil)) (handler-bind ((bad-system-name (lambda (c) + (setf warned-p t) + (format t "Caught bad-system-name condition: ~A~%" c) (assert-equal (component-name c) "test-mutual-redefinition-2") - (assert-equal (pathname-name (system-source-file c)) "test-mutual-redefinition-1") - (setf warned-p t)))) + (assert-equal (pathname-name (system-source-file c)) "test-mutual-redefinition-1")))) (load-system 'test-mutual-redefinition-1)) (assert warned-p)) (assert-pathname-equal @@ -19,21 +25,46 @@ (test-source "test-mutual-redefinition-1.asd") (current-system-source-file "test-mutual-redefinition-2")) - (DBG "loading test-mutual-redefinition-2 in the same cache session") - (load-system 'test-mutual-redefinition-2) + (terpri) + (DBG "Loading test-mutual-redefinition-2 in the same cache session. +Looking for its definition should trigger a DEFINE-OP and cause the asd paths to be affected.") + (let ((warned-p nil)) + (handler-bind ((bad-system-name (lambda (c) + (setf warned-p t) + (format t "Caught bad-system-name condition: ~A~%" c) + (assert-equal (component-name c) "test-mutual-redefinition-1") + (assert-equal (pathname-name (system-source-file c)) "test-mutual-redefinition-2")))) + (load-system 'test-mutual-redefinition-2)) + (assert warned-p)) (assert-pathname-equal - (test-source "test-mutual-redefinition-1.asd") + (test-source "test-mutual-redefinition-2.asd") + (current-system-source-file "test-mutual-redefinition-2")) + (assert-pathname-equal + (test-source "test-mutual-redefinition-2.asd") (current-system-source-file "test-mutual-redefinition-1")) + + (terpri) + (DBG "Loading test-mutual-redefinition-1 again in the same cache session. +It should be considered already loaded.") + (let ((warned-p nil)) + (handler-bind ((bad-system-name (lambda (c) + (setf warned-p t)))) + (load-system 'test-mutual-redefinition-2)) + (assert (not warned-p))) (assert-pathname-equal - (test-source "test-mutual-redefinition-1.asd") + (test-source "test-mutual-redefinition-2.asd") (current-system-source-file "test-mutual-redefinition-2")) + (assert-pathname-equal + (test-source "test-mutual-redefinition-2.asd") + (current-system-source-file "test-mutual-redefinition-1"))) - (with-asdf-cache (:override t) - (DBG "loading test-mutual-redefinition-2 in a different cache session") - (load-system 'test-mutual-redefinition-2) - (assert-pathname-equal - (test-source "test-mutual-redefinition-2.asd") - (current-system-source-file "test-mutual-redefinition-1")) - (assert-pathname-equal - (test-source "test-mutual-redefinition-2.asd") - (current-system-source-file "test-mutual-redefinition-2")))) +(with-asdf-session (:override t) + (terpri) + (DBG "loading test-mutual-redefinition-2 in a different cache session") + (load-system 'test-mutual-redefinition-2) + (assert-pathname-equal + (test-source "test-mutual-redefinition-2.asd") + (current-system-source-file "test-mutual-redefinition-2")) + (assert-pathname-equal + (test-source "test-mutual-redefinition-2.asd") + (current-system-source-file "test-mutual-redefinition-1"))) diff --git a/test/test-preloaded.script b/test/test-preloaded.script index 98bc409daac41510a6a234a5d5c765a8c982718e..c2d56f0e0d01c7ff375f5fac339839e9c2763d27 100644 --- a/test/test-preloaded.script +++ b/test/test-preloaded.script @@ -1,6 +1,8 @@ ;;; -*- Lisp -*- (in-package :asdf-test) +(reset-session) + (DBG "Consider a system that does not exist. Loading it fails.") (assert (null (find-system :this-system-does-not-exist nil))) (errors missing-component (load-system :this-system-does-not-exist)) @@ -8,7 +10,7 @@ (DBG "Now let's register it as preloaded. Loading it will work!") (register-preloaded-system :this-system-does-not-exist :version "3.14") ;; Eagerly registered since 3.1.7.20. See gitlab merge request 13 for the full story. -(assert (system-registered-p :this-system-does-not-exist)) +(assert (registered-system :this-system-does-not-exist)) (load-system :this-system-does-not-exist) ;; We can load it indeed, though it's a NOP. @@ -24,10 +26,10 @@ (DBG "Destroy the package, clear the system, and register it as immutable. Try loading it again.") (DBG "The package should NOT be back, because it's immutable thus it's NOT going to be loaded.") (delete-package :test-package) (clear-system :test-asdf/1) -(assert (null (system-registered-p :test-asdf/1))) ;; not registered as loaded +(assert (null (registered-system :test-asdf/1))) ;; not registered as loaded (register-immutable-system :test-asdf/1) -(assert (system-registered-p :test-asdf/1)) ;; now it's registered as loaded +(assert (registered-system :test-asdf/1)) ;; now it's registered as loaded (load-system :test-asdf/1) -(assert (system-registered-p :test-asdf/1)) ;; and it is "loaded" indeed! +(assert (registered-system :test-asdf/1)) ;; and it is "loaded" indeed! (assert (null (find-package :test-package))) ;; but the source code wasn't loaded diff --git a/test/test-program.script b/test/test-program.script index da366c80c56cc4fa3ac6189675ab803ed0a61dce..93b05a7d90e38369a8583e69c2b1ccab6a017fdc 100644 --- a/test/test-program.script +++ b/test/test-program.script @@ -22,7 +22,7 @@ (assert (find-system :hello-world-example)) -;; Try to load lisp-invocation from xcvb +;; Try to load lisp-invocation from ext/ or from the user environment. (initialize-source-registry `(:source-registry (:directory ,*asdf-directory*) @@ -139,14 +139,23 @@ (format t "~:[But no TEST-PACKAGE :-(~;And TEST-PACKAGE~]!~%" (find-package :test-package)) (format t "~:[And no ASDF~;But ASDF :-( ~]!~%" (find-package :asdf)) #+ecl (si:quit 0) #+mkcl (mk-ext:quit :exit-code 0))) + (DBG :run (output-file 'program-op 'hello-no-uiop) + (component-depends-on 'program-op 'hello-no-uiop) + (input-files 'program-op 'hello-no-uiop) + (component-depends-on 'lib-op 'hello-no-uiop) + (input-files 'lib-op 'hello-no-uiop) + (asdf/bundle::linkable-system "hello-no-uiop")) (operate 'program-op 'hello-no-uiop :force t) - (DBG :run (output-file 'program-op 'hello-no-uiop)) (assert-equal (run-program `(,(native-namestring (output-file 'program-op 'hello-no-uiop))) :output :lines :error-output t) '("Look ma, no UIOP!" "And TEST-PACKAGE!" "And no ASDF!")) (DBG "Now create an program with explicit ASDF dependency, without registered ASDF (use implementation-provided prebuilt)") + (clear-system :asdf) + (setf *central-registry* nil) + (initialize-source-registry `(:source-registry :ignore-inherited-configuration)) + (DBG :foo (system-source-file :asdf)) (assert-pathname-equal (truename (pathname-directory-pathname (output-file 'lib-op (asdf/bundle::linkable-system "asdf")))) (truename (subpathname (lisp-implementation-directory) #+mkcl "contrib/" #-mkcl nil))) @@ -168,8 +177,8 @@ (DBG "Now create an program with explicit ASDF dependency") (register-directory *asdf-directory*) - (with-asdf-cache (:override t) - (load-asd (subpathname *asdf-directory* "asdf.asd")) ;; force re-loading ASDF, from source + (load-asd (subpathname *asdf-directory* "asdf.asd")) ;; force re-loading ASDF, from source + (with-asdf-session (:override t) (assert-pathname-equal (truename (pathname-directory-pathname (output-file 'lib-op (asdf/bundle::linkable-system "asdf")))) (truename (resolve-output "asdf/"))) diff --git a/test/test-read-depends.script b/test/test-read-depends.script new file mode 100644 index 0000000000000000000000000000000000000000..a69e5b0c4fcdb7571a87d54c1dfa8961f7faeafc --- /dev/null +++ b/test/test-read-depends.script @@ -0,0 +1,126 @@ +;;; -*- Lisp -*- +;;; --------------------------------------------------------------------------- +;;; Test to make sure that an update to included files causes a reload +;;; of the system definition. +;;; --------------------------------------------------------------------------- + +(in-package :asdf-test) + +;; I don't know what this does or when it's necessary +;; (setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) +(defparameter *tmp-directory* (subpathname *asdf-directory* "build/")) +;;(defparameter *test-directory* (subpathname *asdf-directory* "test/")) +(push *test-directory* *central-registry*) +(defun under-tmp-directory (designator &optional (defaults *tmp-directory*)) + (namestring (subpathname defaults designator))) +(defun under-test-directory (designator &optional (defaults *test-directory*)) + (namestring (subpathname defaults designator))) + +(defun copy-file-the-hard-way (source dest) + (with-open-file (sourcestr source) + (with-open-file (deststr dest :direction :output :if-exists :supersede) + (loop :for line = (read-line sourcestr nil nil) + :while line + :do (format deststr "~a~%" line)))) + (values)) + +(defparameter *version-file* + (under-tmp-directory "random-version.lisp-expr")) + +;; (trace asdf/component:additional-input-files asdf/parse-defsystem::record-additional-system-input-file) + +;;; write an initial version file +(unwind-protect + (progn + (with-open-file (str *version-file* :direction :output + :if-exists :supersede) + (format str "\"1.0\"~%")) + (copy-file-the-hard-way (under-test-directory "test-include1.asd") + (under-test-directory "test-include.asd")) + (DBG "Set up test-include system definition:" + (probe-file (under-test-directory "test-include.asd"))) + (asdf:load-system "test-include") + (let ((system (asdf:find-system "test-include"))) + (DBG "On initial load, the system version is" (component-version system)) + (DBG "After initial load the input files for the define op are:" + (input-files (make-operation 'define-op) system)) + + ;; read the initial version information correctly... + (assert-equal (asdf:component-version system) "1.0")) + (DBG "*******Initial load successful*******") + (sleep 2) + (DBG "*******Reloading*******") + ;;(trace asdf/plan::action-up-to-date-p) + ;; (trace asdf/action::component-operation-time) + ;; #+allegro #+allegro + ;; (trace (asdf:input-files :inside asdf/plan::compute-action-stamp) + ;; (asdf/plan::stamp<= :inside asdf/plan::compute-action-stamp) + ;; (asdf/plan::get-file-stamp :inside asdf/plan::compute-action-stamp)) + +;;; bump the version + (with-open-file (str *version-file* :direction :output + :if-exists :supersede) + (format str "\"2.0\"~%")) + (asdf:load-system "test-include") + (let ((system (asdf:find-system "test-include"))) + (DBG "After reload, system version is" (asdf:component-version system)) + ;; read the initial version information correctly... + (assert-equal (asdf:component-version system) "2.0"))) + (sleep 2) + (DBG "*******Using new input file*******") + (let ((version-file + (under-tmp-directory "random-version2.lisp-expr"))) + (unwind-protect + ;; swap system definitions with different read file versions + (progn + (copy-file-the-hard-way + (under-test-directory "test-include2.asd") + (under-test-directory "test-include.asd")) + (with-open-file (str version-file :direction :output + :if-exists :supersede) + (format str "\"3.0\"~%")) + (DBG "Test-include ASDF file write date" + (uiop:safe-file-write-date (under-test-directory "test-include.asd"))) + (DBG "version file write date" + (uiop:safe-file-write-date (under-tmp-directory "random-version2.lisp-expr"))) + + ;;; the following establishes that it is NOT the fault of + ;;; DEFINITION-DEPENDENCIES-UP-TO-DATE-P [2017/07/12:rpg] + #+allegro + (trace (asdf/find-system::definition-dependencies-up-to-date-p + :inside asdf:find-system) + (asdf/find-system::get-file-stamp + :inside find-system) + (asdf/find-system::stamp<= + :inside find-system)) + ;; AFAICT, the :WHEREIN in SBCL TRACE does not work + ;; properly. In my copious free time, I should see if I + ;; can find a minimal test case. [2017/07/12:rpg] + #+sbcl + (trace asdf/find-system::definition-dependencies-up-to-date-p + ;; :wherein asdf:find-system + ) + + (DBG "operation time stamp for define-op before reload" + (asdf/action:component-operation-time + (asdf:make-operation 'define-op) + (asdf:find-system "test-include"))) + ;; this is NOT why this is broken on ACL... + #+ignore + (DBG "ASDF thinks the operation is done?" + (asdf:operation-done-p (make-operation 'define-op) + (find-system "test-include"))) + ;; (trace asdf/action:compute-action-stamp asdf:make-plan) + ;; (trace asdf/plan::perform-plan asdf/plan::action-already-done-p) + (asdf:load-system "test-include") + (let ((system (find-system "test-include"))) + (assert-equal (asdf:component-version system) "3.0") + (assert-pathnames-equal (asdf:input-files + (asdf:make-operation 'asdf:define-op) + system) + (mapcar 'parse-namestring + (list (under-test-directory "test-include.asd") + (under-tmp-directory "random-version2.lisp-expr")))))) + (uiop:delete-file-if-exists version-file))) + (uiop:delete-file-if-exists (under-test-directory "test-include.asd")) + (uiop:delete-file-if-exists *version-file*)) diff --git a/test/test-require.script b/test/test-require.script index 7b286cf4c13d1253f521b8b47c23bd0394526df7..e5f708572adb88a4fff75477893b66a3043ba643 100644 --- a/test/test-require.script +++ b/test/test-require.script @@ -74,7 +74,7 @@ (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (DBG "- System `preloaded-system' won't be reloaded on `require-system' when cache is empty") -(clear-cache) +(reset-session) (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (require-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") @@ -138,7 +138,7 @@ (assert (component-loaded-p "require-system/immutable")) ;; *YES* marked loaded! (DBG "- System `immutable-system' won't be reloaded when cache is empty") -(clear-cache) +(reset-session) (load-system "require-system/immutable") (assert-equal (component-version (registered-system "require-system/immutable")) "1.0") @@ -154,7 +154,7 @@ (assert-equal (component-version (registered-system "require-system/ordinary")) "1.0") (DBG "- Load-system loads system from the disk") -(clear-cache) +(reset-session) (load-system "require-system/ordinary") (assert-equal (component-version (registered-system "require-system/ordinary")) "2.0") @@ -190,8 +190,8 @@ ;; Prevent ASDF from finding the modules as ASDF systems on ECL, MKCL, SBCL (and maybe more). (setf asdf::*system-definition-search-functions* (remove 'asdf::sysdef-source-registry-search asdf::*system-definition-search-functions*)) -(asdf::clear-defined-systems) -(clear-cache) +(asdf::clear-registered-systems) +(reset-session) (defun has-module-p (x) 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-run-program.script b/test/test-run-program.script index ec29892497587f384d4999f777474cb9049040bd..cb013048e27a5378407f5f7dd1181e56f180b392 100644 --- a/test/test-run-program.script +++ b/test/test-run-program.script @@ -7,6 +7,7 @@ ;; Implementations that rely on shell redirection on Windows also do, as a limitation. (string-trim " " (remove (code-char 13) x))) +;;#+(and clisp os-windows) (ext:without-package-lock () (trace ext:run-shell-command)) (os-cond ((os-unix-p) (DBG "Testing echo ok 1 via run-program as a list") @@ -14,12 +15,10 @@ (run-program '("echo" "ok" "1") :output '(:string :stripped t)))) ((os-windows-p) (DBG "Testing ipconfig /all via run-progam as a string") - ;;; FIXME: known breakage - #+(and ecl os-windows) - (errors parameter-error - (run-program "ipconfig /all")) - #-(and ecl os-windows) - (run-program "ipconfig /all") + ;; Interestingly, "ipconfig /all" fails on the msys2 bash, but not on the cygwin bash. + (nest + #+ecl (errors parameter-error) ;; FIXME: known breakage + (run-program "ipconfig /all")) (DBG "Testing ipconfig /all via run-progam as a list") (run-program '("ipconfig" "/all")))) diff --git a/test/test-source-file-type.script b/test/test-source-file-type.script index 2d93ebd6e9ad78f77bf09ca2530e6ab5b7d1dc3c..5d7484037408937229e572fe7f197b9fe0c8b65d 100644 --- a/test/test-source-file-type.script +++ b/test/test-source-file-type.script @@ -1,16 +1,11 @@ ;;; -*- Lisp -*- - - -;;(trace asdf::source-file-type asdf::source-file-explicit-type) - -(progn - (asdf:load-system 'test-source-file-type-1 :verbose t) - (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) - (assert - (equal (mapcar #'pathname-type - (mapcar #'asdf:component-pathname (asdf:module-components (asdf:find-system :test-source-file-type-1)))) - '("lisp" "cl"))) - (delete-package :test-package) - (asdf:load-system 'test-source-file-type-2 :verbose t) - (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))) +(load-system 'test-source-file-type-1 :verbose t) +(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) +(assert + (equal (mapcar #'pathname-type + (mapcar #'asdf:component-pathname (asdf:module-components (asdf:find-system :test-source-file-type-1)))) + '("lisp" "cl"))) +(delete-package :test-package) +(load-system 'test-source-file-type-2 :verbose t) +(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) diff --git a/test/test-static-and-serial.script b/test/test-static-and-serial.script index cfa70b105a5c32c18f732a2e6feb2d1ca8195b55..7f5e4b1c7d59f5f08d73dcf254865a8e83c292de 100644 --- a/test/test-static-and-serial.script +++ b/test/test-static-and-serial.script @@ -6,6 +6,8 @@ don't cause full rebuilds all the time... (in-package :asdf-test) +(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) + (defparameter s '(def-test-system static-and-serial :version "0.1" diff --git a/test/test-sysdef-asdf.script b/test/test-sysdef-asdf.script index de87d33575ec1c1e3a3afcb1ef3f05899ad588c7..d834176947238558f857dade055ec20a3f402aaa 100644 --- a/test/test-sysdef-asdf.script +++ b/test/test-sysdef-asdf.script @@ -2,6 +2,25 @@ (format! t "~%Using ASDF ~A~%" (asdf-version)) (assert (version< "3.0" (asdf-version))) ;; check that we have a recent enough ASDF +(setf *asdf-session* nil) + +(defparameter *ticks* 0) +(defun tick () (incf *ticks*)) + +(DBG "Let's define some methods on input-files, to later check what an upgrade does to them.") +(with-asdf-session (:override t) + (def-test-system "fooey") + (def-test-system "foo") + (defmethod input-files :after ((o load-op) (c system)) + (DBG :input-files-after-1 o c + (tick))) + (assert-equal *ticks* 0) + (input-files 'load-op "foo") + (assert-equal *ticks* 1) + (input-files 'load-op "foo") + (assert-equal *ticks* 1) ;; It was cached. + (assert (find-system "fooey" nil))) + (DBG "Try load ASDF with an empty configuration") (initialize-source-registry @@ -10,15 +29,15 @@ ;; We haven't found it, and got the fallback (assert-equal nil (system-source-file (find-system :asdf))) + +(DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore") +(clear-system "asdf") ;; Bogus sysdef finding function, for the sake of testing no-load-old-version. (defun sysdef-bogus-test-search (system) (declare (ignore system)) (subpathname *test-directory* "always-error.lisp")) - -(clear-system "asdf") (let ((*system-definition-search-functions* '(sysdef-bogus-test-search)) (state "Didn't catch warning")) - (DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore") (handler-bind ((simple-warning #'(lambda (c) @@ -27,14 +46,19 @@ (setf state "Caught warning"))))) (clear-system "asdf") (upgrade-asdf)) - (assert-equal state "Caught warning") - (DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning") + (assert-equal state "Caught warning")) + + +(DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning") +(let ((*system-definition-search-functions* '(sysdef-bogus-test-search))) (handler-bind ((simple-warning #'(lambda (c) (error "Should not have issued warning, but did issue:~% ~A" c)))) (clear-system "asdf") (upgrade-asdf))) +(assert-equal nil (system-source-file (find-system :asdf))) + (DBG "Load ASDF with proper configuration: should find asdf.asd from the source above") (initialize-source-registry @@ -43,28 +67,33 @@ (:directory ,*uiop-directory*) :ignore-inherited-configuration)) (clear-system "asdf") -(load-system :asdf) -;; This time we found it, but it was skipped because the version was the same -(assert-equal nil (system-source-file (find-system :asdf))) - - -;; But if we cheat on our version, that should work -(setf asdf::*asdf-version* "3.0") -(clear-system "asdf") -(def-test-system "fooey") -(defparameter *ticks* 0) -(defun tick () (incf *ticks*)) -(defmethod input-files :after ((load-op operation) (c system)) (tick)) -(input-files 'load-op "asdf") -(assert-equal *ticks* 3) +(with-asdf-session (:override t) + (with-expected-failure (#+xcl t) ;; expected-failure: XCL has trouble with the ASDF upgrade + (load-system :asdf) + (assert-pathname-equal (subpathname *asdf-directory* "asdf.asd") + (system-source-file (find-system :asdf)))) + (DBG "Loading from the same version shouldn't have reset methods") + (setf *ticks* 2) + (input-files 'load-op "foo") + (assert-equal *ticks* 3)) + + +(DBG "Loading from an ancient version WILL reset methods") (assert (find-system "fooey" nil)) +(defparameter *current-version* (asdf-version)) +(setf asdf::*asdf-version* "2.0" asdf/upgrade::*previous-asdf-versions* '("2.0")) +(assert (asdf/upgrade::upgrading-p)) +(clear-system "asdf") +(reset-session) (with-expected-failure (#+xcl t) ;; expected-failure: XCL has trouble with the ASDF upgrade (load-system :asdf) + (assert-equal (asdf-version) *current-version*) (assert-pathname-equal (subpathname *asdf-directory* "asdf.asd") (system-source-file (find-system :asdf)))) -;; Upgrading from an old-enough version redefined away the input-files method! + +(DBG "Upgrading from an old-enough version should have redefined away the input-files method!") (setf *ticks* 4) (input-files 'load-op "asdf") (assert-equal *ticks* 4) @@ -72,40 +101,37 @@ (assert (not (find-system "fooey" nil))) +(DBG "Actually upgrade, from a different but forward-compatible version") ;; The data-punting upgrade will mess up component identity, so clear the cache -(clear-cache) - +(reset-session) (setf asdf::*asdf-version* asdf/upgrade::*oldest-forward-compatible-asdf-version*) (clear-system "asdf") (def-test-system "fooey") -(setf *ticks* 5) -(defmethod input-files :after ((load-op operation) (c system)) - (incf *ticks*)) +(setf *ticks* 10) +(defmethod input-files :after ((o load-op) (c system)) + (DBG :input-files-after-2 o c + (tick))) (input-files 'load-op "uiop") -(assert-equal *ticks* 8) +(assert-equal *ticks* 12) (with-expected-failure (#+xcl t) ;; expected-failure: XCL has trouble with the ASDF upgrade (load-system :asdf)) ;; Upgrading from a recent-enough version, the input-files method was preserved! ;; But we need to clear the cache for it not to be short-circuited. -(clear-cache) +(reset-session) (assert (find-system "fooey" nil)) - -(setf *ticks* 9) +(setf *ticks* 20) (eval '(input-files 'load-op "uiop")) -(assert-equal *ticks* 12) +(assert-equal *ticks* 21) -;;; disabling this test on windows since it relies on running make-asdf.bat, which -;;; does not work for me under cygwin. - rpg 2016-03-20 +(DBG "Checking that the bootstrap script and asdf.asd are in synch") (defun bootstrap-lisp-files (file line-prefix) (with-input-file (input (subpathname *asdf-directory* file)) (loop :for line = (read-line input) :when (string-prefix-p line-prefix line) :return (subseq line (length line-prefix)) :finally (error "Didn't find ~a in ~a" line-prefix file)))) - -(DBG "Checking that the bootstrap script and asdf.asd are in synch") (defun system-lisp-files (system) (loop :for f :in (input-files 'concatenate-source-op system) :collect (unix-namestring (enough-pathname f *asdf-directory*)))) diff --git a/test/test-touch-system-1.script b/test/test-touch-system-1.script index b9a63c3e895e9ae4a9485650428a19a2baf01d2f..d46464908354d4376c60fbc08c636386eb37f681 100644 --- a/test/test-touch-system-1.script +++ b/test/test-touch-system-1.script @@ -2,8 +2,14 @@ ;;; test system def reloading if touched ;;; system that can be found using *system-definition-search-functions* + +(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) + (defun system-registered-time (name) - (car (asdf::system-registered-p name))) + (asdf::component-operation-time + 'asdf::define-op + (registered-system (primary-system-name name)))) +(setf (asdf-upgraded-p *asdf-session*) t) (defparameter test1.asd (nth-value 2 (locate-system :test1))) (assert-pathname-equal test1.asd (test-source "test1.asd")) @@ -30,7 +36,7 @@ (sleep 1) (clear-system :test1) -(touch-file test1.asd :offset 600) +(touch-file test1.asd :timestamp date4 :offset 600) (find-system :test1) (defparameter date6 (system-registered-time :test1)) (assert-compare (> date6 date4)) diff --git a/test/test-touch-system-2.script b/test/test-touch-system-2.script index 7cc05e4060d071cff31e102126435b77eab308e1..c7a6a7234abe70374ed46516b0f653e3b98bc06d 100644 --- a/test/test-touch-system-2.script +++ b/test/test-touch-system-2.script @@ -1,26 +1,32 @@ ;;; -*- Lisp -*- -;;; test system definition reloading if touched +;;; test system definition NOT reloaded if touched ;;; system that canNOT be found using *system-definition-search-functions* +(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) + (defun system-registered-time (name) - (car (asdf::system-registered-p name))) + (asdf::component-operation-time + 'asdf::define-op + (registered-system (primary-system-name name)))) -(defparameter test1.asd (nth-value 2 (locate-system :test1))) -(assert-pathname-equal test1.asd (test-source "test1.asd")) -(assert test1.asd) +(asdf::clear-registered-systems) +(defparameter test-asdf.asd (nth-value 2 (locate-system :test-asdf))) +(assert-pathname-equal test-asdf.asd (test-source "test-asdf.asd")) +(assert (not (registered-system :test-asdf))) ;; not loaded -(asdf::clear-defined-systems) +(asdf::clear-registered-systems) (setf asdf:*central-registry* nil) -(load test1.asd) -(assert (find-system :test1)) -(defparameter date1 (system-registered-time :test1)) +(load-asd test-asdf.asd) +(assert (registered-system :test-asdf)) +(defparameter date1 (system-registered-time :test-asdf)) (assert date1) +(assert-equal 1 test-asdf-system::*times-loaded*) -(asdf::clear-defined-systems) -(touch-file test1.asd :timestamp date1 :offset +2) -(load test1.asd) -(find-system :test1) -(defparameter date2 (system-registered-time :test1)) +(asdf::clear-registered-systems) +(touch-file test-asdf.asd :timestamp date1 :offset +2) +(load-asd test-asdf.asd) +(find-system :test-asdf) +(defparameter date2 (system-registered-time :test-asdf)) (assert date2) (assert-compare (> date2 date1)) diff --git a/test/test-try-refinding.script b/test/test-try-refinding.script index ff1c677b2ed7de0708cd36082d60f21f2adc7e30..926accf40eb272eb4594838c2488c2adb8da62c4 100644 --- a/test/test-try-refinding.script +++ b/test/test-try-refinding.script @@ -2,6 +2,7 @@ ;;; test retrying finding location of an ASDF system. +(setf *asdf-session* nil) (in-package asdf-test) (defparameter *old-registry* asdf:*central-registry*) @@ -21,7 +22,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 +46,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))) @@ -66,7 +63,7 @@ (DBG "After invoking restart, CENTRAL-REGISTRY is:" asdf:*central-registry*)) ;; avoid infinite looping - (leave-test 11 "Infinite loop while catching MISSING-COMPONENT")))) + (leave-test "Infinite loop while catching MISSING-COMPONENT" 11)))) (handler-bind ((asdf:missing-dependency-of-version #'(lambda (c) diff --git a/test/test-undeferred-warnings.script b/test/test-undeferred-warnings.script index 940257958d45f774f09f1a044b69fb3823ce9fc9..76f05be349ac9d2ab68adba295d855a71cb3b97b 100644 --- a/test/test-undeferred-warnings.script +++ b/test/test-undeferred-warnings.script @@ -7,6 +7,8 @@ (in-package :asdf-test) +(setf asdf/session:*asdf-session* nil) + (disable-deferred-warnings-check) (def-test-system :undefined-variables diff --git a/test/test-utilities.script b/test/test-utilities.script index 9ce471a732167eb1968fcef43d9f30e66169590c..30ac5bd3b430e1004e789241b65f281365177cfe 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -1,6 +1,5 @@ ;;; -*- Lisp -*- -#+(and sbcl os-windows) (trace sb-ext:run-program) (proclaim '(optimize (debug 3) (speed 1) (safety 3) (compilation-speed 0))) (defun getcwd-from-run-program () @@ -210,8 +209,6 @@ '(;; slots names asdf/action:accept asdf/action:action - asdf/action:done-p - asdf/action:stamp asdf/bundle:prologue-code asdf/bundle:epilogue-code asdf/component:absolute-pathname @@ -241,16 +238,6 @@ asdf/component:sideway-dependencies asdf/component:version asdf/operation:feature - asdf/plan:index - asdf/plan:forced - asdf/plan:forced-not - asdf/plan:planned-action-count - asdf/plan:planned-output-action-count - asdf/plan:planned-p - asdf/plan:total-action-count - asdf/plan:visited-actions - asdf/plan:visiting-action-set - asdf/plan:visiting-action-list asdf/system:bug-tracker asdf/system:build-pathname asdf/system:system-defsystem-depends-on @@ -263,8 +250,8 @@ ;; restarts asdf/action:accept asdf/find-component:retry - asdf/find-system:coerce-entry-to-directory - asdf/find-system:remove-entry-from-registry + asdf/system-registry:coerce-entry-to-directory + asdf/system-registry:remove-entry-from-registry asdf/lisp-action:try-recompiling ;; types asdf/bundle:user-system @@ -280,10 +267,10 @@ ;; backward compatibility upgrade only asdf/backward-interface:on-failure asdf/backward-interface:on-warnings - asdf/find-system:contrib-sysdef-search - asdf/find-system:sysdef-find-asdf + asdf/system-registry:contrib-sysdef-search + asdf/system-registry:sysdef-find-asdf ;; restart - asdf/cache:clear-configuration-and-retry + asdf/session:clear-configuration-and-retry )) (defun defined-symbol-p (symbol) @@ -316,15 +303,14 @@ (ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/d/")) (ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/e/")) (register-directory *asdf-directory*) -(register-directory *uiop-directory*) (let ((new-file (subpathname *build-directory* "deleteme/a/1.x"))) (when (probe-file new-file) (delete-file new-file)) - (copy-file (system-source-file :uiop) new-file)) + (copy-file (system-source-file :asdf) new-file)) (let ((new-file (subpathname *build-directory* "deleteme/a/b/2"))) (when (probe-file new-file) (delete-file new-file)) - (copy-file (system-source-file :uiop) new-file)) + (copy-file (system-source-file :asdf) new-file)) (assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/c/"))) (assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/"))) (assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/"))) diff --git a/test/test-xach-update-bug.script b/test/test-xach-update-bug.script index 5326092d021b64caa15c025f8ab6d01b76428744..bb047d4be45ff1f5b4432085bfd76cf1707b9dff 100644 --- a/test/test-xach-update-bug.script +++ b/test/test-xach-update-bug.script @@ -1,8 +1,6 @@ ;;; -*- Lisp -*- -(setf asdf/cache:*asdf-cache* nil) ;; disable cache between those two very different compilations. -#-(and ecl ecl-bytecmp) -(setf asdf::*load-system-operation* 'load-bundle-op) ;; This triggers a bug on ECL no more! +(setf asdf/session:*asdf-session* nil) ;; disable cache between those two very different compilations. (defparameter foo :test-asdf-location-change) diff --git a/test/test1.script b/test/test1.script index 985592e6f9d4e2211cad5abaaa2c7c717e68f368..8add05953435543998bb5f1bfc4737e5f044497d 100644 --- a/test/test1.script +++ b/test/test1.script @@ -1,5 +1,7 @@ ;;; -*- Lisp -*- +(setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) + ;; We need use the pathnames used by ASDF. (defparameter test1.asd (system-source-file 'test1)) (defparameter file1.lisp (component-pathname (find-component 'test1 "file1"))) @@ -20,7 +22,6 @@ (touch-file file2.lisp :timestamp *date* :offset 200) (assert-equal (get-file-stamp file1.lisp) (+ *date* 100)) (assert-equal (get-file-stamp file2.lisp) (+ *date* 200)) - (DBG "loading test1") (load-system 'test1) @@ -41,7 +42,6 @@ (clear-system 'test1) (DBG "load again") -;;(trace input-files asdf::compute-action-stamp) (defparameter *plan* (nth-value 1 (operate 'load-op 'test1))) (DBG "check that file1 is _not_ recompiled, but file2 is") (assert (in-plan-p *plan* '(compile-op "test1" "file2"))) diff --git a/uiop/backward-driver.lisp b/uiop/backward-driver.lisp index 9a3dea129ac0322dc918fce8b13ad1d398fc180b..05f326140daf4846aeac9e480f746138368c1491 100644 --- a/uiop/backward-driver.lisp +++ b/uiop/backward-driver.lisp @@ -14,7 +14,7 @@ (in-package :uiop/backward-driver) (eval-when (:compile-toplevel :load-toplevel :execute) -(with-deprecation ((version-deprecation *uiop-version* :style-warning "3.2")) +(with-deprecation ((version-deprecation *uiop-version* :style-warning "3.2" :warning "3.4")) ;; Backward compatibility with ASDF 2.000 to 2.26 ;; For backward-compatibility only, for people using internals diff --git a/uiop/run-program.lisp b/uiop/run-program.lisp index 8889846e905f79e46b30c5e27cb287880df0faca..3846cfdfe44dc3862a91ee78ad58adee833c289b 100644 --- a/uiop/run-program.lisp +++ b/uiop/run-program.lisp @@ -409,7 +409,7 @@ or whether it's already taken care of by the implementation's underlying run-pro (reduce/strcat (os-cond ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized)) - ((os-windows-p) `(,@chdir ,@redirections " " ,normalized))))))) + ((os-windows-p) `(,@redirections " (" ,@chdir ,normalized ")"))))))) (defun %system (command &rest keys &key directory input (if-input-does-not-exist :error) diff --git a/uiop/utility.lisp b/uiop/utility.lisp index eb9ebf54fc32fd8de52ef960b58cb0ee96d96027..0b94273a2933637bcb3f14cb7c16e4362dfe100c 100644 --- a/uiop/utility.lisp +++ b/uiop/utility.lisp @@ -82,8 +82,9 @@ to supersede any previous definition." (with-upgradability () (defvar *uiop-debug-utility* '(or (ignore-errors - (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp")) - (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp")) + (probe-file (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp"))) + (probe-file (symbol-call :uiop/pathname :subpathname + (user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp"))) "form that evaluates to the pathname to your favorite debugging utilities") (defmacro uiop-debug (&rest keys) @@ -103,7 +104,7 @@ to supersede any previous definition." ;;; Flow control (with-upgradability () (defmacro nest (&rest things) - "Macro to do keep code nesting and indentation under control." ;; Thanks to mbaringer + "Macro to keep code nesting and indentation under control." ;; Thanks to mbaringer (reduce #'(lambda (outer inner) `(,@outer ,inner)) things :from-end t)) @@ -374,26 +375,26 @@ If optional ERROR argument is NIL, return NIL instead of an error when the symbo (string (standard-case-symbol-name package-designator))) error))) -;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity +;;; stamps: a REAL or a boolean where T=-infinity, NIL=+infinity (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) (deftype stamp () '(or real boolean))) (with-upgradability () (defun stamp< (x y) (etypecase x - (null (and y t)) - ((eql t) nil) + ((eql t) (not (eql y t))) (real (etypecase y - (null nil) - ((eql t) t) - (real (< x y)))))) + ((eql t) nil) + (real (< x y)) + (null t))) + (null nil))) (defun stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y))) (defun stamp*< (&rest list) (stamps< list)) (defun stamp<= (x y) (not (stamp< y x))) (defun earlier-stamp (x y) (if (stamp< x y) x y)) - (defun stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t)) + (defun stamps-earliest (list) (reduce 'earlier-stamp list :initial-value nil)) (defun earliest-stamp (&rest list) (stamps-earliest list)) (defun later-stamp (x y) (if (stamp< x y) y x)) - (defun stamps-latest (list) (reduce 'later-stamp list :initial-value nil)) + (defun stamps-latest (list) (reduce 'later-stamp list :initial-value t)) (defun latest-stamp (&rest list) (stamps-latest list)) (define-modify-macro latest-stamp-f (&rest stamps) latest-stamp)) diff --git a/upgrade.lisp b/upgrade.lisp index e11acc2cf6aa5b11ca1cbce5d799201395bd079c..1599b94df4bc1be69c5c8fd348c0605aae222a34 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -106,32 +106,32 @@ previously-loaded version of ASDF." ;;; Upon upgrade, specially frob some functions and classes that are being incompatibly redefined (when-upgrading () - (let ((redefined-functions ;; List of functions that changes incompatibly since 2.27: - ;; gf signature changed (should NOT happen), defun that became a generic function, - ;; method removed that will mess up with new ones (especially :around :before :after, - ;; more specific or call-next-method'ed method) and/or semantics otherwise modified. Oops. - ;; NB: it's too late to do anything about functions in UIOP! - ;; If you introduce some critical incompatibility there, you must change the function name. - ;; Note that we don't need do anything about functions that changed incompatibly - ;; from ASDF 2.26 or earlier: we wholly punt on the entire ASDF package in such an upgrade. - ;; Also note that we don't include the defgeneric=>defun, because they are - ;; done directly with defun* and need not trigger a punt on data. - ;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36 - '(#:component-depends-on #:input-files ;; methods removed before 3.1.2 - #:find-component ;; gf modified in 3.1.7.20 - )) - (redefined-classes - ;; redefining the classes causes interim circularities - ;; with the old ASDF during upgrade, and many implementations bork - #-clozure () - #+clozure - '((#:compile-concatenated-source-op (#:operation) ()) - (#:compile-bundle-op (#:operation) ()) - (#:concatenate-source-op (#:operation) ()) - (#:dll-op (#:operation) ()) - (#:lib-op (#:operation) ()) - (#:monolithic-compile-bundle-op (#:operation) ()) - (#:monolithic-concatenate-source-op (#:operation) ())))) + (let* ((previous-version (first *previous-asdf-versions*)) + (redefined-functions ;; List of functions that changes incompatibly since 2.27: + ;; gf signature changed (should NOT happen), defun that became a generic function, + ;; method removed that will mess up with new ones (especially :around :before :after, + ;; more specific or call-next-method'ed method) and/or semantics otherwise modified. Oops. + ;; NB: it's too late to do anything about functions in UIOP! + ;; If you introduce some critical incompatibility there, you must change the function name. + ;; Note that we don't need do anything about functions that changed incompatibly + ;; from ASDF 2.26 or earlier: we wholly punt on the entire ASDF package in such an upgrade. + ;; Also note that we don't include the defgeneric=>defun, because they are + ;; done directly with defun* and need not trigger a punt on data. + ;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36 + `(,@(when (version<= previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2 + ,@(when (version<= previous-version "3.1.7.20") '(#:find-component)))) + (redefined-classes + ;; redefining the classes causes interim circularities + ;; with the old ASDF during upgrade, and many implementations bork + #-clozure () + #+clozure + '((#:compile-concatenated-source-op (#:operation) ()) + (#:compile-bundle-op (#:operation) ()) + (#:concatenate-source-op (#:operation) ()) + (#:dll-op (#:operation) ()) + (#:lib-op (#:operation) ()) + (#:monolithic-compile-bundle-op (#:operation) ()) + (#:monolithic-concatenate-source-op (#:operation) ())))) (loop :for name :in redefined-functions :for sym = (find-symbol* name :asdf nil) :do (when sym (fmakunbound sym)))