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
  13 (defmethod sb-pcl:unparse-specializer-using-class
  14     ((gf cons-generic-function) (specializer cons-specializer))
  15   `(cons ,(%car specializer)))
  16 (defmethod sb-pcl::same-specializer-p
  17     ((s1 cons-specializer) (s2 cons-specializer))
  18   (eql (%car s1) (%car s2)))
  19
  20 (defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
  21   (typecase arg
  22     ((cons symbol) (car arg))
  23     (t (call-next-method))))
  24 (defmethod specializer-accepts-generalizer-p ((gf cons-generic-function) (specializer cons-specializer) thing)
  25   (if (eql (%car specializer) thing)
  26       (values t t)
  27       (values nil t)))
  28 (defmethod specializer-accepts-generalizer-p ((gf cons-generic-function) (specializer sb-mop:specializer) (thing symbol))
  29   (specializer-accepts-generalizer-p gf specializer (find-class 'cons)))
  30
  31 ;;; note: this method operates in full knowledge of the object, and so
  32 ;;; does not require the generic function as an argument.
  33 (defmethod specializer-accepts-p ((specializer cons-specializer) obj)
  34   (and (consp obj)
  35        (eql (car obj) (%car specializer))))
  36
  37 (defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 cons-specializer) generalizer)
  38   (declare (ignore generalizer))
  39   (if (eql (%car s1) (%car s2))
  40       '=
  41       nil))
  42 (defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 class) generalizer)
  43   (declare (ignore generalizer))
  44   '<)
  45 (defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
  46   (declare (ignore generalizer))
  47   '>)
  48 (defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
  49   (ecase (specializer< gf s2 s1 generalizer)
  50     ((<) '>)
  51     ((>) '<)))
  52 ;;; note: the need for this method is tricky: we need to translate
  53 ;;; from generalizers that our specializers "know" about to those that
  54 ;;; ordinary generic functions and specializers might know about.
  55 (defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (generalizer symbol))
  56   (specializer< gf s1 s2 (find-class 'cons)))
  57 \f
  58 ;;; tests / examples
  59 (eval
  60  '(progn
  61    (defgeneric walk (form)
  62      (:generic-function-class cons-generic-function))
  63    (defmethod walk ((form symbol))
  64      `(lookup ,form))
  65    (defmethod walk ((form cons))
  66      `(call (flookup ,(car form)) (list ,@(mapcar #'walk (cdr form)))))
  67    (defmethod walk ((form (cons quote)))
  68      (cadr form))
  69    (defmethod walk ((form (cons let)))
  70      (let ((bindings (cadr form)))
  71        `(with-bindings ,bindings ,@(mapcar #'walk (cddr form)))))
  72
  73    (assert (equal (walk t) '(lookup t)))
  74    (assert (equal (walk nil) '(lookup nil)))
  75    (assert (equal (walk '(foo bar)) '(call (flookup foo) (list (lookup bar)))))
  76    (assert (equal (walk '(quote bar)) 'bar))
  77    (assert (equal (walk '(let foo bar)) '(with-bindings foo (lookup bar))))))
  78
  79 (eval
  80  '(progn
  81    (defgeneric multiple-class-specializers (x)
  82      (:generic-function-class cons-generic-function)
  83      (:method-combination list))
  84    (defmethod multiple-class-specializers list ((x t)) 't)
  85    (defmethod multiple-class-specializers list ((x cons)) 'cons)
  86    (defmethod multiple-class-specializers list ((x (cons foo))) '(cons foo))
  87    (defmethod multiple-class-specializers list ((x (cons bar))) '(cons bar))
  88    (defmethod multiple-class-specializers list ((x list)) 'list)
  89    (defmethod multiple-class-specializers list ((x null)) 'null)
  90    (defmethod multiple-class-specializers list ((x (eql nil))) '(eql nil))
  91
  92    (assert (equal (multiple-class-specializers nil) '((eql nil) null list t)))
  93    (assert (equal (multiple-class-specializers t) '(t)))
  94    (assert (equal (multiple-class-specializers (cons nil nil)) '(cons list t)))
  95    (assert (equal (multiple-class-specializers (cons 'foo nil)) '((cons foo) cons list t)))
  96    (assert (equal (multiple-class-specializers (list 'bar nil t 3)) '((cons bar) cons list t)))))