guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 03/04: Add (ice-9 exceptions) module


From: Andy Wingo
Subject: [Guile-commits] 03/04: Add (ice-9 exceptions) module
Date: Mon, 4 Nov 2019 09:21:20 -0500 (EST)

wingo pushed a commit to branch master
in repository guile.

commit 54ab2175f96ed0814d205e304f998be4b07ba78f
Author: Andy Wingo <address@hidden>
Date:   Sun Nov 3 21:37:02 2019 +0100

    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          |   1 +
 module/ice-9/exceptions.scm | 226 ++++++++++++++++++++++++++++++++++++++++++++
 module/rnrs/conditions.scm  | 172 +++++++++++----------------------
 3 files changed, 283 insertions(+), 116 deletions(-)

diff --git a/module/Makefile.am b/module/Makefile.am
index 79f42d3..dff2f95 100644
--- a/module/Makefile.am
+++ b/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                             \
diff --git a/module/ice-9/exceptions.scm b/module/ice-9/exceptions.scm
new file mode 100644
index 0000000..0574df1
--- /dev/null
+++ b/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?)
diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm
index c59d96f..cb8f1ab 100644
--- a/module/rnrs/conditions.scm
+++ b/module/rnrs/conditions.scm
@@ -82,119 +82,59 @@
          &undefined
          make-undefined-violation
          undefined-violation?)
-  (import (only (guile)
-                and=>
-                make-record-type
-                record-constructor
-                record-predicate
-                record-accessor)
-         (rnrs base (6))
-         (rnrs lists (6)))
-
-  (define &condition (make-record-type '&condition '() #:extensible? #t))
-  (define simple-condition? (record-predicate &condition))
-
-  (define &compound-condition (make-record-type '&compound-condition
-                                                '((immutable components))))
-  (define compound-condition? (record-predicate &compound-condition))
-  (define make-compound-condition (record-constructor &compound-condition))
-
-  (define simple-conditions
-    (let ((compound-ref (record-accessor &compound-condition 'components)))
-      (lambda (condition)
-        (cond ((compound-condition? condition)
-               (compound-ref condition))
-              ((simple-condition? condition)
-               (list condition))
-              (else
-               (assertion-violation 'simple-conditions
-                                    "not a condition"
-                                    condition))))))
-
-  (define (condition? obj) 
-    (or (compound-condition? obj) (simple-condition? obj)))
-
-  (define condition
-    (lambda conditions
-      (define (flatten cond)
-       (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)
-    (let ((rtd-predicate (record-predicate rtd)))
-      (lambda (obj)
-       (cond ((compound-condition? obj) 
-              (exists rtd-predicate (simple-conditions obj)))
-             ((simple-condition? obj) (rtd-predicate obj))
-             (else #f)))))
-
-  (define (condition-accessor rtd proc)
-    (let ((rtd-predicate (record-predicate rtd)))
-      (lambda (obj)
-       (cond ((rtd-predicate obj) (proc obj))
-             ((compound-condition? obj) 
-              (and=> (find rtd-predicate (simple-conditions obj)) proc))
-             (else #f)))))
-
-  (define-syntax define-condition-type
-    (syntax-rules ()
-      ((_ 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-serious-condition serious-condition?)
-  (define-condition-type &violation &serious
-    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-violation lexical-violation?)
-
-  (define-condition-type &syntax &violation
-    make-syntax-violation syntax-violation?
-    (form syntax-violation-form)
-    (subform syntax-violation-subform))
-
-  (define-condition-type &undefined &violation
-    make-undefined-violation undefined-violation?))
+  (import (rename (ice-9 exceptions)
+                  (&exception &condition)
+                  (make-exception condition)
+                  (simple-exceptions simple-conditions)
+                  (exception? condition?)
+                  (exception-predicate condition-predicate)
+                  (exception-accessor condition-accessor)
+                  (define-exception-type define-condition-type)
+
+                  (make-exception-with-message make-message-condition)
+                  (exception-with-message? message-condition?)
+                  (exception-message condition-message)
+
+                  (&error &serious)
+                  (make-error make-serious-condition)
+                  (error? serious-condition?)
+
+                  (&external-error &error)
+                  (make-external-error make-error)
+                  (external-error? error?)
+
+                  (&programming-error &violation)
+                  (make-programming-error make-violation)
+                  (programming-error? violation?)
+
+                  (&assertion-failure &assertion-violation)
+                  (make-assertion-failure make-assertion-violation)
+                  (assertion-failure? assertion-violation?)
+
+                  (make-exception-with-irritants make-irritants-condition)
+                  (exception-with-irritants? irritants-condition?)
+                  (exception-irritants condition-irritants)
+
+                  (make-exception-with-origin make-who-condition)
+                  (exception-with-origin? who-condition?)
+                  (exception-origin condition-who)
+
+                  (make-non-continuable-error make-non-continuable-violation)
+                  (non-continuable-error? non-continuable-violation?)
+
+                  (make-implementation-restriction-error
+                   make-implementation-restriction-violation)
+                  (implementation-restriction-error?
+                   implementation-restriction-violation?)
+
+                  (make-lexical-error make-lexical-violation)
+                  (lexical-error? lexical-violation?)
+
+                  (make-syntax-error make-syntax-violation)
+                  (syntax-error? syntax-violation?)
+                  (syntax-error-form syntax-violation-form)
+                  (syntax-error-subform syntax-violation-subform)
+
+                  (&undefined-variable &undefined)
+                  (make-undefined-variable-error make-undefined-violation)
+                  (undefined-variable-error? undefined-violation?))))



reply via email to

[Prev in Thread] Current Thread [Next in Thread]