X-Git-Url: http://christophe.rhodes.io/gitweb/?p=specializable.git;a=blobdiff_plain;f=signum-specializer.lisp;fp=signum-specializer.lisp;h=0000000000000000000000000000000000000000;hp=ab7c0de346b2470adf65d7fee5c03b4ef93470f1;hb=9dd8f1378407cae8ec7b6b05a8b3c152bc4a5f9b;hpb=d55ebbbcbd77023c799d8d95dce5d3772aec5841

diff --git a/signum-specializer.lisp b/signum-specializer.lisp
deleted file mode 100644
index ab7c0de..0000000
--- a/signum-specializer.lisp
+++ /dev/null
@@ -1,82 +0,0 @@
-(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))
-   (defmethod no-applicable-method ((gf (eql #'fact)) &rest args)
-     'gotcha)
-   (assert (eql (fact -6) 'gotcha))))
-
-(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)))))