operation.lisp 2.04 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 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
;;;; -------------------------------------------------------------------------
;;;; Operations

(defpackage :asdf/operation
  (:use :common-lisp :asdf/utility :asdf/upgrade)
  (:export
   #:operation
   #:operation-original-initargs ;; backward-compatibility only. DO NOT USE.
   #:make-operation
   #:find-operation))

(in-package :asdf/operation)

;;; Operation Classes

(with-upgrade (:when (find-class 'operation nil))
  (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)