summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/rnrs/6/conditions.scm112
-rw-r--r--module/rnrs/records/6/procedural.scm3
-rw-r--r--test-suite/Makefile.am1
-rw-r--r--test-suite/tests/r6rs-conditions.test91
4 files changed, 148 insertions, 59 deletions
diff --git a/module/rnrs/6/conditions.scm b/module/rnrs/6/conditions.scm
index b6630c88f..8ff2f347b 100644
--- a/module/rnrs/6/conditions.scm
+++ b/module/rnrs/6/conditions.scm
@@ -66,7 +66,7 @@
non-continuable-violation?
&implementation-restriction
- make-implementation-restriction
+ make-implementation-restriction-violation
implementation-restriction-violation?
&lexical
@@ -82,10 +82,11 @@
&undefined
make-undefined-violation
undefined-violation?)
- (import (rnrs base (6))
- (rnrs records procedural (6))
- (rnrs syntax-case (6)))
-
+ (import (only (guile) and=>)
+ (rnrs base (6))
+ (rnrs lists (6))
+ (rnrs records procedural (6)))
+
(define &compound-condition (make-record-type-descriptor
'&compound-condition #f #f #f #f
'#((immutable components))))
@@ -94,64 +95,64 @@
(define make-compound-condition
(record-constructor (make-record-constructor-descriptor
&compound-condition #f #f)))
- (define compound-condition-components (record-accessor &compound-condition 0))
+ (define simple-conditions (record-accessor &compound-condition 0))
- (define-syntax define-condition-type
- (lambda (stx)
- (syntax-case stx ()
- ((_ condition-type supertype constructor predicate
- (field accessor) ...)
- (let*
- ((fields (let* ((field-spec-syntax #'((field accessor) ...))
- (field-specs (syntax->datum field-spec-syntax)))
- (list->vector (map (lambda (field-spec)
- (cons 'immutable field-spec))
- field-specs))))
- (fields-syntax (datum->syntax stx fields)))
- #`(begin
- (define condition-type
- (make-record-type-descriptor
- #,(datum->syntax
- stx (list 'quote (syntax->datum #'condition-type)))
- supertype #f #f #f #,fields-syntax))
- (define constructor
- (record-constructor
- (make-record-constructor-descriptor condition-type #f #f)))
- (define predicate (record-predicate condition-type))
- #,@(let f ((accessors '())
- (counter 0))
- (if (>= counter (vector-length fields))
- accessors
- (f (cons #`(define #,(datum->syntax
- stx (caddr (vector-ref fields
- counter)))
- (record-accessor condition-type #,counter))
- accessors)
- (+ counter 1))))))))))
-
- (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? obj)
+ (or (compound-condition? obj) (condition-internal? obj)))
(define condition
(lambda conditions
(define (flatten cond)
- (if (compound-condition? cond)
- (fold append '() (map flatten (compound-condition-components cond)))
- cond))
+ (if (compound-condition? cond) (simple-conditions cond) (list cond)))
(or (for-all condition? conditions)
(raise (make-assertion-violation)))
- (make-compound-condition (flatten conditions))))
+ (if (or (null? conditions) (> (length conditions) 1))
+ (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
+ ((transform-fields
+ (syntax-rules ()
+ ((_ (f a) . rest)
+ (cons '(immutable f a) (transform-fields rest)))
+ ((_ ((f a))) '((immutable f a)))
+ ((_ ()) '())
+ ((_) '())))
+
+ (generate-accessors
+ (syntax-rules ()
+ ((_ counter (f a) . rest)
+ (begin (define a (record-accessor condition-type counter))
+ (generate-accessors (+ counter 1) rest)))
+ ((_ counter ((f a)))
+ (define a (record-accessor condition-type counter)))
+ ((_ counter ()) (begin))
+ ((_ counter) (begin)))))
+ (begin
+ (define condition-type
+ (make-record-type-descriptor
+ 'condition-type supertype #f #f #f
+ (list->vector (transform-fields (field accessor) ...))))
+ (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 (simple-conditions condition) (record-accessor &compound-condition 0))
- (define (condition? obj)
- (or (compound-condition? obj) (condition-internal? obj)))
(define (condition-predicate rtd)
(let ((rtd-predicate (record-predicate rtd)))
(lambda (obj)
(cond ((compound-condition? obj)
- (find rtd-predicate (compound-condition-components obj)))
+ (exists rtd-predicate (simple-conditions obj)))
((condition-internal? obj) (rtd-predicate obj))
(else #f)))))
@@ -160,7 +161,7 @@
(lambda (obj)
(cond ((rtd-predicate obj) (proc obj))
((compound-condition? obj)
- (and=> (find rtd-predicate simple-conditions obj) proc))
+ (and=> (find rtd-predicate (simple-conditions obj)) proc))
(else #f)))))
(define-condition-type &message &condition
@@ -172,19 +173,18 @@
(define &serious (@@ (rnrs records procedural) &serious))
(define make-serious-condition
(@@ (rnrs records procedural) make-serious-condition))
- (define serious-condition? (@@ (rnrs records procedural) serious-condition?))
+ (define serious-condition? (condition-predicate &serious))
(define-condition-type &error &serious make-error error?)
(define &violation (@@ (rnrs records procedural) &violation))
(define make-violation (@@ (rnrs records procedural) make-violation))
- (define violation? (@@ (rnrs records procedural) 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?
- (@@ (rnrs records procedural) assertion-violation?))
+ (define assertion-violation? (condition-predicate &assertion))
(define-condition-type &irritants &condition
make-irritants-condition irritants-condition?
diff --git a/module/rnrs/records/6/procedural.scm b/module/rnrs/records/6/procedural.scm
index da30fa407..bd1d0d151 100644
--- a/module/rnrs/records/6/procedural.scm
+++ b/module/rnrs/records/6/procedural.scm
@@ -236,7 +236,6 @@
(define make-serious-condition
(record-constructor &serious-constructor-descriptor))
- (define serious-condition? (record-predicate &serious))
(define &violation (make-record-type-descriptor
'&violation &serious #f #f #f '#()))
@@ -244,7 +243,6 @@
(make-record-constructor-descriptor
&violation &serious-constructor-descriptor #f))
(define make-violation (record-constructor &violation-constructor-descriptor))
- (define violation? (record-predicate &violation))
(define &assertion (make-record-type-descriptor
'&assertion &violation #f #f #f '#()))
@@ -252,7 +250,6 @@
(record-constructor
(make-record-constructor-descriptor
&assertion &violation-constructor-descriptor #f)))
- (define assertion-violation? (record-predicate &assertion))
;; Exception wrapper type, along with a wrapping `throw' implementation.
;; These are used in the current library, and so they are defined here and not
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index b08233f36..01727ce8d 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -77,6 +77,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/r4rs.test \
tests/r5rs_pitfall.test \
tests/r6rs-arithmetic-bitwise.test \
+ tests/r6rs-conditions.test \
tests/r6rs-control.test \
tests/r6rs-exceptions.test \
tests/r6rs-files.test \
diff --git a/test-suite/tests/r6rs-conditions.test b/test-suite/tests/r6rs-conditions.test
new file mode 100644
index 000000000..5883131ca
--- /dev/null
+++ b/test-suite/tests/r6rs-conditions.test
@@ -0,0 +1,91 @@
+;;; r6rs-conditions.test --- Test suite for R6RS (rnrs conditions)
+
+;; Copyright (C) 2010 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 library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(define-module (test-suite test-rnrs-conditions)
+ :use-module ((rnrs conditions) :version (6))
+ :use-module (test-suite lib))
+
+(with-test-prefix "condition?"
+ (pass-if "condition? is #t for simple conditions"
+ (condition? (make-error)))
+
+ (pass-if "condition? is #t for compound conditions"
+ (condition? (condition (make-error) (make-assertion-violation))))
+
+ (pass-if "condition? is #f for non-conditions"
+ (not (condition? 'foo))))
+
+(with-test-prefix "simple-conditions"
+ (pass-if "simple-conditions returns condition components"
+ (let* ((error (make-error))
+ (assertion (make-assertion-violation))
+ (c (condition error assertion))
+ (scs (simple-conditions c)))
+ (equal? scs (list error assertion))))
+
+ (pass-if "simple-conditions flattens compound conditions"
+ (let* ((implementation-restriction
+ (make-implementation-restriction-violation))
+ (error1 (make-error))
+ (c1 (condition implementation-restriction error1))
+ (error2 (make-error))
+ (assertion (make-assertion-violation))
+ (c2 (condition error2 assertion c1))
+ (scs (simple-conditions c2)))
+ (equal? scs (list error2 assertion implementation-restriction error1)))))
+
+(with-test-prefix "condition-predicate"
+ (pass-if "returned procedure identifies matching simple conditions"
+ (let ((mp (condition-predicate &message))
+ (mc (make-message-condition "test")))
+ (mp mc)))
+
+ (pass-if "returned procedure identifies matching compound conditions"
+ (let* ((sp (condition-predicate &serious))
+ (vp (condition-predicate &violation))
+ (sc (make-serious-condition))
+ (vc (make-violation))
+ (c (condition sc vc)))
+ (and (sp c) (vp c))))
+
+ (pass-if "returned procedure is #f for non-matching simple"
+ (let ((sp (condition-predicate &serious)))
+ (not (sp 'foo))))
+
+ (pass-if "returned procedure is #f for compound without match"
+ (let* ((ip (condition-predicate &irritants))
+ (sc (make-serious-condition))
+ (vc (make-violation))
+ (c (condition sc vc)))
+ (not (ip c)))))
+
+(with-test-prefix "condition-accessor"
+ (pass-if "accessor applies proc to field from simple condition"
+ (let* ((proc (lambda (c) (condition-message c)))
+ (ma (condition-accessor &message proc))
+ (mc (make-message-condition "foo")))
+ (equal? (ma mc) "foo")))
+
+ (pass-if "accessor applies proc to field from compound condition"
+ (let* ((proc (lambda (c) (condition-message c)))
+ (ma (condition-accessor &message proc))
+ (mc (make-message-condition "foo"))
+ (vc (make-violation))
+ (c (condition vc mc)))
+ (equal? (ma c) "foo"))))