From 6b2a6f3f91fc8078053727e45ee3e40515274bc3 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 9 Aug 2013 18:27:20 -0400 Subject: [PATCH] Convert guile exceptions to R6RS conditions in R6RS exception handlers. * module/rnrs/exceptions.scm (&guile): New condition type. (guile-condition-converters): New variable. (convert-guile-condition, default-guile-condition-converter, set-guile-condition-converter!, guile-common-conditions, guile-lexical-violation-converter, guile-syntax-violation-converter, guile-assertion-violation-converter, guile-system-error-converter, guile-undefined-violation-converter, guile-error-converter, guile-implementation-restriction-converter): New procedures. (with-exception-handler): Catch all exceptions, not just R6RS exceptions. Convert native Guile exceptions to R6RS conditions, preserving the original Guile exception information in the &guile condition object. (raise, raise-continuable): If the condition includes a &guile condition, use 'throw' to throw the original native guile exception instead of raising an R6RS exception. * test-suite/tests/r6rs-exceptions.test ("guile condition conversions"): Add tests. --- module/rnrs/exceptions.scm | 158 +++++++++++++++++++++++++++++---- test-suite/tests/r6rs-exceptions.test | 56 +++++++++++- 2 files changed, 198 insertions(+), 16 deletions(-) diff --git a/module/rnrs/exceptions.scm b/module/rnrs/exceptions.scm index 95d01df..21aa391 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,82 @@ (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' 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))) + + (define (set-guile-condition-converter! key proc) + (set! guile-condition-converters + (acons key proc guile-condition-converters)))) diff --git a/test-suite/tests/r6rs-exceptions.test b/test-suite/tests/r6rs-exceptions.test index 54a4ddb..c6daa0f 100644 --- a/test-suite/tests/r6rs-exceptions.test +++ b/test-suite/tests/r6rs-exceptions.test @@ -1,6 +1,6 @@ ;;; r6rs-exceptions.test --- Test suite for R6RS (rnrs exceptions) -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 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 @@ -20,6 +20,7 @@ (define-module (test-suite test-rnrs-exceptions) :use-module ((rnrs conditions) :version (6)) :use-module ((rnrs exceptions) :version (6)) + :use-module (system foreign) :use-module (test-suite lib)) (with-test-prefix "with-exception-handler" @@ -96,3 +97,56 @@ (pass-if "guard with cond => syntax" (guard (condition (condition => error?)) (raise (make-error))))) + +(with-test-prefix "guile condition conversions" + + (define-syntax-rule (pass-if-condition name expected-condition? body ...) + (pass-if name + (guard (obj ((expected-condition? obj) #t) + (else #f)) + body ... #f))) + + (pass-if "rethrown native guile exceptions" + (catch #t + (lambda () + (guard (obj ((syntax-violation? obj) #f)) + (vector-ref '#(0 1) 2) + #f)) + (lambda (key . args) + (eq? key 'out-of-range)))) + + (pass-if-condition "syntax-error" + syntax-violation? + (eval '(let) (current-module))) + + (pass-if-condition "unbound-variable" + undefined-violation? + variable-that-does-not-exist) + + (pass-if-condition "out-of-range" + assertion-violation? + (vector-ref '#(0 1) 2)) + + (pass-if-condition "wrong-number-of-args" + assertion-violation? + ((lambda () #f) 'unwanted-argument)) + + (pass-if-condition "wrong-type-arg" + assertion-violation? + (vector-ref '#(0 1) 'invalid-index)) + + (pass-if-condition "keyword-argument-error" + assertion-violation? + ((lambda* (#:key a) #f) #:unwanted-keyword 'val)) + + (pass-if-condition "regular-expression-syntax" + assertion-violation? + (make-regexp "[missing-close-square-bracket")) + + (pass-if-condition "null-pointer-error" + assertion-violation? + (dereference-pointer (make-pointer 0))) + + (pass-if-condition "read-error" + lexical-violation? + (read (open-input-string "(missing-close-paren")))) -- 1.7.10.4