;;; written by David Lichteblau, based on code by Christophe Rhodes,
;;; Closette, and SBCL
;;;
;;; http://www.lichteblau.com/git/?p=specializable.git;a=blob_plain;f=specializable.lisp;hb=eb30d235951c3c1d128811278760f1db36cd336c

(defpackage "SPECIALIZABLE"
  (:use "CL" "SB-EXT")
  (:export "SPECIALIZABLE-GENERIC-FUNCTION" "SPECIALIZABLE-METHOD"
           "EXTENDED-SPECIALIZER"

           "SPECIALIZER-ACCEPTS-P" "SPECIALIZER-ACCEPTS-GENERALIZER-P"
           "SPECIALIZER<"

           "GENERALIZER-OF-USING-CLASS"
           "COMPUTE-APPLICABLE-METHODS-USING-GENERALIZERS"
           "GENERALIZER-EQUAL-HASH-KEY"
           
           "DEFINE-EXTENDED-SPECIALIZER"))

(in-package "SPECIALIZABLE")

(defclass extended-specializer (sb-mop:specializer)
  ;; FIXME: this doesn't actually do quite what I wanted.
  ((direct-methods-table :allocation :class
                         :initform nil :accessor direct-methods-table)))

(defmethod sb-mop:add-direct-method ((specializer extended-specializer) method)
  (let* ((table (direct-methods-table specializer))
         (cell (assoc specializer table :test #'sb-pcl::same-specializer-p)))
    (unless cell
      (setf cell (cons specializer nil))
      (push cell (direct-methods-table specializer)))
    (push method (cdr cell))))

(defmethod sb-mop:remove-direct-method ((specializer extended-specializer) method)
  (let* ((table (direct-methods-table specializer))
         (cell (assoc specializer table :test #'sb-pcl::same-specializer-p)))
    (setf (cdr cell) (remove method (cdr cell)))))

(defmethod sb-mop:specializer-direct-methods ((specializer extended-specializer))
  (cdr (assoc specializer (direct-methods-table specializer)
              :test #'sb-pcl::same-specializer-p)))
(defmethod sb-mop:specializer-direct-generic-functions ((specializer extended-specializer))
  (remove-duplicates (mapcar #'sb-mop:method-generic-function (sb-mop:specializer-direct-methods specializer))))

(defclass specializable-generic-function (standard-generic-function)
  ((emf-table :initform (make-hash-table :test 'equal) :reader emf-table)
   (cacheingp :initform t :initarg :cacheingp)
   (single-arg-cacheing-p :initform t :initarg :single-arg-cacheing-p))
  (:metaclass sb-mop:funcallable-standard-class)
  (:default-initargs :method-class (find-class 'specializable-method)))

;;; TODO: we don't use this class yet, but we might do later
(defclass specializable-method (standard-method) ())

;;; TODO use info?
(defun extended-specializer-name-p (name)
  (and (symbolp name)
       (get name 'extended-specializer-parser)))

(deftype extended-specializer-name ()
  `(satisfies extended-specializer-name-p))

(defmacro define-extended-specializer (name (gf-var &rest args) &body body)
  ;; FIXME: unparser
  `(setf (get ',name 'extended-specializer-parser)
         (lambda (,gf-var ,@args)
           ,@body)))

;; doesn't work, because we'd have to dump GF into the fasl for the macro
;; expansion
;;; (defun intern-extended-specializer (gf sname)
;;;   (destructuring-bind (kind &rest args) sname
;;;     (setf (gethash sname (generic-function-extended-specializers gf))
;;; 	  (apply (or (get kind 'extended-specializer-parser)
;;; 		     (error "not declared as an extended specializer name: ~A"
;;; 			    kind))
;;; 		 gf
;;; 		 args))))

(defun make-extended-specializer (sname)
  (destructuring-bind (kind &rest args) sname
    (apply (or (get kind 'extended-specializer-parser)
	       (error "not declared as an extended specializer name: ~A"
		      kind))
	   '|This is not a generic function| ;fixme, see comment above
	   args)))

;;; from SBCL:

(defmethod sb-pcl:parse-specializer-using-class
    ((gf specializable-generic-function) (specializer-name t))
  (if (typep specializer-name '(cons extended-specializer-name))
      (make-extended-specializer specializer-name)
      (call-next-method)))

(defmethod sb-pcl:make-method-specializers-form
    ((gf specializable-generic-function) method snames env)
  (declare (ignore method env))
  (flet ((parse (name)
           (cond
             ((typep name 'sb-mop:specializer) name)
             ((symbolp name) `(find-class ',name))
             ((consp name)
	      (case (car name)
		(eql `(sb-mop:intern-eql-specializer ,(cadr name)))
		(t `(make-extended-specializer ',name))))
             (t (error "unexpected specializer name")))))
    `(list ,@(mapcar #'parse snames))))

;;; from Closette, changed to use some SBCL functions:

;;; FIXME: this is not actually sufficient argument checking
(defun required-portion (gf args)
  (let ((number-required
	 (sb-pcl::arg-info-number-required (sb-pcl::gf-arg-info gf))))
    (when (< (length args) number-required)
      (error "Too few arguments to generic function ~S." gf))
    (subseq args 0 number-required)))

(defgeneric generalizer-equal-hash-key (generic-function generalizer))
(defmethod generalizer-equal-hash-key
    ((gf specializable-generic-function) (g class))
  (sb-pcl::class-wrapper g))

(defun first-arg-only-special-case (gf)
  (let ((arg-info (sb-pcl::gf-arg-info gf)))
    (and (slot-value gf 'single-arg-cacheing-p)
         (>= (sb-pcl::arg-info-number-required arg-info) 1)
         (every (lambda (x) (eql x t))
                (cdr (sb-pcl::arg-info-metatypes arg-info))))))

;;; FIXME: in some kind of order, the discriminating function needs to handle:
;;; - argument count checking;
;;; - DONE (in effective method) keyword argument validity;
;;; - DONE flushing the emf cache on method addition/removal
;;; - DONE (sort of, using wrappers/g-e-h-k) flushing the cache on class redefinition;
;;; - cache thread-safety.
;;; - speed
;;; - DONE (in SBCL itself) interaction with TRACE et al.
(defmethod sb-mop:compute-discriminating-function ((gf specializable-generic-function))
  (cond
    ((not (slot-value gf 'cacheingp))
     (lambda (&rest args)
       (let ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
                                   args)))
         (slow-method-lookup-and-call gf args generalizers))))
    ((first-arg-only-special-case gf)
     (lambda (&rest args)
       (let* ((g (generalizer-of-using-class gf (car args)))
              (k (generalizer-equal-hash-key gf g))
              (emfun (gethash k (emf-table gf) nil)))
         (if emfun
             (sb-pcl::invoke-emf emfun args)
             (slow-method-lookup-and-call
              gf args (cons g (mapcar (lambda (x) (generalizer-of-using-class gf x))
                                      (cdr (required-portion gf args)))))))))
    (t
     (lambda (&rest args)
       (let* ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
                                    (required-portion gf args)))
              (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers))
              (emfun (gethash keys (emf-table gf) nil)))
         (if emfun
             (sb-pcl::invoke-emf emfun args)
             (slow-method-lookup-and-call gf args generalizers)))))))

(defmethod reinitialize-instance :after ((gf specializable-generic-function) &key)
  (clrhash (emf-table gf)))

(defun slow-method-lookup (gf args generalizers)
  (multiple-value-bind (applicable-methods definitivep)
      (compute-applicable-methods-using-generalizers gf generalizers)
    (unless definitivep
      (setf applicable-methods (compute-applicable-methods gf args)))
    (values (compute-effective-method-function gf applicable-methods)
            definitivep)))

(defun slow-method-lookup-and-call (gf args generalizers)
  (multiple-value-bind (emf cacheablep)
      (slow-method-lookup gf args generalizers)
    (when cacheablep
      (let ((keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers)))
        (if (first-arg-only-special-case gf)
            (setf (gethash (car keys) (emf-table gf)) emf)
            (setf (gethash keys (emf-table gf)) emf))))
    (sb-pcl::invoke-emf emf args)))

(defun compute-effective-method-function (gf methods)
  (if (null methods)
      (lambda (&rest args) (apply #'no-applicable-method gf args))
      (let* ((mc (sb-mop:generic-function-method-combination gf))
             (sb-pcl::*applicable-methods* methods)
             (em (sb-mop:compute-effective-method gf mc methods)))
        (sb-pcl::make-effective-method-function gf em))))

;; new, not in closette
(defgeneric generalizer-of-using-class (generic-function object))
(defmethod generalizer-of-using-class ((generic-function specializable-generic-function) object)
  (class-of object))

(defgeneric specializer-accepts-generalizer-p (gf specializer generalizer))
(defmethod specializer-accepts-generalizer-p
    ((gf specializable-generic-function) (specializer class) (generalizer class))
  (if (subtypep generalizer specializer)
      (values t t)
      (values nil t)))
(defmethod specializer-accepts-generalizer-p
    ((gf specializable-generic-function) (specializer sb-mop:eql-specializer) (generalizer class))
  (if (eq generalizer (class-of (sb-mop:eql-specializer-object specializer)))
      (values t nil)
      (values nil t)))

(defgeneric compute-applicable-methods-using-generalizers (gf generalizers))
(defmethod compute-applicable-methods-using-generalizers
    ((gf specializable-generic-function) generalizers)
  ;; differs from closette
  (let ((result-definitive-p t))
    (flet ((filter (method)
             (every (lambda (s g)
                      (multiple-value-bind (acceptsp definitivep)
                          (specializer-accepts-generalizer-p gf s g)
                        (unless definitivep
                          (setf result-definitive-p nil))
                        acceptsp))
                    (sb-mop:method-specializers method) generalizers))
           (sorter (m1 m2)
             (method-more-specific-p gf m1 m2 generalizers)))
      (values
       (sort
        (copy-list (remove-if-not #'filter (sb-mop:generic-function-methods gf)))
        #'sorter)
       result-definitive-p))))

;; new, not in closette
(defgeneric specializer-accepts-p (specializer object))
(defmethod specializer-accepts-p ((specializer class) object)
  (typep object specializer))
(defmethod specializer-accepts-p ((specializer sb-mop:eql-specializer) object)
  (eq object (sb-mop:eql-specializer-object specializer)))

(defmethod compute-applicable-methods
    ((gf specializable-generic-function) arguments)
  ;; new, not in closette
  (sort
   (copy-list
    (remove-if-not #'(lambda (method)
		       (every #'specializer-accepts-p
			      (sb-mop:method-specializers method)
			      arguments))
		   (sb-mop:generic-function-methods gf)))
   (let ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
                               (required-portion gf arguments))))
     (lambda (m1 m2)
       (method-more-specific-p gf m1 m2 generalizers)))))

(defun method-more-specific-p (gf method1 method2 generalizers)
  ;; FIXME: argument precedence order
  (block nil
    (mapc #'(lambda (spec1 spec2 generalizer)
	      (ecase (specializer< gf spec1 spec2 generalizer)
		(< (return t))
		(=)
		((nil > /=) (return nil))))
	  (sb-mop:method-specializers method1)
	  (sb-mop:method-specializers method2)
	  generalizers)
    nil))

;; new, not in closette
(defgeneric specializer< (gf s1 s2 generalizer))
(defmethod specializer<
    ((gf specializable-generic-function) (s1 class) (s2 class) (generalizer class))
  (if (eq s1 s2)
      '=
      (let ((cpl (sb-mop:class-precedence-list generalizer)))
	(if (find s2 (cdr (member s1 cpl)))
	    '<
            '>))))
(defmethod specializer<
    ((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 sb-mop:eql-specializer) generalizer)
  (declare (ignore generalizer))
  (if (eq (sb-mop:eql-specializer-object s1) (sb-mop:eql-specializer-object s2))
      '=
      nil))
(defmethod specializer< ((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 class) generalizer)
  (declare (ignore generalizer))
  '<)
(defmethod specializer< ((gf specializable-generic-function) (c1 class) (c2 sb-mop:eql-specializer) generalizer)
  (declare (ignore generalizer))
  '>)