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 ;;; FIXME: it looks like these protocol functions should have the GF
  25 ;;; as an argument, since generalizer-of-using-class does
  26 (defmethod specializer-accepts-generalizer-p ((specializer cons-specializer) thing)
  27   (if (eql (%car specializer) thing)
  28       (values t t)
  29       (values nil t)))
  30 ;;; FIXME: yes, definitely need the gf!
  31 (defmethod specializer-accepts-generalizer-p (specializer (thing symbol))
  32   (specializer-accepts-generalizer-p specializer (find-class 'cons)))
  33
  34 ;;; this one might not need the GF
  35 (defmethod specializer-accepts-p ((specializer cons-specializer) obj)
  36   (and (consp obj)
  37        (eql (car obj) (%car specializer))))
  38 ;;; but this one does: it doesn't look like it here, but at issue is
  39 ;;; who is responsible for the SPECIALIZER< method for two distinct
  40 ;;; user-defined specializers.  Also consider a symbol generalizer
  41 ;;; being used to compare two class specializers.
  42 (defmethod specializer< ((s1 cons-specializer) (s2 cons-specializer) generalizer)
  43   (declare (ignore generalizer))
  44   (if (eql (%car s1) (%car s2))
  45       '=
  46       nil))
  47 (defmethod specializer< ((s1 cons-specializer) (s2 class) generalizer)
  48   (declare (ignore generalizer))
  49   '<)
  50 (defmethod specializer< ((s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
  51   (declare (ignore generalizer))
  52   '>)
  53 (defmethod specializer< ((s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
  54   (ecase (specializer< s2 s1 generalizer)
  55     ((<) '>)
  56     ((>) '<)))
  57 \f
  58 (eval
  59  '(progn
  60    (defgeneric walk (form)
  61      (:generic-function-class cons-generic-function))
  62    (defmethod walk ((form symbol))
  63      `(lookup ,form))
  64    (defmethod walk ((form cons))
  65      `(call (flookup ,(car form)) (list ,@(mapcar #'walk (cdr form)))))
  66    (defmethod walk ((form (cons quote)))
  67      (cadr form))
  68    (defmethod walk ((form (cons let)))
  69      (let ((bindings (cadr form)))
  70        `(with-bindings ,bindings ,@(mapcar #'walk (cddr form)))))
  71
  72    (assert (equal (walk t) '(lookup t)))
  73    (assert (equal (walk nil) '(lookup nil)))
  74    (assert (equal (walk '(foo bar)) '(call (flookup foo) (list (lookup bar)))))
  75    (assert (equal (walk '(quote bar)) 'bar))
  76    (assert (equal (walk '(let foo bar)) '(with-bindings foo (lookup bar))))))