summaryrefslogtreecommitdiff
path: root/module/rnrs
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-11-28 15:00:17 +0100
committerAndy Wingo <wingo@pobox.com>2013-11-28 15:00:17 +0100
commitf76cf73a49e0219f81a2fa0fc8431a0b83280822 (patch)
tree6ec1706097e4ec0b39fe42bc45c11f88d45171e3 /module/rnrs
parent6dd98109020997d22f78d9cd516d7809c4fcc493 (diff)
parent8571dbde639e0ee9885bad49c9e180474bd23646 (diff)
downloadguile-f76cf73a49e0219f81a2fa0fc8431a0b83280822.tar.gz
Merge commit '8571dbde639e0ee9885bad49c9e180474bd23646'
Conflicts: libguile/procprop.c
Diffstat (limited to 'module/rnrs')
-rw-r--r--module/rnrs/exceptions.scm160
1 files changed, 145 insertions, 15 deletions
diff --git a/module/rnrs/exceptions.scm b/module/rnrs/exceptions.scm
index 95d01dfdc..52f5c257f 100644
--- a/module/rnrs/exceptions.scm
+++ b/module/rnrs/exceptions.scm
@@ -1,6 +1,6 @@
;;; exceptions.scm --- The R6RS exceptions library
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -29,14 +29,61 @@
newline
display
filter
+ acons
+ assv-ref
+ throw
set-exception-printer!
with-throw-handler
*unspecified*
@@))
- (define raise (@@ (rnrs records procedural) r6rs-raise))
- (define raise-continuable
+ ;; When a native guile exception is caught by an R6RS exception
+ ;; handler, we convert it to an R6RS compound condition that includes
+ ;; not only the standard condition objects expected by R6RS code, but
+ ;; also a special &guile condition that preserves the original KEY and
+ ;; ARGS passed to the native Guile catch handler.
+
+ (define-condition-type &guile &condition
+ make-guile-condition guile-condition?
+ (key guile-condition-key)
+ (args guile-condition-args))
+
+ (define (default-guile-condition-converter key args)
+ (condition (make-serious-condition)
+ (guile-common-conditions key args)))
+
+ (define (guile-common-conditions key args)
+ (apply (case-lambda
+ ((subr msg margs . _)
+ (condition (make-who-condition subr)
+ (make-message-condition msg)
+ (make-irritants-condition margs)))
+ (_ (make-irritants-condition args)))
+ args))
+
+ (define (convert-guile-condition key args)
+ (let ((converter (assv-ref guile-condition-converters key)))
+ (condition (or (and converter (converter key args))
+ (default-guile-condition-converter key args))
+ ;; Preserve the original KEY and ARGS in the R6RS
+ ;; condition object.
+ (make-guile-condition key args))))
+
+ ;; If an R6RS exception handler chooses not to handle a given
+ ;; condition, it will re-raise the condition to pass it on to the next
+ ;; handler. If the condition was converted from a native Guile
+ ;; exception, we must re-raise using the native Guile facilities and
+ ;; the original exception KEY and ARGS. We arrange for this in
+ ;; 'raise' so that native Guile exception handlers will continue to
+ ;; work when mixed with R6RS code.
+
+ (define (raise obj)
+ (if (guile-condition? obj)
+ (apply throw (guile-condition-key obj) (guile-condition-args obj))
+ ((@@ (rnrs records procedural) r6rs-raise) obj)))
+ (define raise-continuable
(@@ (rnrs records procedural) r6rs-raise-continuable))
+
(define raise-object-wrapper?
(@@ (rnrs records procedural) raise-object-wrapper?))
(define raise-object-wrapper-obj
@@ -45,19 +92,22 @@
(@@ (rnrs records procedural) raise-object-wrapper-continuation))
(define (with-exception-handler handler thunk)
- (with-throw-handler 'r6rs:exception
+ (with-throw-handler #t
thunk
(lambda (key . args)
- (if (and (not (null? args))
- (raise-object-wrapper? (car args)))
- (let* ((cargs (car args))
- (obj (raise-object-wrapper-obj cargs))
- (continuation (raise-object-wrapper-continuation cargs))
- (handler-return (handler obj)))
- (if continuation
- (continuation handler-return)
- (raise (make-non-continuable-violation))))
- *unspecified*))))
+ (cond ((not (eq? key 'r6rs:exception))
+ (let ((obj (convert-guile-condition key args)))
+ (handler obj)
+ (raise (make-non-continuable-violation))))
+ ((and (not (null? args))
+ (raise-object-wrapper? (car args)))
+ (let* ((cargs (car args))
+ (obj (raise-object-wrapper-obj cargs))
+ (continuation (raise-object-wrapper-continuation cargs))
+ (handler-return (handler obj)))
+ (if continuation
+ (continuation handler-return)
+ (raise (make-non-continuable-violation)))))))))
(define-syntax guard0
(syntax-rules ()
@@ -143,4 +193,84 @@
(set-exception-printer! 'r6rs:exception exception-printer)
-)
+ ;; Guile condition converters
+ ;;
+ ;; Each converter is a procedure (converter KEY ARGS) that returns
+ ;; either an R6RS condition or #f. If #f is returned,
+ ;; 'default-guile-condition-converter' will be used.
+
+ (define (guile-syntax-violation-converter key args)
+ (apply (case-lambda
+ ((who what where form subform . extra)
+ (condition (make-syntax-violation form subform)
+ (make-who-condition who)
+ (make-message-condition what)))
+ (_ #f))
+ args))
+
+ (define (guile-lexical-violation-converter key args)
+ (condition (make-lexical-violation) (guile-common-conditions key args)))
+
+ (define (guile-assertion-violation-converter key args)
+ (condition (make-assertion-violation) (guile-common-conditions key args)))
+
+ (define (guile-undefined-violation-converter key args)
+ (condition (make-undefined-violation) (guile-common-conditions key args)))
+
+ (define (guile-implementation-restriction-converter key args)
+ (condition (make-implementation-restriction-violation)
+ (guile-common-conditions key args)))
+
+ (define (guile-error-converter key args)
+ (condition (make-error) (guile-common-conditions key args)))
+
+ (define (guile-system-error-converter key args)
+ (apply (case-lambda
+ ((subr msg msg-args errno . rest)
+ ;; XXX TODO we should return a more specific error
+ ;; (usually an I/O error) as expected by R6RS programs.
+ ;; Unfortunately this often requires the 'filename' (or
+ ;; other?) which is not currently provided by the native
+ ;; Guile exceptions.
+ (condition (make-error) (guile-common-conditions key args)))
+ (_ (guile-error-converter key args)))
+ args))
+
+ ;; TODO: Arrange to have the needed information included in native
+ ;; Guile I/O exceptions, and arrange here to convert them to the
+ ;; proper conditions. Remove the earlier exception conversion
+ ;; mechanism: search for 'with-throw-handler' in the 'rnrs'
+ ;; tree, e.g. 'with-i/o-filename-conditions' and
+ ;; 'with-i/o-port-error' in (rnrs io ports).
+
+ ;; XXX TODO: How should we handle the 'misc-error', 'vm-error', and
+ ;; 'signal' native Guile exceptions?
+
+ ;; XXX TODO: Should we handle the 'quit' exception specially?
+
+ ;; An alist mapping native Guile exception keys to converters.
+ (define guile-condition-converters
+ `((read-error . ,guile-lexical-violation-converter)
+ (syntax-error . ,guile-syntax-violation-converter)
+ (unbound-variable . ,guile-undefined-violation-converter)
+ (wrong-number-of-args . ,guile-assertion-violation-converter)
+ (wrong-type-arg . ,guile-assertion-violation-converter)
+ (keyword-argument-error . ,guile-assertion-violation-converter)
+ (out-of-range . ,guile-assertion-violation-converter)
+ (regular-expression-syntax . ,guile-assertion-violation-converter)
+ (program-error . ,guile-assertion-violation-converter)
+ (goops-error . ,guile-assertion-violation-converter)
+ (null-pointer-error . ,guile-assertion-violation-converter)
+ (system-error . ,guile-system-error-converter)
+ (host-not-found . ,guile-error-converter)
+ (getaddrinfo-error . ,guile-error-converter)
+ (no-data . ,guile-error-converter)
+ (no-recovery . ,guile-error-converter)
+ (try-again . ,guile-error-converter)
+ (stack-overflow . ,guile-implementation-restriction-converter)
+ (numerical-overflow . ,guile-implementation-restriction-converter)
+ (memory-allocation-error . ,guile-implementation-restriction-converter)))
+
+ (define (set-guile-condition-converter! key proc)
+ (set! guile-condition-converters
+ (acons key proc guile-condition-converters))))