From: Christophe Rhodes <csr21@cantab.net>
Date: Thu, 6 Feb 2014 14:15:46 +0000 (+0000)
Subject: add signum specializer example
X-Git-Tag: els2014-submission~13
X-Git-Url: http://christophe.rhodes.io/gitweb/?a=commitdiff_plain;h=053eaf6bdc566da3f0ef40ed06e4de0a1adbdeec;p=specializable.git

add signum specializer example
---

diff --git a/signum-specializer.lisp b/signum-specializer.lisp
new file mode 100644
index 0000000..a5d21fa
--- /dev/null
+++ b/signum-specializer.lisp
@@ -0,0 +1,79 @@
+(in-package "SPECIALIZABLE")
+
+;;;; SIGNUM-SPECIALIZER example
+(defclass signum-specializer (extended-specializer)
+  ((signum :initarg :signum :reader %signum)))
+(defclass signum-generic-function (specializable-generic-function)
+  ()
+  (:metaclass sb-mop:funcallable-standard-class))
+
+(define-extended-specializer signum (gf signum)
+  (make-instance 'signum-specializer :signum signum))
+(defmethod sb-pcl:unparse-specializer-using-class
+    ((gf signum-generic-function) (specializer signum-specializer))
+  `(signum ,(%signum specializer)))
+(defmethod sb-pcl::same-specializer-p
+    ((s1 signum-specializer) (s2 signum-specializer))
+  (= (%signum s1) (%signum s2)))
+
+(defmethod generalizer-equal-hash-key ((gf signum-generic-function) (g signum-specializer))
+  (%signum g))
+(defmethod generalizer-of-using-class ((gf signum-generic-function) arg)
+  (typecase arg
+    (real (make-instance 'signum-specializer :signum (signum arg)))
+    (t (call-next-method))))
+(defmethod specializer-accepts-generalizer-p ((gf signum-generic-function) (specializer signum-specializer) (thing signum-specializer))
+  (if (= (%signum specializer) (%signum thing))
+      (values t t)
+      (values nil t)))
+(defmethod specializer-accepts-generalizer-p ((gf signum-generic-function) (specializer sb-mop:specializer) (thing signum-specializer))
+  (specializer-accepts-generalizer-p gf specializer (class-of (%signum thing))))
+
+;;; note: this method operates in full knowledge of the object, and so
+;;; does not require the generic function as an argument.
+(defmethod specializer-accepts-p ((specializer signum-specializer) obj)
+  (and (realp obj)
+       (= (signum obj) (%signum specializer))))
+
+(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 signum-specializer) generalizer)
+  (declare (ignore generalizer))
+  (if (= (%signum s1) (%signum s2))
+      '=
+      nil))
+(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 class) generalizer)
+  (declare (ignore generalizer))
+  '<)
+(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 sb-mop:eql-specializer) generalizer)
+  (declare (ignore generalizer))
+  '>)
+(defmethod specializer< ((gf signum-generic-function) (s1 sb-mop:specializer) (s2 signum-specializer) generalizer)
+  (ecase (specializer< gf s2 s1 generalizer)
+    ((<) '>)
+    ((>) '<)))
+;;; note: the need for this method is tricky: we need to translate
+;;; from generalizers that our specializers "know" about to those that
+;;; ordinary generic functions and specializers might know about.
+(defmethod specializer< ((gf signum-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (generalizer signum-specializer))
+  (specializer< gf s1 s2 (class-of (%signum generalizer))))
+
+;;; tests / examples
+(eval
+ '(progn
+   (defgeneric fact (n) (:generic-function-class signum-generic-function))
+   (defmethod fact ((n (signum 0))) 1)
+   (defmethod fact ((n (signum 1))) (* n (fact (1- n))))
+   (assert (eql (fact 6) 720))
+   (assert (eql (fact 6.0) 720.0))))
+
+(eval
+ '(progn
+   (defgeneric signum-class-specializers (x)
+     (:generic-function-class signum-generic-function)
+     (:method-combination list))
+   (defmethod signum-class-specializers list ((x float)) 'float)
+   (defmethod signum-class-specializers list ((x integer)) 'integer)
+   (defmethod signum-class-specializers list ((x (signum 1))) 1)
+   (assert (equal (signum-class-specializers 1.0) '(1 float)))
+   (assert (equal (signum-class-specializers 1) '(1 integer)))
+   (assert (equal (signum-class-specializers -1.0) '(float)))
+   (assert (equal (signum-class-specializers -1) '(integer)))))