Commit | Line | Data |
---|---|---|
b24b7deb JG |
1 | ;;; r6rs-base.test --- Test suite for R6RS (rnrs base) |
2 | ||
8f2339c4 | 3 | ;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. |
b24b7deb JG |
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 | \f | |
19 | ||
20 | (define-module (test-suite test-r6rs-base) | |
21 | :use-module ((rnrs base) :version (6)) | |
15993bce IP |
22 | :use-module ((rnrs conditions) :version (6)) |
23 | :use-module ((rnrs exceptions) :version (6)) | |
b24b7deb JG |
24 | :use-module (test-suite lib)) |
25 | ||
cf9d4a82 IP |
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 | ||
b98d5a5a JG |
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 | ||
b24b7deb JG |
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 | ||
8f2339c4 MW |
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 | ||
15993bce IP |
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))) | |
06906f37 IP |
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)))) |