source: trunk/source/tests/ansi-tests/find-class.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 7.5 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Thu May 29 07:15:06 2003
4;;;; Contains: Tests of FIND-CLASS
5
6;; find-class is also tested in numerous other places.
7
8(in-package :cl-test)
9
10(deftest find-class.1
11  (loop for name in *cl-types-that-are-classes-symbols*
12        unless (eq (find-class name) (find-class name))
13        collect name)
14  nil)
15
16(deftest find-class.2
17  (loop for name in *cl-types-that-are-classes-symbols*
18        unless (eq (find-class name t) (find-class name))
19        collect name)
20  nil)
21
22(deftest find-class.3
23  (loop for name in *cl-types-that-are-classes-symbols*
24        unless (eq (find-class name nil) (find-class name))
25        collect name)
26  nil)
27
28(deftest find-class.4
29  (handler-case
30   (progn (eval '(find-class (gensym))) :bad)
31   (error () :good))
32  :good)
33
34(deftest find-class.5
35  (handler-case
36   (progn (eval '(find-class (gensym) t)) :bad)
37   (error () :good))
38  :good)
39
40(deftest find-class.6
41  (find-class (gensym) nil)
42  nil)
43
44(deftest find-class.7
45  (loop for name in *cl-types-that-are-classes-symbols*
46        unless (eq (find-class name t nil) (find-class name))
47        collect name)
48  nil)
49
50(deftest find-class.8
51  (loop for name in *cl-types-that-are-classes-symbols*
52        unless (eq (find-class name nil nil) (find-class name))
53        collect name)
54  nil)
55
56(deftest find-class.9
57  (macrolet
58      ((%m (&environment env)
59           (let ((result
60                  (loop for name in *cl-types-that-are-classes-symbols*
61                        unless (eq (find-class name nil env)
62                                   (find-class name))
63                        collect name)))
64             `',result)))
65    (%m))
66  nil)
67
68(deftest find-class.10
69  (macrolet
70      ((%m (&environment env)
71           (let ((result
72                  (loop for name in *cl-types-that-are-classes-symbols*
73                        unless (eq (find-class name t env)
74                                   (find-class name))
75                        collect name)))
76             `',result)))
77    (%m))
78  nil)
79
80(deftest find-class.11
81  (handler-case
82   (progn (eval '(find-class (gensym) 'a nil)) :bad)
83   (error () :good))
84  :good)
85
86(deftest find-class.12
87  (find-class (gensym) nil nil)
88  nil)
89
90(deftest find-class.13
91  (macrolet
92      ((%m (&environment env)
93           `',(find-class (gensym) nil env)))
94    (%m))
95  nil)
96
97(deftest find-class.14
98  (handler-case
99   (progn
100     (eval '(macrolet
101                ((%m (&environment env)
102                     `',(find-class (gensym) 17 env)))
103              (%m)))
104     :bad)
105   (error () :good))
106  :good)
107
108;;; Need tests of assignment to (FIND-CLASS ...)
109;;; Add tests of:
110;;;   Setting class to itself
111;;;   Changing class to a different class
112;;;   Changing to NIL (and that the class object stays around)
113;;;   Check that find-class is affected by the assignment, and
114;;;    class-name is not.
115
116(deftest find-class.15
117  (progn
118    (setf (find-class 'find-class-class-01) nil)
119    (let* ((class  (eval '(defclass find-class-class-01 () ())))
120           (class1 (find-class 'find-class-class-01))
121           (class2 (setf (find-class 'find-class-class-01) class1)))
122      (values
123       (eqt class class1)
124       (eqt class class2)
125       (class-name class)
126       )))
127  t t find-class-class-01)
128
129(deftest find-class.16
130  (progn
131    (setf (find-class 'find-class-class-01 nil) nil)
132    (setf (find-class 'find-class-class-01 t) nil) ;; should not throw error
133    (let* ((i 0)
134           (class  (eval '(defclass find-class-class-01 () ())))
135           (class1 (find-class 'find-class-class-01))
136           (class2 (setf (find-class 'find-class-class-01 (incf i)) class1)))
137      (values
138       i
139       (eqt class class1)
140       (eqt class class2))))
141  1 t t)
142
143(deftest find-class.17
144  (macrolet
145      ((%m (&environment env)
146           `',(progn
147                (setf (find-class 'find-class-class-01) nil)
148                (let*
149                    ((i 0)
150                     x y z
151                     (class  (eval '(defclass find-class-class-01 () ())))
152                     (class1 (find-class (progn (setf x (incf i))
153                                                'find-class-class-01)
154                                         (setf y (incf i))
155                                         (progn (setf z (incf i)) env)))
156                     (class2 (setf (find-class 'find-class-class-01) class1)))
157                  (list
158                   (eqt class class1)
159                   (eqt class class2)
160                   i x y z
161                   )))))
162    (%m))
163  (t t 3 1 2 3))
164
165(deftest find-class.18
166  (progn
167    (setf (find-class 'find-class-class-01) nil)
168    (let* ((class  (eval '(defclass find-class-class-01 () ())))
169           (class1 (find-class 'find-class-class-01))
170           (class2 (setf (find-class 'find-class-class-01) nil))
171           (class3 (find-class 'find-class-class-01 nil)))
172      (values
173       (eqt class class1)
174       (eqt class class2)
175       class2
176       (class-name class)
177       class3)))
178  t nil nil find-class-class-01 nil)
179
180(deftest find-class.19
181  (progn
182    (setf (find-class 'find-class-class-01 nil) nil)
183    (setf (find-class 'find-class-class-01 t) nil) ;; should not throw error
184    (let* ((class  (eval '(defclass find-class-class-01 () ())))
185           (class1 (find-class 'find-class-class-01))
186           (class2 (setf (find-class 'find-class-class-01 t nil)
187                         class1)))
188      (values
189       (eqt class class1)
190       (eqt class class2))))
191  t t)
192
193;; Change to a different class
194
195(deftest find-class.20
196  (progn
197    (setf (find-class 'find-class-class-01) nil)
198    (setf (find-class 'find-class-class-02) nil)
199    (let* ((class1 (eval '(defclass find-class-class-01 () ())))
200           (class2 (eval '(defclass find-class-class-02 () ()))))
201      (setf (find-class 'find-class-class-01) class2)
202      (let* ((new-class1 (find-class 'find-class-class-01 nil))
203             (new-class2 (find-class 'find-class-class-02)))
204        (values
205         (eqt class1 class2)
206         (eqt class2 new-class1)
207         (eqt class2 new-class2)
208         (class-name class2)))))
209  nil t t find-class-class-02)
210
211(deftest find-class.21
212  (progn
213    (setf (find-class 'find-class-class-01) nil)
214    (setf (find-class 'find-class-class-02) nil)
215    (let* ((class1 (eval '(defclass find-class-class-01 () ())))
216           (class2 (eval '(defclass find-class-class-02 () ()))))
217      (psetf (find-class 'find-class-class-01) class2
218             (find-class 'find-class-class-02) class1)
219      (let* ((new-class1 (find-class 'find-class-class-01 nil))
220             (new-class2 (find-class 'find-class-class-02)))
221        (values
222         (eqt class1 class2)
223         (eqt class2 new-class1)
224         (eqt class1 new-class2)
225         (class-name new-class1)
226         (class-name new-class2)
227         ))))
228  nil t t find-class-class-02 find-class-class-01)
229
230;;; Effect on method dispatch
231
232(deftest find-class.22
233  (progn
234    (setf (find-class 'find-class-class-01) nil)
235    (let* ((class1 (eval
236                    '(defclass find-class-class-01 () ())))
237           (fn (eval '(defgeneric find-class-gf-01 (x)
238                        (:method ((x find-class-class-01)) :good)
239                        (:method ((x t)) nil))))
240           (obj (make-instance class1)))
241      (assert (typep fn 'function))
242      (locally
243       (declare (type function fn))
244       (values
245        (funcall fn nil)
246        (funcall fn obj)
247        (setf (find-class 'find-class-class-01) nil)
248        (funcall fn nil)
249        (funcall fn obj)))))
250  nil :good nil nil :good)
251
252(deftest find-class.23
253  (progn
254    (setf (find-class 'find-class-class-01) nil)
255    (setf (find-class 'find-class-class-02) nil)
256    (let* ((class1 (eval '(defclass find-class-class-01 () ())))
257           (class2 (eval '(defclass find-class-class-02
258                            (find-class-class-01) ())))
259           (fn (eval '(defgeneric find-class-gf-02 (x)
260                        (:method ((x find-class-class-01)) 1)
261                        (:method ((x find-class-class-02)) 2)
262                        (:method ((x t)) t))))
263           (obj1 (make-instance class1))
264           (obj2 (make-instance class2)))
265      (assert (typep fn 'function))
266      (locally
267       (declare (type function fn))
268       (values
269        (funcall fn nil)
270        (funcall fn obj1)
271        (funcall fn obj2)
272        (setf (find-class 'find-class-class-01) nil)
273        (funcall fn nil)
274        (funcall fn obj1)
275        (funcall fn obj2)))))
276  t 1 2 nil t 1 2)
277
278;;; Error tests
279
280(deftest find-class.error.1
281  (signals-error (find-class) program-error)
282  t)
283
284(deftest find-class.error.2
285  (signals-error (find-class 'symbol nil nil nil) program-error)
286  t)
Note: See TracBrowser for help on using the repository browser.