1 ;;; written by David Lichteblau, based on code by Christophe Rhodes,
4 ;;; http://www.lichteblau.com/git/?p=specializable.git;a=blob_plain;f=specializable.lisp;hb=eb30d235951c3c1d128811278760f1db36cd336c
6 (defpackage "SPECIALIZABLE"
8 (:export "SPECIALIZABLE-GENERIC-FUNCTION" "SPECIALIZABLE-METHOD"
11 "SPECIALIZER-ACCEPTS-P" "SPECIALIZER-ACCEPTS-CLASS-P"
14 "GENERALIZER-OF-USING-CLASS"
15 "COMPUTE-APPLICABLE-METHODS-USING-GENERALIZERS"
17 "DEFINE-EXTENDED-SPECIALIZER"))
19 (in-package "SPECIALIZABLE")
21 (defclass extended-specializer (sb-mop:specializer)
22 ((direct-methods :initform nil
23 :accessor %specializer-direct-methods
24 :reader specializer-direct-methods)))
26 (defclass specializable-generic-function (standard-generic-function)
27 ((extended-specializers :initform (make-hash-table :test 'equal)
28 :reader generic-function-extended-specializers)
29 (emf-table :initform (make-hash-table :test 'equal) :reader emf-table))
30 (:metaclass sb-mop:funcallable-standard-class)
31 (:default-initargs :method-class (find-class 'specializable-method)))
33 (defclass specializable-method (standard-method)
34 ((lambda-expression :initarg :lambda-expression
35 :accessor specializable-method-lambda-expression)))
37 (defmacro define-extended-specializer (name (gf-var &rest args) &body body)
39 `(setf (get ',name 'extended-specializer-parser)
40 (lambda (,gf-var ,@args)
43 ;; doesn't work, because we'd have to dump GF into the fasl for the macro
45 ;;; (defun intern-extended-specializer (gf sname)
46 ;;; (destructuring-bind (kind &rest args) sname
47 ;;; (setf (gethash sname (generic-function-extended-specializers gf))
48 ;;; (apply (or (get kind 'extended-specializer-parser)
49 ;;; (error "not declared as an extended specializer name: ~A"
54 (defun make-extended-specializer (sname)
55 (destructuring-bind (kind &rest args) sname
56 (apply (or (get kind 'extended-specializer-parser)
57 (error "not declared as an extended specializer name: ~A"
59 '|This is not a generic function| ;fixme, see comment above
62 (defmethod sb-mop:add-direct-method ((specializer extended-specializer) method)
63 (pushnew method (%specializer-direct-methods specializer)))
65 (defmethod sb-mop:remove-direct-method ((specializer extended-specializer) method)
66 (setf (%specializer-direct-methods specializer)
67 (remove method (specializer-direct-methods specializer))))
71 (defmethod sb-pcl:parse-specializer-using-class
72 ((gf specializable-generic-function) name)
74 ((typep name 'sb-mop:specializer) name)
75 ((symbolp name) (find-class name))
78 (eql (sb-mop:intern-eql-specializer (cadr name)))
79 (t (make-extended-specializer name))))
80 (t (error "unexpected specializer name"))))
82 (defmethod sb-pcl:make-method-specializers-form
83 ((gf specializable-generic-function) method snames env)
84 (declare (ignore method env))
87 ((typep name 'sb-mop:specializer) name)
88 ((symbolp name) `(find-class ',name))
91 (eql `(sb-mop:intern-eql-specializer ,(cadr name)))
92 (t `(make-extended-specializer ',name))))
93 (t (error "unexpected specializer name")))))
94 `(list ,@(mapcar #'parse snames))))
96 ;;; from Closette, changed to use some SBCL functions:
98 ;;; FIXME: this is not actually sufficient argument checking
99 (defun required-portion (gf args)
100 (let ((number-required
101 (sb-pcl::arg-info-number-required (sb-pcl::gf-arg-info gf))))
102 (when (< (length args) number-required)
103 (error "Too few arguments to generic function ~S." gf))
104 (subseq args 0 number-required)))
106 ;;; FIXME: in some kind of order, the discriminating function needs to handle:
107 ;;; - argument count checking;
108 ;;; - keyword argument validity;
109 ;;; - flushing the emf cache on method addition/removal
110 ;;; - flushing the cache on class redefinition;
111 ;;; - cache thread-safety.
112 (defmethod sb-mop:compute-discriminating-function ((gf specializable-generic-function))
114 (let* ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
115 (required-portion gf args)))
116 (emfun (gethash generalizers (emf-table gf) nil)))
119 (slow-method-lookup gf args generalizers)))))
121 (defun slow-method-lookup (gf args generalizers)
122 ;; differs from closette
123 (multiple-value-bind (applicable-methods definitivep)
124 (compute-applicable-methods-using-generalizers gf generalizers)
127 (compute-effective-method-function gf applicable-methods)))
128 (setf (gethash generalizers (emf-table gf)) emfun)
129 (funcall emfun args))
130 (funcall (compute-effective-method-function
131 gf (sb-mop:compute-applicable-methods gf args))
134 ;; new, not in closette
135 (defgeneric generalizer-of-using-class (generic-function object))
136 (defmethod generalizer-of-using-class ((generic-function specializable-generic-function) object)
139 (defgeneric specializer-accepts-generalizer-p (specializer generalizer))
140 (defmethod specializer-accepts-generalizer-p ((specializer class) (generalizer class))
141 ;; does the specializer's object have the -same- class as the the actual
143 (if (subtypep generalizer specializer)
144 ;; definitive: this method matches all instances of this class
146 ;; definitive: this method doesn't match instances of this class
148 (defmethod specializer-accepts-generalizer-p
149 ((specializer sb-mop:eql-specializer) (generalizer class))
150 ;; does the specializer's object have the -same- class as the actual
152 (if (eq generalizer (class-of (sb-mop:eql-specializer-object specializer)))
153 ;; not definitive, since the actual object might differ
155 ;; definitely not the same object
158 (defgeneric compute-applicable-methods-using-generalizers (gf generalizers))
159 (defmethod compute-applicable-methods-using-generalizers
160 ((gf specializable-generic-function) generalizers)
161 ;; differs from closette
162 (let ((result-definitive-p t))
163 (flet ((filter (method)
165 (multiple-value-bind (acceptsp definitivep)
166 (specializer-accepts-generalizer-p s g)
168 (setf result-definitive-p nil))
170 (sb-mop:method-specializers method) generalizers))
172 (method-more-specific-p gf m1 m2 generalizers)))
175 (copy-list (remove-if-not #'filter (sb-mop:generic-function-methods gf)))
177 result-definitive-p))))
179 ;; new, not in closette
180 (defgeneric specializer-accepts-p (specializer object))
181 (defmethod specializer-accepts-p ((specializer class) object)
182 (typep object specializer))
183 (defmethod specializer-accepts-p ((specializer sb-mop:eql-specializer) object)
184 (eq object (sb-mop:eql-specializer-object specializer)))
186 (defmethod compute-applicable-methods
187 ((gf specializable-generic-function) arguments)
188 ;; new, not in closette
191 (remove-if-not #'(lambda (method)
192 (every #'specializer-accepts-p
193 (sb-mop:method-specializers method)
195 (sb-mop:generic-function-methods gf)))
196 (let ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
197 (required-portion gf arguments))))
199 (method-more-specific-p gf m1 m2 generalizers)))))
201 (defun method-more-specific-p (gf method1 method2 generalizers)
202 ;; differs from closette
203 (declare (ignore gf))
204 ;; FIXME: argument precedence order
206 (mapc #'(lambda (spec1 spec2 generalizer)
207 (ecase (specializer< spec1 spec2 generalizer)
210 ((nil > /=) (return nil))))
211 (sb-mop:method-specializers method1)
212 (sb-mop:method-specializers method2)
216 ;; new, not in closette
217 (defgeneric specializer< (s1 s2 generalizer))
218 (defmethod specializer< ((s1 class) (s2 class) (generalizer class))
221 (let ((cpl (sb-mop:class-precedence-list generalizer)))
222 (if (find s2 (cdr (member s1 cpl)))
225 (defmethod specializer<
226 ((s1 sb-mop:eql-specializer) (s2 sb-mop:eql-specializer) generalizer)
227 (declare (ignore generalizer))
228 (if (eq (sb-mop:eql-specializer-object s1) (sb-mop:eql-specializer-object s2))
231 (defmethod specializer< ((s1 sb-mop:eql-specializer) (s2 class) generalizer)
232 (declare (ignore generalizer))
234 (defmethod specializer< ((c1 class) (c2 sb-mop:eql-specializer) generalizer)
235 (declare (ignore generalizer))
238 ;;;; method combination
240 ;;; FIXME: this is actually only standard method combination.
242 ;; unchanged from closette
243 (defun primary-method-p (method)
244 (null (method-qualifiers method)))
245 (defun before-method-p (method)
246 (equal '(:before) (method-qualifiers method)))
247 (defun after-method-p (method)
248 (equal '(:after) (method-qualifiers method)))
249 (defun around-method-p (method)
250 (equal '(:around) (method-qualifiers method)))
252 ;;; (defun compute-effective-method-function (gf methods)
253 ;;; (let ((primaries (remove-if-not #'primary-method-p methods))
254 ;;; (around (find-if #'around-method-p methods)))
255 ;;; (when (null primaries)
256 ;;; (error "No primary methods for the~@
257 ;;; generic function ~S." gf))
259 ;;; (let ((next-emfun
260 ;;; (compute-effective-method-function gf (remove around methods))))
262 ;;; (funcall (method-function around) args next-emfun)))
263 ;;; (let ((next-emfun (compute-primary-emfun (cdr primaries)))
264 ;;; (befores (remove-if-not #'before-method-p methods))
266 ;;; (reverse (remove-if-not #'after-method-p methods))))
268 ;;; (dolist (before befores)
269 ;;; (funcall (method-function before) args nil))
270 ;;; (multiple-value-prog1
271 ;;; (funcall (method-function (car primaries)) args next-emfun)
272 ;;; (dolist (after reverse-afters)
273 ;;; (funcall (method-function after) args nil))))))))
275 (defun compute-effective-method-function (gf methods)
277 (or (remove-if-not #'primary-method-p methods)
278 (error "No primary methods for the generic function ~S." gf)))
280 (let* ((nexts (mapcar #'sb-mop:method-function (cdr primaries)))
281 (befores (remove-if-not #'before-method-p methods))
283 (reverse (remove-if-not #'after-method-p methods))))
285 (dolist (before befores)
286 (funcall (sb-mop:method-function before) args nil))
287 (multiple-value-prog1
288 (funcall (sb-mop:method-function (car primaries))
291 (dolist (after reverse-afters)
292 (funcall (sb-mop:method-function after) args nil))))))
293 (arounds (remove-if-not #'around-method-p methods)))
295 (let ((next (append (mapcar #'sb-mop:method-function (cdr arounds))
297 (declare (ignore nexts))
298 (funcall primary-emf args)))))
300 (funcall (sb-mop:method-function (car arounds))
306 (defclass cons-specializer (extended-specializer)
307 ((car :initarg :car :reader %car)))
308 (defclass cons-generic-function (specializable-generic-function)
310 (:metaclass sb-mop:funcallable-standard-class))
312 (define-extended-specializer cons (gf car)
313 (make-instance 'cons-specializer :car car))
315 (defmethod sb-pcl:unparse-specializer-using-class
316 ((gf cons-generic-function) (specializer cons-specializer))
317 `(cons ,(%car specializer)))
318 (defmethod sb-pcl::same-specializer-p
319 ((s1 cons-specializer) (s2 cons-specializer))
320 (eql (%car s1) (%car s2)))
322 (defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
324 ((cons symbol) (car arg))
325 (t (call-next-method))))
326 ;;; FIXME: it looks like these protocol functions should have the GF
327 ;;; as an argument, since generalizer-of-using-class does
328 (defmethod specializer-accepts-generalizer-p ((specializer cons-specializer) thing)
329 (if (eql (%car specializer) thing)
332 ;;; FIXME: yes, definitely need the gf!
333 (defmethod specializer-accepts-generalizer-p (specializer (thing symbol))
334 (specializer-accepts-generalizer-p specializer (find-class 'cons)))
336 (defmethod specializer-accepts-p ((specializer cons-specializer) obj)
338 (eql (car obj) (%car specializer))))
339 (defmethod specializer< ((s1 cons-specializer) (s2 cons-specializer) generalizer)
340 (declare (ignore generalizer))
341 (if (eql (%car s1) (%car s2))
344 (defmethod specializer< ((s1 cons-specializer) (s2 class) generalizer)
345 (declare (ignore generalizer))
347 (defmethod specializer< ((s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
348 (declare (ignore generalizer))
350 (defmethod specializer< ((s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
351 (ecase (specializer< s2 s1 generalizer)
355 (defgeneric walk (form)
356 (:generic-function-class cons-generic-function))
358 (defmethod walk ((form symbol))
360 (defmethod walk ((form cons))
361 `(call (flookup ,(car form)) (list ,@(mapcar #'walk (cdr form)))))
362 (defmethod walk ((form (cons quote)))
364 (defmethod walk ((form (cons let)))
365 (let ((bindings (cadr form)))
366 `(with-bindings ,bindings ,@(cddr form))))