mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-14 15:40:19 +02:00
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): 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.
This commit is contained in:
Mark H Weaver
parent
750ac8c592
commit
02500d4477
2 changed files with 205 additions and 17 deletions
|
|
@ -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))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue