diff options
author | Andy Wingo <wingo@pobox.com> | 2013-11-28 15:00:17 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-11-28 15:00:17 +0100 |
commit | f76cf73a49e0219f81a2fa0fc8431a0b83280822 (patch) | |
tree | 6ec1706097e4ec0b39fe42bc45c11f88d45171e3 /module/rnrs | |
parent | 6dd98109020997d22f78d9cd516d7809c4fcc493 (diff) | |
parent | 8571dbde639e0ee9885bad49c9e180474bd23646 (diff) | |
download | guile-f76cf73a49e0219f81a2fa0fc8431a0b83280822.tar.gz |
Merge commit '8571dbde639e0ee9885bad49c9e180474bd23646'
Conflicts:
libguile/procprop.c
Diffstat (limited to 'module/rnrs')
-rw-r--r-- | module/rnrs/exceptions.scm | 160 |
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)))) |