...
 
Commits (9)
...@@ -14,6 +14,7 @@ ...@@ -14,6 +14,7 @@
#:component-depends-on #:component-depends-on
#:input-files #:output-files #:output-file #:operation-done-p #:input-files #:output-files #:output-file #:operation-done-p
#:action-status #:action-stamp #:action-done-p #:action-status #:action-stamp #:action-done-p
#:action-operation #:action-component #:make-action
#:component-operation-time #:mark-operation-done #:compute-action-stamp #:component-operation-time #:mark-operation-done #:compute-action-stamp
#:perform #:perform-with-restarts #:retry #:accept #:perform #:perform-with-restarts #:retry #:accept
#:action-path #:find-action #:stamp #:done-p #:action-path #:find-action #:stamp #:done-p
...@@ -33,16 +34,26 @@ of steps to be performed while building a system." ...@@ -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." and a class-name or class designates the canonical instance of the designated class."
'(or operation null symbol 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 ;;;; Reified representation for storage or debugging. Note: it drops the operation-original-initargs
(with-upgradability () (with-upgradability ()
(defun action-path (action) (defun action-path (action)
"A readable data structure that identifies the 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) (defun find-action (path)
"Reconstitute an action from its 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 ;;;; Convenience methods
(with-upgradability () (with-upgradability ()
...@@ -92,7 +103,7 @@ and a class-name or class designates the canonical instance of the designated cl ...@@ -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) (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
(if (typep ,component 'component) (if (typep ,component 'component)
(error "No defined method for ~S on ~/asdf-action:format-action/" (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)) (if-let (,found (find-component () ,component))
,(next-method operation found) ,(next-method operation found)
,if-no-component)))))))) ,if-no-component))))))))
...@@ -415,7 +426,7 @@ in some previous image, or T if it needs to be done.") ...@@ -415,7 +426,7 @@ in some previous image, or T if it needs to be done.")
selfward-operation non-propagating-operation)) selfward-operation non-propagating-operation))
(sysdef-error (sysdef-error
(compatfmt "~@<Required method ~S not implemented for ~/asdf-action:format-action/~@:>") (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 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 ;; The retry strategies of p-w-r itself, and/or the background workers of a multiprocess build
......
...@@ -342,7 +342,7 @@ initialized with SEED." ...@@ -342,7 +342,7 @@ initialized with SEED."
(defmethod call-while-visiting-action ((plan plan-traversal) operation component fun) (defmethod call-while-visiting-action ((plan plan-traversal) operation component fun)
(with-accessors ((action-set plan-visiting-action-set) (with-accessors ((action-set plan-visiting-action-set)
(action-list plan-visiting-action-list)) plan (action-list plan-visiting-action-list)) plan
(let ((action (cons operation component))) (let ((action (make-action operation component)))
(when (gethash action action-set) (when (gethash action action-set)
(error 'circular-dependency :actions (error 'circular-dependency :actions
(member action (reverse action-list) :test 'equal))) (member action (reverse action-list) :test 'equal)))
...@@ -439,7 +439,7 @@ initialized with SEED." ...@@ -439,7 +439,7 @@ initialized with SEED."
(defmethod (setf plan-action-status) :after (defmethod (setf plan-action-status) :after
(new-status (p sequential-plan) (o operation) (c component)) (new-status (p sequential-plan) (o operation) (c component))
(when (action-planned-p new-status) (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 ;;;; High-level interface: traverse, perform-plan, plan-operates-on-p
...@@ -473,7 +473,9 @@ initialized with SEED." ...@@ -473,7 +473,9 @@ initialized with SEED."
(apply 'perform-plan (plan-actions plan) keys)) (apply 'perform-plan (plan-actions plan) keys))
(defmethod perform-plan ((steps list) &key force &allow-other-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)))) :when (or force (not (nth-value 1 (compute-action-stamp nil o c))))
:do (perform-with-restarts o c))) :do (perform-with-restarts o c)))
...@@ -481,7 +483,7 @@ initialized with SEED." ...@@ -481,7 +483,7 @@ initialized with SEED."
(plan-operates-on-p (plan-actions plan) component-path)) (plan-operates-on-p (plan-actions plan) component-path))
(defmethod plan-operates-on-p ((plan list) (component-path list)) (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))) :test 'equal :key 'component-find-path)))
...@@ -517,7 +519,10 @@ initialized with SEED." ...@@ -517,7 +519,10 @@ initialized with SEED."
(defun* (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." "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))) (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)) plan))
(defgeneric traverse-sub-actions (operation component &key &allow-other-keys)) (defgeneric traverse-sub-actions (operation component &key &allow-other-keys))
...@@ -529,16 +534,19 @@ initialized with SEED." ...@@ -529,16 +534,19 @@ initialized with SEED."
(defmethod plan-actions ((plan filtered-sequential-plan)) (defmethod plan-actions ((plan filtered-sequential-plan))
(with-slots (keep-operation keep-component) 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)) :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) (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 "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." return a list of the components involved in building the desired action."
(remove-duplicates (remove-duplicates
(mapcar 'cdr (plan-actions (mapcar 'action-component
(apply 'traverse-sub-actions goal-operation system (plan-actions
(remove-plist-key :goal-operation keys)))) (apply 'traverse-sub-actions goal-operation system
(remove-plist-key :goal-operation keys))))
:from-end t))) :from-end t)))