* bug#14922: Improving R6RS exception handling in Guile
2013-07-21 9:29 bug#14922: guard expression doesn't catch everything Göran Weinholt
@ 2013-08-10 17:07 ` Mark H Weaver
0 siblings, 0 replies; 4+ messages in thread
From: Mark H Weaver @ 2013-08-10 17:07 UTC (permalink / raw)
To: guile-devel; +Cc: Göran Weinholt, 14922
[-- Attachment #1: Type: text/plain, Size: 1379 bytes --]
Hello all,
I've cooked up a patch to help improve R6RS exception handling in Guile.
As noted by Göran Weinholt in <http://bugs.gnu.org/14922>, the R6RS
exception handlers in Guile are currently unable to catch native Guile
exceptions. To fix this, the basic approach of this patch is to convert
native Guile exceptions into R6RS conditions within the R6RS exception
handlers.
It's almost that simple, but there's one twist: if an R6RS exception
handler chooses not to handle a given exception, it will call 'raise'
again on the condition object, and here we must arrange to throw the
original Guile exception again. We must do this because there's a lot
of Guile code out there that can only handle native Guile exceptions,
and which should not be broken by an R6RS exception handler somewhere in
the middle of the call stack.
We cope with this by including a special &guile condition object in the
compound condition that is produced by conversion. Whenever 'raise' is
applied to such a condition, it will use the native Guile 'throw' with
the original KEY and ARGS stored in the &guile condition object.
Still to do: Modify the core Guile routines where needed (especially
I/O) to include enough information in exceptions to generate the
standard R6RS condition objects.
I'd be grateful for any feedback.
Regards,
Mark
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: [PATCH] Convert guile exceptions to R6RS conditions in R6RS exception handlers --]
[-- Type: text/x-diff, Size: 12768 bytes --]
From 6b2a6f3f91fc8078053727e45ee3e40515274bc3 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
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
^ permalink raw reply related [flat|nested] 4+ messages in thread