operation.lisp 2.56 KB
Newer Older
1
2
3
;;;; -------------------------------------------------------------------------
;;;; Operations

4
(asdf/package:define-package :asdf/operation
5
  (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5.
6
  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
7
8
9
  (:export
   #:operation
   #:operation-original-initargs ;; backward-compatibility only. DO NOT USE.
10
   #:build-op ;; THE generic operation
11
   #:*operations* #:make-operation #:find-operation #:feature))
12
13
14
15
(in-package :asdf/operation)

;;; Operation Classes

16
(when-upgrading (:when (find-class 'operation nil))
17
18
19
  (defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key)
    (declare (ignorable o slot-names initargs)) (values)))

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
(with-upgradability ()
  (defclass operation ()
    ((original-initargs ;; for backward-compat -- used by GBBopen and swank (via operation-forced)
      :initform nil :initarg :original-initargs :accessor operation-original-initargs)))

  (defmethod initialize-instance :after ((o operation) &rest initargs
                                         &key force force-not system verbose &allow-other-keys)
    (declare (ignorable force force-not system verbose))
    (unless (slot-boundp o 'original-initargs)
      (setf (operation-original-initargs o) initargs)))

  (defmethod print-object ((o operation) stream)
    (print-unreadable-object (o stream :type t :identity nil)
      (ignore-errors
       (format stream "~{~S~^ ~}" (operation-original-initargs o))))))
35
36
37

;;; make-operation, find-operation

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
(with-upgradability ()
  (defparameter *operations* (make-hash-table :test 'equal))
  (defun make-operation (operation-class &rest initargs)
    (let ((key (cons operation-class initargs)))
      (multiple-value-bind (operation foundp) (gethash key *operations*)
        (if foundp operation
            (setf (gethash key *operations*)
                  (apply 'make-instance operation-class initargs))))))

  (defgeneric find-operation (context spec)
    (:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
  (defmethod find-operation (context (spec operation))
    (declare (ignorable context))
    spec)
  (defmethod find-operation (context (spec symbol))
53
    (unless (member spec '(nil feature))
54
55
      ;; NIL designates itself, i.e. absence of operation
      ;; FEATURE is the ASDF1 misfeature that comes with IF-COMPONENT-DEP-FAILS
56
      (apply 'make-operation spec (operation-original-initargs context))))
57
58
59
60
61
62
  (defmethod operation-original-initargs ((context symbol))
    (declare (ignorable context))
    nil)

  (defclass build-op (operation) ()))

63