Add (ice-9 exceptions) module

* module/ice-9/exceptions.scm: New file, derived from (rnrs
  conditions).  Perhaps unadvisedly, in this file I've renamed a number
  of the identifiers.  I have never found that the R6RS identifiers made
  sense to me.  For now this is an internal module that R6RS and SRFI-35
  will be based on.
* module/Makefile.am (SOURCES): Add the new file.
* module/rnrs/conditions.scm (rnrs): Export renamed identifiers
  from (ice-9 exceptions).

module/Makefile.am

@@ -57,6 +57,7 @@ SOURCES =					\
   ice-9/documentation.scm			\
   ice-9/eval-string.scm				\
   ice-9/eval.scm				\
+  ice-9/exceptions.scm				\
   ice-9/expect.scm				\
   ice-9/fdes-finalizers.scm			\
   ice-9/format.scm				\

module/ice-9/exceptions.scm

@@ -0,0 +1,226 @@
+;;; Exceptions
+;;; Copyright (C) 2019 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 License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; Definition of the standard exception types.
+;;;
+;;; Code:
+
+
+(define-module (ice-9 exceptions)
+  #:export (&exception
+            make-exception
+            make-exception-type
+            simple-exceptions
+            exception?
+            exception-predicate
+            exception-accessor
+            define-exception-type
+
+            &message
+            make-exception-with-message
+            exception-with-message?
+            exception-message
+
+            &warning
+            make-warning
+            warning?
+
+            &error
+            make-error
+            error?
+
+            &external-error
+	    make-external-error
+	    external-error?
+	
+            &programming-error
+	    make-programming-error
+	    programming-error?
+
+	    &assertion-failure
+	    make-assertion-failure
+	    assertion-failure?
+
+	    &irritants
+	    make-exception-with-irritants
+            exception-with-irritants?
+	    exception-irritants
+
+	    &origin
+	    make-exception-with-origin
+            exception-with-origin?
+	    exception-origin
+
+            &non-continuable
+            make-non-continuable-error
+            non-continuable-error?
+
+            &implementation-restriction
+            make-implementation-restriction-error
+            implementation-restriction-error?
+
+            &lexical
+            make-lexical-error
+            lexical-error?
+
+            &syntax
+            make-syntax-error
+            syntax-error?
+            syntax-error-form
+            syntax-error-subform
+
+            &undefined-variable
+            make-undefined-variable-error
+            undefined-variable-error?))
+
+(define &exception (make-record-type '&exception '() #:extensible? #t))
+(define simple-exception? (record-predicate &exception))
+
+(define &compound-exception (make-record-type '&compound-exception
+                                              '((immutable components))))
+(define compound-exception? (record-predicate &compound-exception))
+(define make-compound-exception (record-constructor &compound-exception))
+
+(define simple-exceptions
+  (let ((compound-ref (record-accessor &compound-exception 'components)))
+    (lambda (exception)
+      "Return a list of the simple exceptions that compose the exception
+object @var{exception}."
+      (cond ((compound-exception? exception)
+             (compound-ref exception))
+            ((simple-exception? exception)
+             (list exception))
+            (else
+             (error "not a exception" exception))))))
+
+(define make-exception
+  (lambda exceptions
+    (let ((simple
+           (let flatten ((exceptions exceptions))
+             (if (null? exceptions)
+                 '()
+                 (append (simple-exceptions (car exceptions))
+                         (flatten (cdr exceptions)))))))
+      (if (and (pair? simple) (null? (cdr simple)))
+          (car simple)
+          (make-compound-exception simple)))))
+
+(define (exception? obj) 
+  "Return true if @var{obj} is an exception."
+  (or (compound-exception? obj) (simple-exception? obj)))
+
+(define (exception-type? obj)
+  "Return true if OBJ is an exception type."
+  (and (record-type? obj)
+       (record-type-has-parent? obj &exception)))
+
+(define (make-exception-type id parent field-names)
+  "Return a new exception type named @var{id}, inheriting from
+@var{parent}, and with the fields whose names are listed in
+@var{field-names}.  @var{field-names} must be a list of symbols and must
+not contain names already used by @var{parent} or one of its
+supertypes."
+  (unless (exception-type? parent)
+    (error "parent is not a exception type" parent))
+  (unless (and-map symbol? field-names)
+    (error "field names should be a list of symbols" field-names))
+  (make-record-type id field-names #:parent parent #:extensible? #t))
+
+(define (exception-predicate rtd)
+  "Return a procedure that will return true if its argument is a simple
+exception that is an instance of @var{rtd}, or a compound exception
+composed of such an instance."
+  (let ((rtd-predicate (record-predicate rtd)))
+    (lambda (obj)
+      (cond ((compound-exception? obj) 
+	     (or-map rtd-predicate (simple-exceptions obj)))
+	    (else (rtd-predicate obj))))))
+
+(define (exception-accessor rtd proc)
+  (let ((rtd-predicate (record-predicate rtd)))
+    (lambda (obj)
+      (if (rtd-predicate obj)
+          (proc obj)
+          (let lp ((exceptions (if (compound-exception? obj) 
+                                   (simple-exceptions obj)
+                                   '())))
+            (when (null? exceptions)
+              (error "object is not an exception of the right type" obj rtd))
+            (if (rtd-predicate (car exceptions))
+                (proc (car exceptions))
+                (lp (cdr exceptions))))))))
+
+(define-syntax define-exception-type
+  (syntax-rules ()
+    ((_ exception-type supertype constructor predicate
+	(field accessor) ...)
+     (begin
+       (define exception-type
+         (make-record-type 'exception-type '((immutable field) ...)
+                           #:parent supertype #:extensible? #t))
+       (define constructor (record-constructor exception-type))
+       (define predicate (exception-predicate exception-type))
+       (define accessor
+         (exception-accessor exception-type
+                             (record-accessor exception-type 'field)))
+       ...))))
+
+(define-exception-type &error &exception
+  make-error error?)
+(define-exception-type &programming-error &error
+  make-programming-error programming-error?)
+(define-exception-type &assertion-failure &programming-error
+  make-assertion-failure assertion-failure?)
+
+(define-exception-type &message &exception 
+  make-exception-with-message exception-with-message? 
+  (message exception-message))
+
+(define-exception-type &warning &exception
+  make-warning warning?)
+
+(define-exception-type &external-error &error
+  make-external-error external-error?)
+
+(define-exception-type &irritants &exception
+  make-exception-with-irritants exception-with-irritants?
+  (irritants exception-irritants))
+
+(define-exception-type &origin &exception
+  make-exception-with-origin exception-with-origin?
+  (origin exception-origin))
+
+(define-exception-type &non-continuable &programming-error
+  make-non-continuable-error
+  non-continuable-error?)
+
+(define-exception-type &implementation-restriction &programming-error
+  make-implementation-restriction-error
+  implementation-restriction-error?)
+
+(define-exception-type &lexical &programming-error
+  make-lexical-error lexical-error?)
+
+(define-exception-type &syntax &programming-error
+  make-syntax-error syntax-error?
+  (form syntax-error-form)
+  (subform syntax-error-subform))
+
+(define-exception-type &undefined-variable &programming-error
+  make-undefined-variable-error undefined-variable-error?)

module/rnrs/conditions.scm

@@ -82,119 +82,59 @@
 	  &undefined
 	  make-undefined-violation
 	  undefined-violation?)
-  (import (only (guile)
+  (import (rename (ice-9 exceptions)
-                and=>
+                  (&exception &condition)
-                make-record-type
+                  (make-exception condition)
-                record-constructor
+                  (simple-exceptions simple-conditions)
-                record-predicate
+                  (exception? condition?)
-                record-accessor)
+                  (exception-predicate condition-predicate)
-	  (rnrs base (6))
+                  (exception-accessor condition-accessor)
-	  (rnrs lists (6)))
+                  (define-exception-type define-condition-type)
 
-  (define &condition (make-record-type '&condition '() #:extensible? #t))
+                  (make-exception-with-message make-message-condition)
-  (define simple-condition? (record-predicate &condition))
+                  (exception-with-message? message-condition?)
+                  (exception-message condition-message)
 
-  (define &compound-condition (make-record-type '&compound-condition
+                  (&error &serious)
-                                                '((immutable components))))
+                  (make-error make-serious-condition)
-  (define compound-condition? (record-predicate &compound-condition))
+                  (error? serious-condition?)
-  (define make-compound-condition (record-constructor &compound-condition))
 
-  (define simple-conditions
+                  (&external-error &error)
-    (let ((compound-ref (record-accessor &compound-condition 'components)))
+                  (make-external-error make-error)
-      (lambda (condition)
+                  (external-error? error?)
-        (cond ((compound-condition? condition)
-               (compound-ref condition))
-              ((simple-condition? condition)
-               (list condition))
-              (else
-               (assertion-violation 'simple-conditions
-                                    "not a condition"
-                                    condition))))))
 
-  (define (condition? obj) 
+                  (&programming-error &violation)
-    (or (compound-condition? obj) (simple-condition? obj)))
+                  (make-programming-error make-violation)
+                  (programming-error? violation?)
 
-  (define condition
+                  (&assertion-failure &assertion-violation)
-    (lambda conditions
+                  (make-assertion-failure make-assertion-violation)
-      (define (flatten cond)
+                  (assertion-failure? assertion-violation?)
-	(if (compound-condition? cond) (simple-conditions cond) (list cond)))
-      (or (for-all condition? conditions)
-	  (assertion-violation 'condition "non-condition argument" conditions))
-      (if (or (null? conditions) (> (length conditions) 1))
-	  (make-compound-condition (apply append (map flatten conditions)))
-	  (car conditions))))
 
-  (define (condition-predicate rtd)
+                  (make-exception-with-irritants make-irritants-condition)
-    (let ((rtd-predicate (record-predicate rtd)))
+                  (exception-with-irritants? irritants-condition?)
-      (lambda (obj)
+                  (exception-irritants condition-irritants)
-	(cond ((compound-condition? obj) 
-	       (exists rtd-predicate (simple-conditions obj)))
-	      ((simple-condition? obj) (rtd-predicate obj))
-	      (else #f)))))
 
-  (define (condition-accessor rtd proc)
+                  (make-exception-with-origin make-who-condition)
-    (let ((rtd-predicate (record-predicate rtd)))
+                  (exception-with-origin? who-condition?)
-      (lambda (obj)
+                  (exception-origin condition-who)
-	(cond ((rtd-predicate obj) (proc obj))
-	      ((compound-condition? obj) 
-	       (and=> (find rtd-predicate (simple-conditions obj)) proc))
-	      (else #f)))))
 
-  (define-syntax define-condition-type
+                  (make-non-continuable-error make-non-continuable-violation)
-    (syntax-rules ()
+                  (non-continuable-error? non-continuable-violation?)
-      ((_ condition-type supertype constructor predicate
-	  (field accessor) ...)
-       (begin
-         (define condition-type
-           (make-record-type 'condition-type '((immutable field) ...)
-                             #:parent supertype #:extensible? #t))
-         (define constructor (record-constructor condition-type))
-         (define predicate (condition-predicate condition-type))
-         (define accessor
-           (condition-accessor condition-type
-                               (record-accessor condition-type 'field)))
-         ...))))
 
-  (define-condition-type &serious &condition
+                  (make-implementation-restriction-error
-    make-serious-condition serious-condition?)
+                   make-implementation-restriction-violation)
-  (define-condition-type &violation &serious
+                  (implementation-restriction-error?
-    make-violation violation?)
-  (define-condition-type &assertion &violation
-    make-assertion-violation assertion-violation?)
-
-  (define-condition-type &message &condition 
-    make-message-condition message-condition? 
-    (message condition-message))
-
-  (define-condition-type &warning &condition
-    make-warning warning?)
-
-  (define-condition-type &error &serious
-    make-error error?)
-
-  (define-condition-type &irritants &condition 
-    make-irritants-condition irritants-condition?
-    (irritants condition-irritants))
-
-  (define-condition-type &who &condition
-    make-who-condition who-condition?
-    (who condition-who))
-
-  (define-condition-type &non-continuable &violation
-    make-non-continuable-violation
-    non-continuable-violation?)
-
-  (define-condition-type &implementation-restriction &violation
-    make-implementation-restriction-violation
                    implementation-restriction-violation?)
 
-  (define-condition-type &lexical &violation
+                  (make-lexical-error make-lexical-violation)
-    make-lexical-violation lexical-violation?)
+                  (lexical-error? lexical-violation?)
 
-  (define-condition-type &syntax &violation
+                  (make-syntax-error make-syntax-violation)
-    make-syntax-violation syntax-violation?
+                  (syntax-error? syntax-violation?)
-    (form syntax-violation-form)
+                  (syntax-error-form syntax-violation-form)
-    (subform syntax-violation-subform))
+                  (syntax-error-subform syntax-violation-subform)
 
-  (define-condition-type &undefined &violation
+                  (&undefined-variable &undefined)
-    make-undefined-violation undefined-violation?))
+                  (make-undefined-variable-error make-undefined-violation)
+                  (undefined-variable-error? undefined-violation?))))