Newer
Older
;;;; -------------------------------------------------------------------------
;;;; Operations
Francois-Rene Rideau
committed
(asdf/package:define-package :asdf/operation
(:recycle :asdf/operation :asdf)
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
(: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)