examples/cons-specializer.lisp

   1 (in-package "SPECIALIZABLE")
   2
   3 ;;;; CONS-SPECIALIZER example
   4 (defclass cons-specializer (extended-specializer)
   5   ((car :initarg :car :reader %car)))
   6 (defclass cons-generic-function (specializable-generic-function)
   7   ()
   8   (:metaclass sb-mop:funcallable-standard-class))
   9
  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)))
  18
  19 ;;; FIXME: make a proper generalizer
  20 (defmethod generalizer-equal-hash-key ((gf cons-generic-function) (g symbol))
  21   g)
  22 (defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
  23   (typecase 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)
  28       (values t t)
  29       (values nil t)))
  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)))
  32
  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)
  36   (and (consp obj)
  37        (eql (car obj) (%car specializer))))
  38
  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))
  42       '=
  43       nil))
  44 (defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 class) generalizer)
  45   (declare (ignore generalizer))
  46   '<)
  47 (defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
  48   (declare (ignore generalizer))
  49   '>)
  50 (defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
  51   (ecase (specializer< gf s2 s1 generalizer)
  52     ((<) '>)
  53     ((>) '<)))
  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)))
  59 \f
  60 ;;; tests / examples
  61 (eval
  62  '(progn
  63    (defgeneric walk (form)
  64      (:generic-function-class cons-generic-function))
  65    (defmethod walk ((form symbol))
  66      `(lookup ,form))
  67    (defmethod walk ((form cons))
  68      `(call (flookup ,(car form)) (list ,@(mapcar #'walk (cdr form)))))
  69    (defmethod walk ((form (cons quote)))
  70      (cadr form))
  71    (defmethod walk ((form (cons let)))
  72      (let ((bindings (cadr form)))
  73        `(with-bindings ,bindings ,@(mapcar #'walk (cddr form)))))
  74
  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))))))
  80
  81 (eval
  82  '(progn
  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))
  93
  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)))))
  99
 100 (eval
 101  '(progn
 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)
 107               nil)
 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))
 115
 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))
 123
 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))))