1 (in-package "SPECIALIZABLE")
3 (defclass prototype-object ()
4 (;; FIXME: we should add slots at some point
5 (delegations :initarg :delegations :accessor delegations)
6 (roles :initform (make-array 0 :adjustable t :fill-pointer t)
10 (defmethod print-object ((o prototype-object) s)
11 (if (slot-boundp o 'name)
12 (format s "~S" (slot-value o 'name))
13 (print-unreadable-object (o s :type t :identity t)
14 (format s "[~{~S~^, ~}]" (delegations o)))))
15 (defun add-delegation (obj del)
16 (push del (delegations obj)))
17 (defun remove-delegation (obj)
18 (pop (delegations obj)))
19 (defun map-delegations (fun obj)
21 ;; FIXME: should we maintain a table of visited nodes? Should it be
22 ;; topologically sorted? Section 5.3 in PwMD [Salzman & Aldrich]
23 ;; suggests not, at least for now
24 (mapc (lambda (o) (map-delegations fun o)) (delegations obj))
26 (defstruct (role (:type list) (:constructor make-role (method argpos)))
28 (defun add-role (obj role)
29 (let ((pos (role-argpos role))
31 (unless (< pos (length roles))
32 (dotimes (i (- (1+ pos) (length roles)))
33 (vector-push-extend nil roles)))
34 (pushnew (role-method role) (aref roles pos))))
35 (defun remove-role (obj role)
36 (let ((pos (role-argpos role)))
37 (setf (aref (roles obj) pos)
38 (remove (role-method role) (aref (roles obj) pos)))
41 (when (or (= (length (roles obj)) 0)
42 (aref (roles obj) (1- (length (roles obj)))))
44 (vector-pop (roles obj))
47 (defun map-roles (fun obj)
48 (dotimes (i (length (roles obj)))
49 (dolist (m (aref (roles obj) i))
50 (funcall fun (make-role m i)))))
51 (defun find-role (role obj)
52 (when (< (role-argpos role) (length (roles obj)))
53 (find (role-method role) (aref (roles obj) (role-argpos role)))))
54 (defmacro do-roles ((rvar form &optional result) &body body)
55 `(progn (map-roles (lambda (,rvar) ,@body) ,form) ,result))
57 (let ((result (make-instance 'prototype-object
58 :delegations (copy-list (delegations p)))))
59 (do-roles (r p result)
60 (add-role result r))))
62 ;;; redefinition semantics are interesting. We need the INFO here so
63 ;;; that we can implement specializer-accepts-p, which must be able to
64 ;;; lookup the particular method/argpos that the specializer
65 ;;; represents. But we must also be able to redefine methods in a way
66 ;;; that isn't insane, which I think implies that same-specializer-p
67 ;;; should ignore the INFO and just use the OBJECT.
68 (defclass prototype-specializer (extended-specializer)
69 ((role :accessor prototype-specializer-role)
70 (object :initarg :object :accessor prototype-specializer-object)))
71 (defmethod print-object ((o prototype-specializer) s)
72 (print-unreadable-object (o s :type t :identity t)
73 (format s "~S" (prototype-specializer-object o))))
74 (defmethod sb-pcl::same-specializer-p
75 ((s1 prototype-specializer) (s2 prototype-specializer))
76 (eql (prototype-specializer-object s1)
77 (prototype-specializer-object s2)))
78 (defclass prototype-generic-function (specializable-generic-function)
80 (:metaclass sb-mop:funcallable-standard-class))
81 (defmethod sb-pcl:make-method-specializers-form
82 ((gf prototype-generic-function) method snames env)
85 (sb-mop:specializer x)
86 (symbol `(make-instance 'prototype-specializer :object ,x))
87 ((cons (eql 'class)) `(find-class ',(cadr x)))
88 ((cons (eql 'eql)) `(sb-mop:intern-eql-specializer ,(cadr x)))
89 (t (error "unexpected specializer name: ~S" x)))))
90 `(list ,@(mapcar #'frob snames))))
91 (defmethod sb-pcl:parse-specializer-using-class
92 ((gf prototype-generic-function) name)
93 (make-instance 'prototype-specializer :object name))
94 (defmethod sb-pcl:unparse-specializer-using-class
95 ((gf prototype-generic-function) (s prototype-specializer))
96 (let ((object (prototype-specializer-object s)))
97 (if (slot-boundp object 'name)
98 (slot-value object 'name)
101 (defmethod add-method :after ((gf prototype-generic-function) m)
102 (let ((ss (sb-mop:method-specializers m)))
105 (s (car ss) (car ss)))
107 (when (typep s 'prototype-specializer)
108 (let ((object (prototype-specializer-object s))
109 (role (make-role m i)))
110 (setf (prototype-specializer-role s) role)
111 (add-role object role))))))
112 (defmethod remove-method :after ((gf prototype-generic-function) m)
113 (let ((ss (sb-mop:method-specializers m)))
116 (s (car ss) (car ss)))
118 (when (typep s 'prototype-specializer)
119 (let ((object (prototype-specializer-object s))
120 (role (make-role m i)))
121 (setf (prototype-specializer-role s) nil)
122 ;; this is one of the places where the semantics
123 ;; are... dodgy. Removing the method from the generic
124 ;; function, and the role from the object, doesn't affect
125 ;; the roles in any clones. We could potentially use the
126 ;; fact that once removed the method is no longer associated
127 ;; with a generic function? Hm, C-A-M will not consider the
128 ;; removed method for applicability...
129 (remove-role object role))))))
131 (defmethod generalizer-of-using-class
132 ((gf prototype-generic-function) (object prototype-object))
135 (defmethod specializer-accepts-generalizer-p
136 ((gf prototype-generic-function) (s prototype-specializer) object)
137 (values (specializer-accepts-p s object) t))
139 (defmethod specializer-accepts-p ((specializer prototype-specializer) object)
141 ((not (typep object 'prototype-object)) nil)
142 ((eql (prototype-specializer-object specializer) /root/) t)
144 (let ((role (prototype-specializer-role specializer)))
147 (when (find-role role o)
148 (return-from specializer-accepts-p t)))
151 (defmethod specializer< ((gf prototype-generic-function) (s1 prototype-specializer) (s2 prototype-specializer) g)
152 (let ((o1 (prototype-specializer-object s1))
153 (o2 (prototype-specializer-object s2)))
157 ((eql o o1) (return-from specializer< '<))
158 ((eql o o2) (return-from specializer< '>))))
162 (defmethod compute-applicable-methods-using-generalizers ((gf prototype-generic-function) generalizers)
164 (defmethod generalizer-equal-hash-key ((gf prototype-generic-function) (g prototype-object))
167 (defmacro defpvar (name value)
169 (setf (slot-value val 'name) ',name)
170 (defparameter ,name val)))
172 (defpvar /root/ (make-instance 'prototype-object :delegations nil))
173 (defpvar /animal/ (clone /root/))
174 (defpvar /fish/ (clone /root/))
175 (defpvar /shark/ (clone /root/))
176 (defpvar /healthy-shark/ (clone /root/))
177 (defpvar /dying-shark/ (clone /root/))
178 (add-delegation /fish/ /animal/)
179 (add-delegation /shark/ /animal/)
180 (add-delegation /shark/ /healthy-shark/)
181 (defgeneric encounter (x y)
182 (:generic-function-class prototype-generic-function))
183 (defmethod encounter ((x /fish/) (y /healthy-shark/))
184 (format t "~&~A swims away~%" x))
185 (defmethod encounter ((x /fish/) (y /animal/))
187 (defgeneric fight (x y)
188 (:generic-function-class prototype-generic-function))
189 (defmethod fight ((x /healthy-shark/) (y /shark/))
190 (remove-delegation x)
191 (add-delegation x /dying-shark/)
193 (defmethod encounter ((x /healthy-shark/) (y /fish/))
194 (format t "~&~A swallows ~A~%" x y))
195 (defmethod encounter ((x /healthy-shark/) (y /shark/))
196 (format t "~&~A fights ~A~%" x y)