1;;; r6rs-conditions.test --- Test suite for R6RS (rnrs conditions) 2 3;; Copyright (C) 2010 Free Software Foundation, Inc. 4;; 5;; This library is free software; you can redistribute it and/or 6;; modify it under the terms of the GNU Lesser General Public 7;; License as published by the Free Software Foundation; either 8;; version 3 of the License, or (at your option) any later version. 9;; 10;; This library is distributed in the hope that it will be useful, 11;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13;; Lesser General Public License for more details. 14;; 15;; You should have received a copy of the GNU Lesser General Public 16;; License along with this library; if not, write to the Free Software 17;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 19 20(define-module (test-suite test-rnrs-conditions) 21 :use-module ((rnrs base) :version (6)) 22 :use-module ((rnrs conditions) :version (6)) 23 :use-module (test-suite lib)) 24 25(define-condition-type &a &condition make-a-condition a-condition? (foo a-foo)) 26(define-condition-type &b &condition make-b-condition b-condition? (bar b-bar)) 27(define-condition-type &c &condition make-c-condition c-condition? 28 (baz c-baz) 29 (qux c-qux) 30 (frobotz c-frobotz)) 31 32(with-test-prefix "condition?" 33 (pass-if "condition? is #t for simple conditions" 34 (condition? (make-error))) 35 36 (pass-if "condition? is #t for compound conditions" 37 (condition? (condition (make-error) (make-assertion-violation)))) 38 39 (pass-if "condition? is #f for non-conditions" 40 (not (condition? 'foo)))) 41 42(with-test-prefix "simple-conditions" 43 (pass-if "simple-conditions returns condition components" 44 (let* ((error (make-error)) 45 (assertion (make-assertion-violation)) 46 (c (condition error assertion)) 47 (scs (simple-conditions c))) 48 (equal? scs (list error assertion)))) 49 50 (pass-if "simple-conditions flattens compound conditions" 51 (let* ((implementation-restriction 52 (make-implementation-restriction-violation)) 53 (error1 (make-error)) 54 (c1 (condition implementation-restriction error1)) 55 (error2 (make-error)) 56 (assertion (make-assertion-violation)) 57 (c2 (condition error2 assertion c1)) 58 (scs (simple-conditions c2))) 59 (equal? scs (list error2 assertion implementation-restriction error1))))) 60 61(with-test-prefix "condition-predicate" 62 (pass-if "returned procedure identifies matching simple conditions" 63 (let ((mp (condition-predicate &message)) 64 (mc (make-message-condition "test"))) 65 (mp mc))) 66 67 (pass-if "returned procedure identifies matching compound conditions" 68 (let* ((sp (condition-predicate &serious)) 69 (vp (condition-predicate &violation)) 70 (sc (make-serious-condition)) 71 (vc (make-violation)) 72 (c (condition sc vc))) 73 (and (sp c) (vp c)))) 74 75 (pass-if "returned procedure is #f for non-matching simple" 76 (let ((sp (condition-predicate &serious))) 77 (not (sp 'foo)))) 78 79 (pass-if "returned procedure is #f for compound without match" 80 (let* ((ip (condition-predicate &irritants)) 81 (sc (make-serious-condition)) 82 (vc (make-violation)) 83 (c (condition sc vc))) 84 (not (ip c))))) 85 86(with-test-prefix "condition-accessor" 87 (pass-if "accessor applies proc to field from simple condition" 88 (let* ((proc (lambda (c) (condition-message c))) 89 (ma (condition-accessor &message proc)) 90 (mc (make-message-condition "foo"))) 91 (equal? (ma mc) "foo"))) 92 93 (pass-if "accessor applies proc to field from compound condition" 94 (let* ((proc (lambda (c) (condition-message c))) 95 (ma (condition-accessor &message proc)) 96 (mc (make-message-condition "foo")) 97 (vc (make-violation)) 98 (c (condition vc mc))) 99 (equal? (ma c) "foo")))) 100 101(with-test-prefix "define-condition-type" 102 (pass-if "define-condition-type produces proper accessors" 103 (let ((c (condition (make-a-condition 'foo) (make-b-condition 'bar)))) 104 (and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar)))) 105 (pass-if "define-condition-type works for multiple fields" 106 (let ((c (condition (make-a-condition 'foo) 107 (make-c-condition 1 2 3)))) 108 (and (eq? (a-foo c) 'foo) 109 (= (c-baz c) 1) 110 (= (c-qux c) 2) 111 (= (c-frobotz c) 3))))) 112