diff options
author | Andy Wingo <wingo@pobox.com> | 2019-11-03 21:37:02 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-11-03 21:37:02 +0100 |
commit | 54ab2175f96ed0814d205e304f998be4b07ba78f (patch) | |
tree | e0330745dfbf80ec95b05d348d3e69a44830e2fd | |
parent | 90d52a9e1dd6419e0fef13e7b09e284e9d895920 (diff) | |
download | guile-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.am | 1 | ||||
-rw-r--r-- | module/ice-9/exceptions.scm | 226 | ||||
-rw-r--r-- | module/rnrs/conditions.scm | 172 |
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?)))) |