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

4 5
(asdf/package:define-package :asdf/operation
  (:recycle :asdf/operation :asdf)
6
  (:use :common-lisp :asdf/driver :asdf/upgrade)
7 8 9 10 11 12 13 14 15
  (:export
   #:operation
   #:operation-original-initargs ;; backward-compatibility only. DO NOT USE.
   #:make-operation
   #:find-operation))
(in-package :asdf/operation)

;;; Operation Classes

16
(when-upgrade (:when (find-class 'operation nil))
17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52
  (defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key)
    (declare (ignorable o slot-names initargs)) (values)))

(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)))))

;;; make-operation, find-operation

(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))
  (apply 'make-operation spec (operation-original-initargs context)))
(defmethod operation-original-initargs ((context null)) context)