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 ,@(cddr form))))))