source: project/release/4/simple-exceptions/trunk/simple-exceptions.scm @ 33128

Last change on this file since 33128 was 33128, checked in by juergen, 3 years ago

simple-exceptions 0.2 renames with-handler to with-exn-handler

File size: 6.6 KB
Line 
1#|[
2Author: Juergen Lorenz
3ju (at) jugilo (dot) de
4
5Copyright (c) 2014-2016, Juergen Lorenz
6All rights reserved.
7
8Redistribution and use in source and binary forms, with or without
9modification, are permitted provided that the following conditions are
10met:
11
12Redistributions of source code must retain the above copyright
13notice, this list of conditions and the following disclaimer.
14
15Redistributions in binary form must reproduce the above copyright
16notice, this list of conditions and the following disclaimer in the
17documentation and/or other materials provided with the distribution.
18
19Neither the name of the author nor the names of its contributors may be
20used to endorse or promote products derived from this software without
21specific prior written permission.
22
23THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
24IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
25TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
26PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
27HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
28SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
29TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34]|#
35
36
37(module simple-exceptions
38  (export simple-exceptions exception? exception-of? make-exception location
39          message arguments raise with-exn-handler guard assert*)
40  (import scheme
41          (only chicken
42                case-lambda void condition? condition-predicate
43                make-property-condition make-composite-condition
44                get-condition-property continuation-capture
45                continuation-graft))
46  (reexport (only chicken
47                  current-exception-handler handle-exceptions condition-case))
48
49;;; (exception? xpr)
50;;; ----------------
51;;; type predicate
52(define (exception? xpr)
53  (and (condition? xpr)
54       ((condition-predicate 'exn) xpr)))
55
56;;; (exception-of? kind-key)
57;;; ------------------------
58;;; returns a predicate which checks, if its argument is an exception of
59;;; kind kind-key
60(define (exception-of? kind-key)
61  (lambda (xpr)
62    (and (exception? xpr)
63         ((condition-predicate kind-key) xpr))))
64
65
66;;; (make-exception msg . kind-keys)
67;;; ---------------------------------
68;;; returns a procedure with arguments loc and args
69;;; to construct composite-conditions of kind 'exn and kind-keys.
70;;; Note, that msg and kind-keys are independent of a concrete use of
71;;; this exception, while loc and args depend exactly on that use.
72(define (make-exception msg . kind-keys)
73  (lambda (loc . args)
74    (if (null? kind-keys)
75      (make-property-condition 'exn 
76                               'location loc
77                               'message msg
78                               'arguments args)
79      (apply make-composite-condition
80             (make-property-condition 'exn 
81                                      'location loc
82                                      'message msg
83                                      'arguments args)
84             (map (lambda (kind) (make-property-condition kind))
85                  kind-keys)))))
86
87;;; (guard (exn cond-clause . cond-clauses) xpr . xprs)
88;;; ---------------------------------------------------
89;;; R6RS and R7RS high-level exception-handler
90(define-syntax guard
91  (syntax-rules ()
92    ((_ (exn cond-clause . cond-clauses) xpr . xprs)
93     (handle-exceptions exn (cond cond-clause . cond-clauses)
94                        xpr . xprs))))
95;;; (assert* loc xpr . xprs)
96;;; ------------------------
97;;; checks, if its arguments xpr . xprs are not #f.
98(define-syntax assert*
99  (syntax-rules ()
100    ((_ loc)
101     (void))
102    ((_ loc xpr . xprs)
103     (if xpr
104       (assert* loc . xprs)
105       ;(raise (assert-exn loc 'xpr))))))
106       (raise ((make-exception "assertion violated" 'assert)
107               loc 'xpr))))))
108
109;;; (location exn)
110;;; --------------
111;;; returns the location property of its exception argument
112(define (location exn)
113  (assert* 'location (exception? exn))
114  (get-condition-property exn 'exn 'location 'unknown))
115
116;;; (message exn)
117;;; -------------
118;;; returns the message property of its exception argument
119(define (message exn)
120  (assert* 'message (exception? exn))
121  (get-condition-property exn 'exn 'message "no message supplied"))
122
123;;; (arguments exn)
124;;; ---------------
125;;; returns the arguments property of its exception argument
126(define (arguments exn)
127  (assert* 'arguments (exception? exn))
128  (get-condition-property exn 'exn 'arguments '()))
129
130(define (##sys#raise x)
131  (##sys#current-exception-handler x)
132  (##sys#abort
133   (##sys#make-structure
134    'condition
135    '(exn)
136    (list '(exn . message)"exception handler returned"
137          '(exn . arguments) (arguments x)
138          '(exn . location) (location x)))))
139
140;;; (raise exn)
141;;; -----------
142;;; raises a non-continuable exception
143(define (raise exn)
144  (if (exception? exn)
145    (##sys#raise exn)
146    (##sys#abort exn)))
147
148;;; (with-exn-handler handler thunk)
149;;; ----------------------------
150;;; wrapping Chicken's with-exception-handler into pop-and-call
151;;; to avoid the generation of infinite loops
152(define (with-exn-handler handler thunk)
153  ;((call-with-current-continuation
154  (continuation-capture
155     (lambda (k)
156       ;(with-exception-handler ; Chicken's handler
157       ;  (lambda (exn)
158       ;    (k (lambda () (handler exn))))
159       ;  thunk)))))
160       (let ((old-handler (current-exception-handler)))
161         (dynamic-wind
162           (lambda ()
163             (current-exception-handler
164               (lambda (exn)
165                 ;(k (lambda () (handler exn))))))
166                 (continuation-graft k (lambda () (handler exn))))))
167           thunk
168           (lambda ()
169             (current-exception-handler old-handler)))))));)
170
171;;; (simple-exceptions [sym])
172;;; -------------------------
173;;; documentation procedure
174(define simple-exceptions
175  (let (
176    (signatures '(
177      (assert* loc xpr . xprs)
178      (exception? xpr)
179      (exception-of? kind-key)
180      (make-exception msg . kind-keys)
181      (location exn)
182      (message exn)
183      (arguments exn)
184      (raise exn)
185      (with-exn-handler handler thunk)
186      (handle-exceptions exn handle-xpr xpr . xprs)
187      (guard (exn cond-clause . cond-clauses) xpr . xprs)
188      (condition-case xpr ([var] (kind ...) body) . other-clauses)))
189    )
190    (case-lambda
191      (() (map car signatures))
192      ((sym) (assq sym signatures)))))
193
194) ; module simple-exceptions
195
Note: See TracBrowser for help on using the repository browser.