diff --git a/action.lisp b/action.lisp index a07a4135aac4a9a54fa22b6bc15a0bb89f0114a7..fd4821dbedaf397fb7e32cefa4139de425111910 100644 --- a/action.lisp +++ b/action.lisp @@ -18,7 +18,7 @@ #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan #:action-path #:find-action #:stamp #:done-p ;; condition - #:operation-definition-error + #:operation-definition-warning #:operation-definition-error )) (in-package :asdf/action) @@ -127,10 +127,7 @@ You can put together sentences using this phrase.")) (defmethod component-depends-on :around ((o operation) (c component)) (do-asdf-cache `(component-depends-on ,o ,c) - (call-next-method))) - - (defmethod component-depends-on ((o operation) (c component)) - (cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies + (call-next-method)))) ;;;; upward-operation, downward-operation, sideway-operation, selfward-operation @@ -146,8 +143,10 @@ the action (O . M) of O on module M will depends on each of (D . C) for each chi The default value for slot DOWNWARD-OPERATION is NIL, which designates the operation O itself. E.g. in order for a MODULE to be loaded with LOAD-OP (resp. compiled with COMPILE-OP), all the children of the MODULE must have been loaded with LOAD-OP (resp. compiled with COMPILE-OP.")) + (defun downward-operation-depends-on (o c) + `((,(or (downward-operation o) o) ,@(component-children c)))) (defmethod component-depends-on ((o downward-operation) (c parent-component)) - `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method))) + `(,@(downward-operation-depends-on o c) ,@(call-next-method))) (defclass upward-operation (operation) ((upward-operation @@ -161,9 +160,10 @@ E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPA must first be prepared for loading or compiling with PREPARE-OP.")) ;; For backward-compatibility reasons, a system inherits from module and is a child-component ;; so we must guard against this case. ASDF4: remove that. + (defun upward-operation-depends-on (o c) + (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p)))) (defmethod component-depends-on ((o upward-operation) (c child-component)) - `(,@(if-let (p (component-parent c)) - `((,(or (upward-operation o) o) ,p))) ,@(call-next-method))) + `(,@(upward-operation-depends-on o c) ,@(call-next-method))) (defclass sideway-operation (operation) ((sideway-operation @@ -175,11 +175,12 @@ designates operation S (where NIL designates O itself), then the action (O . C) depends on each of (S . D) where D is a declared dependency of C. E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, each of its declared dependencies must first be loaded as by LOAD-OP.")) - (defmethod component-depends-on ((o sideway-operation) (c component)) + (defun sideway-operation-depends-on (o c) `((,(or (sideway-operation o) o) ,@(loop :for dep :in (component-sideway-dependencies c) - :collect (resolve-dependency-spec c dep))) - ,@(call-next-method))) + :collect (resolve-dependency-spec c dep))))) + (defmethod component-depends-on ((o sideway-operation) (c component)) + `(,@(sideway-operation-depends-on o c) ,@(call-next-method))) (defclass selfward-operation (operation) ((selfward-operation @@ -192,14 +193,14 @@ A operation-designator designates a singleton list of the designated operation; a list of operation-designators designates the list of designated operations; NIL is not a valid operation designator in that context. E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP.")) + (defun selfward-operation-depends-on (o c) + (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c))) (defmethod component-depends-on ((o selfward-operation) (c component)) - `(,@(loop :for op :in (ensure-list (selfward-operation o)) - :collect `(,op ,c)) - ,@(call-next-method))) + `(,@(selfward-operation-depends-on o c) ,@(call-next-method))) (defclass non-propagating-operation (operation) () - (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates + (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates no dependencies whatsoever. It is supplied in order that the programmer be able to specify that s/he is intentionally specifying an operation which invokes no dependencies."))) @@ -208,40 +209,47 @@ dependencies."))) ;;;--------------------------------------------------------------------------- ;;; Help programmers catch obsolete OPERATION subclasses ;;;--------------------------------------------------------------------------- -(define-condition operation-definition-error (simple-error) - () - (:documentation "Error conditions related to incorrect definitions of -OPERATION objects.")) -(defmethod initialize-instance :before ((obj operation) &key) - (unless - (loop :for x :in '(downward-operation upward-operation sideway-operation - selfward-operation non-propagating-operation - ;; the following is a special case - build-op) - :when (typep obj x) - :return t - :finally (return nil)) - (error 'operation-definition-error - :format-control - "No dependency propagating scheme specified for operation ~a.~ -This is likely because the OPERATION subclass of this object has not been ~ -updated for ASDF 3." - :format-arguments (list obj)))) - -(defmethod initialize-instance :before ((obj non-propagating-operation) &key) - (when - (loop :for x :in '(downward-operation upward-operation sideway-operation - selfward-operation) - :when (typep obj x) - :return t - :finally (return nil)) - (error 'operation-definition-error - :format-control - "Inconsistent class: ~a No class should have both NON-PROPAGATING-OPERATION and a propagating -operation class as superclasses." - :format-arguments - (list - (class-name (class-of obj)))))) +(with-upgradability () + (define-condition operation-definition-warning (simple-warning) + () + (:documentation "Warning condition related to definition of obsolete OPERATION objects.")) + + (define-condition operation-definition-error (simple-error) + () + (:documentation "Error condition related to definition of incorrect OPERATION objects.")) + + (defmethod initialize-instance :before ((o operation) &key) + ;; build-op is a special case. + (unless (typep o '(or downward-operation upward-operation sideway-operation + selfward-operation non-propagating-operation build-op)) + (warn 'operation-definition-warning + :format-control + "No dependency propagating scheme specified for operation class ~S. +The class needs to be updated for ASDF 3.1 and specify appropriate propagation mixins." + :format-arguments (list (type-of o))))) + + (defmethod initialize-instance :before ((o non-propagating-operation) &key) + (when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation)) + (error 'operation-definition-error + :format-control + "Inconsistent class: ~S + NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses." + :format-arguments + (list (type-of o))))) + + (defmethod component-depends-on ((o operation) (c component)) + `(;; Normal behavior, to allow user-specified in-order-to dependencies + ,@(cdr (assoc (type-of o) (component-in-order-to c))) + ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation + ;; or non-propagation through an appropriate mixin will be downward and sideway. + ,@(unless (typep o '(or downward-operation upward-operation sideway-operation + selfward-operation non-propagating-operation build-op)) + `(,@(downward-operation-depends-on o c) + ,@(sideway-operation-depends-on o c))))) + + (defmethod downward-operation ((o operation)) nil) + (defmethod sideway-operation ((o operation)) nil)) + ;;;--------------------------------------------------------------------------- ;;; End of OPERATION class checking diff --git a/interface.lisp b/interface.lisp index 17170b6d120fd7e1ea229a93aa18581a97e7db52..b92a120260d5ff824e2f78513c006e22ba8c1f02 100644 --- a/interface.lisp +++ b/interface.lisp @@ -121,7 +121,7 @@ #:circular-dependency ; errors #:duplicate-names #:non-toplevel-system #:non-system-system #:package-system-missing-package-error - #:operation-definition-error + #:operation-definition-warning #:operation-definition-error #:try-recompiling #:retry diff --git a/test/test-operation-classes.script b/test/test-operation-classes.script index 152b7727e254cba04f3bdd386e562766d012007b..8b3ad531d3a6ddffaef947dadeaf4d3dab3d96d9 100644 --- a/test/test-operation-classes.script +++ b/test/test-operation-classes.script @@ -53,20 +53,10 @@ (loop :for class :in *good-classes* :do (assert (make-instance class))) -(assert - (catch 'op-def-error - (handler-bind ((operation-definition-error #'(lambda (e) - (declare (ignore e)) - (throw 'op-def-error t)))) - (make-instance 'my-unupdated-operation) - nil))) +(signals operation-definition-warning + (make-instance 'my-unupdated-operation)) -(assert - (catch 'op-def-error - (handler-bind ((operation-definition-error #'(lambda (e) - (declare (ignore e)) - (throw 'op-def-error t)))) - (make-instance 'my-incoherent-operation) - nil))) +(signals operation-definition-error + (make-instance 'my-incoherent-operation)) (assert (make-instance 'my-good-operation))