cons-specializer.lisp

   1 ;;;; CONS-SPECIALIZER example
   2 (defclass cons-specializer (extended-specializer)
   3   ((car :initarg :car :reader %car)))
   4 (defclass cons-generic-function (specializable-generic-function)
   5   ()
   6   (:metaclass sb-mop:funcallable-standard-class))
   7
   8 (define-extended-specializer cons (gf car)
   9   (make-instance 'cons-specializer :car car))
  10
  11 (defmethod sb-pcl:unparse-specializer-using-class
  12     ((gf cons-generic-function) (specializer cons-specializer))
  13   `(cons ,(%car specializer)))
  14 (defmethod sb-pcl::same-specializer-p
  15     ((s1 cons-specializer) (s2 cons-specializer))
  16   (eql (%car s1) (%car s2)))
  17
  18 (defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
  19   (typecase arg
  20     ((cons symbol) (car arg))
  21     (t (call-next-method))))
  22 ;;; FIXME: it looks like these protocol functions should have the GF
  23 ;;; as an argument, since generalizer-of-using-class does
  24 (defmethod specializer-accepts-generalizer-p ((specializer cons-specializer) thing)
  25   (if (eql (%car specializer) thing)
  26       (values t t)
  27       (values nil t)))
  28 ;;; FIXME: yes, definitely need the gf!
  29 (defmethod specializer-accepts-generalizer-p (specializer (thing symbol))
  30   (specializer-accepts-generalizer-p specializer (find-class 'cons)))
  31
  32 ;;; this one might not need the GF
  33 (defmethod specializer-accepts-p ((specializer cons-specializer) obj)
  34   (and (consp obj)
  35        (eql (car obj) (%car specializer))))
  36 ;;; but this one does: it doesn't look like it here, but at issue is
  37 ;;; who is responsible for the SPECIALIZER< method for two distinct
  38 ;;; user-defined specializers.
  39 (defmethod specializer< ((s1 cons-specializer) (s2 cons-specializer) generalizer)
  40   (declare (ignore generalizer))
  41   (if (eql (%car s1) (%car s2))
  42       '=
  43       nil))
  44 (defmethod specializer< ((s1 cons-specializer) (s2 class) generalizer)
  45   (declare (ignore generalizer))
  46   '<)
  47 (defmethod specializer< ((s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
  48   (declare (ignore generalizer))
  49   '>)
  50 (defmethod specializer< ((s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
  51   (ecase (specializer< s2 s1 generalizer)
  52     ((<) '>)
  53     ((>) '<)))
  54 \f
  55 (eval
  56  '(progn
  57    (defgeneric walk (form)
  58      (:generic-function-class cons-generic-function))
  59    (defmethod walk ((form symbol))
  60      `(lookup ,form))
  61    (defmethod walk ((form cons))
  62      `(call (flookup ,(car form)) (list ,@(mapcar #'walk (cdr form)))))
  63    (defmethod walk ((form (cons quote)))
  64      (cadr form))
  65    (defmethod walk ((form (cons let)))
  66      (let ((bindings (cadr form)))
  67        `(with-bindings ,bindings ,@(cddr form))))))