source: project/release/5/simple-exceptions/tags/1.2/tests/run.scm @ 37040

Last change on this file since 37040 was 37040, checked in by juergen, 6 months ago

simple-exceptions 1.2 improve argument and result checks

File size: 3.9 KB
Line 
1(import simple-tests simple-exceptions)
2
3  (define (baz n)
4    (abs (<< n 'baz number?)))
5
6  (define foo-exn (make-exn "foo-msg"))
7
8  (define bar-exn (make-exn "bar-msg" 'bar))
9
10  (define list-empty-exn
11    (make-exn "argument list empty" 'list-empty))
12
13  (define (try-car lst)
14    (if (null? lst)
15      (raise (list-empty-exn 'try-car lst))
16      (car lst)))
17
18(define-test (simple-exceptions?)
19  "NAMED LAMBDA"
20  (= ((named-lambda (! n)
21        (if (zero? n)
22          1
23          (* n (! (- n 1)))))
24      5)
25     120)
26  "CHECKS"
27  (null? (<<))
28  (= (>> 5) 5)
29  (= (<< 5) 5)
30  (= (<< 5 integer? odd? (named-lambda (5<= x) (<= 5 x))) 5)
31  (= ((<<< 'foo 'x) 5 integer? odd?) 5)
32  (= ((<<< 'foo) 5 integer? odd?) 5)
33  (= ((>>> 'foo 'x) 5 integer? odd?) 5)
34  (= ((>>> 'foo) 5 integer? odd?) 5)
35  (not (condition-case
36         (>> 5 integer? even?)
37         ((exn result) #f))) 
38  (not (<< ((lambda () #f)) boolean?))
39  '(define (baz n) (abs (<< n 'baz number?)))
40  (not (condition-case (baz "baz")
41         ((exn argument) #f)))
42  (not (with-exn-handler
43         (lambda (exn)
44           (if ((exn-of? 'argument) exn)
45             #f
46             #t))
47         (lambda () (baz "baz"))))
48
49  "EXCEPTIONS" 
50  '(define foo-exn (make-exn "foo-msg"))
51  '(define bar-exn (make-exn "bar-msg" 'bar))
52  (exn? (foo-exn 'nowhere))
53
54  (bar-exn 'nowhere)
55  (exn? (bar-exn 'nowhere))
56
57  ((exn-of? 'bar) (bar-exn 'nowhere))
58  (not ((exn-of? 'bar) (foo-exn 'nowhere)))
59 
60  (equal?
61    (arguments ((make-exn "msg" 'baz) 'nowhere "bar"))
62    (list "bar"))
63
64  ((exn-of? 'key)
65   ((make-exn "msg" 'key) 'nowhere))
66
67  '(define list-empty-exn
68    (make-exn "argument list empty" 'list-empty))
69
70  '(define (try-car lst)
71    (if (null? lst)
72      (raise (list-empty-exn 'try-car lst))
73      (car lst)))
74 
75  ;; exception handler procedure
76  (not (with-exn-handler
77         (lambda (exn)
78           (if ((exn-of? 'list-empty) exn)
79             #f
80             #t))
81         (lambda () (try-car '()))))
82 
83  (zero? (with-exn-handler (lambda (e) 0) (lambda () (/ 5 0))))
84
85  ;; the three high-level exception handler macros
86  (not (condition-case (try-car '())
87         ((exn list-empty) #f)))
88
89  "GUARD"
90  (null? (guard
91           (exn (((exn-of? 'list-empty) exn)
92                 (car (arguments exn)))
93                (else #f))
94           (try-car '())))
95
96  (null? (handle-exceptions exn
97           (if ((exn-of? 'list-empty) exn)
98             (car (arguments exn))
99             #f)
100           (try-car '())))
101
102  (= (handle-exceptions cnd
103       (cond
104         ((assq 'a cnd) => cdr)
105         ((assq 'b cnd)))
106       (raise (list (cons 'a 42))))
107     42)
108
109  (= (guard
110       (exn ((assq 'a exn) => cdr)
111            ((assq 'b exn)))
112       (raise (list (cons 'a 42))))
113     42)
114
115  (equal? (guard
116            (exn ((assq 'a exn) => cdr)
117                 ((assq 'b exn)))
118            (raise (list (cons 'b 23))))
119          '(b . 23))
120
121  (eq? (guard
122         (exn (((exn-of? 'foo) exn)
123               (location exn))
124              ((exn? exn)
125               (message exn))
126              (else
127                (arguments exn)))
128         (raise ((make-exn "msg" 'foo)
129                  'location-unknown)))
130        'location-unknown)
131  (string=? (guard
132              (exn (((exn-of? 'foo) exn)
133                    (location exn))
134                   ((exn? exn)
135                    (message exn))
136                   (else
137                     (arguments exn)))
138              (raise ((make-exn "nothing" 'bar) 'loc)))
139            "nothing")
140  (not (guard (exn (((exn-of? 'foo) exn)
141                    (location exn))
142                   ((exn? exn)
143                    (message exn))
144                   (else
145                     #f)) 
146              (raise 'bar)))
147
148  (not (condition-case (assert* 'nowhere
149                                (= 1 1)
150                                (= 1 2))
151         ((exn assert) #f)))
152  )
153
154(compound-test (SIMPLE-EXEPTIONS)
155  (simple-exceptions?)
156  )
157
158
Note: See TracBrowser for help on using the repository browser.