diff --git a/action.lisp b/action.lisp index 1005d6c551466066de957998a46a6964174f1613..a216de27a5482f237fdf1b7b78ae0e50d561e63e 100644 --- a/action.lisp +++ b/action.lisp @@ -8,14 +8,13 @@ :asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation) (:export #:action #:define-convenience-action-methods - #:explain #:action-description + #:action-description #: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 #:component-operation-time #:mark-operation-done #:compute-action-stamp #:perform #:perform-with-restarts #:retry #:accept - #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan #:action-path #:find-action #:stamp #:done-p #:operation-definition-warning #:operation-definition-error ;; condition )) @@ -34,13 +33,6 @@ and a class-name or class designates the canonical instance of the designated cl '(or operation null symbol class))) -;;; TODO: These should be moved to asdf/plan and be made simple defuns. -(with-upgradability () - (defgeneric traverse-actions (actions &key &allow-other-keys)) - (defgeneric traverse-sub-actions (operation component &key &allow-other-keys)) - (defgeneric required-components (component &key &allow-other-keys))) - - ;;;; Reified representation for storage or debugging. Note: it drops the operation-original-initargs (with-upgradability () (defun action-path (action) @@ -115,14 +107,6 @@ You can put together sentences using this phrase.")) (format nil (compatfmt "~@<~A on ~A~@:>") (type-of operation) component)) - ;; This is for compatibility with ASDF 1, and is deprecated. - ;; TODO: move it to backward-interface - (defgeneric* (explain) (operation component) - (:documentation "Display a message describing an action")) - (defmethod explain ((o operation) (c component)) - (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c))) - (define-convenience-action-methods explain (operation component)) - (defun format-action (stream action &optional colon-p at-sign-p) "FORMAT helper to display an action's action-description. Use it in FORMAT control strings as ~/asdf-action:format-action/" diff --git a/backward-interface.lisp b/backward-interface.lisp index 07f366aa7492cc0657756cfddef8cb03fd98bf5a..19a1d49cd41fd863f9c053040df1a0d95f5e7d34 100644 --- a/backward-interface.lisp +++ b/backward-interface.lisp @@ -16,7 +16,8 @@ #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings #:component-property #:run-shell-command - #:system-definition-pathname)) + #:system-definition-pathname + #:explain)) (in-package :asdf/backward-interface) (with-upgradability () @@ -52,9 +53,7 @@ ;; More generally, if you have to do something when the operation was forced, ;; you should also do it when not, and vice-versa, because it really shouldn't matter. ;; Thus, the backward-compatible thing to do is to always return T. - ;; - ;; TODO: change this function to a defun that always returns T. - (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) + (defmethod operation-forced ((o operation)) t) ;; These old interfaces from ASDF1 have never been very meaningful @@ -182,10 +181,12 @@ Please use UIOP:RUN-PROGRAM instead." ((integer 0 255) exit-code) (t 255)))))) + (with-upgradability () (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. -;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED. + +;;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED. (with-upgradability () (defgeneric component-property (component property)) (defgeneric (setf component-property) (new-value component property)) @@ -200,3 +201,15 @@ Please use UIOP:RUN-PROGRAM instead." (setf (slot-value c 'properties) (acons property new-value (slot-value c 'properties))))) new-value)) + + +;;; This method survives from ASDF 1, but really it is superseded by action-description. +(with-upgradability () + (defgeneric* (explain) (operation component) + (:documentation "Display a message describing an action. +DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead.")) + (defmethod explain ((o operation) (c component)) + (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c))) + (define-convenience-action-methods explain (operation component))) + + diff --git a/bundle.lisp b/bundle.lisp index 23c4e382b2b15936bf2e7f3ac7831d210fb54882..1100a9e5e34fba10a4ae89331d265e43d55d5378 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -71,9 +71,8 @@ itself.")) (defclass link-op (bundle-op) () (:documentation "Abstract operation for linking files together")) - (defclass gather-op (bundle-op) - ;; TODO: rename the slot and reader gather-op to gather-operation - ((gather-op :initform nil :allocation :class :reader gather-op) + (defclass gather-operation (bundle-op) + ((gather-operation :initform nil :allocation :class :reader gather-operation) (gather-type :initform :no-output-file :allocation :class :reader gather-type)) (:documentation "Abstract operation for gathering many input files from a system")) @@ -86,7 +85,7 @@ itself.")) ;; and all system-level dependencies as required components. ;; Non-monolithic operations typically use compile-op as the dependent operation, ;; and all transitive sub-components as required components (excluding other systems). - (defmethod component-depends-on ((o gather-op) (s system)) + (defmethod component-depends-on ((o gather-operation) (s system)) (let* ((mono (operation-monolithic-p o)) (deps (required-components @@ -95,7 +94,7 @@ itself.")) :keep-operation 'compile-op))) ;; NB: the explicit make-operation on ECL and MKCL ;; ensures that we drop the original-initargs and its magic flags when recursing. - `((,(make-operation (or (gather-op o) (if mono 'lib-op 'compile-op))) ,@deps) + `((,(or (gather-operation o) (if mono 'lib-op 'compile-op)) ,@deps) ,@(call-next-method)))) ;; Create a single fasl for the entire library @@ -112,7 +111,7 @@ itself.")) :allocation :class)) (:documentation "Operation class for loading the bundles of a system's dependencies")) - (defclass lib-op (link-op gather-op non-propagating-operation) + (defclass lib-op (link-op gather-operation non-propagating-operation) ((gather-type :initform :object :allocation :class) (bundle-type :initform :lib :allocation :class)) (:documentation "Compile the system and produce a linkable static library (.a/.lib) @@ -125,7 +124,7 @@ themselves. In any case, this operation will produce what you need to further bu a static runtime for your system, or a dynamic library to load in an existing runtime.")) (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation - #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-op) + #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-operation) ((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op) :allocation :class)) (:documentation "This operator is an alternative to COMPILE-OP. Build a system @@ -145,7 +144,7 @@ faster and more resource efficient.")) ;; we'd have to have the monolithic-op not inherit from the main op, ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above. - (defclass dll-op (link-op gather-op non-propagating-operation) + (defclass dll-op (link-op gather-operation non-propagating-operation) ((gather-type :initform :object :allocation :class) (bundle-type :initform :dll :allocation :class)) (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) @@ -170,11 +169,13 @@ for all the linkable object files associated with the system. Compare with LIB-O (defclass monolithic-compile-bundle-op (monolithic-bundle-op basic-compile-bundle-op - #+(or clasp ecl mkcl) link-op gather-op non-propagating-operation) - ((gather-op :initform #-(or clasp ecl mkcl) 'compile-bundle-op #+(or clasp ecl mkcl) 'lib-op - :allocation :class) - (gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :static-library - :allocation :class)) + #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation) + ((gather-operation + :initform #-(or clasp ecl mkcl) 'compile-bundle-op #+(or clasp ecl mkcl) 'lib-op + :allocation :class) + (gather-type + :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :static-library + :allocation :class)) (:documentation "Create a single fasl for the system and its dependencies.")) (defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op) @@ -192,7 +193,7 @@ for all the linkable object files associated with the system or its dependencies for all the linkable object files associated with the system or its dependencies. See LIB-OP")) (defclass image-op (monolithic-bundle-op selfward-operation - #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op) + #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation) ((bundle-type :initform :image) #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class) (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class)) @@ -333,7 +334,7 @@ or of opaque libraries shipped along the source code.")) (defun pathname-type-equal-function (type) #'(lambda (p) (equalp (pathname-type p) type))) - (defmethod input-files ((o gather-op) (c system)) + (defmethod input-files ((o gather-operation) (c system)) (unless (eq (bundle-type o) :no-output-file) (direct-dependency-files o c :key 'output-files @@ -454,7 +455,7 @@ or of opaque libraries shipped along the source code.")) (defmethod perform ((o dll-op) (c prebuilt-system)) nil) - (defmethod component-depends-on ((o gather-op) (c prebuilt-system)) + (defmethod component-depends-on ((o gather-operation) (c prebuilt-system)) nil) (defmethod output-files ((o lib-op) (c prebuilt-system)) diff --git a/component.lisp b/component.lisp index 3fb587cbc080de33bbf16d328f17d7080d650d31..f77337e6c871fffa0849ac3d9e19bccc2481ccec 100644 --- a/component.lisp +++ b/component.lisp @@ -49,7 +49,7 @@ (:documentation "Top-level system containing the COMPONENT")) (defgeneric component-pathname (component) (:documentation "Pathname of the COMPONENT if any, or NIL.")) - (defgeneric (component-relative-pathname) (component) + (defgeneric* (component-relative-pathname) (component) ;; in ASDF4, rename that to component-specified-pathname ? (:documentation "Specified pathname of the COMPONENT, intended to be merged with the pathname of that component's parent if any, using merged-pathnames*. @@ -78,7 +78,7 @@ or NIL for top-level components (a.k.a. systems)")) ;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component. ;; TODO: find users, have them stop using that, remove it for ASDF4. - (defgeneric (source-file-type) (component system) + (defgeneric* (source-file-type) (component system) (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead.")) (define-condition system-definition-error (error) () diff --git a/concatenate-source.lisp b/concatenate-source.lisp index 34bed3c286c01752f1d07859acd2a8cd7547f95e..e01500f9836d544aa496a96b93bf6b0ee9823e7f 100644 --- a/concatenate-source.lisp +++ b/concatenate-source.lisp @@ -6,7 +6,7 @@ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/operation :asdf/system :asdf/find-system - :asdf/action :asdf/lisp-action :asdf/bundle) + :asdf/action :asdf/lisp-action :asdf/plan :asdf/bundle) (:export #:concatenate-source-op #:load-concatenated-source-op @@ -24,7 +24,7 @@ (with-upgradability () ;; Base classes for both regular and monolithic concatenate-source operations (defclass basic-concatenate-source-op (bundle-op) - ((bundle-type :initform "lisp"))) + ((bundle-type :initform "lisp" :allocation :class))) (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ()) (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ()) (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ()) diff --git a/find-component.lisp b/find-component.lisp index a5a844273dd297a1bf1bd64680116e6614f9a199..43b77d2a385bbe47312f0da24307b1f5854c2896 100644 --- a/find-component.lisp +++ b/find-component.lisp @@ -129,8 +129,7 @@ in the context of COMPONENT")) (equal (missing-requires c) name)))) (unless (component-parent component) (let ((name (coerce-name name))) - (unset-asdf-cache-entry `(find-system ,name)) - (unset-asdf-cache-entry `(locate-system ,name)))))))) + (unset-asdf-cache-entry `(find-system ,name)))))))) ;; Resolve dependency specification DEP-SPEC in the context of COMPONENT. ;; This is notably used by MAP-DIRECT-DEPENDENCIES to process the results of COMPONENT-DEPENDS-ON diff --git a/find-system.lisp b/find-system.lisp index 98cc0660175d99795674ce65631d18f53f61f581..e0d36077b4be2e9b12dc3adf6bef62919529f569 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -123,6 +123,14 @@ or NIL if not found." (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. @@ -154,13 +162,6 @@ then define and register said preloaded system." (if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name))) (register-system system))) - (defun ensure-all-preloaded-systems-registered () - "Make sure all registered preloaded systems are defined. -This function is run whenever ASDF is upgraded." - (loop :for name :being :the :hash-keys :of *preloaded-systems* - :do (ensure-preloaded-system-registered name))) - (register-hook-function '*post-upgrade-restart-hook* 'ensure-all-preloaded-systems-registered) - (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 @@ -230,17 +231,7 @@ Returns T if system was or is now undefined, NIL if a new preloaded system was r "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 (equal name "asdf") :do (clear-system name))) - - (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil) - - (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)))) + :unless (member name '("asdf" "uiop") :test 'equal) :do (clear-system name))) ;;; Searching for system definitions @@ -452,9 +443,7 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." (ensure-gethash (list (namestring pathname) version) *old-asdf-systems* #'(lambda () - (let ((old-pathname - (if-let (pair (system-registered-p "asdf")) - (system-source-file (cdr pair))))) + (let ((old-pathname (system-source-file (registered-system "asdf")))) (warn "~@<~ You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~ or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~ @@ -502,8 +491,8 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (found-system (and (typep found 'system) found)) (pathname (ensure-pathname (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous))) + (system-source-file found-system) + (system-source-file previous)) :want-absolute t :resolve-symlinks *resolve-symlinks*)) (foundp (and (or found-system pathname previous) t))) (check-type found (or null pathname system)) @@ -526,7 +515,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (multiple-value-bind (foundp found-system pathname previous previous-time) (locate-system name) (assert (eq foundp (and (or found-system pathname previous) t))) - (let ((previous-pathname (and previous (system-source-file previous))) + (let ((previous-pathname (system-source-file previous)) (system (or previous found-system))) (when (and found-system (not previous)) (register-system found-system)) diff --git a/operate.lisp b/operate.lisp index 625895b2b748c084daec9734127630d492646efb..5f30d10873ed3e6aad58cd429915dd09653ba419 100644 --- a/operate.lisp +++ b/operate.lisp @@ -8,7 +8,6 @@ :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan) (:export #:operate #:oos - #:*systems-being-operated* #:build-op #:make #:load-system #:load-systems #:load-systems* #:compile-system #:test-system #:require-system @@ -50,10 +49,8 @@ But do NOT depend on it, for this is deprecated behavior.")) :operation-initargs t ;; backward-compatibility with ASDF1. Deprecated. :if-no-component (error 'missing-component :requires component)) - ;; TODO: actually, the use as a hash-set is write-only, so it can be reduced to a boolean, - ;; and then possibly replaced by checking for say *asdf-cache*. - (defvar *systems-being-operated* nil - "A hash-set of names of systems being operated on, or NIL") + (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, @@ -62,36 +59,36 @@ But do NOT depend on it, for this is deprecated behavior.")) &key verbose (on-warnings *compile-file-warnings-behaviour*) (on-failure *compile-file-failure-behaviour*) &allow-other-keys) - (let* ((systems-being-operated *systems-being-operated*) - (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))) + (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)) - (initargs (operation-original-initargs operation))) - #'(lambda () (apply 'make-operation name :original-initargs initargs initargs)))) - ((or symbol string) (constantly operation)))) + (etypecase operation + (operation (let ((name (type-of operation)) + (initargs (operation-original-initargs operation))) + #'(lambda () (apply 'make-operation name :original-initargs initargs initargs)))) + ((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. - (unless systems-being-operated - (when (upgrade-asdf) - ;; If we were upgraded, restart OPERATE the hardest of ways, for - ;; its function may have been redefined, its symbol uninterned, its package deleted. - (return-from operate - (apply 'operate (funcall operation-remaker) component-path keys)))) + (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 + (when (upgrade-asdf) + ;; If we were upgraded, restart OPERATE the hardest of ways, for + ;; its function may have been redefined, its symbol uninterned, its package deleted. + (return-from operate + (apply 'operate (funcall operation-remaker) component-path keys))))) ;; Setup proper bindings around any operate call. - (with-asdf-cache () - (let* ((*verbose-out* (and verbose *standard-output*)) - (*compile-file-warnings-behaviour* on-warnings) - (*compile-file-failure-behaviour* on-failure)) - (call-next-method))))) + (let* ((*verbose-out* (and verbose *standard-output*)) + (*compile-file-warnings-behaviour* on-warnings) + (*compile-file-failure-behaviour* on-failure)) + (call-next-method)))) (defmethod operate :before ((operation operation) (component component) &key version &allow-other-keys) - (let ((system (component-system component))) - (setf (gethash (coerce-name system) *systems-being-operated*) system)) (unless (version-satisfies component version) (error 'missing-component-of-version :requires component :version version))) @@ -178,7 +175,7 @@ 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-instance 'load-op) component))) + (action-already-done-p nil (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" @@ -262,12 +259,20 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms.")) (with-upgradability () (defun restart-upgraded-asdf () ;; If we're in the middle of something, restart it. - (when *asdf-cache* - (let ((l (loop :for k :being :the hash-keys :of *asdf-cache* - :when (eq (first k) 'find-system) :collect (second k)))) - (clrhash *asdf-cache*) - (dolist (s l) (find-system s nil))))) - (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf) + (let ((systems-being-defined + (when *asdf-cache* + (prog1 + (loop :for k :being :the hash-keys :of *asdf-cache* + :when (eq (first k) 'find-system) :collect (second k)) + (clrhash *asdf-cache*))))) + ;; Regardless, clear defined systems, since they might be invalid + ;; after an incompatible ASDF upgrade. + (clear-defined-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. diff --git a/output-translations.lisp b/output-translations.lisp index 26c3506765a1fd0a072cd7adc46d3b9439af742d..4c2b3f24f1dd4f77b371c30695048e0df4c8e321 100644 --- a/output-translations.lisp +++ b/output-translations.lisp @@ -49,7 +49,9 @@ and the order is by decreasing length of namestring of the source pathname.") (etypecase (car x) ((eql t) -1) (pathname - (let ((directory (pathname-directory (car x)))) + (let ((directory + (normalize-pathname-directory-component + (pathname-directory (car x))))) (if (listp directory) (length directory) 0)))))))) new-value) (defun* ((setf output-translations)) (new-value) (set-output-translations new-value)) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index 0c38183cf0d582653ef5a0af56dad3dbb50cc9d7..b952635c846f9699cec956fb90c833bb96f982c1 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -189,7 +189,7 @@ system names contained using COERCE-NAME. Return the result." (mapcar 'parse-dependency-def dd-list)) - (defun (parse-component-form) (parent options &key previous-serial-component) + (defun* (parse-component-form) (parent options &key previous-serial-component) (destructuring-bind (type name &rest rest &key (builtin-system-p () bspp) diff --git a/plan.lisp b/plan.lisp index e7f661fee12249b0467deebc17c7f1e8af3a0661..81fb34abe6d0a073c6d333da85f33b458b7f6661 100644 --- a/plan.lisp +++ b/plan.lisp @@ -200,7 +200,7 @@ 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) (plan 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) @@ -210,7 +210,7 @@ to be meaningful, or could it just as well have been done in another Lisp image? :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) + (defun* (reduce-direct-dependencies) (plan 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." @@ -220,7 +220,7 @@ initialized with SEED." (setf seed (funcall combinator dep-o dep-c seed)))) seed) - (defun (direct-dependencies) (plan operation component) + (defun* (direct-dependencies) (plan operation component) "Compute a list of the direct dependencies of the action within the plan" (reduce-direct-dependencies plan operation component #'acons nil)) @@ -514,12 +514,13 @@ initialized with SEED." (typep c (plan-component-type plan)) (call-next-method))) - (defmethod traverse-actions (actions &rest keys &key plan-class &allow-other-keys) + (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 (o . c) :in actions :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) @@ -532,7 +533,7 @@ initialized with SEED." :when (and (typep o keep-operation) (typep c keep-component)) :collect (cons o c)))) - (defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) + (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 diff --git a/system.lisp b/system.lisp index 0140f0e8ae6b90a99deee45578073359e95e28b4..bbb8aaf2c477451e8110c21de6e31d605976b1b9 100644 --- a/system.lisp +++ b/system.lisp @@ -108,14 +108,15 @@ based on supplied KEYS." (defmethod system-source-file ((system-name string)) (system-source-file (find-system system-name))) (defmethod system-source-file ((system-name symbol)) - (system-source-file (find-system system-name))) + (when system-name + (system-source-file (find-system system-name)))) (defun system-source-directory (system-designator) "Return a pathname object corresponding to the directory in which the system specification (.asd file) is located." (pathname-directory-pathname (system-source-file system-designator))) - (defun (system-relative-pathname) (system name &key type) + (defun* (system-relative-pathname) (system name &key type) "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE, return the absolute pathname of a corresponding file under that system's source code pathname." (subpathname (system-source-directory system) name :type type)) diff --git a/test/run-tests.sh b/test/run-tests.sh index 5133fd800964bde6867488edb8dbaada215c646e..d2f3f6d517641b7ece7a5c63470cff64800d4ce1 100755 --- a/test/run-tests.sh +++ b/test/run-tests.sh @@ -361,11 +361,16 @@ upgrade_tags () { # We return the above designated versions in order of decreasing relevance, # which pretty much means REQUIRE and most recent first. echo REQUIRE - echo 3.1.4 3.1.3 3.1.2 - echo 3.0.3 3.0.2 3.0.1 -# echo 2.32 2.27 -# echo 2.26 2.22 2.20 2.019 2.014.6 2.011 2.008 2.000 -# echo 1.369 1.97 1.85 + echo 3.1.7 # 2016-03-23, latest release (as of 2016-09) + echo 3.1.5 # 2015-07-21, what SBCL sports (as of 1.3.9, 2016-08-30) + echo 3.0.3 # 2013-10-22, last in ASDF 3.0 series + echo 2.26 # 2012-10-30, last in ASDF 2 series, still sported by Quicklisp 2016-02-22 (!) + + #echo 3.1.7 3.1.6 3.1.5 3.1.4 3.1.3 3.1.2 + #echo 3.0.3 3.0.2 3.0.1 + #echo 2.32 2.27 + #echo 2.26 2.22 2.20 2.019 2.014.6 2.011 2.008 2.000 + #echo 1.369 1.97 1.85 } upgrade_methods () { if [ -n "$ASDF_UPGRADE_TEST_METHODS" ] ; then @@ -390,7 +395,7 @@ extract_tagged_asdf () { case $tag in 1.*|2.0*|2.2[0-6]|2.26.61) git show ${tag}:asdf.lisp > $file ;; - 2.2[7-9]*|2.[3-9]*|3.*) + 2.2[7-9]*|2.[3-9][0-9]*|3.*) mkdir -p build/old/build git archive ${tag} | (cd build/old/ ; tar xf -) make -C build/old diff --git a/test/script-support.lisp b/test/script-support.lisp index f47482433d5c8e9c2bf329f67f9cbbb7538df5fe..0e8a94cffce375b8847de86cc2e5103a5dd73a37 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -621,18 +621,24 @@ 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*)) - (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~%~ + (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))) + (pathname-components *test-directory*) + (pathname-components x))) + (setf *test-directory* x))))) t) (defun frob-packages () diff --git a/test/stamp-propagation/test-stamp-propagation.lisp b/test/stamp-propagation/test-stamp-propagation.lisp index 1ffe1bdf6388d378cff59aad657ca80cdb14fa05..2e32d1723b06b71fba88df14857d41f1f9296f46 100644 --- a/test/stamp-propagation/test-stamp-propagation.lisp +++ b/test/stamp-propagation/test-stamp-propagation.lisp @@ -156,13 +156,11 @@ (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 (make-instance 'asdf:compile-op) - (asdf:find-component :test-stamp-propagation '("file1")))) + (dolist (l (asdf:output-files 'asdf:compile-op '(:test-stamp-propagation "file1"))) (touch-file l :timestamp base :offset f1)) (touch-file (lisppath "file2.lisp") :timestamp base :offset l2) (touch-file (faslpath "file2.lisp") :timestamp base :offset f2) - (dolist (l (asdf:output-files (make-instance 'asdf:compile-op) - (asdf:find-component :test-stamp-propagation '("file2")))) + (dolist (l (asdf:output-files 'asdf:compile-op '(:test-stamp-propagation "file2"))) (touch-file l :timestamp base :offset f2))) (defun test-defsystem (&optional (defsystem *default-defsystem*)) diff --git a/test/test-mutual-redefinition.script b/test/test-mutual-redefinition.script index 4f66c4672449e6fbb969f02ecf9e7f3487f24ec6..52e4422e10692776d0c0413160d00aad3b55a34d 100644 --- a/test/test-mutual-redefinition.script +++ b/test/test-mutual-redefinition.script @@ -2,7 +2,7 @@ (load-system 'test-mutual-redefinition-1) (defun current-system-source-file (x) - (system-source-file (cdr (gethash x asdf/find-system:*defined-systems*)))) + (system-source-file (asdf::registered-system x))) (with-asdf-cache () (DBG "loading test-mutual-redefinition-1") diff --git a/test/test-operation-classes.script b/test/test-operation-classes.script index bbcf83ca21a1c6aa1c3aeed018ceaa8c80cf9a4b..4b16a8a0c292e274e3334e1cceb3652318ebc41b 100644 --- a/test/test-operation-classes.script +++ b/test/test-operation-classes.script @@ -47,16 +47,16 @@ (defclass my-incoherent-operation (downward-operation non-propagating-operation) ()) -(dolist (class *good-classes*) (assert (make-instance class))) +(dolist (class *good-classes*) (assert (make-operation class))) (signals operation-definition-warning - (make-instance 'my-unupdated-operation)) + (make-operation 'my-unupdated-operation)) (with-expected-failure (#+gcl "GCL has trouble with CLOS?") (signals operation-definition-error - (make-instance 'my-incoherent-operation))) + (make-operation 'my-incoherent-operation))) -(assert (make-instance 'my-good-operation)) +(assert (make-operation 'my-good-operation)) ;; This test exercises the backward-compatibility mechanism of operation, diff --git a/tools/asdf-tools b/tools/asdf-tools index f12aac8dab73abfa5ed776007a213baee7d6c26c..549b33d7d0259985ca273ca1016e087aca8a254c 100755 --- a/tools/asdf-tools +++ b/tools/asdf-tools @@ -1,12 +1,15 @@ #| -*- Lisp -*- case "$LISP" in - # CCL is our default because it is the single free software implementation that has - # decent portable support on all of Windows, Linux (x64, x86, ARM), MacOS X - ""|ccl) exec ${CCL:-ccl} --no-init --load "$0" -- "$@" ;; + # SBCL is our default on Unix, because while CCL has better support on Windows and MacOS, + # SBCL still runs decently on MacOS and CCL has a background thread that eats input + # (and still puts the tty in raw mode if using single-threaded-ccl) which defeats + # the purpose of `make load`. See: https://bugs.launchpad.net/asdf/+bug/1624909 allegro) ${ALLEGRO:-alisp} -qq -e "(setf *load-verbose* nil)" -L "$0" -- "$@" ;; - sbcl) exec ${SBCL:-sbcl} --noinform --no-userinit --no-sysinit --script "$0" "$@" ;; + ccl) exec ${CCL:-ccl} --no-init --load "$0" -- "$@" ;; + + ""|sbcl) exec ${SBCL:-sbcl} --noinform --no-userinit --no-sysinit --script "$0" "$@" ;; # Let cl-launch choose its preferred Lisp cl-launch) cl-launch -Q -sp asdf-tools -r entry-point -- "$@" ;; diff --git a/tools/asdf-tools.bat b/tools/asdf-tools.bat index aaa3ba3b01b82379a49fa7eab448a8b586569228..f79dd6d6a1a36a9e79fb65135c08fef5755c5b8e 100644 --- a/tools/asdf-tools.bat +++ b/tools/asdf-tools.bat @@ -1,6 +1,6 @@ @echo off -::: By default. We use CCL. +::: By default. We use CCL, because SBCL doesn't have a good enough run-program on Windows. if "%LISP%" == "" goto ccl if "%LISP%" == "allegro" goto allegro if "%LISP%" == "ccl" goto ccl diff --git a/tools/test-environment.lisp b/tools/test-environment.lisp index b5601f3079a664905343bb135d59cff6baabfcc3..3508ccbab25cb1ad81b610dad7f6e5408e5516bb 100644 --- a/tools/test-environment.lisp +++ b/tools/test-environment.lisp @@ -228,8 +228,9 @@ and which systems to test loading with ASDF_TEST_SYSTEMS or s= (output (if (eq output *stdout*) :interactive output))) (log! log "~A" (print-process-spec command nil)) (multiple-value-bind (out err code) - (run `((>& 2 1) ,@(when interactive '(rlwrap)) ,@command - ,@(when log `((>> ,log)))) ;; unhappily, | tee -a log eats error codes :-( + (run `(,@(when interactive '(rlwrap)) + ,@command + ,@(when log `((>> ,log) (>& 2 1)))) ;; unhappily, | tee -a log eats error codes :-( :input interactive :output output :error-output (or interactive :output) :on-error nil) (declare (ignore out err)) (let ((okp (eql code 0))) diff --git a/tools/test-upgrade.lisp b/tools/test-upgrade.lisp index 08757b75d91154bd0777d3dc3c8fd03c12184d11..adbc2cdb88ad79c331876dd367526546851bf1db 100644 --- a/tools/test-upgrade.lisp +++ b/tools/test-upgrade.lisp @@ -6,13 +6,19 @@ ;; We return a list of entries in reverse chronological order, ;; which should also be more or less the order of decreasing relevance. '("REQUIRE" ;; a magic tag meaning whatever your implementation provides, if anything + "3.1.7" ;; (2016-03-23) more bug fixes, latest release (as of 2016-09-17) + "3.1.5" ;; (2015-07-21) more bug fixes + "3.0.3" ;; (2013-10-22) the last in the ASDF 3.0 series + "2.26")) ;; (2012-10-30), last in ASDF 2 series, still sported by Quicklisp 2016-02-22 (!) - ;; The 3.1 series provides the asdf3.1 feature, meaning users can rely on +(defparameter *obsolete-upgrade-test-tags* + '(;; The 3.1 series provides the asdf3.1 feature, meaning users can rely on ;; all the stabilization work done in 3.0 so far, plus extra developments ;; in UIOP, package-inferred-system, and more robustification. + ;;(included above) "3.1.7" ;; (2016-03-23) more bug fixes, latest release (as of 2016-09-17) "3.1.6" ;; (2015-10-17) more bug fixes - "3.1.5" ;; (2015-07-21) more bug fixes - "3.1.4" ;; (2014-10-09) more bug fixes, source-registry cache + ;;(included above) "3.1.5" ;; (2015-07-21) more bug fixes, what SBCL sports (as of 1.3.9, 2016-08-30) + "3.1.4" ;; (2014-10-09) more bug fixes, source-registry cache, in LispWorks 7 "3.1.3" ;; (2014-07-24) a bug fix release for 3.1.2 "3.1.2" ;; (2014-05-06) the first ASDF 3.1 release @@ -20,19 +26,18 @@ ;; with Robert Goldman taking over maintainership at 3.0.2. ;; 3.0.0 was just 2.33.10 promoted, but version-satisfies meant it was suddenly ;; not compatible with ASDF2 anymore, so we immediately released 3.0.1 - "3.0.3" ;; (2013-10-22) the last in the ASDF 3.0 series + ;;(included above) "3.0.3" ;; (2013-10-22) the last in the ASDF 3.0 series "3.0.2" ;; (2013-07-02) the first ASDF 3 in SBCL - "3.0.1")) ;; (2013-05-16) the first stable ASDF 3 release + "3.0.1" ;; (2013-05-16) the first stable ASDF 3 release -(defparameter *obsolete-upgrade-test-tags* - '(;; 2.27 to 2.33 are Faré's "stable" ASDF 3 pre-releases + ;; 2.27 to 2.33 are Faré's "stable" ASDF 3 pre-releases "2.32" ;; (2013-03-05) the first really stable ASDF 3 pre-release "2.27" ;; (2013-02-01) the first ASDF 3 pre-release ;; The ASDF 2 series ;; Note that 2.26.x is where the refactoring that begat ASDF 3 took place. ;; 2.26.61 is the last single-file, single-package ASDF. - "2.26" ;; (2012-10-30) the last stable ASDF 2 release, long used by Quicklisp, SBCL, etc. + ;;(included above) "2.26" ;; (2012-10-30), last in ASDF 2 series, still sported by Quicklisp 2016-02-22 (!), long used by SBCL, etc. "2.22" ;; (2012-06-12) used by debian wheezy, etc. "2.20" ;; (2012-01-18) in CCL 1.8, Ubuntu 12.04 LTS "2.019" ;; (2011-11-29) still included in LispWorks in 2014. @@ -48,8 +53,12 @@ (defun get-upgrade-tags (&optional (x *upgrade-test-tags*)) (cond - ((eq x :default) *default-upgrade-test-tags*) - ((or (eq x :old) (equal x '("old"))) *obsolete-upgrade-test-tags*) + ((string-equal x :default) + *default-upgrade-test-tags*) + ((string-equal x :old) + *obsolete-upgrade-test-tags*) + ((string-equal x :all) + (mappend *default-upgrade-test-tags* *obsolete-upgrade-test-tags*)) (t x))) (defun extract-tagged-asdf (tag) diff --git a/uiop/contrib/debug.lisp b/uiop/contrib/debug.lisp index 1cd6da295e3dd82bdaee110d77a3d613612c6f65..d10d01ee4b6a2b41db64a6fdf590d58c707fbfcc 100644 --- a/uiop/contrib/debug.lisp +++ b/uiop/contrib/debug.lisp @@ -89,7 +89,7 @@ The macro expansion has relatively low overhead in space or time." (e "~& ~S => " expression) (let ((results (multiple-value-list (funcall thunk)))) (e "~{~S~^ ~}~%" results) - (apply 'values results)))) + (values-list results)))) (map () #'z (list *standard-output* *error-output* *trace-output*)) (e "~A~%" tag) (loop :for (expression . thunk) :in expressions-thunks diff --git a/uiop/image.lisp b/uiop/image.lisp index 0c31a53e6d45b5b4a94326cba9f723f70d2c5fec..8fe35b8bb59e3f48fac0053b2285b3b8e6bbc61b 100644 --- a/uiop/image.lisp +++ b/uiop/image.lisp @@ -318,7 +318,7 @@ of the function will be returned rather than interpreted as a boolean designatin (call-function entry-point) t)))) (if lisp-interaction - (apply 'values results) + (values-list results) (shell-boolean-exit (first results))))))) @@ -350,7 +350,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." (setf *image-dump-hook* dump-hook) (call-image-dump-hook) (setf *image-restored-p* nil) - #-(or clisp clozure cmucl lispworks sbcl scl) + #-(or clisp clozure (and cmucl executable) lispworks sbcl scl) (when executable (error "Dumping an executable is not supported on this implementation! Aborting.")) #+allegro @@ -384,8 +384,10 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." (setf ext:*batch-mode* nil) (setf ext::*gc-run-time* 0) (apply 'ext:save-lisp filename - #+cmucl :executable #+cmucl t - (when executable '(:init-function restore-image :process-command-line nil)))) + :allow-other-keys t ;; hush SCL and old versions of CMUCL + #+(and cmucl executable) :executable #+(and cmucl executable) t + (when executable '(:init-function restore-image :process-command-line nil + :quiet t :load-init-file nil :site-init nil)))) #+gcl (progn (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t) diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp index 15af1fb4bdfa332b4fd7a735ee14ced5c153960d..fbc8c225eb0ece3a328c4118745a3eddb40075a2 100644 --- a/uiop/pathname.lisp +++ b/uiop/pathname.lisp @@ -337,6 +337,8 @@ actually-existing directory." ;;; Parsing filenames (with-upgradability () + (declaim (ftype function ensure-pathname)) ; forward reference + (defun split-unix-namestring-directory-components (unix-namestring &key ensure-directory dot-dot) "Splits the path string UNIX-NAMESTRING, returning four values: diff --git a/uiop/stream.lisp b/uiop/stream.lisp index d699c94cf3c330f95c5517945fa2004a4e824555..eae37685283a8719267b05184de53d623f83be35 100644 --- a/uiop/stream.lisp +++ b/uiop/stream.lisp @@ -496,7 +496,7 @@ within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE." :for form = (read input nil eof) :until (eq form eof) :do (setf results (multiple-value-list (eval form))) - :finally (return (apply 'values results))))) + :finally (return (values-list results))))) (defun eval-thunk (thunk) "Evaluate a THUNK of code: @@ -622,7 +622,7 @@ Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'e ((not okp) nil) (after (return (call-function after okp))) ((and want-pathname-p (not want-stream-p)) (return (call-function thunk okp))) - (t (return (apply 'values results))))) + (t (return (values-list results))))) (when (and okp (not (call-function keep))) (ignore-errors (delete-file-if-exists okp)))))) diff --git a/upgrade.lisp b/upgrade.lisp index 3e6644fe949e85307efe4c2f773e1663d07d0b65..53a7131309b17520939e15f611d70bcf7739a6ce 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -9,7 +9,7 @@ #:asdf-version #:*previous-asdf-versions* #:*asdf-version* #:asdf-message #:*verbose-out* #:upgrading-p #:when-upgrading #:upgrade-asdf #:defparameter* - #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf + #:*post-upgrade-cleanup-hook* #:cleanup-upgraded-asdf ;; There will be no symbol left behind! #:intern*) (:import-from :uiop/package #:intern* #:find-symbol*)) @@ -53,11 +53,6 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO (when *verbose-out* (apply 'format *verbose-out* format-string format-args))) ;; Private hook for functions to run after ASDF has upgraded itself from an older variant: (defvar *post-upgrade-cleanup-hook* ()) - ;; Private hook for functions to run after ASDF is restarted, whether by starting a process - ;; from a dumped image or after upgrading from an older variant: - ;; TODO: understand what happened with that hook, why functions are registered on it but it is - ;; never called anymore. This is a bug that should be fixed before next release (3.1.8)! - (defvar *post-upgrade-restart-hook* ()) ;; Private function to detect whether the current upgrade counts as an incompatible ;; data schema upgrade implying the need to drop data. (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*)) @@ -157,9 +152,4 @@ previously-loaded version of ASDF." (let ((*load-print* nil) (*compile-print* nil)) (handler-bind (((or style-warning) #'muffle-warning)) - (symbol-call :asdf :load-system :asdf :verbose nil)))) - - ;; Register the upgrade-configuration function from UIOP, - ;; to ensure configuration is upgraded as needed. - (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration)) - + (symbol-call :asdf :load-system :asdf :verbose nil)))))