← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to test-suite/tests/exceptions.test

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Schepler
  • Date: 2006-11-09 03:11:16 UTC
  • Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1

Show diffs side-by-side

added added

removed removed

Lines of Context:
test-suite/tests/exceptions.test
 
1
;;;; exceptions.test --- tests for Guile's exception handling  -*- scheme -*-
 
2
;;;; Copyright (C) 2001, 2003, 2004, 2006 Free Software Foundation, Inc.
 
3
;;;;
 
4
;;;; This library is free software; you can redistribute it and/or
 
5
;;;; modify it under the terms of the GNU Lesser General Public
 
6
;;;; License as published by the Free Software Foundation; either
 
7
;;;; version 2.1 of the License, or (at your option) any later version.
 
8
;;;; 
 
9
;;;; This library is distributed in the hope that it will be useful,
 
10
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 
11
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
12
;;;; Lesser General Public License for more details.
 
13
;;;; 
 
14
;;;; You should have received a copy of the GNU Lesser General Public
 
15
;;;; License along with this library; if not, write to the Free Software
 
16
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
17
 
 
18
 
 
19
(use-modules (test-suite lib))
 
20
 
 
21
(define-macro (throw-test title result . exprs)
 
22
  `(pass-if ,title
 
23
     (equal? ,result
 
24
             (letrec ((stack '())
 
25
                      (push (lambda (val)
 
26
                              (set! stack (cons val stack)))))
 
27
               (begin ,@exprs)
 
28
               ;;(display ,title)
 
29
               ;;(display ": ")
 
30
               ;;(write (reverse stack))
 
31
               ;;(newline)
 
32
               (reverse stack)))))
 
33
 
 
34
(with-test-prefix "throw/catch"
 
35
 
 
36
  (with-test-prefix "wrong type argument"
 
37
 
 
38
    (pass-if-exception "(throw 1)"
 
39
      exception:wrong-type-arg
 
40
      (throw 1)))
 
41
 
 
42
  (with-test-prefix "wrong number of arguments"
 
43
 
 
44
    (pass-if-exception "(throw)"
 
45
      exception:wrong-num-args
 
46
      (throw))
 
47
 
 
48
    (pass-if-exception "throw 1 / catch 0"
 
49
      exception:wrong-num-args
 
50
      (catch 'a
 
51
        (lambda () (throw 'a))
 
52
        (lambda () #f)))
 
53
 
 
54
    (pass-if-exception "throw 2 / catch 1"
 
55
      exception:wrong-num-args
 
56
      (catch 'a
 
57
        (lambda () (throw 'a 2))
 
58
        (lambda (x) #f)))
 
59
 
 
60
    (pass-if-exception "throw 1 / catch 2"
 
61
      exception:wrong-num-args
 
62
      (catch 'a
 
63
        (lambda () (throw 'a))
 
64
        (lambda (x y) #f)))
 
65
 
 
66
    (pass-if-exception "throw 3 / catch 2"
 
67
      exception:wrong-num-args
 
68
      (catch 'a
 
69
        (lambda () (throw 'a 2 3))
 
70
        (lambda (y x) #f)))
 
71
 
 
72
    (pass-if-exception "throw 1 / catch 2+"
 
73
      exception:wrong-num-args
 
74
      (catch 'a
 
75
        (lambda () (throw 'a))
 
76
        (lambda (x y . rest) #f))))
 
77
 
 
78
  (with-test-prefix "with lazy handler"
 
79
 
 
80
    (pass-if "lazy fluid state"
 
81
      (equal? '(inner outer arg)
 
82
       (let ((fluid-parm (make-fluid))
 
83
             (inner-val #f))
 
84
         (fluid-set! fluid-parm 'outer)
 
85
         (catch 'misc-exc
 
86
           (lambda ()
 
87
             (with-fluids ((fluid-parm 'inner))
 
88
               (throw 'misc-exc 'arg)))
 
89
           (lambda (key . args)
 
90
             (list inner-val
 
91
                   (fluid-ref fluid-parm)
 
92
                   (car args)))
 
93
           (lambda (key . args)
 
94
             (set! inner-val (fluid-ref fluid-parm))))))))
 
95
 
 
96
  (throw-test "normal catch"
 
97
              '(1 2)
 
98
              (catch 'a
 
99
                     (lambda ()
 
100
                       (push 1)
 
101
                       (throw 'a))
 
102
                     (lambda (key . args)
 
103
                       (push 2))))
 
104
 
 
105
  (throw-test "catch and lazy catch"
 
106
              '(1 2 3 4)
 
107
              (catch 'a
 
108
                     (lambda ()
 
109
                       (push 1)
 
110
                       (lazy-catch 'a
 
111
                                   (lambda ()
 
112
                                     (push 2)
 
113
                                     (throw 'a))
 
114
                                   (lambda (key . args)
 
115
                                     (push 3))))
 
116
                     (lambda (key . args)
 
117
                       (push 4))))
 
118
 
 
119
  (throw-test "catch with rethrowing lazy catch handler"
 
120
              '(1 2 3 4)
 
121
              (catch 'a
 
122
                     (lambda ()
 
123
                       (push 1)
 
124
                       (lazy-catch 'a
 
125
                                   (lambda ()
 
126
                                     (push 2)
 
127
                                     (throw 'a))
 
128
                                   (lambda (key . args)
 
129
                                     (push 3)
 
130
                                     (apply throw key args))))
 
131
                     (lambda (key . args)
 
132
                       (push 4))))
 
133
 
 
134
  (throw-test "catch with pre-unwind handler"
 
135
              '(1 3 2)
 
136
              (catch 'a
 
137
                     (lambda ()
 
138
                       (push 1)
 
139
                       (throw 'a))
 
140
                     (lambda (key . args)
 
141
                       (push 2))
 
142
                     (lambda (key . args)
 
143
                       (push 3))))
 
144
 
 
145
  (throw-test "catch with rethrowing pre-unwind handler"
 
146
              '(1 3 2)
 
147
              (catch 'a
 
148
                     (lambda ()
 
149
                       (push 1)
 
150
                       (throw 'a))
 
151
                     (lambda (key . args)
 
152
                       (push 2))
 
153
                     (lambda (key . args)
 
154
                       (push 3)
 
155
                       (apply throw key args))))
 
156
 
 
157
  (throw-test "catch with throw handler"
 
158
              '(1 2 3 4)
 
159
              (catch 'a
 
160
                     (lambda ()
 
161
                       (push 1)
 
162
                       (with-throw-handler 'a
 
163
                                           (lambda ()
 
164
                                             (push 2)
 
165
                                             (throw 'a))
 
166
                                           (lambda (key . args)
 
167
                                             (push 3))))
 
168
                     (lambda (key . args)
 
169
                       (push 4))))
 
170
 
 
171
  (throw-test "catch with rethrowing throw handler"
 
172
              '(1 2 3 4)
 
173
              (catch 'a
 
174
                     (lambda ()
 
175
                       (push 1)
 
176
                       (with-throw-handler 'a
 
177
                                           (lambda ()
 
178
                                             (push 2)
 
179
                                             (throw 'a))
 
180
                                           (lambda (key . args)
 
181
                                             (push 3)
 
182
                                             (apply throw key args))))
 
183
                     (lambda (key . args)
 
184
                       (push 4))))
 
185
 
 
186
  (throw-test "effect of lazy-catch unwinding on throw to another key"
 
187
              '(1 2 3 5 7)
 
188
              (catch 'a
 
189
                     (lambda ()
 
190
                       (push 1)
 
191
                       (lazy-catch 'b
 
192
                                   (lambda ()
 
193
                                     (push 2)
 
194
                                     (catch 'a
 
195
                                            (lambda ()
 
196
                                              (push 3)
 
197
                                              (throw 'b))
 
198
                                            (lambda (key . args)
 
199
                                              (push 4))))
 
200
                                   (lambda (key . args)
 
201
                                     (push 5)
 
202
                                     (throw 'a)))
 
203
                       (push 6))
 
204
                     (lambda (key . args)
 
205
                       (push 7))))
 
206
 
 
207
  (throw-test "effect of with-throw-handler not-unwinding on throw to another key"
 
208
              '(1 2 3 5 4 6)
 
209
              (catch 'a
 
210
                     (lambda ()
 
211
                       (push 1)
 
212
                       (with-throw-handler 'b
 
213
                                   (lambda ()
 
214
                                     (push 2)
 
215
                                     (catch 'a
 
216
                                            (lambda ()
 
217
                                              (push 3)
 
218
                                              (throw 'b))
 
219
                                            (lambda (key . args)
 
220
                                              (push 4))))
 
221
                                   (lambda (key . args)
 
222
                                     (push 5)
 
223
                                     (throw 'a)))
 
224
                       (push 6))
 
225
                     (lambda (key . args)
 
226
                       (push 7))))
 
227
 
 
228
  (throw-test "lazy-catch chaining"
 
229
              '(1 2 3 4 6 8)
 
230
              (catch 'a
 
231
                (lambda ()
 
232
                  (push 1)
 
233
                  (lazy-catch 'a
 
234
                    (lambda ()
 
235
                      (push 2)
 
236
                      (lazy-catch 'a
 
237
                        (lambda ()
 
238
                          (push 3)
 
239
                          (throw 'a))
 
240
                        (lambda (key . args)
 
241
                          (push 4)))
 
242
                      (push 5))
 
243
                    (lambda (key . args)
 
244
                      (push 6)))
 
245
                  (push 7))
 
246
                (lambda (key . args)
 
247
                  (push 8))))
 
248
 
 
249
  (throw-test "with-throw-handler chaining"
 
250
              '(1 2 3 4 6 8)
 
251
              (catch 'a
 
252
                (lambda ()
 
253
                  (push 1)
 
254
                  (with-throw-handler 'a
 
255
                    (lambda ()
 
256
                      (push 2)
 
257
                      (with-throw-handler 'a
 
258
                        (lambda ()
 
259
                          (push 3)
 
260
                          (throw 'a))
 
261
                        (lambda (key . args)
 
262
                          (push 4)))
 
263
                      (push 5))
 
264
                    (lambda (key . args)
 
265
                      (push 6)))
 
266
                  (push 7))
 
267
                (lambda (key . args)
 
268
                  (push 8))))
 
269
 
 
270
  (throw-test "with-throw-handler inside lazy-catch"
 
271
              '(1 2 3 4 6 8)
 
272
              (catch 'a
 
273
                (lambda ()
 
274
                  (push 1)
 
275
                  (lazy-catch 'a
 
276
                    (lambda ()
 
277
                      (push 2)
 
278
                      (with-throw-handler 'a
 
279
                        (lambda ()
 
280
                          (push 3)
 
281
                          (throw 'a))
 
282
                        (lambda (key . args)
 
283
                          (push 4)))
 
284
                      (push 5))
 
285
                    (lambda (key . args)
 
286
                      (push 6)))
 
287
                  (push 7))
 
288
                (lambda (key . args)
 
289
                  (push 8))))
 
290
 
 
291
  (throw-test "lazy-catch inside with-throw-handler"
 
292
              '(1 2 3 4 6 8)
 
293
              (catch 'a
 
294
                (lambda ()
 
295
                  (push 1)
 
296
                  (with-throw-handler 'a
 
297
                    (lambda ()
 
298
                      (push 2)
 
299
                      (lazy-catch 'a
 
300
                        (lambda ()
 
301
                          (push 3)
 
302
                          (throw 'a))
 
303
                        (lambda (key . args)
 
304
                          (push 4)))
 
305
                      (push 5))
 
306
                    (lambda (key . args)
 
307
                      (push 6)))
 
308
                  (push 7))
 
309
                (lambda (key . args)
 
310
                  (push 8))))
 
311
 
 
312
  (throw-test "throw handlers throwing to each other recursively"
 
313
              '(1 2 3 4 8 6 10 12)
 
314
              (catch #t
 
315
                (lambda ()
 
316
                  (push 1)
 
317
                  (with-throw-handler 'a
 
318
                    (lambda ()
 
319
                      (push 2)
 
320
                      (with-throw-handler 'b
 
321
                        (lambda ()
 
322
                          (push 3)
 
323
                          (with-throw-handler 'c
 
324
                            (lambda ()
 
325
                              (push 4)
 
326
                              (throw 'b)
 
327
                              (push 5))
 
328
                            (lambda (key . args)
 
329
                              (push 6)
 
330
                              (throw 'a)))
 
331
                          (push 7))
 
332
                        (lambda (key . args)
 
333
                          (push 8)
 
334
                          (throw 'c)))
 
335
                      (push 9))
 
336
                    (lambda (key . args)
 
337
                      (push 10)
 
338
                      (throw 'b)))
 
339
                  (push 11))
 
340
                (lambda (key . args)
 
341
                  (push 12))))
 
342
 
 
343
  (throw-test "repeat of previous test but with lazy-catch"
 
344
              '(1 2 3 4 8 12)
 
345
              (catch #t
 
346
                (lambda ()
 
347
                  (push 1)
 
348
                  (lazy-catch 'a
 
349
                    (lambda ()
 
350
                      (push 2)
 
351
                      (lazy-catch 'b
 
352
                        (lambda ()
 
353
                          (push 3)
 
354
                          (lazy-catch 'c
 
355
                            (lambda ()
 
356
                              (push 4)
 
357
                              (throw 'b)
 
358
                              (push 5))
 
359
                            (lambda (key . args)
 
360
                              (push 6)
 
361
                              (throw 'a)))
 
362
                          (push 7))
 
363
                        (lambda (key . args)
 
364
                          (push 8)
 
365
                          (throw 'c)))
 
366
                      (push 9))
 
367
                    (lambda (key . args)
 
368
                      (push 10)
 
369
                      (throw 'b)))
 
370
                  (push 11))
 
371
                (lambda (key . args)
 
372
                  (push 12))))
 
373
 
 
374
  (throw-test "throw handler throwing to lexically inside catch"
 
375
              '(1 2 7 5 4 6 9)
 
376
              (with-throw-handler 'a
 
377
                                  (lambda ()
 
378
                                    (push 1)
 
379
                                    (catch 'b
 
380
                                           (lambda ()
 
381
                                             (push 2)
 
382
                                             (throw 'a)
 
383
                                             (push 3))
 
384
                                           (lambda (key . args)
 
385
                                             (push 4))
 
386
                                           (lambda (key . args)
 
387
                                             (push 5)))
 
388
                                    (push 6))
 
389
                                  (lambda (key . args)
 
390
                                    (push 7)
 
391
                                    (throw 'b)
 
392
                                    (push 8)))
 
393
              (push 9))
 
394
 
 
395
  (throw-test "reuse of same throw handler after lexically inside catch"
 
396
              '(0 1 2 7 5 4 6 7 10)
 
397
              (catch 'b
 
398
                (lambda ()
 
399
                  (push 0)
 
400
                  (with-throw-handler 'a
 
401
                    (lambda ()
 
402
                      (push 1)
 
403
                      (catch 'b
 
404
                        (lambda ()
 
405
                          (push 2)
 
406
                          (throw 'a)
 
407
                          (push 3))
 
408
                        (lambda (key . args)
 
409
                          (push 4))
 
410
                        (lambda (key . args)
 
411
                          (push 5)))
 
412
                      (push 6)
 
413
                      (throw 'a))
 
414
                    (lambda (key . args)
 
415
                      (push 7)
 
416
                      (throw 'b)
 
417
                      (push 8)))
 
418
                  (push 9))
 
419
                (lambda (key . args)
 
420
                  (push 10))))
 
421
 
 
422
  (throw-test "again but with two chained throw handlers"
 
423
              '(0 1 11 2 13 7 5 4 12 13 7 10)
 
424
              (catch 'b
 
425
                (lambda ()
 
426
                  (push 0)
 
427
                  (with-throw-handler 'a
 
428
                    (lambda ()
 
429
                      (push 1)
 
430
                      (with-throw-handler 'a
 
431
                        (lambda ()
 
432
                          (push 11)
 
433
                          (catch 'b
 
434
                            (lambda ()
 
435
                              (push 2)
 
436
                              (throw 'a)
 
437
                              (push 3))
 
438
                            (lambda (key . args)
 
439
                              (push 4))
 
440
                            (lambda (key . args)
 
441
                              (push 5)))
 
442
                          (push 12)
 
443
                          (throw 'a))
 
444
                        (lambda (key . args)
 
445
                          (push 13)))
 
446
                      (push 6))
 
447
                    (lambda (key . args)
 
448
                      (push 7)
 
449
                      (throw 'b)))
 
450
                  (push 9))
 
451
                (lambda (key . args)
 
452
                  (push 10))))
 
453
 
 
454
  )
 
455
 
 
456
(with-test-prefix "false-if-exception"
 
457
 
 
458
  (pass-if (false-if-exception #t))
 
459
  (pass-if (not (false-if-exception #f)))
 
460
  (pass-if (not (false-if-exception (error "xxx"))))
 
461
 
 
462
  ;; Not yet working.
 
463
  ;;
 
464
  ;; (with-test-prefix "in empty environment"
 
465
  ;;   ;; an environment with no bindings at all
 
466
  ;;   (define empty-environment
 
467
  ;;     (make-module 1))
 
468
  ;;
 
469
  ;;   (pass-if "#t"
 
470
  ;;     (eval `(,false-if-exception #t)
 
471
  ;;        empty-environment))
 
472
  ;;   (pass-if "#f"
 
473
  ;;     (not (eval `(,false-if-exception #f)
 
474
  ;;             empty-environment)))
 
475
  ;;   (pass-if "exception"
 
476
  ;;     (not (eval `(,false-if-exception (,error "xxx"))
 
477
  ;;                empty-environment))))
 
478
  )