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))
12 (defmethod sb-pcl:unparse-specializer-using-class
13 ((gf cons-generic-function) (specializer cons-specializer))
14 `(cons ,(%car specializer)))
15 (defmethod sb-pcl::same-specializer-p
16 ((s1 cons-specializer) (s2 cons-specializer))
17 (eql (%car s1) (%car s2)))
19 ;;; FIXME: make a proper generalizer
20 (defmethod generalizer-equal-hash-key ((gf cons-generic-function) (g symbol))
22 (defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
24 ((cons symbol) (car arg))
25 (t (call-next-method))))
26 (defmethod specializer-accepts-generalizer-p ((gf cons-generic-function) (specializer cons-specializer) thing)
27 (if (eql (%car specializer) thing)
30 (defmethod specializer-accepts-generalizer-p ((gf cons-generic-function) (specializer sb-mop:specializer) (thing symbol))
31 (specializer-accepts-generalizer-p gf specializer (find-class 'cons)))
33 ;;; note: this method operates in full knowledge of the object, and so
34 ;;; does not require the generic function as an argument.
35 (defmethod specializer-accepts-p ((specializer cons-specializer) obj)
37 (eql (car obj) (%car specializer))))
39 (defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 cons-specializer) generalizer)
40 (declare (ignore generalizer))
41 (if (eql (%car s1) (%car s2))
44 (defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 class) generalizer)
45 (declare (ignore generalizer))
47 (defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
48 (declare (ignore generalizer))
50 (defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
51 (ecase (specializer< gf s2 s1 generalizer)
54 ;;; note: the need for this method is tricky: we need to translate
55 ;;; from generalizers that our specializers "know" about to those that
56 ;;; ordinary generic functions and specializers might know about.
57 (defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (generalizer symbol))
58 (specializer< gf s1 s2 (find-class 'cons)))
63 (defgeneric walk (form)
64 (:generic-function-class cons-generic-function))
65 (defmethod walk ((form symbol))
67 (defmethod walk ((form cons))
68 `(call (flookup ,(car form)) (list ,@(mapcar #'walk (cdr form)))))
69 (defmethod walk ((form (cons quote)))
71 (defmethod walk ((form (cons let)))
72 (let ((bindings (cadr form)))
73 `(with-bindings ,bindings ,@(mapcar #'walk (cddr form)))))
75 (assert (equal (walk t) '(lookup t)))
76 (assert (equal (walk nil) '(lookup nil)))
77 (assert (equal (walk '(foo bar)) '(call (flookup foo) (list (lookup bar)))))
78 (assert (equal (walk '(quote bar)) 'bar))
79 (assert (equal (walk '(let foo bar)) '(with-bindings foo (lookup bar))))))
83 (defgeneric multiple-class-specializers (x)
84 (:generic-function-class cons-generic-function)
85 (:method-combination list))
86 (defmethod multiple-class-specializers list ((x t)) 't)
87 (defmethod multiple-class-specializers list ((x cons)) 'cons)
88 (defmethod multiple-class-specializers list ((x (cons foo))) '(cons foo))
89 (defmethod multiple-class-specializers list ((x (cons bar))) '(cons bar))
90 (defmethod multiple-class-specializers list ((x list)) 'list)
91 (defmethod multiple-class-specializers list ((x null)) 'null)
92 (defmethod multiple-class-specializers list ((x (eql nil))) '(eql nil))
94 (assert (equal (multiple-class-specializers nil) '((eql nil) null list t)))
95 (assert (equal (multiple-class-specializers t) '(t)))
96 (assert (equal (multiple-class-specializers (cons nil nil)) '(cons list t)))
97 (assert (equal (multiple-class-specializers (cons 'foo nil)) '((cons foo) cons list t)))
98 (assert (equal (multiple-class-specializers (list 'bar nil t 3)) '((cons bar) cons list t)))))
102 (defgeneric keyword-args (x &key key1)
103 (:generic-function-class cons-generic-function))
104 (defmethod keyword-args ((x integer) &key key1 key2) (1+ x))
105 (defmethod keyword-args ((x float) &key key1 key3) (+ x 2.0))
106 (defmethod keyword-args :after ((x double-float) &key &allow-other-keys)
108 (assert (= (keyword-args 1) 2))
109 (assert (= (keyword-args 1 :key1 t) 2))
110 (assert (= (keyword-args 1 :key2 t) 2))
111 (assert (= (keyword-args 1 :key1 t :key2 t) 2))
112 (assert (nth-value 1 (ignore-errors (keyword-args 1 :key1 t :key3 t))))
113 (assert (nth-value 1 (ignore-errors (keyword-args 1 :key3 t))))
114 (assert (= (keyword-args 1 :key3 t :allow-other-keys t) 2))
116 (assert (= (keyword-args 1.0) 3.0))
117 (assert (= (keyword-args 1.0 :key1 t) 3.0))
118 (assert (= (keyword-args 1.0 :key3 t) 3.0))
119 (assert (= (keyword-args 1.0 :key1 t :key3 t) 3.0))
120 (assert (nth-value 1 (ignore-errors (keyword-args 1.0 :key1 t :key2 t))))
121 (assert (nth-value 1 (ignore-errors (keyword-args 1.0 :key2 t))))
122 (assert (= (keyword-args 1.0 :key2 t :allow-other-keys t) 3.0))
124 (assert (= (keyword-args 1.0d0) 3.0d0))
125 (assert (= (keyword-args 1.0d0 :key1 t) 3.0d0))
126 (assert (= (keyword-args 1.0d0 :key3 t) 3.0d0))
127 (assert (= (keyword-args 1.0d0 :key1 t :key3 t) 3.0d0))
128 (assert (= (keyword-args 1.0d0 :key1 t :key2 t) 3.0d0))
129 (assert (= (keyword-args 1.0d0 :key2 t) 3.0d0))
130 (assert (= (keyword-args 1.0d0 :key2 t :allow-other-keys t) 3.0d0))))