← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/find-class.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/find-class.lsp
 
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)