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 /module/rnrs | |
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).
Diffstat (limited to 'module/rnrs')
-rw-r--r-- | module/rnrs/conditions.scm | 172 |
1 files changed, 56 insertions, 116 deletions
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?)))) |