summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2019-11-03 21:37:02 +0100
committerAndy Wingo <wingo@pobox.com>2019-11-03 21:37:02 +0100
commit54ab2175f96ed0814d205e304f998be4b07ba78f (patch)
treee0330745dfbf80ec95b05d348d3e69a44830e2fd
parent90d52a9e1dd6419e0fef13e7b09e284e9d895920 (diff)
downloadguile-54ab2175f96ed0814d205e304f998be4b07ba78f.tar.gz
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).
-rw-r--r--module/Makefile.am1
-rw-r--r--module/ice-9/exceptions.scm226
-rw-r--r--module/rnrs/conditions.scm172
3 files changed, 283 insertions, 116 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index 79f42d353..dff2f9500 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 000000000..0574df1e1
--- /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 c59d96f81..cb8f1ab3a 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?))))