From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Mark H Weaver Newsgroups: gmane.lisp.guile.bugs Subject: bug#14922: Improving R6RS exception handling in Guile Date: Sat, 10 Aug 2013 13:07:50 -0400 Message-ID: <87txixqxsp.fsf__17065.567468717$1376154564$gmane$org@tines.lan> References: <87d2qcqn1c.fsf@industria.weinholt.se> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1376154557 9165 80.91.229.3 (10 Aug 2013 17:09:17 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Sat, 10 Aug 2013 17:09:17 +0000 (UTC) Cc: =?UTF-8?Q?G=C3=B6ran?= Weinholt , 14922@debbugs.gnu.org To: guile-devel@gnu.org Original-X-From: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Sat Aug 10 19:09:19 2013 Return-path: Envelope-to: guile-bugs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1V8CfF-0006Dm-Hb for guile-bugs@m.gmane.org; Sat, 10 Aug 2013 19:09:17 +0200 Original-Received: from localhost ([::1]:58226 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1V8CfF-0001PR-20 for guile-bugs@m.gmane.org; Sat, 10 Aug 2013 13:09:17 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:33031) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1V8Cf6-0001PA-RR for bug-guile@gnu.org; Sat, 10 Aug 2013 13:09:14 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1V8Cf1-00082y-65 for bug-guile@gnu.org; Sat, 10 Aug 2013 13:09:08 -0400 Original-Received: from debbugs.gnu.org ([140.186.70.43]:57669) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1V8Cf1-000829-1A for bug-guile@gnu.org; Sat, 10 Aug 2013 13:09:03 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.80) (envelope-from ) id 1V8Cf0-0006YU-EZ for bug-guile@gnu.org; Sat, 10 Aug 2013 13:09:02 -0400 X-Loop: help-debbugs@gnu.org In-Reply-To: <87d2qcqn1c.fsf@industria.weinholt.se> Resent-From: Mark H Weaver Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Sat, 10 Aug 2013 17:09:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 14922 X-GNU-PR-Package: guile X-GNU-PR-Keywords: Original-Received: via spool by 14922-submit@debbugs.gnu.org id=B14922.137615450825148 (code B ref 14922); Sat, 10 Aug 2013 17:09:02 +0000 Original-Received: (at 14922) by debbugs.gnu.org; 10 Aug 2013 17:08:28 +0000 Original-Received: from localhost ([127.0.0.1]:51985 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.80) (envelope-from ) id 1V8CeR-0006XX-Fx for submit@debbugs.gnu.org; Sat, 10 Aug 2013 13:08:28 -0400 Original-Received: from world.peace.net ([96.39.62.75]:53126 ident=hope7) by debbugs.gnu.org with esmtp (Exim 4.80) (envelope-from ) id 1V8CeN-0006XJ-IG for 14922@debbugs.gnu.org; Sat, 10 Aug 2013 13:08:24 -0400 Original-Received: from c-98-217-64-74.hsd1.ma.comcast.net ([98.217.64.74] helo=tines.lan) by world.peace.net with esmtpsa (TLS1.0:DHE_RSA_AES_128_CBC_SHA1:16) (Exim 4.72) (envelope-from ) id 1V8Ce0-0007I3-Ix; Sat, 10 Aug 2013 13:08:01 -0400 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.15 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x X-Received-From: 140.186.70.43 X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Original-Sender: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.bugs:7251 Archived-At: --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Hello all, I've cooked up a patch to help improve R6RS exception handling in Guile. As noted by G=C3=B6ran Weinholt in , 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 --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-Convert-guile-exceptions-to-R6RS-conditions-in-R6RS-.patch Content-Description: [PATCH] Convert guile exceptions to R6RS conditions in R6RS exception handlers >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 --=-=-=--