1 (in-package "SPECIALIZABLE")
3 ;;;; CONS-SPECIALIZER example
4 (defclass cons-specializer (extended-specializer)
5 ((car :initarg :car :reader %car)))
6 (defclass cons-generic-function (specializable-generic-function)
8 (:metaclass sb-mop:funcallable-standard-class))
10 (define-extended-specializer cons (gf car)
11 (make-instance 'cons-specializer :car car))
13 (defmethod sb-pcl:unparse-specializer-using-class
14 ((gf cons-generic-function) (specializer cons-specializer))
15 `(cons ,(%car specializer)))
16 (defmethod sb-pcl::same-specializer-p
17 ((s1 cons-specializer) (s2 cons-specializer))
18 (eql (%car s1) (%car s2)))
20 (defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
22 ((cons symbol) (car arg))
23 (t (call-next-method))))
24 ;;; FIXME: it looks like these protocol functions should have the GF
25 ;;; as an argument, since generalizer-of-using-class does
26 (defmethod specializer-accepts-generalizer-p ((specializer cons-specializer) thing)
27 (if (eql (%car specializer) thing)
30 ;;; FIXME: yes, definitely need the gf!
31 (defmethod specializer-accepts-generalizer-p (specializer (thing symbol))
32 (specializer-accepts-generalizer-p specializer (find-class 'cons)))
34 ;;; this one might not need the GF
35 (defmethod specializer-accepts-p ((specializer cons-specializer) obj)
37 (eql (car obj) (%car specializer))))
38 ;;; but this one does: it doesn't look like it here, but at issue is
39 ;;; who is responsible for the SPECIALIZER< method for two distinct
40 ;;; user-defined specializers. Also consider a symbol generalizer
41 ;;; being used to compare two class specializers.
42 (defmethod specializer< ((s1 cons-specializer) (s2 cons-specializer) generalizer)
43 (declare (ignore generalizer))
44 (if (eql (%car s1) (%car s2))
47 (defmethod specializer< ((s1 cons-specializer) (s2 class) generalizer)
48 (declare (ignore generalizer))
50 (defmethod specializer< ((s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
51 (declare (ignore generalizer))
53 (defmethod specializer< ((s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
54 (ecase (specializer< s2 s1 generalizer)
60 (defgeneric walk (form)
61 (:generic-function-class cons-generic-function))
62 (defmethod walk ((form symbol))
64 (defmethod walk ((form cons))
65 `(call (flookup ,(car form)) (list ,@(mapcar #'walk (cdr form)))))
66 (defmethod walk ((form (cons quote)))
68 (defmethod walk ((form (cons let)))
69 (let ((bindings (cadr form)))
70 `(with-bindings ,bindings ,@(cddr form))))))