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