source: project/release/4/simple-exceptions/trunk/tests/run.scm @ 31762

Last change on this file since 31762 was 31762, checked in by juergen, 4 years ago

initial import

  • Property svn:mime-type set to application/zlib
File size: 2.9 KB
Line 
1(require-library simple-tests simple-exceptions)
2(import simple-tests simple-exceptions)
3
4(define-test (simple-exceptions?)
5  (check
6    (define foo-exn (make-exception "foo-msg"))
7    (define bar-exn (make-exception "bar-msg" 'bar))
8    (exception? (foo-exn 'nowhere))
9
10    (bar-exn 'nowhere)
11    (exception? (bar-exn 'nowhere))
12
13    ((exception-of? 'bar) (bar-exn 'nowhere))
14    (not ((exception-of? 'bar) (foo-exn 'nowhere)))
15   
16    (equal?
17      (arguments ((make-exception "msg" 'baz) 'nowhere "bar"))
18      (list "bar"))
19
20    ((exception-of? 'key)
21     ((make-exception "msg" 'key) 'nowhere))
22
23    (define list-empty-exn
24      (make-exception "argument list empty" 'list-empty))
25
26    (define (try-car lst)
27      (if (null? lst)
28        (raise (list-empty-exn 'try-car lst))
29        (car lst)))
30   
31    ;; exception handler procedure
32    (not (with-handler
33           (lambda (exn)
34             (if ((exception-of? 'list-empty) exn)
35               #f
36               #t))
37           (lambda () (try-car '()))))
38   
39    (zero? (with-handler (lambda (e) 0) (lambda () (/ 5 0))))
40
41    ;; the three high-level exception handler macros
42    (not (condition-case (try-car '())
43           ((exn list-empty) #f)))
44
45    (null? (guard
46             (exn (((exception-of? 'list-empty) exn)
47                   (car (arguments exn)))
48                  (else #f))
49             (try-car '())))
50
51    (null? (handle-exceptions exn
52             (if ((exception-of? 'list-empty) exn)
53               (car (arguments exn))
54               #f)
55             (try-car '())))
56
57    (= (guard
58         (exn ((assq 'a exn) => cdr)
59              ((assq 'b exn)))
60         (raise (list (cons 'a 42))))
61       42)
62    (equal? (guard
63              (exn ((assq 'a exn) => cdr)
64                   ((assq 'b exn)))
65              (raise (list (cons 'b 23))))
66            '(b . 23))
67    (eq? (guard
68           (exn (((exception-of? 'foo) exn)
69                 (location exn))
70                ((exception? exn)
71                 (message exn))
72                (else
73                  (arguments exn)))
74           (raise ((make-exception "msg" 'foo)
75                    'location-unknown)))
76          'location-unknown)
77    (string=? (guard
78                (exn (((exception-of? 'foo) exn)
79                      (location exn))
80                     ((exception? exn)
81                      (message exn))
82                     (else
83                       (arguments exn)))
84                (raise ((make-exception "nothing" 'bar) 'loc)))
85              "nothing")
86    (not (guard (exn (((exception-of? 'foo) exn)
87                      (location exn))
88                     ((exception? exn)
89                      (message exn))
90                     (else
91                       #f))
92                (raise 'bar)))
93
94    (not (condition-case (assert* 'nowhere
95                                  (= 1 1)
96                                  (= 1 2))
97           ((exn assert) #f)))
98    ))
99
100(compound-test (SIMPLE-EXEPTIONS)
101  (simple-exceptions?)
102  )
103
104
Note: See TracBrowser for help on using the repository browser.