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

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

;;; Operation Classes

16
(when-upgrading (:when (find-class 'operation nil))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
17 18 19
  ;; override any obsolete shared-initialize method when upgrading from ASDF2.
  (defmethod shared-initialize :after ((o operation) (slot-names t) &key)
    (values)))
20

21 22 23 24 25
(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)))

26 27
  ;; Cache a copy of the INITARGS in the ORIGINAL-INITARGS slot, if that slot is not
  ;; already bound.
28 29
  (defmethod initialize-instance :after ((o operation) &rest initargs
                                         &key force force-not system verbose &allow-other-keys)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
30
    (declare (ignore force force-not system verbose))
31 32 33 34 35 36 37
    (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))))))
38 39 40

;;; make-operation, find-operation

41
(with-upgradability ()
42 43
  (defparameter* *operations* (make-hash-table :test 'equal))

44
  (defun make-operation (operation-class &rest initargs)
45 46 47 48
    (let ((class (coerce-class operation-class
                               :package :asdf/interface :super 'operation :error 'sysdef-error)))
      (ensure-gethash (cons class initargs) *operations*
                      (list* 'make-instance class initargs))))
49 50 51

  (defgeneric find-operation (context spec)
    (:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
52
  (defmethod find-operation ((context t) (spec operation))
53 54
    spec)
  (defmethod find-operation (context (spec symbol))
55
    (when spec ;; NIL designates itself, i.e. absence of operation
56
      (apply 'make-operation spec (operation-original-initargs context))))
57 58
  (defmethod find-operation (context (spec string))
    (apply 'make-operation spec (operation-original-initargs context)))
59 60
  (defmethod operation-original-initargs ((context symbol))
    (declare (ignorable context))
61
    nil))
62