(in-package "VCLOS")

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

(defmethod compute-discriminating-function ((gf generic-function))
  ;; FIXME: since the cacheing is based on specializers (and not on
  ;; any kind of wrapper) we lose on class redefinition.
  (let ((cache (make-hash-table :test #'equal)))
    (lambda (&rest args)
      (let ((specializers (specializers-of gf args))
            (emf nil))
        (block effective-method
          (let ((cached (gethash specializers cache)))
            (when cached
              (return-from effective-method (setq emf cached))))
          (multiple-value-bind (ms cacheablep)
              (compute-applicable-methods-using-specializers gf specializers)
            (cond
              (cacheablep
               (let* ((mc (generic-function-method-combination gf))
                      (effective-method (compute-effective-method gf mc ms)))
                 (setq emf (setf (gethash specializers cache)
                                 (compile-effective-method effective-method))))
               (return-from effective-method))
              ;; FIXME: falling back to a full
              ;; COMPUTE-APPLICABLE-METHODS and going through the
              ;; compiler in COMPILE-EFFECTIVE-METHOD for each call is
              ;; ruinously expensive.  PCL has the notion of a
              ;; "secondary dispatch function", and a protocol for
              ;; computing it: a non-NIL first return value from
              ;; COMPUTE-APPLICABLE-METHODS-USING-CLASSES coupled with
              ;; a NIL second value (designating "uncacheable") means
              ;; that all of the primary value methods are potentially
              ;; applicable, and a dispatch function is constructed to
              ;; distinguish between them; the conservative list of
              ;; methods and dispatch function are both cacheable.
              (t
               (setq ms (compute-applicable-methods gf args))
               (let* ((mc (generic-function-method-combination gf))
                      (effective-method (compute-effective-method gf mc ms)))
                 (setq emf (compile-effective-method effective-method)))))))
        (funcall emf args)))))

(defun compile-effective-method (effective-method)
  (compile
   nil
   `(lambda (args)
     (locally
         (declare (sb-ext:disable-package-locks call-method make-method))
       (macrolet ((call-method (method next-methods &rest cm-args)
                    `(apply (method-function ,method) args (list ,@next-methods) ',cm-args))
                  (make-method (form)
                    `(make-instance 'standard-method
                      :function (lambda (a nm &rest cm-a)
                                  (declare (ignorable a nm cm-a))
                                  ,form))))
         (declare (sb-ext:enable-package-locks call-method make-method))
         ,effective-method)))))

(defun interpret-effective-method (effective-method args)
  (eval `(locally
          (declare (sb-ext:disable-package-locks call-method make-method))
          (macrolet ((call-method (method next-methods &rest cm-args)
                       `(apply (method-function ,method) ',',args (list ,@next-methods) ',cm-args))
                     (make-method (form)
                       `(make-instance 'standard-method
                         :function (lambda (a nm &rest cm-a)
                                     ,form))))
            (declare (sb-ext:enable-package-locks call-method make-method))
            ,effective-method))))

(defgeneric specializers-of (gf args)
  (:method ((gf generic-function) args)
    (mapcar #'class-of args)))

(defgeneric compute-applicable-methods-using-specializers (gf specializers)
  (:method ((gf generic-function) specializers)
    ;; FIXME: this is actually more featureful than VCLOS, as it
    ;; includes EQL-specializer support by default.
    (compute-applicable-methods-using-classes gf specializers)))