summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2019-11-05 09:36:36 +0100
committerAndy Wingo <wingo@pobox.com>2019-11-05 09:36:36 +0100
commit9835ed1809f774233bd9962273f1d6fc07314671 (patch)
tree7128d3a90a560a5cea379906c6b9ebd0e6207f44
parent86bc3da9e01791f73e406cfecb99bf696c8865b1 (diff)
downloadguile-9835ed1809f774233bd9962273f1d6fc07314671.tar.gz
Move adapter between "throw" and "raise" exceptions into core
* module/ice-9/exceptions.scm (&guile): (default-guile-exception-converter): (guile-common-exceptions): (convert-guile-exception): (&raise-object-wrapper): (make-raise-object-wrapper): (raise-object-wrapper?): (raise-object-wrapper-obj): (raise-object-wrapper-continuation): (raise-exception): (raise-continuable): (with-exception-handler): (exception-printer): (format-exception): (format-simple-exception): (%exception): (guile-syntax-error-converter): (guile-lexical-error-converter): (guile-assertion-failure-converter): (guile-undefined-variable-error-converter): (guile-implementation-restriction-converter): (guile-external-error-converter): (guile-system-error-converter): (guile-exception-converters): (set-guile-exception-converter!): Move here, from (rnrs exceptions). * module/rnrs/exceptions.scm: Re-export bindings from (ice-9 exceptions).
-rw-r--r--module/ice-9/exceptions.scm221
-rw-r--r--module/rnrs/exceptions.scm230
2 files changed, 223 insertions, 228 deletions
diff --git a/module/ice-9/exceptions.scm b/module/ice-9/exceptions.scm
index 7685c3812..a97e16d83 100644
--- a/module/ice-9/exceptions.scm
+++ b/module/ice-9/exceptions.scm
@@ -88,7 +88,11 @@
&undefined-variable
make-undefined-variable-error
- undefined-variable-error?))
+ undefined-variable-error?
+
+ with-exception-handler
+ raise-exception
+ raise-continuable))
(define &exception (make-record-type '&exception '() #:extensible? #t))
(define simple-exception? (record-predicate &exception))
@@ -225,3 +229,218 @@ composed of such an instance."
(define-exception-type &undefined-variable &programming-error
make-undefined-variable-error undefined-variable-error?)
+
+;; When a native guile exception is caught by with-exception-handler, we
+;; convert it to a compound exception that includes not only the
+;; standard exception objects expected by users of R6RS, SRFI-35, and
+;; R7RS, but also a special &guile condition that preserves the original
+;; KEY and ARGS passed to the native Guile catch handler.
+
+(define-exception-type &guile &exception
+ make-guile-exception guile-exception?
+ (key guile-exception-key)
+ (args guile-exception-args))
+
+(define (default-guile-exception-converter key args)
+ (make-exception (make-error)
+ (guile-common-exceptions key args)))
+
+(define (guile-common-exceptions key args)
+ (apply (case-lambda
+ ((subr msg margs . _)
+ (make-exception
+ (make-exception-with-origin subr)
+ (make-exception-with-message msg)
+ (make-exception-with-irritants margs)))
+ (_ (make-exception-with-irritants args)))
+ args))
+
+(define (convert-guile-exception key args)
+ (let ((converter (assv-ref guile-exception-converters key)))
+ (make-exception (or (and converter (converter key args))
+ (default-guile-exception-converter key args))
+ ;; Preserve the original KEY and ARGS in the R6RS
+ ;; exception object.
+ (make-guile-exception key args))))
+
+;; If an exception handler chooses not to handle a given exception, it
+;; will re-raise the exception to pass it on to the next handler. If
+;; the exception 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
+;; with-exception-handler.
+
+(define &raise-object-wrapper
+ (make-record-type '&raise-object-wrapper
+ '((immutable obj) (immutable continuation))))
+(define make-raise-object-wrapper
+ (record-constructor &raise-object-wrapper))
+(define raise-object-wrapper?
+ (record-predicate &raise-object-wrapper))
+(define raise-object-wrapper-obj
+ (record-accessor &raise-object-wrapper 'obj))
+(define raise-object-wrapper-continuation
+ (record-accessor &raise-object-wrapper 'continuation))
+
+(define (raise-exception obj)
+ (if (guile-exception? obj)
+ (apply throw (guile-exception-key obj) (guile-exception-args obj))
+ (throw '%exception (make-raise-object-wrapper obj #f))))
+
+(define (raise-continuable obj)
+ (call/cc
+ (lambda (k)
+ (throw '%exception (make-raise-object-wrapper obj k)))))
+
+(define (with-exception-handler handler thunk)
+ (with-throw-handler #t
+ thunk
+ (lambda (key . args)
+ (cond ((not (eq? key '%exception))
+ (let ((obj (convert-guile-exception key args)))
+ (handler obj)
+ (raise-exception (make-non-continuable-error))))
+ ((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-exception (make-non-continuable-error)))))))))
+
+;;; Exception printing
+
+(define (exception-printer port key args punt)
+ (cond ((and (= 1 (length args))
+ (raise-object-wrapper? (car args)))
+ (let ((obj (raise-object-wrapper-obj (car args))))
+ (cond ((exception? obj)
+ (display "ERROR:\n" port)
+ (format-exception port obj))
+ (else
+ (format port "ERROR: `~s'" obj)))))
+ (else
+ (punt))))
+
+(define (format-exception port exception)
+ (let ((components (simple-exceptions exception)))
+ (if (null? components)
+ (format port "Empty exception object")
+ (let loop ((i 1) (components components))
+ (cond ((pair? components)
+ (format port " ~a. " i)
+ (format-simple-exception port (car components))
+ (when (pair? (cdr components))
+ (newline port))
+ (loop (+ i 1) (cdr components))))))))
+
+(define (format-simple-exception port exception)
+ (let* ((type (struct-vtable exception))
+ (name (record-type-name type))
+ (fields (record-type-fields type)))
+ (cond
+ ((null? fields)
+ (format port "~a" name))
+ ((null? (cdr fields))
+ (format port "~a: ~s" name (struct-ref exception 0)))
+ (else
+ (format port "~a:\n" name)
+ (let lp ((fields fields) (i 0))
+ (let ((field (car fields))
+ (fields (cdr fields)))
+ (format port " ~a: ~s" field (struct-ref exception i))
+ (unless (null? fields)
+ (newline port)
+ (lp fields (+ i 1)))))))))
+
+(set-exception-printer! '%exception exception-printer)
+
+;; Guile exception converters
+;;
+;; Each converter is a procedure (converter KEY ARGS) that returns
+;; either an exception object or #f. If #f is returned,
+;; 'default-guile-exception-converter' will be used.
+
+(define (guile-syntax-error-converter key args)
+ (apply (case-lambda
+ ((who what where form subform . extra)
+ (make-exception (make-syntax-error form subform)
+ (make-exception-with-origin who)
+ (make-exception-with-message what)))
+ (_ #f))
+ args))
+
+(define (guile-lexical-error-converter key args)
+ (make-exception (make-lexical-error)
+ (guile-common-exceptions key args)))
+
+(define (guile-assertion-failure-converter key args)
+ (make-exception (make-assertion-failure)
+ (guile-common-exceptions key args)))
+
+(define (guile-undefined-variable-error-converter key args)
+ (make-exception (make-undefined-variable-error)
+ (guile-common-exceptions key args)))
+
+(define (guile-implementation-restriction-converter key args)
+ (make-exception (make-implementation-restriction-error)
+ (guile-common-exceptions key args)))
+
+(define (guile-external-error-converter key args)
+ (make-exception (make-external-error)
+ (guile-common-exceptions 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.
+ (make-exception (make-external-error)
+ (guile-common-exceptions key args)))
+ (_ (guile-external-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 exceptions. Remove the earlier exception conversion
+;; mechanism: search for 'with-throw-handler' in the 'rnrs'
+;; tree, e.g. 'with-i/o-filename-exceptions' 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-exception-converters
+ `((read-error . ,guile-lexical-error-converter)
+ (syntax-error . ,guile-syntax-error-converter)
+ (unbound-variable . ,guile-undefined-variable-error-converter)
+ (wrong-number-of-args . ,guile-assertion-failure-converter)
+ (wrong-type-arg . ,guile-assertion-failure-converter)
+ (keyword-argument-error . ,guile-assertion-failure-converter)
+ (out-of-range . ,guile-assertion-failure-converter)
+ (regular-expression-syntax . ,guile-assertion-failure-converter)
+ (program-error . ,guile-assertion-failure-converter)
+ (goops-error . ,guile-assertion-failure-converter)
+ (null-pointer-error . ,guile-assertion-failure-converter)
+ (system-error . ,guile-system-error-converter)
+ (host-not-found . ,guile-external-error-converter)
+ (getaddrinfo-error . ,guile-external-error-converter)
+ (no-data . ,guile-external-error-converter)
+ (no-recovery . ,guile-external-error-converter)
+ (try-again . ,guile-external-error-converter)
+ (stack-overflow . ,guile-implementation-restriction-converter)
+ (numerical-overflow . ,guile-implementation-restriction-converter)
+ (memory-allocation-error . ,guile-implementation-restriction-converter)))
+
+(define (set-guile-exception-converter! key proc)
+ (set! guile-exception-converters
+ (acons key proc guile-exception-converters)))
diff --git a/module/rnrs/exceptions.scm b/module/rnrs/exceptions.scm
index fda87ff94..68797b27f 100644
--- a/module/rnrs/exceptions.scm
+++ b/module/rnrs/exceptions.scm
@@ -22,103 +22,8 @@
(import (rnrs base (6))
(rnrs control (6))
(rnrs conditions (6))
- (only (guile)
- make-record-type
- record-type-name
- record-type-fields
- record-constructor
- record-predicate
- record-accessor
- struct-ref
- struct-vtable
- format
- newline
- display
- acons
- assv-ref
- throw
- set-exception-printer!
- with-throw-handler))
-
- ;; 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-object-wrapper
- (make-record-type '&raise-object-wrapper
- '((immutable obj) (immutable continuation))))
- (define make-raise-object-wrapper
- (record-constructor &raise-object-wrapper))
- (define raise-object-wrapper?
- (record-predicate &raise-object-wrapper))
- (define raise-object-wrapper-obj
- (record-accessor &raise-object-wrapper 'obj))
- (define raise-object-wrapper-continuation
- (record-accessor &raise-object-wrapper 'continuation))
-
- (define (raise obj)
- (if (guile-condition? obj)
- (apply throw (guile-condition-key obj) (guile-condition-args obj))
- (throw 'r6rs:exception (make-raise-object-wrapper obj #f))))
-
- (define (raise-continuable obj)
- (call/cc
- (lambda (k)
- (throw 'r6rs:exception (make-raise-object-wrapper obj k)))))
-
- (define (with-exception-handler handler thunk)
- (with-throw-handler #t
- thunk
- (lambda (key . args)
- (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)))))))))
+ (rename (ice-9 exceptions)
+ (raise-exception raise)))
(define-syntax guard0
(syntax-rules ()
@@ -134,133 +39,4 @@
((_ (variable cond-clause ... . ((else else-clause ...))) . body)
(guard0 (variable cond-clause ... (else else-clause ...)) . body))
((_ (variable cond-clause ...) . body)
- (guard0 (variable cond-clause ... (else (raise variable))) . body))))
-
- ;;; Exception printing
-
- (define (exception-printer port key args punt)
- (cond ((and (= 1 (length args))
- (raise-object-wrapper? (car args)))
- (let ((obj (raise-object-wrapper-obj (car args))))
- (cond ((condition? obj)
- (display "ERROR: R6RS exception:\n" port)
- (format-condition port obj))
- (else
- (format port "ERROR: R6RS exception: `~s'" obj)))))
- (else
- (punt))))
-
- (define (format-condition port condition)
- (let ((components (simple-conditions condition)))
- (if (null? components)
- (format port "Empty condition object")
- (let loop ((i 1) (components components))
- (cond ((pair? components)
- (format port " ~a. " i)
- (format-simple-condition port (car components))
- (when (pair? (cdr components))
- (newline port))
- (loop (+ i 1) (cdr components))))))))
-
- (define (format-simple-condition port condition)
- (let* ((type (struct-vtable condition))
- (name (record-type-name type))
- (fields (record-type-fields type)))
- (cond
- ((null? fields)
- (format port "~a" name))
- ((null? (cdr fields))
- (format port "~a: ~s" name (struct-ref condition 0)))
- (else
- (format port "~a:\n" name)
- (let lp ((fields fields) (i 0))
- (let ((field (car fields))
- (fields (cdr fields)))
- (format port " ~a: ~s" field (struct-ref condition i))
- (unless (null? fields)
- (newline port)
- (lp fields (+ i 1)))))))))
-
- (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))))
+ (guard0 (variable cond-clause ... (else (raise variable))) . body)))))