;;;; miscellaneous side-effectful tests of the MOP

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

;;; a test of a non-standard specializer class and non-standard
;;; generic function class, which nevertheless admit the cacheing
;;; strategy implicit in the second return value of
;;; compute-applicable-methods-using-classes.

(load "assertoid.lisp")

(defpackage "OR-SPECIALIZER-TEST"
  (:use "CL" "SB-MOP" "ASSERTOID"))

(in-package "OR-SPECIALIZER-TEST")

(defclass or-specializer (specializer)
  ((classes :initform nil :reader or-specializer-classes :initarg :classes)
   (direct-methods :initform nil :reader specializer-direct-methods)))

(defvar *or-specializer-table* (make-hash-table :test 'equal))

(defun ensure-or-specializer (&rest classes)
  ;; FIXME: duplicate hash values
  (let* ((cs (mapcar (lambda (x) (if (symbolp x) (find-class x) x)) classes))
         (sorted-classes (sort cs #'< :key #'sxhash)))
    (or (gethash sorted-classes *or-specializer-table*)
        (setf (gethash sorted-classes *or-specializer-table*)
              (make-instance 'or-specializer :classes sorted-classes)))))

(defclass gf-with-or (standard-generic-function) ()
  (:metaclass funcallable-standard-class))

(defmethod compute-applicable-methods-using-classes
    ((generic-function gf-with-or) classes)
  ;; FIXME: assume one-argument for now
  (let (applicable-methods)
    (let ((methods (generic-function-methods generic-function)))
      (dolist (m methods)
        (let ((specializer (car (method-specializers m)))
              (class (car classes)))
          (typecase specializer
            (class (when (subtypep class specializer)
                     (push m applicable-methods)))
            (eql-specializer
             (when (eql (class-of (eql-specializer-object specializer))
                        class)
               (return-from compute-applicable-methods-using-classes
                 (values nil nil))))
            (or-specializer
             (dolist (c (or-specializer-classes specializer))
               (when (subtypep class c)
                 (push m applicable-methods))))))))
    ;; FIXME: sort the methods
    (values applicable-methods t)))

(defmethod compute-applicable-methods
    ((generic-function gf-with-or) arguments)
  ;; FIXME: assume one-argument for now
  (let (applicable-methods)
    (let ((methods (generic-function-methods generic-function)))
      (dolist (m methods)
        (let ((specializer (car (method-specializers m)))
              (argument (car arguments)))
          (typecase specializer
            (class (when (typep argument specializer)
                     (push m applicable-methods)))
            (eql-specializer
             (when (eql (eql-specializer-object specializer) argument)
               (push m applicable-methods)))
            (or-specializer
             (dolist (c (or-specializer-classes specializer))
               (when (typep argument c)
                 (push m applicable-methods))))))))
    ;; FIXME: sort the methods
    applicable-methods))

(defmethod add-direct-method ((specializer or-specializer) method)
  (pushnew method (slot-value specializer 'direct-methods)))

(defmethod remove-direct-method ((specializer or-specializer) method)
  (setf (slot-value specializer 'direct-methods)
        (remove method (slot-value specializer 'direct-methods))))

;;; FIXME: write SPECIALIZER-DIRECT-GENERIC-FUNCTIONS method

(defclass class1 () ())
(defclass class2 () ())
(defclass class3 () ())
(defclass class4 (class1) ())

(defgeneric foo (x)
  (:generic-function-class gf-with-or))

(let ((specializer (ensure-or-specializer 'class1 'class2)))
  (eval `(defmethod foo ((x ,specializer)) t)))

(assert (foo (make-instance 'class1)))
(assert (foo (make-instance 'class2)))
(assert (raises-error? (foo (make-instance 'class3))))
(assert (foo (make-instance 'class4)))

;;; check that we are actually cacheing effective methods.  If the
;;; representation in PCL changes, this test needs to change too.
(assert (typep (cddr (sb-pcl::gf-dfun-state #'foo)) 'sb-pcl::caching))