summaryrefslogtreecommitdiff
path: root/module/rnrs/conditions.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/rnrs/conditions.scm')
-rw-r--r--module/rnrs/conditions.scm110
1 files changed, 46 insertions, 64 deletions
diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm
index fa2ed6782..c59d96f81 100644
--- a/module/rnrs/conditions.scm
+++ b/module/rnrs/conditions.scm
@@ -82,25 +82,29 @@
&undefined
make-undefined-violation
undefined-violation?)
- (import (only (guile) and=> @@)
+ (import (only (guile)
+ and=>
+ make-record-type
+ record-constructor
+ record-predicate
+ record-accessor)
(rnrs base (6))
- (rnrs lists (6))
- (rnrs records procedural (6)))
+ (rnrs lists (6)))
- (define &compound-condition (make-record-type-descriptor
- '&compound-condition #f #f #f #f
- '#((immutable components))))
+ (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 (make-record-constructor-descriptor
- &compound-condition #f #f)))
+ (define make-compound-condition (record-constructor &compound-condition))
+
(define simple-conditions
- (let ((compound-ref (record-accessor &compound-condition 0)))
+ (let ((compound-ref (record-accessor &compound-condition 'components)))
(lambda (condition)
(cond ((compound-condition? condition)
(compound-ref condition))
- ((condition-internal? condition)
+ ((simple-condition? condition)
(list condition))
(else
(assertion-violation 'simple-conditions
@@ -108,7 +112,7 @@
condition))))))
(define (condition? obj)
- (or (compound-condition? obj) (condition-internal? obj)))
+ (or (compound-condition? obj) (simple-condition? obj)))
(define condition
(lambda conditions
@@ -120,41 +124,12 @@
(make-compound-condition (apply append (map flatten conditions)))
(car conditions))))
- (define-syntax define-condition-type
- (syntax-rules ()
- ((_ condition-type supertype constructor predicate
- (field accessor) ...)
- (letrec-syntax
- ((generate-accessors
- (syntax-rules ()
- ((_ counter (f a) . rest)
- (begin (define a
- (condition-accessor
- condition-type
- (record-accessor condition-type counter)))
- (generate-accessors (+ counter 1) . rest)))
- ((_ counter) (begin)))))
- (define condition-type
- (make-record-type-descriptor
- 'condition-type supertype #f #f #f
- '#((immutable field) ...)))
- (define constructor
- (record-constructor
- (make-record-constructor-descriptor condition-type #f #f)))
- (define predicate (condition-predicate condition-type))
- (generate-accessors 0 (field accessor) ...)))))
-
- (define &condition (@@ (rnrs records procedural) &condition))
- (define &condition-constructor-descriptor
- (make-record-constructor-descriptor &condition #f #f))
- (define condition-internal? (record-predicate &condition))
-
(define (condition-predicate rtd)
(let ((rtd-predicate (record-predicate rtd)))
(lambda (obj)
(cond ((compound-condition? obj)
(exists rtd-predicate (simple-conditions obj)))
- ((condition-internal? obj) (rtd-predicate obj))
+ ((simple-condition? obj) (rtd-predicate obj))
(else #f)))))
(define (condition-accessor rtd proc)
@@ -165,27 +140,37 @@
(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 &serious (@@ (rnrs records procedural) &serious))
- (define make-serious-condition
- (@@ (rnrs records procedural) make-serious-condition))
- (define serious-condition? (condition-predicate &serious))
-
- (define-condition-type &error &serious make-error error?)
+ (define-condition-type &warning &condition
+ make-warning warning?)
- (define &violation (@@ (rnrs records procedural) &violation))
- (define make-violation (@@ (rnrs records procedural) make-violation))
- (define violation? (condition-predicate &violation))
-
- (define &assertion (@@ (rnrs records procedural) &assertion))
- (define make-assertion-violation
- (@@ (rnrs records procedural) make-assertion-violation))
- (define assertion-violation? (condition-predicate &assertion))
+ (define-condition-type &error &serious
+ make-error error?)
(define-condition-type &irritants &condition
make-irritants-condition irritants-condition?
@@ -199,8 +184,7 @@
make-non-continuable-violation
non-continuable-violation?)
- (define-condition-type &implementation-restriction
- &violation
+ (define-condition-type &implementation-restriction &violation
make-implementation-restriction-violation
implementation-restriction-violation?)
@@ -213,6 +197,4 @@
(subform syntax-violation-subform))
(define-condition-type &undefined &violation
- make-undefined-violation undefined-violation?)
-
-)
+ make-undefined-violation undefined-violation?))