action.lisp 26.2 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; Actions

4
(uiop/package:define-package :asdf/action
5
  (:nicknames :asdf-action)
6 7
  (:recycle :asdf/action :asdf/plan :asdf)
  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/operation)
8
  (:import-from :asdf/operation #:check-operation-constructor)
9
  (:import-from :asdf/component #:%additional-input-files)
10
  #-clisp (:unintern #:required-components #:traverse-action #:traverse-sub-actions)
11
  (:export
12
   #:action #:define-convenience-action-methods
13 14 15
   #:action-description #:format-action
   #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
   #:non-propagating-operation
16
   #:component-depends-on
17
   #:input-files #:output-files #:output-file #:operation-done-p
18
   #:action-operation #:action-component #:make-action
19
   #:component-operation-time #:mark-operation-done #:compute-action-stamp
20
   #:perform #:perform-with-restarts #:retry #:accept
21
   #:action-path #:find-action
22
   #:operation-definition-warning #:operation-definition-error ;; condition
23 24
   #:action-valid-p
   #:circular-dependency #:circular-dependency-actions
25 26
   #:call-while-visiting-action #:while-visiting-action
   #:additional-input-files))
27 28
(in-package :asdf/action)

29
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning
30 31 32 33 34

  (deftype action ()
    "A pair of operation and component uniquely identifies a node in the dependency graph
of steps to be performed while building a system."
    '(cons operation component))
35 36

  (deftype operation-designator ()
37 38
    "An operation designates itself. NIL designates a context-dependent current operation,
and a class-name or class designates the canonical instance of the designated class."
39
    '(or operation null symbol class)))
40

41 42 43 44 45 46 47 48 49
;;; 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)))
50

51
;;;; Reified representation for storage or debugging. Note: an action is identified by its class.
52 53
(with-upgradability ()
  (defun action-path (action)
54
    "A readable data structure that identifies the action."
55 56 57 58
    (when action
      (let ((o (action-operation action))
            (c (action-component action)))
        (cons (type-of o) (component-find-path c)))))
59
  (defun find-action (path)
60
    "Reconstitute an action from its action-path"
61
    (destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c)))))
62 63

;;;; Convenience methods
64
(with-upgradability ()
65 66 67 68 69 70 71 72
  ;; A macro that defines convenience methods for a generic function (gf) that
  ;; dispatches on operation and component.  The convenience methods allow users
  ;; to call the gf with operation and/or component designators, that the
  ;; methods will resolve into actual operation and component objects, so that
  ;; the users can interact using readable designators, but developers only have
  ;; to write methods that handle operation and component objects.
  ;; FUNCTION is the generic function name
  ;; FORMALS is its list of arguments, which must include OPERATION and COMPONENT.
73 74
  ;; IF-NO-OPERATION is a form (defaults to NIL) describing what to do if no operation is found.
  ;; IF-NO-COMPONENT is a form (defaults to NIL) describing what to do if no component is found.
75
  (defmacro define-convenience-action-methods
76
      (function formals &key if-no-operation if-no-component)
77 78
    (let* ((rest (gensym "REST"))
           (found (gensym "FOUND"))
79 80 81
           (keyp (equal (last formals) '(&key)))
           (formals-no-key (if keyp (butlast formals) formals))
           (len (length formals-no-key))
82 83 84 85
           (operation 'operation)
           (component 'component)
           (opix (position operation formals))
           (coix (position component formals))
86 87 88
           (first-arg (if (< opix coix) operation component))
           (prefix (subseq formals 0 (min opix coix)))
           (suffix (subseq formals (1+ (max opix coix)) len))
89
           (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
90 91
      (assert (and (integerp opix) (integerp coix)
                   (or (= coix (1+ opix)) (= opix (1+ coix)))))
92 93
      (flet ((next-method (o c)
               (if keyp
94 95 96 97 98 99
                   `(apply ',function ,@prefix ,(if (eq first-arg operation) o c)
                           ,(if (eq first-arg operation) c o)
                           ,@suffix ,rest)
                   `(,function ,@prefix
                               ,(if (eq first-arg operation) o c)
                               ,(if (eq first-arg operation) c o) ,@suffix))))
100
        `(progn
101 102
           (defmethod ,function (,@prefix ,(if (eq first-arg operation) `(,operation string) component)
                                 ,(if (eq first-arg operation) component `(,operation string)) ,@suffix ,@more-args)
103
             (declare (notinline ,function))
104 105
             (let ((,component (find-component () ,component))) ;; do it first, for defsystem-depends-on
               ,(next-method `(safe-read-from-string ,operation :package :asdf/interface) component)))
106 107
           (defmethod ,function (,@prefix ,(if (eq first-arg operation) `(,operation symbol) component)
                                 ,(if (eq first-arg operation) component `(,operation symbol)) ,@suffix ,@more-args)
108
             (declare (notinline ,function))
109 110
             (if ,operation
                 ,(next-method
111
                   `(make-operation ,operation)
112 113
                   `(or (find-component () ,component) ,if-no-component))
                 ,if-no-operation))
114 115
           (defmethod ,function (,@prefix ,(if (eq first-arg operation) `(,operation operation) component)
                                 ,(if (eq first-arg operation) component `(,operation operation)) ,@suffix ,@more-args)
116
             (declare (notinline ,function))
117 118
             (if (typep ,component 'component)
                 (error "No defined method for ~S on ~/asdf-action:format-action/"
119
                        ',function (make-action ,operation ,component))
120 121 122
                 (if-let (,found (find-component () ,component))
                    ,(next-method operation found)
                    ,if-no-component))))))))
123

124

125
;;;; Self-description
126 127 128
(with-upgradability ()
  (defgeneric action-description (operation component)
    (:documentation "returns a phrase that describes performing this operation
129 130
on this component, e.g. \"loading /a/b/c\".
You can put together sentences using this phrase."))
131 132
  (defmethod action-description (operation component)
    (format nil (compatfmt "~@<~A on ~A~@:>")
133
            operation component))
134

135
  (defun format-action (stream action &optional colon-p at-sign-p)
136 137
    "FORMAT helper to display an action's action-description.
Use it in FORMAT control strings as ~/asdf-action:format-action/"
138 139 140
    (assert (null colon-p)) (assert (null at-sign-p))
    (destructuring-bind (operation . component) action
      (princ (action-description operation component) stream))))
141 142


143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178
;;;; Detection of circular dependencies
(with-upgradability ()
  (defun (action-valid-p) (operation component)
    "Is this action valid to include amongst dependencies?"
    ;; If either the operation or component was resolved to nil, the action is invalid.
    ;; :if-feature will invalidate actions on components for which the features don't apply.
    (and operation component
         (if-let (it (component-if-feature component)) (featurep it) t)))

  (define-condition circular-dependency (system-definition-error)
    ((actions :initarg :actions :reader circular-dependency-actions))
    (:report (lambda (c s)
               (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
                       (circular-dependency-actions c)))))

  (defun call-while-visiting-action (operation component fun)
    "Detect circular dependencies"
    (with-asdf-session ()
      (with-accessors ((action-set visiting-action-set)
                       (action-list visiting-action-list)) *asdf-session*
        (let ((action (cons operation component)))
          (when (gethash action action-set)
            (error 'circular-dependency :actions
                   (member action (reverse action-list) :test 'equal)))
          (setf (gethash action action-set) t)
          (push action action-list)
          (unwind-protect
               (funcall fun)
            (pop action-list)
            (setf (gethash action action-set) nil))))))

  ;; Syntactic sugar for call-while-visiting-action
  (defmacro while-visiting-action ((o c) &body body)
    `(call-while-visiting-action ,o ,c #'(lambda () ,@body))))


179
;;;; Dependencies
180
(with-upgradability ()
181
  (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
182 183
    (:documentation
     "Returns a list of dependencies needed by the component to perform
184 185
    the operation.  A dependency has one of the following forms:

186 187 188 189 190
      (<operation> <component>*), where <operation> is an operation designator
        with respect to FIND-OPERATION in the context of the OPERATION argument,
        and each <component> is a component designator with respect to
        FIND-COMPONENT in the context of the COMPONENT argument,
        and means that the component depends on
191 192 193 194
        <operation> having been performed on each <component>;

        [Note: an <operation> is an operation designator -- it can be either an
        operation name or an operation object.  Similarly, a <component> may be
195 196
        a component name or a component object.  Also note that, the degenerate
        case of (<operation>) is a no-op.]
197

198
    Methods specialized on subclasses of existing component types
199
    should usually append the results of CALL-NEXT-METHOD to the list."))
200
  (define-convenience-action-methods component-depends-on (operation component))
201 202 203

  (defmethod component-depends-on :around ((o operation) (c component))
    (do-asdf-cache `(component-depends-on ,o ,c)
204
      (call-next-method))))
205 206


207 208
;;;; upward-operation, downward-operation, sideway-operation, selfward-operation
;; These together handle actions that propagate along the component hierarchy or operation universe.
209 210 211
(with-upgradability ()
  (defclass downward-operation (operation)
    ((downward-operation
212
      :initform nil :reader downward-operation
213
      :type operation-designator :allocation :class))
214 215 216 217 218 219
    (:documentation "A DOWNWARD-OPERATION's dependencies propagate down the component hierarchy.
I.e., if O is a DOWNWARD-OPERATION and its DOWNWARD-OPERATION slot designates operation D, then
the action (O . M) of O on module M will depends on each of (D . C) for each child C of module M.
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."))
220 221
  (defun downward-operation-depends-on (o c)
    `((,(or (downward-operation o) o) ,@(component-children c))))
222
  (defmethod component-depends-on ((o downward-operation) (c parent-component))
223
    `(,@(downward-operation-depends-on o c) ,@(call-next-method)))
224

225 226
  (defclass upward-operation (operation)
    ((upward-operation
227
      :initform nil :reader upward-operation
228
      :type operation-designator :allocation :class))
229 230 231 232 233 234
    (:documentation "An UPWARD-OPERATION has dependencies that propagate up the component hierarchy.
I.e., if O is an instance of UPWARD-OPERATION, and its UPWARD-OPERATION slot designates operation U,
then the action (O . C) of O on a component C that has the parent P will depends on (U . P).
The default value for slot UPWARD-OPERATION is NIL, which designates the operation O itself.
E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, its PARENT
must first be prepared for loading or compiling with PREPARE-OP."))
235 236
  ;; For backward-compatibility reasons, a system inherits from module and is a child-component
  ;; so we must guard against this case. ASDF4: remove that.
237 238
  (defun upward-operation-depends-on (o c)
    (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p))))
239
  (defmethod component-depends-on ((o upward-operation) (c child-component))
240
    `(,@(upward-operation-depends-on o c) ,@(call-next-method)))
241

242 243
  (defclass sideway-operation (operation)
    ((sideway-operation
244
      :initform nil :reader sideway-operation
245
      :type operation-designator :allocation :class))
246 247 248 249 250 251
    (:documentation "A SIDEWAY-OPERATION has dependencies that propagate \"sideway\" to siblings
that a component depends on. I.e. if O is a SIDEWAY-OPERATION, and its SIDEWAY-OPERATION slot
designates operation S (where NIL designates O itself), then the action (O . C) of O on component 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."))
252
  (defun sideway-operation-depends-on (o c)
253
    `((,(or (sideway-operation o) o) ,@(component-sideway-dependencies c))))
254 255
  (defmethod component-depends-on ((o sideway-operation) (c component))
    `(,@(sideway-operation-depends-on o c) ,@(call-next-method)))
256

257 258
  (defclass selfward-operation (operation)
    ((selfward-operation
259
      ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which
260
      :type (or operation-designator list) :reader selfward-operation :allocation :class))
261
    (:documentation "A SELFWARD-OPERATION depends on another operation on the same component.
262 263
I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates a list of operations L,
then the action (O . C) of O on component C depends on each (S . C) for S in L.
264
E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP.
265 266
A operation-designator designates a singleton list of the designated operation;
a list of operation-designators designates the list of designated operations;
267 268 269
NIL is not a valid operation designator in that context.  Note that any dependency
ordering between the operations in a list of SELFWARD-OPERATION should be specified separately
in the respective operation's COMPONENT-DEPENDS-ON methods so that they be scheduled properly."))
270 271
  (defun selfward-operation-depends-on (o c)
    (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c)))
272
  (defmethod component-depends-on ((o selfward-operation) (c component))
273
    `(,@(selfward-operation-depends-on o c) ,@(call-next-method)))
274 275 276

  (defclass non-propagating-operation (operation)
    ()
277
    (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates
278 279 280 281 282 283 284 285
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.")))


;;;---------------------------------------------------------------------------
;;; Help programmers catch obsolete OPERATION subclasses
;;;---------------------------------------------------------------------------
286 287 288 289 290 291 292 293 294 295
(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)
296
    (check-operation-constructor)
297
    (unless (typep o '(or downward-operation upward-operation sideway-operation
298
                          selfward-operation non-propagating-operation))
299 300 301 302 303 304 305 306 307 308 309 310 311 312 313
      (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)))))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
314 315
  (defun backward-compatible-depends-on (o c)
    "DEPRECATED: all subclasses of OPERATION used in ASDF should inherit from one of
316 317 318
 DOWNWARD-OPERATION UPWARD-OPERATION SIDEWAY-OPERATION SELFWARD-OPERATION NON-PROPAGATING-OPERATION.
 The function BACKWARD-COMPATIBLE-DEPENDS-ON temporarily provides ASDF2 behaviour for those that
 don't. In the future this functionality will be removed, and the default will be no propagation."
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
319 320
    (uiop/version::notify-deprecated-function
     (version-deprecation *asdf-version* :style-warning "3.2")
321
     `(backward-compatible-depends-on :for-operation ,o))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
322 323
    `(,@(sideway-operation-depends-on o c)
      ,@(when (typep c 'parent-component) (downward-operation-depends-on o c))))
324

325 326 327
  (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)))
328 329 330 331 332
        ;; 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))
            (backward-compatible-depends-on o c))))
333 334 335 336

  (defmethod downward-operation ((o operation)) nil)
  (defmethod sideway-operation ((o operation)) nil))

337 338 339 340

;;;---------------------------------------------------------------------------
;;; End of OPERATION class checking
;;;---------------------------------------------------------------------------
341 342 343


;;;; Inputs, Outputs, and invisible dependencies
344
(with-upgradability ()
345
  (defgeneric output-files (operation component)
346
    (:documentation "Methods for this function return two values: a list of output files
347 348 349
corresponding to this action, and a boolean indicating if they have already been subjected
to relevant output translations and should not be further translated.

350
Methods on PERFORM *must* call this function to determine where their outputs are to be located.
351 352
They may rely on the order of the files to discriminate between outputs.
"))
353
  (defgeneric input-files (operation component)
354 355
    (:documentation "A list of input files corresponding to this action.

356
Methods on PERFORM *must* call this function to determine where their inputs are located.
357 358
They may rely on the order of the files to discriminate between inputs.
"))
359
  (defgeneric operation-done-p (operation component)
360
    (:documentation "Returns a boolean which is NIL if the action must be performed (again)."))
361 362 363 364 365 366 367
  (define-convenience-action-methods output-files (operation component))
  (define-convenience-action-methods input-files (operation component))
  (define-convenience-action-methods operation-done-p (operation component))

  (defmethod operation-done-p ((o operation) (c component))
    t)

368
  ;; Translate output files, unless asked not to. Memoize the result.
369
  (defmethod output-files :around ((operation t) (component t))
370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392
    (do-asdf-cache `(output-files ,operation ,component)
      (values
       (multiple-value-bind (pathnames fixedp) (call-next-method)
         ;; 1- Make sure we have absolute pathnames
         (let* ((directory (pathname-directory-pathname
                            (component-pathname (find-component () component))))
                (absolute-pathnames
                  (loop
                    :for pathname :in pathnames
                    :collect (ensure-absolute-pathname pathname directory))))
           ;; 2- Translate those pathnames as required
           (if fixedp
               absolute-pathnames
               (mapcar *output-translation-function* absolute-pathnames))))
       t)))
  (defmethod output-files ((o operation) (c component))
    nil)
  (defun output-file (operation component)
    "The unique output file of performing OPERATION on COMPONENT"
    (let ((files (output-files operation component)))
      (assert (length=n-p files 1))
      (first files)))

393
  (defgeneric additional-input-files (operation component)
394 395
    (:documentation "Additional input files for the operation on this
    component.  These are files that are inferred, rather than
396 397 398 399
    explicitly specified."))
  (define-convenience-action-methods additional-input-files (operation component))
  (defmethod additional-input-files ((op operation) (comp component))
      (cdr (assoc op (%additional-input-files comp))))
400

401
  ;; Memoize input files.
402 403
  (defmethod input-files :around (operation component)
    (do-asdf-cache `(input-files ,operation ,component)
404 405 406 407
      ;; get the additional input files, if any
      (append (call-next-method)
              ;; must come after the first, for other code that
              ;; assumes the first will be the "key" file
408
              (additional-input-files operation component))))
409

410
  ;; By default an action has no input-files.
411
  (defmethod input-files ((o operation) (c component))
412 413
    nil)

414 415 416 417
  ;; An action with a selfward-operation by default gets its input-files from the output-files of
  ;; the actions using selfward-operations it depends on (and the same component),
  ;; or if there are none, on the component-pathname of the component if it's a file
  ;; -- and then on the results of the next-method.
418 419 420 421 422 423
  (defmethod input-files ((o selfward-operation) (c component))
    `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o))
                  :append (or (output-files dep-o c) (input-files dep-o c)))
            (if-let ((pathname (component-pathname c)))
              (and (file-pathname-p pathname) (list pathname))))
      ,@(call-next-method))))
424 425 426


;;;; Done performing
427
(with-upgradability ()
428 429 430 431 432
  ;; ASDF4: hide it behind plan-action-stamp
  (defgeneric component-operation-time (operation component)
    (:documentation "Return the timestamp for when an action was last performed"))
  (defgeneric (setf component-operation-time) (time operation component)
    (:documentation "Update the timestamp for when an action was last performed"))
433
  (define-convenience-action-methods component-operation-time (operation component))
434

435 436 437 438 439 440
  ;; ASDF4: hide it behind (setf plan-action-stamp)
  (defgeneric mark-operation-done (operation component)
    (:documentation "Mark a action as having been just done.

Updates the action's COMPONENT-OPERATION-TIME to match the COMPUTE-ACTION-STAMP
using the JUST-DONE flag."))
441 442
  (defgeneric compute-action-stamp (plan operation component &key just-done)
    (:documentation "Has this action been successfully done already,
443
and at what known timestamp has it been done at or will it be done at?
444 445 446 447
* PLAN is a plan object modelling future effects of actions,
  or NIL to denote what actually happened.
* OPERATION and COMPONENT denote the action.
Takes keyword JUST-DONE:
448 449 450
* JUST-DONE is a boolean that is true if the action was just successfully performed,
  at which point we want compute the actual stamp and warn if files are missing;
  otherwise we are making plans, anticipating the effects of the action.
451 452
Returns two values:
* a STAMP saying when it was done or will be done,
453
  or T if the action involves files that need to be recomputed.
454 455 456
* a boolean DONE-P that indicates whether the action has actually been done,
  and both its output-files and its in-image side-effects are up to date."))

457
  (defmethod component-operation-time ((o operation) (c component))
458
    (gethash o (component-operation-times c)))
459

460
  (defmethod (setf component-operation-time) (stamp (o operation) (c component))
461
    (assert stamp () "invalid null stamp for ~A" (action-description o c))
462
    (setf (gethash o (component-operation-times c)) stamp))
463

464
  (defmethod mark-operation-done ((o operation) (c component))
465 466 467
    (let ((stamp (compute-action-stamp nil o c :just-done t)))
      (assert stamp () "Failed to compute a stamp for completed action ~A" (action-description o c))1
      (setf (component-operation-time o c) stamp))))
468 469 470


;;;; Perform
471
(with-upgradability ()
472
  (defgeneric perform (operation component)
473
    (:documentation "PERFORM an action, consuming its input-files and building its output-files"))
474 475
  (define-convenience-action-methods perform (operation component))

476
  (defmethod perform :around ((o operation) (c component))
477
    (while-visiting-action (o c) (call-next-method)))
478 479 480 481 482 483 484
  (defmethod perform :before ((o operation) (c component))
    (ensure-all-directories-exist (output-files o c)))
  (defmethod perform :after ((o operation) (c component))
    (mark-operation-done o c))
  (defmethod perform ((o operation) (c parent-component))
    nil)
  (defmethod perform ((o operation) (c source-file))
485 486 487 488 489
    ;; For backward compatibility, don't error on operations that don't specify propagation.
    (when (typep o '(or downward-operation upward-operation sideway-operation
                     selfward-operation non-propagating-operation))
      (sysdef-error
       (compatfmt "~@<Required method ~S not implemented for ~/asdf-action:format-action/~@:>")
490
       'perform (make-action o c))))
491

492 493 494
  ;; 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
  ;; may call perform directly rather than call p-w-r.
495
  (defgeneric perform-with-restarts (operation component)
496
    (:documentation "PERFORM an action in a context where suitable restarts are in place."))
497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514
  (defmethod perform-with-restarts (operation component)
    (perform operation component))
  (defmethod perform-with-restarts :around (operation component)
    (loop
      (restart-case
          (return (call-next-method))
        (retry ()
          :report
          (lambda (s)
            (format s (compatfmt "~@<Retry ~A.~@:>")
                    (action-description operation component))))
        (accept ()
          :report
          (lambda (s)
            (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
                    (action-description operation component)))
          (mark-operation-done operation component)
          (return))))))