Commit | Line | Data |
---|---|---|
ce543a9f JG |
1 | ;;; exceptions.scm --- The R6RS exceptions library |
2 | ||
02500d44 | 3 | ;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc. |
ce543a9f JG |
4 | ;; |
5 | ;; This library is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 3 of the License, or (at your option) any later version. | |
9 | ;; | |
10 | ;; This library 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 GNU | |
13 | ;; Lesser General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | \f | |
19 | ||
20 | (library (rnrs exceptions (6)) | |
d1c83d38 | 21 | (export guard with-exception-handler raise raise-continuable) |
ce543a9f | 22 | (import (rnrs base (6)) |
32b63129 | 23 | (rnrs control (6)) |
ce543a9f JG |
24 | (rnrs conditions (6)) |
25 | (rnrs records procedural (6)) | |
32b63129 AR |
26 | (rnrs records inspection (6)) |
27 | (only (guile) | |
28 | format | |
29 | newline | |
30 | display | |
31 | filter | |
02500d44 MW |
32 | acons |
33 | assv-ref | |
34 | throw | |
32b63129 AR |
35 | set-exception-printer! |
36 | with-throw-handler | |
37 | *unspecified* | |
38 | @@)) | |
ce543a9f | 39 | |
02500d44 MW |
40 | ;; When a native guile exception is caught by an R6RS exception |
41 | ;; handler, we convert it to an R6RS compound condition that includes | |
42 | ;; not only the standard condition objects expected by R6RS code, but | |
43 | ;; also a special &guile condition that preserves the original KEY and | |
44 | ;; ARGS passed to the native Guile catch handler. | |
45 | ||
46 | (define-condition-type &guile &condition | |
47 | make-guile-condition guile-condition? | |
48 | (key guile-condition-key) | |
49 | (args guile-condition-args)) | |
50 | ||
51 | (define (default-guile-condition-converter key args) | |
52 | (condition (make-serious-condition) | |
53 | (guile-common-conditions key args))) | |
54 | ||
55 | (define (guile-common-conditions key args) | |
56 | (apply (case-lambda | |
57 | ((subr msg margs . _) | |
58 | (condition (make-who-condition subr) | |
59 | (make-message-condition msg) | |
60 | (make-irritants-condition margs))) | |
61 | (_ (make-irritants-condition args))) | |
62 | args)) | |
63 | ||
64 | (define (convert-guile-condition key args) | |
65 | (let ((converter (assv-ref guile-condition-converters key))) | |
66 | (condition (or (and converter (converter key args)) | |
67 | (default-guile-condition-converter key args)) | |
68 | ;; Preserve the original KEY and ARGS in the R6RS | |
69 | ;; condition object. | |
70 | (make-guile-condition key args)))) | |
71 | ||
72 | ;; If an R6RS exception handler chooses not to handle a given | |
73 | ;; condition, it will re-raise the condition to pass it on to the next | |
74 | ;; handler. If the condition was converted from a native Guile | |
75 | ;; exception, we must re-raise using the native Guile facilities and | |
76 | ;; the original exception KEY and ARGS. We arrange for this in | |
77 | ;; 'raise' so that native Guile exception handlers will continue to | |
78 | ;; work when mixed with R6RS code. | |
79 | ||
80 | (define (raise obj) | |
81 | (if (guile-condition? obj) | |
82 | (apply throw (guile-condition-key obj) (guile-condition-args obj)) | |
83 | ((@@ (rnrs records procedural) r6rs-raise) obj))) | |
84 | (define raise-continuable | |
ce543a9f | 85 | (@@ (rnrs records procedural) r6rs-raise-continuable)) |
02500d44 | 86 | |
ce543a9f JG |
87 | (define raise-object-wrapper? |
88 | (@@ (rnrs records procedural) raise-object-wrapper?)) | |
89 | (define raise-object-wrapper-obj | |
90 | (@@ (rnrs records procedural) raise-object-wrapper-obj)) | |
91 | (define raise-object-wrapper-continuation | |
92 | (@@ (rnrs records procedural) raise-object-wrapper-continuation)) | |
93 | ||
94 | (define (with-exception-handler handler thunk) | |
02500d44 | 95 | (with-throw-handler #t |
ce543a9f JG |
96 | thunk |
97 | (lambda (key . args) | |
02500d44 MW |
98 | (cond ((not (eq? key 'r6rs:exception)) |
99 | (let ((obj (convert-guile-condition key args))) | |
100 | (handler obj) | |
101 | (raise (make-non-continuable-violation)))) | |
102 | ((and (not (null? args)) | |
103 | (raise-object-wrapper? (car args))) | |
104 | (let* ((cargs (car args)) | |
105 | (obj (raise-object-wrapper-obj cargs)) | |
106 | (continuation (raise-object-wrapper-continuation cargs)) | |
107 | (handler-return (handler obj))) | |
108 | (if continuation | |
109 | (continuation handler-return) | |
110 | (raise (make-non-continuable-violation))))))))) | |
d1c83d38 JG |
111 | |
112 | (define-syntax guard0 | |
0c7398a7 | 113 | (syntax-rules () |
23988e8c | 114 | ((_ (variable cond-clause ...) . body) |
0c7398a7 JG |
115 | (call/cc (lambda (continuation) |
116 | (with-exception-handler | |
117 | (lambda (variable) | |
118 | (continuation (cond cond-clause ...))) | |
23988e8c | 119 | (lambda () . body))))))) |
d1c83d38 JG |
120 | |
121 | (define-syntax guard | |
0c7398a7 | 122 | (syntax-rules (else) |
23988e8c AR |
123 | ((_ (variable cond-clause ... . ((else else-clause ...))) . body) |
124 | (guard0 (variable cond-clause ... (else else-clause ...)) . body)) | |
125 | ((_ (variable cond-clause ...) . body) | |
126 | (guard0 (variable cond-clause ... (else (raise variable))) . body)))) | |
32b63129 AR |
127 | |
128 | ;;; Exception printing | |
129 | ||
130 | (define (exception-printer port key args punt) | |
131 | (cond ((and (= 1 (length args)) | |
132 | (raise-object-wrapper? (car args))) | |
133 | (let ((obj (raise-object-wrapper-obj (car args)))) | |
134 | (cond ((condition? obj) | |
135 | (display "ERROR: R6RS exception:\n" port) | |
136 | (format-condition port obj)) | |
137 | (else | |
138 | (format port "ERROR: R6RS exception: `~s'" obj))))) | |
139 | (else | |
140 | (punt)))) | |
141 | ||
142 | (define (format-condition port condition) | |
143 | (let ((components (simple-conditions condition))) | |
144 | (if (null? components) | |
145 | (format port "Empty condition object") | |
146 | (let loop ((i 1) (components components)) | |
147 | (cond ((pair? components) | |
148 | (format port " ~a. " i) | |
149 | (format-simple-condition port (car components)) | |
150 | (when (pair? (cdr components)) | |
151 | (newline port)) | |
152 | (loop (+ i 1) (cdr components)))))))) | |
153 | ||
154 | (define (format-simple-condition port condition) | |
155 | (define (print-rtd-fields rtd field-names) | |
156 | (let ((n-fields (vector-length field-names))) | |
157 | (do ((i 0 (+ i 1))) | |
158 | ((>= i n-fields)) | |
159 | (format port " ~a: ~s" | |
160 | (vector-ref field-names i) | |
161 | ((record-accessor rtd i) condition)) | |
162 | (unless (= i (- n-fields 1)) | |
163 | (newline port))))) | |
164 | (let ((condition-name (record-type-name (record-rtd condition)))) | |
165 | (let loop ((rtd (record-rtd condition)) | |
166 | (rtd.fields-list '()) | |
167 | (n-fields 0)) | |
168 | (cond (rtd | |
169 | (let ((field-names (record-type-field-names rtd))) | |
170 | (loop (record-type-parent rtd) | |
171 | (cons (cons rtd field-names) rtd.fields-list) | |
172 | (+ n-fields (vector-length field-names))))) | |
173 | (else | |
174 | (let ((rtd.fields-list | |
175 | (filter (lambda (rtd.fields) | |
176 | (not (zero? (vector-length (cdr rtd.fields))))) | |
177 | (reverse rtd.fields-list)))) | |
178 | (case n-fields | |
179 | ((0) (format port "~a" condition-name)) | |
180 | ((1) (format port "~a: ~s" | |
181 | condition-name | |
182 | ((record-accessor (caar rtd.fields-list) 0) | |
183 | condition))) | |
184 | (else | |
185 | (format port "~a:\n" condition-name) | |
186 | (let loop ((lst rtd.fields-list)) | |
187 | (when (pair? lst) | |
188 | (let ((rtd.fields (car lst))) | |
189 | (print-rtd-fields (car rtd.fields) (cdr rtd.fields)) | |
190 | (when (pair? (cdr lst)) | |
191 | (newline port)) | |
192 | (loop (cdr lst))))))))))))) | |
193 | ||
194 | (set-exception-printer! 'r6rs:exception exception-printer) | |
195 | ||
02500d44 MW |
196 | ;; Guile condition converters |
197 | ;; | |
198 | ;; Each converter is a procedure (converter KEY ARGS) that returns | |
199 | ;; either an R6RS condition or #f. If #f is returned, | |
200 | ;; 'default-guile-condition-converter' will be used. | |
201 | ||
202 | (define (guile-syntax-violation-converter key args) | |
203 | (apply (case-lambda | |
204 | ((who what where form subform . extra) | |
205 | (condition (make-syntax-violation form subform) | |
206 | (make-who-condition who) | |
207 | (make-message-condition what))) | |
208 | (_ #f)) | |
209 | args)) | |
210 | ||
211 | (define (guile-lexical-violation-converter key args) | |
212 | (condition (make-lexical-violation) (guile-common-conditions key args))) | |
213 | ||
214 | (define (guile-assertion-violation-converter key args) | |
215 | (condition (make-assertion-violation) (guile-common-conditions key args))) | |
216 | ||
217 | (define (guile-undefined-violation-converter key args) | |
218 | (condition (make-undefined-violation) (guile-common-conditions key args))) | |
219 | ||
220 | (define (guile-implementation-restriction-converter key args) | |
221 | (condition (make-implementation-restriction-violation) | |
222 | (guile-common-conditions key args))) | |
223 | ||
224 | (define (guile-error-converter key args) | |
225 | (condition (make-error) (guile-common-conditions key args))) | |
226 | ||
227 | (define (guile-system-error-converter key args) | |
228 | (apply (case-lambda | |
229 | ((subr msg msg-args errno . rest) | |
230 | ;; XXX TODO we should return a more specific error | |
231 | ;; (usually an I/O error) as expected by R6RS programs. | |
232 | ;; Unfortunately this often requires the 'filename' (or | |
233 | ;; other?) which is not currently provided by the native | |
234 | ;; Guile exceptions. | |
235 | (condition (make-error) (guile-common-conditions key args))) | |
236 | (_ (guile-error-converter key args))) | |
237 | args)) | |
238 | ||
239 | ;; TODO: Arrange to have the needed information included in native | |
240 | ;; Guile I/O exceptions, and arrange here to convert them to the | |
241 | ;; proper conditions. Remove the earlier exception conversion | |
242 | ;; mechanism: search for 'with-throw-handler' in the 'rnrs' | |
243 | ;; tree, e.g. 'with-i/o-filename-conditions' and | |
244 | ;; 'with-i/o-port-error' in (rnrs io ports). | |
245 | ||
246 | ;; XXX TODO: How should we handle the 'misc-error', 'vm-error', and | |
247 | ;; 'signal' native Guile exceptions? | |
248 | ||
249 | ;; XXX TODO: Should we handle the 'quit' exception specially? | |
250 | ||
251 | ;; An alist mapping native Guile exception keys to converters. | |
252 | (define guile-condition-converters | |
253 | `((read-error . ,guile-lexical-violation-converter) | |
254 | (syntax-error . ,guile-syntax-violation-converter) | |
255 | (unbound-variable . ,guile-undefined-violation-converter) | |
256 | (wrong-number-of-args . ,guile-assertion-violation-converter) | |
257 | (wrong-type-arg . ,guile-assertion-violation-converter) | |
258 | (keyword-argument-error . ,guile-assertion-violation-converter) | |
259 | (out-of-range . ,guile-assertion-violation-converter) | |
260 | (regular-expression-syntax . ,guile-assertion-violation-converter) | |
261 | (program-error . ,guile-assertion-violation-converter) | |
262 | (goops-error . ,guile-assertion-violation-converter) | |
263 | (null-pointer-error . ,guile-assertion-violation-converter) | |
264 | (system-error . ,guile-system-error-converter) | |
265 | (host-not-found . ,guile-error-converter) | |
266 | (getaddrinfo-error . ,guile-error-converter) | |
267 | (no-data . ,guile-error-converter) | |
268 | (no-recovery . ,guile-error-converter) | |
269 | (try-again . ,guile-error-converter) | |
270 | (stack-overflow . ,guile-implementation-restriction-converter) | |
271 | (numerical-overflow . ,guile-implementation-restriction-converter) | |
272 | (memory-allocation-error . ,guile-implementation-restriction-converter))) | |
273 | ||
274 | (define (set-guile-condition-converter! key proc) | |
275 | (set! guile-condition-converters | |
276 | (acons key proc guile-condition-converters)))) |