1 ;;; exceptions.scm --- The R6RS exceptions library
3 ;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
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.
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.
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
20 (library (rnrs exceptions (6))
21 (export guard with-exception-handler raise raise-continuable)
22 (import (rnrs base (6))
25 (rnrs records procedural (6))
26 (rnrs records inspection (6))
35 set-exception-printer!
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.
46 (define-condition-type &guile &condition
47 make-guile-condition guile-condition?
48 (key guile-condition-key)
49 (args guile-condition-args))
51 (define (default-guile-condition-converter key args)
52 (condition (make-serious-condition)
53 (guile-common-conditions key args)))
55 (define (guile-common-conditions key args)
58 (condition (make-who-condition subr)
59 (make-message-condition msg)
60 (make-irritants-condition margs)))
61 (_ (make-irritants-condition args)))
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
70 (make-guile-condition key args))))
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.
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
85 (@@ (rnrs records procedural) r6rs-raise-continuable))
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))
94 (define (with-exception-handler handler thunk)
95 (with-throw-handler #t
98 (cond ((not (eq? key 'r6rs:exception))
99 (let ((obj (convert-guile-condition key args)))
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)))
109 (continuation handler-return)
110 (raise (make-non-continuable-violation)))))))))
112 (define-syntax guard0
114 ((_ (variable cond-clause ...) . body)
115 (call/cc (lambda (continuation)
116 (with-exception-handler
118 (continuation (cond cond-clause ...)))
119 (lambda () . body)))))))
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))))
128 ;;; Exception printing
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))
138 (format port "ERROR: R6RS exception: `~s'" obj)))))
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))
152 (loop (+ i 1) (cdr components))))))))
154 (define (format-simple-condition port condition)
155 (define (print-rtd-fields rtd field-names)
156 (let ((n-fields (vector-length field-names)))
159 (format port " ~a: ~s"
160 (vector-ref field-names i)
161 ((record-accessor rtd i) condition))
162 (unless (= i (- n-fields 1))
164 (let ((condition-name (record-type-name (record-rtd condition))))
165 (let loop ((rtd (record-rtd condition))
166 (rtd.fields-list '())
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)))))
174 (let ((rtd.fields-list
175 (filter (lambda (rtd.fields)
176 (not (zero? (vector-length (cdr rtd.fields)))))
177 (reverse rtd.fields-list))))
179 ((0) (format port "~a" condition-name))
180 ((1) (format port "~a: ~s"
182 ((record-accessor (caar rtd.fields-list) 0)
185 (format port "~a:\n" condition-name)
186 (let loop ((lst rtd.fields-list))
188 (let ((rtd.fields (car lst)))
189 (print-rtd-fields (car rtd.fields) (cdr rtd.fields))
190 (when (pair? (cdr lst))
192 (loop (cdr lst)))))))))))))
194 (set-exception-printer! 'r6rs:exception exception-printer)
196 ;; Guile condition converters
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.
202 (define (guile-syntax-violation-converter key args)
204 ((who what where form subform . extra)
205 (condition (make-syntax-violation form subform)
206 (make-who-condition who)
207 (make-message-condition what)))
211 (define (guile-lexical-violation-converter key args)
212 (condition (make-lexical-violation) (guile-common-conditions key args)))
214 (define (guile-assertion-violation-converter key args)
215 (condition (make-assertion-violation) (guile-common-conditions key args)))
217 (define (guile-undefined-violation-converter key args)
218 (condition (make-undefined-violation) (guile-common-conditions key args)))
220 (define (guile-implementation-restriction-converter key args)
221 (condition (make-implementation-restriction-violation)
222 (guile-common-conditions key args)))
224 (define (guile-error-converter key args)
225 (condition (make-error) (guile-common-conditions key args)))
227 (define (guile-system-error-converter key args)
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
235 (condition (make-error) (guile-common-conditions key args)))
236 (_ (guile-error-converter key args)))
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).
246 ;; XXX TODO: How should we handle the 'misc-error', 'vm-error', and
247 ;; 'signal' native Guile exceptions?
249 ;; XXX TODO: Should we handle the 'quit' exception specially?
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)))
274 (define (set-guile-condition-converter! key proc)
275 (set! guile-condition-converters
276 (acons key proc guile-condition-converters))))