1 (in-package "SPECIALIZABLE")
3 ;;;; SIGNUM-SPECIALIZER example
4 (defclass signum-specializer (extended-specializer)
5 ((signum :initarg :signum :reader %signum)))
6 (defclass signum-generic-function (specializable-generic-function)
8 (:metaclass sb-mop:funcallable-standard-class))
10 (define-extended-specializer signum (gf signum)
11 (make-instance 'signum-specializer :signum signum))
12 (defmethod sb-pcl:unparse-specializer-using-class
13 ((gf signum-generic-function) (specializer signum-specializer))
14 `(signum ,(%signum specializer)))
15 (defmethod sb-pcl::same-specializer-p
16 ((s1 signum-specializer) (s2 signum-specializer))
17 (= (%signum s1) (%signum s2)))
19 (defmethod generalizer-equal-hash-key ((gf signum-generic-function) (g signum-specializer))
21 (defmethod generalizer-of-using-class ((gf signum-generic-function) arg)
23 (real (make-instance 'signum-specializer :signum (signum arg)))
24 (t (call-next-method))))
25 (defmethod specializer-accepts-generalizer-p ((gf signum-generic-function) (specializer signum-specializer) (thing signum-specializer))
26 (if (= (%signum specializer) (%signum thing))
29 (defmethod specializer-accepts-generalizer-p ((gf signum-generic-function) (specializer sb-mop:specializer) (thing signum-specializer))
30 (specializer-accepts-generalizer-p gf specializer (class-of (%signum thing))))
32 ;;; note: this method operates in full knowledge of the object, and so
33 ;;; does not require the generic function as an argument.
34 (defmethod specializer-accepts-p ((specializer signum-specializer) obj)
36 (= (signum obj) (%signum specializer))))
38 (defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 signum-specializer) generalizer)
39 (declare (ignore generalizer))
40 (if (= (%signum s1) (%signum s2))
43 (defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 class) generalizer)
44 (declare (ignore generalizer))
46 (defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 sb-mop:eql-specializer) generalizer)
47 (declare (ignore generalizer))
49 (defmethod specializer< ((gf signum-generic-function) (s1 sb-mop:specializer) (s2 signum-specializer) generalizer)
50 (ecase (specializer< gf s2 s1 generalizer)
53 ;;; note: the need for this method is tricky: we need to translate
54 ;;; from generalizers that our specializers "know" about to those that
55 ;;; ordinary generic functions and specializers might know about.
56 (defmethod specializer< ((gf signum-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (generalizer signum-specializer))
57 (specializer< gf s1 s2 (class-of (%signum generalizer))))
62 (defgeneric fact (n) (:generic-function-class signum-generic-function))
63 (defmethod fact ((n (signum 0))) 1)
64 (defmethod fact ((n (signum 1))) (* n (fact (1- n))))
65 (assert (eql (fact 6) 720))
66 (assert (eql (fact 6.0) 720.0))
67 (defmethod no-applicable-method ((gf (eql #'fact)) &rest args)
69 (assert (eql (fact -6) 'gotcha))))
73 (defgeneric signum-class-specializers (x)
74 (:generic-function-class signum-generic-function)
75 (:method-combination list))
76 (defmethod signum-class-specializers list ((x float)) 'float)
77 (defmethod signum-class-specializers list ((x integer)) 'integer)
78 (defmethod signum-class-specializers list ((x (signum 1))) 1)
79 (assert (equal (signum-class-specializers 1.0) '(1 float)))
80 (assert (equal (signum-class-specializers 1) '(1 integer)))
81 (assert (equal (signum-class-specializers -1.0) '(float)))
82 (assert (equal (signum-class-specializers -1) '(integer)))))