examples/signum-specializer.lisp

   1 (in-package "SPECIALIZABLE")
   2
   3 ;;;; SIGNUM-SPECIALIZER example
   4 (defclass signum-specializer (extended-specializer)
   5   ((signum :initarg :signum :reader %signum)))
   6 (defclass signum-generic-function (specializable-generic-function)
   7   ()
   8   (:metaclass sb-mop:funcallable-standard-class))
   9
  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)))
  18
  19 (defmethod generalizer-equal-hash-key ((gf signum-generic-function) (g signum-specializer))
  20   (%signum g))
  21 (defmethod generalizer-of-using-class ((gf signum-generic-function) arg)
  22   (typecase 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))
  27       (values t t)
  28       (values nil t)))
  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))))
  31
  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)
  35   (and (realp obj)
  36        (= (signum obj) (%signum specializer))))
  37
  38 (defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 signum-specializer) generalizer)
  39   (declare (ignore generalizer))
  40   (if (= (%signum s1) (%signum s2))
  41       '=
  42       nil))
  43 (defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 class) generalizer)
  44   (declare (ignore generalizer))
  45   '<)
  46 (defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 sb-mop:eql-specializer) generalizer)
  47   (declare (ignore generalizer))
  48   '>)
  49 (defmethod specializer< ((gf signum-generic-function) (s1 sb-mop:specializer) (s2 signum-specializer) generalizer)
  50   (ecase (specializer< gf s2 s1 generalizer)
  51     ((<) '>)
  52     ((>) '<)))
  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))))
  58 \f
  59 ;;; tests / examples
  60 (eval
  61  '(progn
  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)
  68      'gotcha)
  69    (assert (eql (fact -6) 'gotcha))))
  70
  71 (eval
  72  '(progn
  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)))))