Commit eb2da723 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Implement the discussed non-monotonic inheritance of propagation traits.

For backward compatibility with ASDF 2, an operation that doesn't explicitly
inherit from one of the propagation classes or non-propagating-operation
will be downward- and sideway- propagating, with a warning at instantiation.
Inheriting from non-propagating and a propagating class at the same time
yields an error, not a warning.
Update packages and tests.
parent cf56bc2d
Loading
Loading
Loading
Loading
+57 −49
Original line number Diff line number Diff line
@@ -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,10 +193,10 @@ 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)
    ()
@@ -208,40 +209,47 @@ dependencies.")))
;;;---------------------------------------------------------------------------
;;; Help programmers catch obsolete OPERATION subclasses
;;;---------------------------------------------------------------------------
(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 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
    (: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 ~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))
            "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: ~a No class should have both NON-PROPAGATING-OPERATION and a propagating 
operation class as superclasses."
             "Inconsistent class: ~S
  NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses."
             :format-arguments
           (list
            (class-name (class-of obj))))))
             (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
+1 −1
Original line number Diff line number Diff line
@@ -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
+4 −14
Original line number Diff line number Diff line
@@ -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))