summaryrefslogtreecommitdiff
path: root/module/rnrs
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 /module/rnrs
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).
Diffstat (limited to 'module/rnrs')
-rw-r--r--module/rnrs/conditions.scm172
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?))))