Commit bbf1914a authored by Robert Goldman's avatar Robert Goldman
Browse files

Add pseudo-accessors to ACTIONs.

ACTIONs are currently simply CONS cells.
Previously these were accessed with CAR and CDR and made with CONS.
Now there are "accessor" functions, ACTION-OPERATOR and
ACTION-COMPONENT.  Also MAKE-ACTION.
The intention is to make the ASDF code more readable.
parent 2a764194
Loading
Loading
Loading
Loading
+16 −5
Original line number Diff line number Diff line
@@ -14,6 +14,7 @@
   #: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
@@ -33,16 +34,26 @@ of steps to be performed while building a system."
and a class-name or class designates the canonical instance of the designated class."
    '(or operation null symbol class)))

;;; these are pseudo accessors -- let us abstract away the CONS cell representation of plan
;;; actions.
(with-upgradability ()
  (defun make-action (operation component)
    (cons operation component))
  (defun action-operation (action)
    (car action))
  (defun action-component (action)
    (cdr action)))

;;;; Reified representation for storage or debugging. Note: it drops the operation-original-initargs
(with-upgradability ()
  (defun action-path (action)
    "A readable data structure that identifies the action."
    (destructuring-bind (o . c) action (cons (type-of o) (component-find-path c))))
    (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 (cons (make-operation o) (find-component () c)))))

    (destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c)))))

;;;; Convenience methods
(with-upgradability ()
@@ -92,7 +103,7 @@ and a class-name or class designates the canonical instance of the designated cl
           (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
             (if (typep ,component 'component)
                 (error "No defined method for ~S on ~/asdf-action:format-action/"
                        ',function (cons ,operation ,component))
                        ',function (make-action ,operation ,component))
                 (if-let (,found (find-component () ,component))
                    ,(next-method operation found)
                    ,if-no-component))))))))
@@ -415,7 +426,7 @@ in some previous image, or T if it needs to be done.")
                     selfward-operation non-propagating-operation))
      (sysdef-error
       (compatfmt "~@<Required method ~S not implemented for ~/asdf-action:format-action/~@:>")
       'perform (cons o c))))
       'perform (make-action o c))))

  ;; The restarts of the perform-with-restarts variant matter in an interactive context.
  ;; The retry strategies of p-w-r itself, and/or the background workers of a multiprocess build
+18 −10
Original line number Diff line number Diff line
@@ -342,7 +342,7 @@ initialized with SEED."
  (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 (cons operation component)))
      (let ((action (make-action operation component)))
        (when (gethash action action-set)
          (error 'circular-dependency :actions
                 (member action (reverse action-list) :test 'equal)))
@@ -439,7 +439,7 @@ initialized with SEED."
  (defmethod (setf plan-action-status) :after
      (new-status (p sequential-plan) (o operation) (c component))
    (when (action-planned-p new-status)
      (push (cons o c) (plan-actions-r p)))))
      (push (make-action o c) (plan-actions-r p)))))


;;;; High-level interface: traverse, perform-plan, plan-operates-on-p
@@ -473,7 +473,9 @@ initialized with SEED."
    (apply 'perform-plan (plan-actions plan) keys))

  (defmethod perform-plan ((steps list) &key force &allow-other-keys)
    (loop* :for (o . c) :in steps
    (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)))

@@ -481,7 +483,7 @@ initialized with SEED."
    (plan-operates-on-p (plan-actions plan) component-path))

  (defmethod plan-operates-on-p ((plan list) (component-path list))
    (find component-path (mapcar 'cdr plan)
    (find component-path (mapcar 'action-component plan)
          :test 'equal :key 'component-find-path)))


@@ -517,7 +519,10 @@ initialized with SEED."
  (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))
      (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))
@@ -529,15 +534,18 @@ initialized with SEED."

  (defmethod plan-actions ((plan filtered-sequential-plan))
    (with-slots (keep-operation keep-component) plan
      (loop* :for (o . c) :in (call-next-method)
      (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 (cons o c))))
             :collect (make-action o c))))

  (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 'cdr (plan-actions
     (mapcar 'action-component
             (plan-actions
              (apply 'traverse-sub-actions goal-operation system
                     (remove-plist-key :goal-operation keys))))
     :from-end t)))