(in-package "VCLOS")

;;; suggested mappings from Jim Newton's terminology into this model:
;;;
;;; The alist stuff for specializer names seems a little bit weird,
;;; exposing a bit too much about implementation details.  I think I
;;; would tend to suggest that the discriminating function calls
;;; SPECIALIZERS-OF, which is responsible for finding specializer
;;; objects corresponding to arguments for the particular generic
;;; function class.
;;;
;;; GetAvailableSpecializers and the "class"-precedence-list is odd,
;;; as it ties a particular specializer to a particular use of that
;;; specializer.  For instance, you cannot share a CONS specializer
;;; between two gf classes, one which has some superspecializer in
;;; between CONS and CLASS and one which does not.  There's then
;;; ClosCmpLikeSpecializers which has a similar defect in that it
;;; (maybe) implicitly assumes that there's only one possible
;;; ordering.  We use instead SPECIALIZER-PRECEDENCE-LIST which
;;; dispatches on the generic function as well as the specializer.
;;;
;;; We don't need the stuff for syntax of specializers, as we already
;;; have MAKE-METHOD-SPECIALIZERS-FORM.
;;;
;;; We need something that is like ClosArgMatchesSpecializerP, maybe
;;; SPECIALIZER-APPLICABLE-P?

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

(defgeneric specializer-of (generic-function thing)
  (:method ((gf specializer-generic-function) thing) (class-of thing)))

(defmethod specializers-of ((gf specializer-generic-function) things)
  (mapcar (lambda (x) (specializer-of gf x)) things))

(defgeneric specializer-precedence-list (generic-function specializer)
  (:method ((gf specializer-generic-function) (s eql-specializer))
    (cons s (specializer-precedence-list gf (class-of (eql-specializer-object s)))))
  (:method ((gf specializer-generic-function) (class class))
    (class-precedence-list class)))

;;; FIXME: assumes all arguments are required, and that precedence
;;; order is left-to-right.
(defmethod compute-applicable-methods-using-specializers 
    ((gf specializer-generic-function) specializers)
  (labels ((sorter (s1 s2 specializers)
             (cond
               ((null s1))
               ((eq (car s1) (car s2))
                (sorter (cdr s1) (cdr s2) (cdr specializers)))
               (t (member (car s2) (member (car s1) (specializer-precedence-list gf (car specializers)))))))
           (applicable-p (m)
             (do ((ms (method-specializers m) (cdr ms))
                  (ss specializers (cdr ss)))
                 ((null ms) t)
               (cond
                 ((typep (car ms) 'eql-specializer)
                  (if (specializer-applicable-p gf (eql-specializer-object (car ms)) (car ss))
                      (return-from compute-applicable-methods-using-specializers
                        (values nil nil))
                      (return-from applicable-p nil)))
                 ((member (car ms) (specializer-precedence-list gf (car ss))))
                 (t (return-from applicable-p nil))))))
    (let ((methods (generic-function-methods gf)))
      (values (sort (remove-if-not #'applicable-p methods) 
                    (lambda (x y) (sorter x y specializers))
                    :key #'method-specializers)
              t))))

(defmethod compute-applicable-methods ((gf specializer-generic-function) args)
  (labels ((sorter (s1 s2 specializers)
             (cond
               ((null s1))
               ((eq (car s1) (car s2))
                (sorter (cdr s1) (cdr s2) (cdr specializers)))
               ((typep (car s1) 'eql-specializer) t)
               ((typep (car s2) 'eql-specializer) nil)
               (t (member (car s2) (member (car s1) (specializer-precedence-list gf (car specializers)))))))
           (applicable-p (m)
             (do ((ms (method-specializers m) (cdr ms))
                  (as args (cdr as)))
                 ((null ms) t)
               (unless (specializer-applicable-p gf (car as) (car ms))
                 (return-from applicable-p nil)))))
    (let ((methods (generic-function-methods gf)))
      (sort (remove-if-not #'applicable-p methods) 
            (let ((ss (specializers-of gf args)))
              (lambda (x y) (sorter x y ss)))
            :key #'method-specializers))))

(defgeneric specializer-applicable-p (gf arg specializer)
  (:method ((gf specializer-generic-function) arg (specializer eql-specializer))
    (eql arg (eql-specializer-object specializer)))
  (:method ((gf specializer-generic-function) arg (specializer class))
    (member specializer (specializer-precedence-list gf (specializer-of gf arg)))))