;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Thu May 29 07:15:06 2003
;;;; Contains: Tests of FIND-CLASS

;; find-class is also tested in numerous other places.



(deftest find-class.1
  (loop for name in *cl-types-that-are-classes-symbols*
        unless (eq (find-class name) (find-class name))
        collect name)
  nil)

(deftest find-class.2
  (loop for name in *cl-types-that-are-classes-symbols*
        unless (eq (find-class name t) (find-class name))
        collect name)
  nil)

(deftest find-class.3
  (loop for name in *cl-types-that-are-classes-symbols*
        unless (eq (find-class name nil) (find-class name))
        collect name)
  nil)

(deftest find-class.4
  (handler-case
   (progn (eval '(find-class (gensym))) :bad)
   (error () :good))
  :good)

(deftest find-class.5
  (handler-case
   (progn (eval '(find-class (gensym) t)) :bad)
   (error () :good))
  :good)

(deftest find-class.6
  (find-class (gensym) nil)
  nil)

(deftest find-class.7
  (loop for name in *cl-types-that-are-classes-symbols*
        unless (eq (find-class name t nil) (find-class name))
        collect name)
  nil)

(deftest find-class.8
  (loop for name in *cl-types-that-are-classes-symbols*
        unless (eq (find-class name nil nil) (find-class name))
        collect name)
  nil)

(deftest find-class.9
  (macrolet
      ((%m (&environment env)
           (let ((result
                  (loop for name in *cl-types-that-are-classes-symbols*
                        unless (eq (find-class name nil env)
                                   (find-class name))
                        collect name)))
             `',result)))
    (%m))
  nil)

(deftest find-class.10
  (macrolet
      ((%m (&environment env)
           (let ((result
                  (loop for name in *cl-types-that-are-classes-symbols*
                        unless (eq (find-class name t env)
                                   (find-class name))
                        collect name)))
             `',result)))
    (%m))
  nil)

(deftest find-class.11
  (handler-case
   (progn (eval '(find-class (gensym) 'a nil)) :bad)
   (error () :good))
  :good)

(deftest find-class.12
  (find-class (gensym) nil nil)
  nil)

(deftest find-class.13
  (macrolet
      ((%m (&environment env)
           `',(find-class (gensym) nil env)))
    (%m))
  nil)

(deftest find-class.14
  (handler-case
   (progn
     (eval '(macrolet
                ((%m (&environment env)
                     `',(find-class (gensym) 17 env)))
              (%m)))
     :bad)
   (error () :good))
  :good)

;;; Need tests of assignment to (FIND-CLASS ...)
;;; Add tests of:
;;;   Setting class to itself
;;;   Changing class to a different class
;;;   Changing to NIL (and that the class object stays around)
;;;   Check that find-class is affected by the assignment, and
;;;    class-name is not.

(deftest find-class.15
  (progn
    (setf (find-class 'find-class-class-01) nil)
    (let* ((class  (eval '(defclass find-class-class-01 () ())))
           (class1 (find-class 'find-class-class-01))
           (class2 (setf (find-class 'find-class-class-01) class1)))
      (values
       (eqt class class1)
       (eqt class class2)
       (class-name class)
       )))
  t t find-class-class-01)

(deftest find-class.16
  (progn
    (setf (find-class 'find-class-class-01 nil) nil)
    (setf (find-class 'find-class-class-01 t) nil) ;; should not throw error
    (let* ((i 0)
           (class  (eval '(defclass find-class-class-01 () ())))
           (class1 (find-class 'find-class-class-01))
           (class2 (setf (find-class 'find-class-class-01 (incf i)) class1)))
      (values
       i
       (eqt class class1)
       (eqt class class2))))
  1 t t)

(deftest find-class.17
  (macrolet
      ((%m (&environment env)
           `',(progn
                (setf (find-class 'find-class-class-01) nil)
                (let*
                    ((i 0)
                     x y z
                     (class  (eval '(defclass find-class-class-01 () ())))
                     (class1 (find-class (progn (setf x (incf i))
                                                'find-class-class-01)
                                         (setf y (incf i))
                                         (progn (setf z (incf i)) env)))
                     (class2 (setf (find-class 'find-class-class-01) class1)))
                  (list
                   (eqt class class1)
                   (eqt class class2)
                   i x y z
                   )))))
    (%m))
  (t t 3 1 2 3))

(deftest find-class.18
  (progn
    (setf (find-class 'find-class-class-01) nil)
    (let* ((class  (eval '(defclass find-class-class-01 () ())))
           (class1 (find-class 'find-class-class-01))
           (class2 (setf (find-class 'find-class-class-01) nil))
           (class3 (find-class 'find-class-class-01 nil)))
      (values
       (eqt class class1)
       (eqt class class2)
       class2
       (class-name class)
       class3)))
  t nil nil find-class-class-01 nil)

(deftest find-class.19
  (progn
    (setf (find-class 'find-class-class-01 nil) nil)
    (setf (find-class 'find-class-class-01 t) nil) ;; should not throw error
    (let* ((class  (eval '(defclass find-class-class-01 () ())))
           (class1 (find-class 'find-class-class-01))
           (class2 (setf (find-class 'find-class-class-01 t nil)
                         class1)))
      (values
       (eqt class class1)
       (eqt class class2))))
  t t)

;; Change to a different class

(deftest find-class.20
  (progn
    (setf (find-class 'find-class-class-01) nil)
    (setf (find-class 'find-class-class-02) nil)
    (let* ((class1 (eval '(defclass find-class-class-01 () ())))
           (class2 (eval '(defclass find-class-class-02 () ()))))
      (setf (find-class 'find-class-class-01) class2)
      (let* ((new-class1 (find-class 'find-class-class-01 nil))
             (new-class2 (find-class 'find-class-class-02)))
        (values
         (eqt class1 class2)
         (eqt class2 new-class1)
         (eqt class2 new-class2)
         (class-name class2)))))
  nil t t find-class-class-02)

(deftest find-class.21
  (progn
    (setf (find-class 'find-class-class-01) nil)
    (setf (find-class 'find-class-class-02) nil)
    (let* ((class1 (eval '(defclass find-class-class-01 () ())))
           (class2 (eval '(defclass find-class-class-02 () ()))))
      (psetf (find-class 'find-class-class-01) class2
             (find-class 'find-class-class-02) class1)
      (let* ((new-class1 (find-class 'find-class-class-01 nil))
             (new-class2 (find-class 'find-class-class-02)))
        (values
         (eqt class1 class2)
         (eqt class2 new-class1)
         (eqt class1 new-class2)
         (class-name new-class1)
         (class-name new-class2)
         ))))
  nil t t find-class-class-02 find-class-class-01)

;;; Effect on method dispatch

(deftest find-class.22
  (progn
    (setf (find-class 'find-class-class-01) nil)
    (let* ((class1 (eval
                    '(defclass find-class-class-01 () ())))
           (fn (eval '(defgeneric find-class-gf-01 (x)
                        (:method ((x find-class-class-01)) :good)
                        (:method ((x t)) nil))))
           (obj (make-instance class1)))
      (assert (typep fn 'function))
      (locally
       (declare (type function fn))
       (values
        (funcall fn nil)
        (funcall fn obj)
        (setf (find-class 'find-class-class-01) nil)
        (funcall fn nil)
        (funcall fn obj)))))
  nil :good nil nil :good)

(deftest find-class.23
  (progn
    (setf (find-class 'find-class-class-01) nil)
    (setf (find-class 'find-class-class-02) nil)
    (let* ((class1 (eval '(defclass find-class-class-01 () ())))
           (class2 (eval '(defclass find-class-class-02
                            (find-class-class-01) ())))
           (fn (eval '(defgeneric find-class-gf-02 (x)
                        (:method ((x find-class-class-01)) 1)
                        (:method ((x find-class-class-02)) 2)
                        (:method ((x t)) t))))
           (obj1 (make-instance class1))
           (obj2 (make-instance class2)))
      (assert (typep fn 'function))
      (locally
       (declare (type function fn))
       (values
        (funcall fn nil)
        (funcall fn obj1)
        (funcall fn obj2)
        (setf (find-class 'find-class-class-01) nil)
        (funcall fn nil)
        (funcall fn obj1)
        (funcall fn obj2)))))
  t 1 2 nil t 1 2)

;;; CLHS defclass: If a defclass form appears as a top level form,
;;; [...] the compiler must make the class definition available to be
;;; returned by find-class when its environment argument is a value
;;; received as the environment parameter of a macro.

(defvar *find-class-in-environment-results*)

(deftest find-class.24
  (let ((file-name "find-class-in-environment.lisp")
        (results nil))
    (with-open-file (s file-name :direction :output :if-exists :supersede)
      (prin1 '(defclass test-class () ())
             s)
      (prin1 '(defmacro test-macro (&environment env)
               (let ((class (find-class 'test-class nil env)))
                 `(list ,(notnot (typep class 'class))
                        ,(notnot (and class (eq (class-name class) 'test-class)))
                        ,(null (typep nil 'test-class env)))))
             s)
      (prin1 '(setf *find-class-in-environment-results* (test-macro))
             s)
      (terpri s))
    (setf (find-class 'test-class) nil)
    (load file-name)
    (push *find-class-in-environment-results* results)
    (setf (find-class 'test-class) nil)
    (load (compile-file file-name))
    (push *find-class-in-environment-results* results)
    results)
  ((t t t) (t t t)))

;;; Error tests

(deftest find-class.error.1
  (signals-error (find-class) program-error)
  t)

(deftest find-class.error.2
  (signals-error (find-class 'symbol nil nil nil) program-error)
  t)