1;;; r6rs-base.test --- Test suite for R6RS (rnrs base) 2 3;; Copyright (C) 2010, 2011 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-r6rs-base) 21 :use-module ((rnrs base) :version (6)) 22 :use-module ((rnrs conditions) :version (6)) 23 :use-module ((rnrs exceptions) :version (6)) 24 :use-module (test-suite lib)) 25 26 27;; numbers are considered =? if their difference is less than a set 28;; tolerance 29(define (=? alpha beta) 30 (< (abs (- alpha beta)) 1e-10)) 31 32(with-test-prefix "log (2nd arg)" 33 (pass-if "log positive-base" (=? (log 8 2) 3)) 34 (pass-if "log negative-base" (=? (real-part (log 256 -4)) 35 0.6519359443)) 36 (pass-if "log base-one" (= (log 10 1) +inf.0)) 37 (pass-if "log base-zero" 38 (catch #t 39 (lambda () (log 10 0) #f) 40 (lambda args #t)))) 41 42(with-test-prefix "boolean=?" 43 (pass-if "boolean=? null" (boolean=?)) 44 (pass-if "boolean=? unary" (boolean=? #f)) 45 (pass-if "boolean=? many" 46 (and (boolean=? #t #t #t) 47 (boolean=? #f #f #f) 48 (not (boolean=? #t #f #t)))) 49 (pass-if "boolean=? mixed type" (not (boolean=? #t #t 'foo)))) 50 51(with-test-prefix "symbol=?" 52 (pass-if "symbol=? null" (symbol=?)) 53 (pass-if "symbol=? unary" (symbol=? 'a)) 54 (pass-if "symbol=? many" 55 (and (symbol=? 'a 'a 'a) 56 (symbol=? 'foo 'foo 'foo) 57 (not (symbol=? 'a 'foo 'a)))) 58 (pass-if "symbol=? mixed type" (not (symbol=? 'a 'a 123)))) 59 60(with-test-prefix "infinite?" 61 (pass-if "infinite? true on infinities" 62 (and (infinite? +inf.0) (infinite? -inf.0))) 63 (pass-if "infinite? false on non-infities" 64 (and (not (infinite? 123)) (not (infinite? +nan.0))))) 65 66(with-test-prefix "finite?" 67 (pass-if "finite? false on infinities" 68 (and (not (finite? +inf.0)) (not (finite? -inf.0)))) 69 (pass-if "finite? true on non-infinities" 70 (and (finite? 123) (finite? 123.0)))) 71 72(with-test-prefix "exact-integer-sqrt" 73 (pass-if "exact-integer-sqrt simple" 74 (let-values (((s e) (exact-integer-sqrt 5))) 75 (and (eqv? s 2) (eqv? e 1))))) 76 77(with-test-prefix "integer-valued?" 78 (pass-if "true on integers" 79 (and (integer-valued? 3) (integer-valued? 3.0) (integer-valued? 3.0+0.0i))) 80 (pass-if "false on rationals" (not (integer-valued? 3.1))) 81 (pass-if "false on reals" (not (integer-valued? +nan.0)))) 82 83(with-test-prefix "rational-valued?" 84 (pass-if "true on integers" (rational-valued? 3)) 85 (pass-if "true on rationals" 86 (and (rational-valued? 3.1) (rational-valued? 3.1+0.0i))) 87 (pass-if "false on reals" 88 (or (not (rational-valued? +nan.0)) 89 (throw 'unresolved)))) 90 91(with-test-prefix "real-valued?" 92 (pass-if "true on integers" (real-valued? 3)) 93 (pass-if "true on rationals" (real-valued? 3.1)) 94 (pass-if "true on reals" (real-valued? +nan.0))) 95 96(with-test-prefix "vector-for-each" 97 (pass-if "vector-for-each simple" 98 (let ((sum 0)) 99 (vector-for-each (lambda (x) (set! sum (+ sum x))) '#(1 2 3)) 100 (eqv? sum 6)))) 101 102(with-test-prefix "vector-map" 103 (pass-if "vector-map simple" 104 (equal? '#(3 2 1) (vector-map (lambda (x) (- 4 x)) '#(1 2 3))))) 105 106(with-test-prefix "real-valued?" 107 (pass-if (real-valued? +nan.0)) 108 (pass-if (real-valued? +nan.0+0i)) 109 (pass-if (real-valued? +nan.0+0.0i)) 110 (pass-if (real-valued? +inf.0)) 111 (pass-if (real-valued? -inf.0)) 112 (pass-if (real-valued? +inf.0+0.0i)) 113 (pass-if (real-valued? -inf.0-0.0i)) 114 (pass-if (real-valued? 3)) 115 (pass-if (real-valued? -2.5)) 116 (pass-if (real-valued? -2.5+0i)) 117 (pass-if (real-valued? -2.5+0.0i)) 118 (pass-if (real-valued? -2.5-0i)) 119 (pass-if (real-valued? #e1e10)) 120 (pass-if (real-valued? 1e200)) 121 (pass-if (real-valued? 1e200+0.0i)) 122 (pass-if (real-valued? 6/10)) 123 (pass-if (real-valued? 6/10+0.0i)) 124 (pass-if (real-valued? 6/10+0i)) 125 (pass-if (real-valued? 6/3)) 126 (pass-if (not (real-valued? 3+i))) 127 (pass-if (not (real-valued? -2.5+0.01i))) 128 (pass-if (not (real-valued? +nan.0+0.01i))) 129 (pass-if (not (real-valued? +nan.0+nan.0i))) 130 (pass-if (not (real-valued? +inf.0-0.01i))) 131 (pass-if (not (real-valued? +0.01i))) 132 (pass-if (not (real-valued? -inf.0i)))) 133 134(with-test-prefix "rational-valued?" 135 (pass-if (not (rational-valued? +nan.0))) 136 (pass-if (not (rational-valued? +nan.0+0i))) 137 (pass-if (not (rational-valued? +nan.0+0.0i))) 138 (pass-if (not (rational-valued? +inf.0))) 139 (pass-if (not (rational-valued? -inf.0))) 140 (pass-if (not (rational-valued? +inf.0+0.0i))) 141 (pass-if (not (rational-valued? -inf.0-0.0i))) 142 (pass-if (rational-valued? 3)) 143 (pass-if (rational-valued? -2.5)) 144 (pass-if (rational-valued? -2.5+0i)) 145 (pass-if (rational-valued? -2.5+0.0i)) 146 (pass-if (rational-valued? -2.5-0i)) 147 (pass-if (rational-valued? #e1e10)) 148 (pass-if (rational-valued? 1e200)) 149 (pass-if (rational-valued? 1e200+0.0i)) 150 (pass-if (rational-valued? 6/10)) 151 (pass-if (rational-valued? 6/10+0.0i)) 152 (pass-if (rational-valued? 6/10+0i)) 153 (pass-if (rational-valued? 6/3)) 154 (pass-if (not (rational-valued? 3+i))) 155 (pass-if (not (rational-valued? -2.5+0.01i))) 156 (pass-if (not (rational-valued? +nan.0+0.01i))) 157 (pass-if (not (rational-valued? +nan.0+nan.0i))) 158 (pass-if (not (rational-valued? +inf.0-0.01i))) 159 (pass-if (not (rational-valued? +0.01i))) 160 (pass-if (not (rational-valued? -inf.0i)))) 161 162(with-test-prefix "integer-valued?" 163 (pass-if (not (integer-valued? +nan.0))) 164 (pass-if (not (integer-valued? +nan.0+0i))) 165 (pass-if (not (integer-valued? +nan.0+0.0i))) 166 (pass-if (not (integer-valued? +inf.0))) 167 (pass-if (not (integer-valued? -inf.0))) 168 (pass-if (not (integer-valued? +inf.0+0.0i))) 169 (pass-if (not (integer-valued? -inf.0-0.0i))) 170 (pass-if (integer-valued? 3)) 171 (pass-if (integer-valued? 3.0)) 172 (pass-if (integer-valued? 3+0i)) 173 (pass-if (integer-valued? 3+0.0i)) 174 (pass-if (integer-valued? 8/4)) 175 (pass-if (integer-valued? #e1e10)) 176 (pass-if (integer-valued? 1e200)) 177 (pass-if (integer-valued? 1e200+0.0i)) 178 (pass-if (not (integer-valued? -2.5))) 179 (pass-if (not (integer-valued? -2.5+0i))) 180 (pass-if (not (integer-valued? -2.5+0.0i))) 181 (pass-if (not (integer-valued? -2.5-0i))) 182 (pass-if (not (integer-valued? 6/10))) 183 (pass-if (not (integer-valued? 6/10+0.0i))) 184 (pass-if (not (integer-valued? 6/10+0i))) 185 (pass-if (not (integer-valued? 3+i))) 186 (pass-if (not (integer-valued? -2.5+0.01i))) 187 (pass-if (not (integer-valued? +nan.0+0.01i))) 188 (pass-if (not (integer-valued? +nan.0+nan.0i))) 189 (pass-if (not (integer-valued? +inf.0-0.01i))) 190 (pass-if (not (integer-valued? +0.01i))) 191 (pass-if (not (integer-valued? -inf.0i)))) 192 193(with-test-prefix "assert" 194 (pass-if "assert returns value" (= 1 (assert 1))) 195 (pass-if "assertion-violation" 196 (guard (condition ((assertion-violation? condition) #t)) 197 (assert #f) 198 #f))) 199 200(with-test-prefix "string-for-each" 201 (pass-if "reverse string" 202 (let ((s "reverse me") (l '())) 203 (string-for-each (lambda (x) (set! l (cons x l))) s) 204 (equal? "em esrever" (list->string l)))) 205 (pass-if "two strings good" 206 (let ((s1 "two legs good") 207 (s2 "four legs bad") 208 (c '())) 209 (string-for-each (lambda (c1 c2) 210 (set! c (cons* c2 c1 c))) 211 s1 s2) 212 (equal? (list->string c) 213 "ddaobo gs gsegle lr uoowft"))) 214 (pass-if "two strings bad" 215 (let ((s1 "frotz") 216 (s2 "veeblefetzer")) 217 (guard (condition ((assertion-violation? condition) #t)) 218 (string-for-each (lambda (s1 s2) #f) s1 s2) 219 #f))) 220 (pass-if "many strings good" 221 (let ((s1 "foo") 222 (s2 "bar") 223 (s3 "baz") 224 (s4 "zot") 225 (c '())) 226 (string-for-each (lambda (c1 c2 c3 c4) 227 (set! c (cons* c4 c3 c2 c1 c))) 228 s1 s2 s3 s4) 229 (equal? (list->string c) 230 "tzrooaaozbbf"))) 231 (pass-if "many strings bad" 232 (let ((s1 "foo") 233 (s2 "bar") 234 (s3 "baz") 235 (s4 "quux")) 236 (guard (condition ((assertion-violation? condition) #t)) 237 (string-for-each (lambda _ #f) s1 s2 s3 s4) 238 #f)))) 239