source: trunk/j/src/org/armedbear/lisp/tests/condition-tests.lisp @ 10344

Last change on this file since 10344 was 10344, checked in by piso, 16 years ago

Work in progress.

File size: 10.1 KB
Line 
1;;; condition-tests.lisp
2;;;
3;;; Copyright (C) 2005 Peter Graves
4;;;
5;;; This program is free software; you can redistribute it and/or
6;;; modify it under the terms of the GNU General Public License
7;;; as published by the Free Software Foundation; either version 2
8;;; of the License, or (at your option) any later version.
9;;;
10;;; This program is distributed in the hope that it will be useful,
11;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13;;; GNU General Public License for more details.
14;;;
15;;; You should have received a copy of the GNU General Public License
16;;; along with this program; if not, write to the Free Software
17;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
18
19(load (merge-pathnames "test-utilities.lisp" *load-truename*))
20
21(in-package #:test)
22
23(defun filter (string)
24  "If STRING is unreadable, return \"#<>\"; otherwise return STRING unchanged."
25  (let ((len (length string)))
26    (when (> len 3)
27      (when (string= (subseq string 0 2) "#<")
28        (when (char= (char string (1- len)) #\>)
29          (setf string "#<>")))))
30  string)
31
32(deftest condition.1
33  (filter (write-to-string (make-condition 'condition) :escape t))
34  "#<>")
35
36(deftest condition.2
37  (filter (write-to-string (make-condition 'condition) :escape nil))
38  #+(or abcl allegro)
39  "#<>"
40  #+clisp
41  "Condition of type CONDITION."
42  #+(or cmu sbcl)
43  "Condition CONDITION was signalled.")
44
45#+(or abcl allegro)
46(deftest condition.3
47  (write-to-string (make-condition 'condition
48                                   :format-control "The bear is armed.")
49                   :escape nil)
50  "The bear is armed.")
51
52(deftest print-not-readable-object.1
53  (signals-error (slot-boundp (make-condition 'print-not-readable)
54                              #+abcl    'system::object
55                              #+allegro 'excl::object
56                              #+clisp   'system::$object
57                              #+cmu     'lisp::object
58                              #+sbcl    'sb-kernel::object)
59                 'error)
60  nil)
61
62(deftest print-not-readable-object.2
63  (slot-boundp (make-condition 'print-not-readable)
64               #+abcl    'system::object
65               #+allegro 'excl::object
66               #+clisp   'system::$object
67               #+cmu     'lisp::object
68               #+sbcl    'sb-kernel::object)
69  nil)
70
71(deftest type-error.1
72  (type-error-datum (make-instance 'type-error :datum 42))
73  42)
74
75(deftest type-error.2
76  (type-error-expected-type (make-instance 'type-error :expected-type 'symbol))
77  symbol)
78
79(deftest type-error.3
80  (let ((c (make-condition 'type-error :datum 42 :expected-type 'symbol)))
81    (filter (write-to-string c :escape nil)))
82  #+allegro
83  "#<>"
84  #+clisp
85  "Condition of type TYPE-ERROR."
86  #+cmu
87  "Type-error in NIL:  42 is not of type SYMBOL"
88  #+(or abcl sbcl)
89  "The value 42 is not of type SYMBOL.")
90
91(deftest type-error.4
92  (let ((c (make-condition 'type-error :datum 42 :expected-type 'symbol)))
93    (filter (format nil "~A" c)))
94  #+allegro
95  "#<>"
96  #+clisp
97  "Condition of type TYPE-ERROR."
98  #+cmu
99  "Type-error in NIL:  42 is not of type SYMBOL"
100  #+(or abcl sbcl)
101  "The value 42 is not of type SYMBOL.")
102
103(deftest simple-type-error.1
104  (slot-boundp (make-condition 'simple-type-error)
105               #+abcl    'system::datum
106               #+allegro 'excl::datum
107               #+clisp   'system::$datum
108               #+cmu     'conditions::datum
109               #+sbcl    'sb-kernel::datum)
110  nil)
111
112(deftest simple-type-error.2
113  (slot-boundp (make-condition 'simple-type-error)
114               #+abcl    'system::expected-type
115               #+allegro 'excl::expected-type
116               #+clisp   'system::$expected-type
117               #+cmu     'conditions::expected-type
118               #+sbcl    'sb-kernel::expected-type)
119  nil)
120
121(deftest simple-type-error.3
122  (slot-boundp (make-condition 'simple-type-error)
123               #+abcl    'system::format-control
124               #+allegro 'excl::format-control
125               #+clisp   'system::$format-control
126               #+cmu     'conditions::format-control
127               #+sbcl    'sb-kernel:format-control)
128  #-clisp nil
129  #+clisp t)
130
131#+clisp
132(deftest simple-type-error.3a
133  (simple-condition-format-control (make-condition 'simple-type-error))
134  nil)
135
136(deftest simple-type-error.4
137  (slot-boundp (make-condition 'simple-type-error)
138               #+abcl    'system::format-arguments
139               #+allegro 'excl::format-arguments
140               #+clisp   'system::$format-arguments
141               #+cmu     'conditions::format-arguments
142               #+sbcl    'sb-kernel::format-arguments)
143  t)
144
145(deftest simple-type-error.5
146  (slot-value (make-condition 'simple-type-error)
147              #+abcl    'system::format-arguments
148              #+allegro 'excl::format-arguments
149              #+clisp   'system::$format-arguments
150              #+cmu     'conditions::format-arguments
151              #+sbcl    'sb-kernel::format-arguments)
152  nil)
153
154(deftest simple-type-error.6
155  (slot-boundp (make-instance 'simple-type-error)
156               #+abcl    'system::datum
157               #+allegro 'excl::datum
158               #+clisp   'system::$datum
159               #+cmu     'conditions::datum
160               #+sbcl    'sb-kernel::datum)
161  nil)
162
163(deftest simple-type-error.7
164  (slot-boundp (make-instance 'simple-type-error)
165               #+abcl    'system::expected-type
166               #+allegro 'excl::expected-type
167               #+clisp   'system::$expected-type
168               #+cmu     'conditions::expected-type
169               #+sbcl    'sb-kernel::expected-type)
170  nil)
171
172(deftest simple-type-error.8
173  (slot-boundp (make-instance 'simple-type-error)
174               #+abcl    'system::format-control
175               #+allegro 'excl::format-control
176               #+clisp   'system::$format-control
177               #+cmu     'conditions::format-control
178               #+sbcl    'sb-kernel:format-control)
179  #-clisp nil
180  #+clisp t)
181
182#+clisp
183(deftest simple-type-error.8a
184  (simple-condition-format-control (make-instance 'simple-type-error))
185  nil)
186
187(deftest simple-type-error.9
188  (slot-boundp (make-instance 'simple-type-error)
189               #+abcl    'system::format-arguments
190               #+allegro 'excl::format-arguments
191               #+clisp   'system::$format-arguments
192               #+cmu     'conditions::format-arguments
193               #+sbcl    'sb-kernel::format-arguments)
194  t)
195
196(deftest simple-type-error.10
197  (slot-value (make-instance 'simple-type-error)
198              #+abcl    'system::format-arguments
199              #+allegro 'excl::format-arguments
200              #+clisp   'system::$format-arguments
201              #+cmu     'conditions::format-arguments
202              #+sbcl    'sb-kernel::format-arguments)
203  nil)
204
205(deftest define-condition.1
206  (progn
207    (setf (find-class 'test-error) nil)
208    (define-condition test-error (type-error) ())
209    (type-error-datum (make-condition 'test-error :datum 42 :expected-type 'symbol)))
210  42)
211
212(deftest define-condition.2
213  (progn
214    (setf (find-class 'test-error) nil)
215    (define-condition test-error (type-error) ())
216    (type-error-expected-type (make-condition 'test-error :datum 42 :expected-type 'symbol)))
217  symbol)
218
219#+(or abcl allegro)
220(deftest define-condition.3
221  (progn
222    (setf (find-class 'test-error) nil)
223    (define-condition test-error (type-error) ())
224    (slot-boundp (make-condition 'test-error)
225                 #+abcl    'system::format-control
226                 #+allegro 'excl::format-control))
227  nil)
228
229#+(or abcl allegro)
230(deftest define-condition.4
231  (progn
232    (setf (find-class 'test-error) nil)
233    (define-condition test-error (type-error) ())
234    (simple-condition-format-arguments (make-condition 'test-error)))
235  nil)
236
237(deftest define-condition.5
238  (progn
239    (setf (find-class 'test-error) nil)
240    (define-condition test-error (type-error) ())
241    (let ((c (make-condition 'test-error :datum 42 :expected-type 'symbol)))
242      (filter (format nil "~A" c))))
243  #+allegro
244  "#<>"
245  #+clisp
246  "Condition of type TEST-ERROR."
247  #+cmu
248  "Type-error in NIL:  42 is not of type SYMBOL"
249  #+(or abcl sbcl)
250  "The value 42 is not of type SYMBOL.")
251
252#+(or abcl clisp cmu sbcl)
253(deftest define-condition.6
254  (progn
255    (setf (find-class 'test-error) nil)
256    (define-condition test-error (type-error) ())
257    (let ((c (make-condition 'test-error :datum 42 :expected-type 'symbol)))
258      (filter (write-to-string c :escape nil))))
259  #+allegro
260  "#<>"
261  #+clisp
262  "Condition of type TEST-ERROR."
263  #+cmu
264  "Type-error in NIL:  42 is not of type SYMBOL"
265  #+(or abcl sbcl)
266  "The value 42 is not of type SYMBOL.")
267
268#+(or abcl allegro)
269(deftest define-condition.7
270  (progn
271    (setf (find-class 'test-error) nil)
272    (define-condition test-error (type-error) ())
273    (let ((c (make-condition 'test-error
274                             :datum 42
275                             :expected-type 'symbol
276                             :format-control "The bear is armed.")))
277      (write-to-string c :escape nil)))
278  "The bear is armed.")
279
280#+(or abcl allegro)
281(deftest define-condition.8
282  (progn
283    (setf (find-class 'test-error) nil)
284    (define-condition test-error (type-error) ())
285    (let ((c (make-condition 'test-error
286                             :datum 42
287                             :expected-type 'symbol
288                             :format-control "~A is ~A."
289                             :format-arguments (list "The bear" "armed"))))
290      (write-to-string c :escape nil)))
291  "The bear is armed.")
292
293#+(or abcl allegro)
294(deftest define-condition.9
295  (progn
296    (setf (find-class 'test-error) nil)
297    (define-condition test-error (condition) ())
298    (let ((c (make-condition 'test-error
299                             :format-control "The bear is armed.")))
300      (write-to-string c :escape nil)))
301  "The bear is armed.")
302
303#+(or abcl allegro)
304(deftest define-condition.10
305  (progn
306    (setf (find-class 'test-error) nil)
307    (define-condition test-error (condition) ())
308    (let ((c (make-condition 'test-error
309                             :format-control "~A is ~A."
310                             :format-arguments (list "The bear" "armed"))))
311      (write-to-string c :escape nil)))
312  "The bear is armed.")
313
314(do-tests)
Note: See TracBrowser for help on using the repository browser.