;;;; miscellaneous side-effectful tests of CLOS

;;;; 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.

;;; clos.impure.lisp was getting too big and confusing

;;; tests that various optimization paths for slot-valuish things
;;; respect class redefinitions.
(defclass foo ()
  ((a :initarg :a)))

(defvar *foo* (make-instance 'foo :a 1))

(defmethod a-of ((x foo))
  (slot-value x 'a))
(defmethod b-of ((x foo))
  (slot-value x 'b))
(defmethod c-of ((x foo))
  (slot-value x 'c))

(let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  (dotimes (i 4)                        ; KLUDGE: get caches warm
    (assert (= 1 (slot-value *foo* 'a)))
    (assert (= 1 (a-of *foo*)))
    (assert (= 1 (funcall fun *foo*)))
    (assert-error (b-of *foo*))
    (assert-error (c-of *foo*))))

(defclass foo ()
  ((b :initarg :b :initform 3) (a :initarg :a)))

(let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  (dotimes (i 4)                        ; KLUDGE: get caches warm
    (assert (= 1 (slot-value *foo* 'a)))
    (assert (= 1 (a-of *foo*)))
    (assert (= 1 (funcall fun *foo*)))
    (assert (= 3 (b-of *foo*)))
    (assert-error (c-of *foo*))))

(defclass foo ()
  ((c :initarg :c :initform t :allocation :class)
   (b :initarg :b :initform 3)
   (a :initarg :a)))

(let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  (dotimes (i 4) ; KLUDGE: get caches warm
    (assert (= 1 (slot-value *foo* 'a)))
    (assert (= 1 (a-of *foo*)))
    (assert (= 1 (funcall fun *foo*)))
    (assert (= 3 (b-of *foo*)))
    (assert (eq t (c-of *foo*)))))

(defclass foo ()
  ((a :initarg :a)
   (b :initarg :b :initform 3)
   (c :initarg :c :initform t)))

(let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  (dotimes (i 4) ; KLUDGE: get caches warm
    (assert (= 1 (slot-value *foo* 'a)))
    (assert (= 1 (a-of *foo*)))
    (assert (= 1 (funcall fun *foo*)))
    (assert (= 3 (b-of *foo*)))
    (assert (eq t (c-of *foo*)))))

(defclass foo ()
  ((b :initarg :b :initform 3)))

(let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  (dotimes (i 4)                        ; KLUDGE: get caches warm
    (assert-error (slot-value *foo* 'a))
    (assert-error (a-of *foo*))
    (assert-error (funcall fun *foo*))
    (assert (= 3 (b-of *foo*)))
    (assert-error (c-of *foo*))))

;;; test that :documentation argument to slot specifiers are used as
;;; the docstrings of accessor methods.
(defclass foo ()
  ((a :reader a-of :documentation "docstring for A")
   (b :writer set-b-of :documentation "docstring for B")
   (c :accessor c :documentation  "docstring for C")))

(flet ((doc (fun)
         (documentation fun t)))
  (assert (string= (doc (find-method #'a-of nil '(foo))) "docstring for A"))
  (assert (string= (doc (find-method #'set-b-of nil '(t foo))) "docstring for B"))
  (assert (string= (doc (find-method #'c nil '(foo))) "docstring for C"))
  (assert (string= (doc (find-method #'(setf c) nil '(t foo))) "docstring for C")))

;;; some nasty tests of NO-NEXT-METHOD.
(defvar *method-with-no-next-method*)
(defvar *nnm-count* 0)
(defun make-nnm-tester (x)
  (setq *method-with-no-next-method* (defmethod nnm-tester ((y (eql x))) (call-next-method))))
(make-nnm-tester 1)
(defmethod no-next-method ((gf (eql #'nnm-tester)) method &rest args)
  (declare (ignore args))
  (assert (eql method *method-with-no-next-method*))
  (incf *nnm-count*))
(with-test (:name (no-next-method :unknown-specializer))
  (nnm-tester 1)
  (assert (= *nnm-count* 1)))
(let ((gf #'nnm-tester))
  (reinitialize-instance gf :name 'new-nnm-tester)
  (setf (fdefinition 'new-nnm-tester) gf))
(with-test (:name (no-next-method :gf-name-changed))
  (new-nnm-tester 1)
  (assert (= *nnm-count* 2)))

;;; Tests the compiler's incremental rejiggering of GF types.
(fmakunbound 'foo)
(with-test (:name :keywords-supplied-in-methods-ok-1)
  (defgeneric foo (x &key))
  (defmethod foo ((x integer) &key bar) (list x bar))
  (checked-compile '(lambda () (foo (read) :bar 10))))

(fmakunbound 'foo)
(with-test (:name :keywords-supplied-in-methods-ok-2)
  (defgeneric foo (x &key))
  (defmethod foo ((x integer) &key bar) (list x bar))
  ;; On second thought...
  (remove-method #'foo (find-method #'foo () '(integer)))
  (multiple-value-bind  (fun failure-p warnings style-warnings)
      (checked-compile '(lambda () (foo (read) :bar 10))
                       :allow-style-warnings t)
    (declare (ignore fun failure-p warnings))
    (assert (= (length style-warnings) 1))))

;; If the GF has &REST with no &KEY, not all methods are required to
;; parse the tail of the arglist as keywords, so we don't treat the
;; function type as having &KEY in it.
(fmakunbound 'foo)
(with-test (:name :gf-rest-method-key)
  (defgeneric foo (x &rest y))
  (defmethod foo ((i integer) &key w) (list i w))
  ;; 1.0.20.30 failed here.
  (checked-compile '(lambda () (foo 5 :w 10 :foo 15)))
  (assert
   (not (sb-kernel::args-type-keyp (sb-int:global-ftype 'foo)))))

;; If the GF has &KEY and &ALLOW-OTHER-KEYS, the methods' keys can be
;; anything, and we don't warn about unrecognized keys.
(fmakunbound 'foo)
(with-test (:name :gf-allow-other-keys)
  (defgeneric foo (x &key &allow-other-keys))
  (defmethod foo ((i integer) &key y z) (list i y z))
  ;; Correctness of a GF's ftype was previously ensured by the compiler,
  ;; and only if a lambda was compiled that referenced the GF, in a way
  ;; that was just barely non-broken enough to make the compiler happy.
  ;; Now the FTYPE is computed the instant anyone asks for it.
  (assert (equal (mapcar 'sb-kernel:key-info-name
                         (sb-kernel:fun-type-keywords
                          (sb-int:global-ftype 'foo)))
                 '(:y :z)))
  (checked-compile '(lambda () (foo 5 :z 10 :y 15)))
  (checked-compile '(lambda () (foo 5 :z 10 :foo 15)))
  (assert
   (sb-kernel::args-type-keyp (sb-int:global-ftype 'foo)))
  (assert
   (sb-kernel::args-type-allowp (sb-int:global-ftype 'foo))))

;; If any method has &ALLOW-OTHER-KEYS, 7.6.4 point 5 seems to say the
;; GF should be construed to have &ALLOW-OTHER-KEYS.
(fmakunbound 'foo)
(with-test (:name :method-allow-other-keys)
  (defgeneric foo (x &key))
  (defmethod foo ((x integer) &rest y &key &allow-other-keys) (list x y))
  (checked-compile '(lambda () (foo 10 :foo 20)))
  (assert (sb-kernel::args-type-keyp (sb-int:global-ftype 'foo)))
  (assert (sb-kernel::args-type-allowp (sb-int:global-ftype 'foo))))

(fmakunbound 'foo)
(with-test (:name (defmethod symbol-macrolet))
  (symbol-macrolet ((cnm (call-next-method)))
    (defmethod foo ((x number)) (1+ cnm)))
  (defmethod foo ((x t)) 3)
  (assert (= (foo t) 3))
  (assert (= (foo 3) 4)))

(fmakunbound 'foo)
(define-symbol-macro magic-cnm (call-next-method))
(with-test (:name (defmethod define-symbol-macro))
  (defmethod foo ((x number)) (1- magic-cnm))
  (defmethod foo ((x t)) 3)
  (assert (= (foo t) 3))
  (assert (= (foo 3) 2)))

(with-test (:name :bug-309084-a-i)
  (assert-error (eval '(define-method-combination bug-309084-a-i :documentation :operator))
                program-error))
(with-test (:name :bug-309084-a-ii)
  (assert-error (eval '(define-method-combination bug-309084-a-ii :documentation nil))
                program-error))
(with-test (:name :bug-309084-a-iii)
  (assert-error (eval '(define-method-combination bug-309084-a-iii nil))
                program-error))
(with-test (:name :bug-309084-a-vi)
  (assert-error (eval '(define-method-combination bug-309084-a-vi nil nil
                        (:generic-function)))
                program-error))
(with-test (:name :bug-309084-a-vii)
  (assert-error (eval '(define-method-combination bug-309084-a-vii nil nil
                        (:generic-function bar baz)))
                program-error))
(with-test (:name :bug-309084-a-viii)
  (assert-error (eval '(define-method-combination bug-309084-a-viii nil nil
                        (:generic-function (bar))))
                program-error))
(with-test (:name :bug-309084-a-ix)
  (assert-error (eval '(define-method-combination bug-309084-a-ix nil ((3))))
                program-error))
(with-test (:name :bug-309084-a-x)
  (assert-error (eval '(define-method-combination bug-309084-a-x nil ((a))))
                program-error))
(with-test (:name :bug-309084-a-iv)
  (assert-error (eval '(define-method-combination bug-309084-a-iv nil nil
                        (:arguments order &aux &key)))
                program-error))
(with-test (:name :bug-309084-a-v)
  (assert-error (eval '(define-method-combination bug-309084-a-v nil nil
                        (:arguments &whole)))
                program-error))

(define-method-combination bug-309084-b/mc nil
  ((all *))
  (:arguments x &optional (y 'a yp) &key (z 'b zp) &aux (w (list y z)))
  `(list ,x ,y ,yp ,z ,zp ,w))

(defgeneric bug-309084-b/gf (a &optional b &key &allow-other-keys)
  (:method-combination bug-309084-b/mc)
  (:method (m &optional n &key) (list m n)))

(with-test (:name :bug-309084-b)
  (assert (equal (bug-309084-b/gf 1) '(1 a nil b nil (a b))))
  (assert (equal (bug-309084-b/gf 1 2) '(1 2 t b nil (2 b))))
  (assert (equal (bug-309084-b/gf 1 2 :z 3) '(1 2 t 3 t (2 3)))))

(defgeneric bug-309084-b/gf2 (a b &optional c d &key &allow-other-keys)
  (:method-combination bug-309084-b/mc)
  (:method (m n &optional o p &key) (list m n o p)))

(with-test (:name :bug-309084-b2)
  (assert (equal (bug-309084-b/gf2 1 2) '(1 a nil b nil (a b))))
  (assert (equal (bug-309084-b/gf2 1 2 3) '(1 3 t b nil (3 b))))
  (assert (equal (bug-309084-b/gf2 1 2 3 4) '(1 3 t b nil (3 b))))
  (assert (equal (bug-309084-b/gf2 1 2 :z t) '(1 :z t b nil (:z b))))
  (assert (equal (bug-309084-b/gf2 1 2 3 4 :z 5) '(1 3 t 5 t (3 5)))))

(defmethod bug-1840595-a (x y))
(defmethod bug-1840595-z (x))

(with-test (:name :bug-1840595/reader)
  (eval '(defclass bug-1840595r () ()))
  (assert-error (eval '(defclass bug-1840595r () ((a :reader bug-1840595-a)))))
  (eval '(defclass bug-1840595r () ())))

(with-test (:name :bug-1840595/writer)
  (eval '(defclass bug-1840595w () ()))
  (assert-error (eval '(defclass bug-1840595w () ((z :writer bug-1840595-z)))))
  (eval '(defclass bug-1840595w () ())))
