/[gcl]/gcl/ansi-tests/find-class.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/find-class.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by pfdietz, Thu May 29 12:28:08 2003 UTC revision 1.2 by pfdietz, Sat May 31 12:36:09 2003 UTC
# Line 112  Line 112 
112  ;;;   Changing to NIL (and that the class object stays around)  ;;;   Changing to NIL (and that the class object stays around)
113  ;;;   Check that find-class is affected by the assignment, and  ;;;   Check that find-class is affected by the assignment, and
114  ;;;    class-name is not.  ;;;    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          (values
242           (funcall fn nil)
243           (funcall fn obj)
244           (setf (find-class 'find-class-class-01) nil)
245           (funcall fn nil)
246           (funcall fn obj))))
247      nil :good nil nil :good)
248    
249    (deftest find-class.23
250      (progn
251        (setf (find-class 'find-class-class-01) nil)
252        (setf (find-class 'find-class-class-02) nil)
253        (let* ((class1 (eval '(defclass find-class-class-01 () ())))
254               (class2 (eval '(defclass find-class-class-02
255                                (find-class-class-01) ())))
256               (fn (eval '(defgeneric find-class-gf-02 (x)
257                            (:method ((x find-class-class-01)) 1)
258                            (:method ((x find-class-class-02)) 2)
259                            (:method ((x t)) t))))
260               (obj1 (make-instance class1))
261               (obj2 (make-instance class2)))
262          (values
263           (funcall fn nil)
264           (funcall fn obj1)
265           (funcall fn obj2)
266           (setf (find-class 'find-class-class-01) nil)
267           (funcall fn nil)
268           (funcall fn obj1)
269           (funcall fn obj2))))
270      t 1 2 nil t 1 2)
271    
272    ;;; Error tests
273    
274    (deftest find-class.error.1
275      (classify-error (find-class))
276      program-error)
277    
278    (deftest find-class.error.2
279      (classify-error (find-class 'symbol nil nil nil))
280      program-error)

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26