summaryrefslogtreecommitdiff
path: root/test-suite/tests/r6rs-conditions.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/r6rs-conditions.test')
-rw-r--r--test-suite/tests/r6rs-conditions.test111
1 files changed, 111 insertions, 0 deletions
diff --git a/test-suite/tests/r6rs-conditions.test b/test-suite/tests/r6rs-conditions.test
new file mode 100644
index 000000000..7480b9c47
--- /dev/null
+++ b/test-suite/tests/r6rs-conditions.test
@@ -0,0 +1,111 @@
+;;; 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 base) :version (6))
+ :use-module ((rnrs conditions) :version (6))
+ :use-module (test-suite lib))
+
+(define-condition-type &a &condition make-a-condition a-condition? (foo a-foo))
+(define-condition-type &b &condition make-b-condition b-condition? (bar b-bar))
+(define-condition-type &c &condition make-c-condition c-condition?
+ (baz c-baz)
+ (qux c-qux)
+ (frobotz c-frobotz))
+
+(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"))))
+
+(with-test-prefix "define-condition-type"
+ (pass-if "define-condition-type produces proper accessors"
+ (let ((c (condition (make-a-condition 'foo) (make-b-condition 'bar))))
+ (and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar))))
+ (pass-if "define-condition-type works for multiple fields"
+ (let ((c (condition (make-a-condition 'foo)
+ (make-c-condition 1 2 3))))
+ (and (eq? (a-foo c) 'foo)
+ (= (c-baz c) 1)
+ (= (c-qux c) 2)
+ (= (c-frobotz c) 3)))))