[Guile-commits] 01/07: Move adapter between "throw" and "raise" exceptions into core

[Andy Wingo]

wingo pushed a commit to branch wip-exceptions
in repository guile.

commit 9835ed1809f774233bd9962273f1d6fc07314671
Author: Andy Wingo <address@hidden>
Date:   Tue Nov 5 09:36:36 2019 +0100

    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).
---
 module/ice-9/exceptions.scm | 221 +++++++++++++++++++++++++++++++++++++++++-
 module/rnrs/exceptions.scm  | 230 +-------------------------------------------
 2 files changed, 223 insertions(+), 228 deletions(-)

diff --git a/module/ice-9/exceptions.scm b/module/ice-9/exceptions.scm
index 7685c38..a97e16d 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 fda87ff..68797b2 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)))))