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

(load "assertoid.lisp")

(defpackage "CLOS-1"
  (:use "CL" "ASSERTOID" "TEST-UTIL"))

;;; 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 (compile nil '(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 (raises-error? (b-of *foo*)))
    (assert (raises-error? (c-of *foo*)))))

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

(let ((fun (compile nil '(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 (raises-error? (c-of *foo*)))))

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

(let ((fun (compile nil '(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 (compile nil '(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 (compile nil '(lambda (x) (slot-value x 'a)))))
  (dotimes (i 4) ; KLUDGE: get caches warm
    (assert (raises-error? (slot-value *foo* 'a)))
    (assert (raises-error? (a-of *foo*)))
    (assert (raises-error? (funcall fun *foo*)))
    (assert (= 3 (b-of *foo*)))
    (assert (raises-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)
  (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)
  (assert
   (null
    (nth-value
     1
     (progn
       (defgeneric foo (x &key))
       (defmethod foo ((x integer) &key bar) (list x bar))
       (compile nil '(lambda () (foo (read) :bar 10))))))))

(fmakunbound 'foo)
(with-test (:name :keywords-supplied-in-methods-ok-2)
  (assert
   (nth-value
    1
    (progn
      (defgeneric foo (x &key))
      (defmethod foo ((x integer) &key bar) (list x bar))
      ;; On second thought...
      (remove-method #'foo (find-method #'foo () '(integer)))
      (compile nil '(lambda () (foo (read) :bar 10)))))))

;; 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.
  (assert
   (null (nth-value 1 (compile nil '(lambda () (foo 5 :w 10 :foo 15))))))
  (assert
   (not (sb-kernel::args-type-keyp (sb-c::info :function :type '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))
  (assert
   (null (nth-value 1 (compile nil '(lambda () (foo 5 :z 10 :y 15))))))
  (assert
   (null (nth-value 1 (compile nil '(lambda () (foo 5 :z 10 :foo 15))))))
  (assert
   (sb-kernel::args-type-keyp (sb-c::info :function :type 'foo)))
  (assert
   (sb-kernel::args-type-allowp (sb-c::info :function :type '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))
  (assert (null (nth-value 1 (compile nil '(lambda () (foo 10 :foo 20))))))
  (assert (sb-kernel::args-type-keyp (sb-c::info :function :type 'foo)))
  (assert (sb-kernel::args-type-allowp (sb-c::info :function :type 'foo))))