(in-package "VCLOS")

(defclass cons-specializer-generic-function (specializer-generic-function)
  ()
  (:metaclass funcallable-standard-class))

(defclass cons-specializer (specializer)
  ((car-specializer :initarg :car-specializer :reader car-specializer)
   (direct-methods :initform nil :reader specializer-direct-methods)))

(defmethod add-direct-method ((specializer cons-specializer) method)
  (pushnew method (slot-value specializer 'direct-methods)))
(defmethod remove-direct-method ((specializer cons-specializer) method)
  (setf (slot-value specializer 'direct-methods)
        (remove method (slot-value specializer 'direct-methods))))

(defvar *cons-specializer-table* (make-hash-table))

(defun intern-cons-specializer (car-specializer)
  (or (gethash car-specializer *cons-specializer-table*)
      (setf (gethash car-specializer *cons-specializer-table*)
            (make-instance 'cons-specializer :car-specializer car-specializer))))

(defmethod specializer-applicable-p 
    ((gf cons-specializer-generic-function) arg (specializer cons-specializer))
  (and (consp arg)
       (specializer-applicable-p gf (car arg) (car-specializer specializer))))

(defmethod specializer-precedence-list 
    ((gf cons-specializer-generic-function) (s cons-specializer))
  (let* ((car (car-specializer s))
         (carcpl (specializer-precedence-list gf car)))
    (append (mapcar #'intern-cons-specializer carcpl)
            (specializer-precedence-list gf (find-class 'cons)))))

(defmethod specializer-precedence-list
    ((gf cons-specializer-generic-function) (s eql-specializer))
  (let ((eso (eql-specializer-object s)))
    (if (consp eso)
        (cons s (specializer-precedence-list gf (intern-cons-specializer (intern-eql-specializer (car eso)))))
        (call-next-method))))

;;; This is tricky.  In order to get methods with specializers of the
;;; form (CONS (EQL 1)) to work, the specializer-of must have an EQL
;;; specializer as its car.  However, this plays havoc with cacheing,
;;; as this means that any argument of the form of a nested list will
;;; have a different specializer-of.  Maybe we should define cons
;;; specializers as being unable to specialize EQLly on lists, so that
;;; (CONS (EQL '(FOO))) is not allowed?
(defmethod specializer-of ((gf cons-specializer-generic-function) thing)
  (if (consp thing)
      (intern-cons-specializer (intern-eql-specializer (car thing)))
      (call-next-method)))

(defmethod sb-pcl:make-method-specializers-form
    ((gf cons-specializer-generic-function) m names env)
  (labels ((make (name)
             (typecase name
               (specializer name)
               ((cons (eql eql)) `(intern-eql-specializer ,(cadr name)))
               ((cons (eql cons)) `(intern-cons-specializer ,(make (cadr name))))
               (symbol `(find-class ',name)))))
    `(list ,@(mapcar #'make names))))