1;;; arithmetic-fixnums.test --- Test suite for R6RS (rnrs arithmetic bitwise)
2
3;;      Copyright (C) 2010, 2011, 2013 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-arithmetic-fixnums)
21  :use-module ((rnrs arithmetic fixnums) :version (6))
22  :use-module ((rnrs conditions) :version (6))
23  :use-module ((rnrs exceptions) :version (6))
24  :use-module (test-suite lib))
25
26(with-test-prefix "fixnum-width"
27  (pass-if-equal "consistent with least-fixnum"
28      (- (expt 2 (- (fixnum-width) 1)))
29    (least-fixnum))
30  (pass-if-equal "consistent with greatest-fixnum"
31      (- (expt 2 (- (fixnum-width) 1)) 1)
32    (greatest-fixnum)))
33
34(with-test-prefix "fixnum?"
35  (pass-if "fixnum? is #t for fixnums" (fixnum? 0))
36
37  (pass-if "fixnum? is #f for non-fixnums" (not (fixnum? 'foo)))
38
39  (pass-if "fixnum? is #f for non-fixnum numbers"
40    (and (not (fixnum? 1.0)) (not (fixnum? (+ (greatest-fixnum) 1))))))
41
42(with-test-prefix "fx=?"
43  (pass-if "fx=? is #t for eqv inputs" (fx=? 3 3 3))
44
45  (pass-if "fx=? is #f for non-eqv inputs" (not (fx=? 1 2 3))))
46
47(with-test-prefix "fx>?"
48  (pass-if "fx>? is #t for monotonically > inputs" (fx>? 3 2 1))
49
50  (pass-if "fx>? is #f for non-monotonically > inputs" (not (fx>? 1 2 3))))
51
52(with-test-prefix "fx<?"
53  (pass-if "fx<? is #t for monotonically < inputs" (fx<? 1 2 3))
54
55  (pass-if "fx<? is #t for non-monotonically < inputs" (not (fx<? 3 2 1))))
56
57(with-test-prefix "fx>=?"
58  (pass-if "fx>=? is #t for monotonically > or = inputs" (fx>=? 3 2 2 1))
59
60  (pass-if "fx>=? is #f for non-monotonically > or = inputs"
61    (not (fx>=? 1 2 3))))
62
63(with-test-prefix "fx<=?"
64  (pass-if "fx<=? is #t for monotonically < or = inputs" (fx<=? 1 2 2 3))
65
66  (pass-if "fx<=? is #f for non-monotonically < or = inputs"
67    (not (fx<=? 3 2 1))))
68
69(with-test-prefix "fxzero?"
70  (pass-if "fxzero? is #t for zero" (fxzero? 0))
71
72  (pass-if "fxzero? is #f for non-zero fixnums"
73    (and (not (fxzero? 1)) (not (fxzero? -1)))))
74
75(with-test-prefix "fxpositive?"
76  (pass-if "fxpositive? is #t for positive fixnums" (fxpositive? 1))
77
78  (pass-if "fxpositive? is #f for non-positive fixnums"
79    (and (not (fxpositive? -1))
80	 (not (fxpositive? 0)))))
81
82(with-test-prefix "fxnegative?"
83  (pass-if "fxnegative? is #t for negative fixnums" (fxnegative? -1))
84
85  (pass-if "fxnegative? is #f for non-negative fixnums"
86    (and (not (fxnegative? 1))
87	 (not (fxnegative? 0)))))
88
89(with-test-prefix "fxodd?"
90  (pass-if "fxodd? is #t for odd fixnums" (fxodd? 1))
91
92  (pass-if "fxodd? is #f for even fixnums" (not (fxodd? 2))))
93
94(with-test-prefix "fxeven?"
95  (pass-if "fxeven? is #t for even fixnums" (fxeven? 2))
96
97  (pass-if "fxeven? is #f for odd fixnums" (not (fxeven? 1))))
98
99(with-test-prefix "fxmax" (pass-if "simple" (fx=? (fxmax 1 3 2) 3)))
100
101(with-test-prefix "fxmin" (pass-if "simple" (fx=? (fxmin -1 0 2) -1)))
102
103(with-test-prefix "fx+"
104  (pass-if "simple" (fx=? (fx+ 1 2) 3))
105
106  (pass-if "&implementation-restriction on non-fixnum result"
107    (guard (condition ((implementation-restriction-violation? condition) #t)
108		      (else #f))
109	   (begin (fx+ (greatest-fixnum) 1) #f))))
110
111(with-test-prefix "fx*"
112  (pass-if "simple" (fx=? (fx* 2 3) 6))
113
114  (pass-if "&implementation-restriction on non-fixnum result"
115    (guard (condition ((implementation-restriction-violation? condition) #t)
116		      (else #f))
117	   (begin (fx* (greatest-fixnum) 2) #f))))
118
119(with-test-prefix "fx-"
120  (pass-if "unary fx- negates argument" (fx=? (fx- 1) -1))
121
122  (pass-if "simple" (fx=? (fx- 3 2) 1))
123
124  (pass-if "&assertion on non-fixnum result"
125    (guard (condition ((assertion-violation? condition) #t) (else #f))
126	   (fx- (least-fixnum) 1))))
127
128(with-test-prefix "fxdiv-and-mod"
129  (pass-if "simple"
130    (call-with-values (lambda () (fxdiv-and-mod 123 10))
131      (lambda (d m)
132	(and (fx=? d 12) (fx=? m 3))))))
133
134(with-test-prefix "fxdiv" (pass-if "simple" (fx=? (fxdiv -123 10) -13)))
135(with-test-prefix "fxmod" (pass-if "simple" (fx=? (fxmod -123 10) 7)))
136
137(with-test-prefix "fxdiv0-and-mod0"
138  (pass-if "simple"
139    (call-with-values (lambda () (fxdiv0-and-mod0 -123 10))
140      (lambda (d m)
141	(and (fx=? d -12) (fx=? m -3))))))
142
143(with-test-prefix "fxdiv0" (pass-if "simple" (fx=? (fxdiv0 -123 10) -12)))
144(with-test-prefix "fxmod0" (pass-if "simple" (fx=? (fxmod0 -123 10) -3)))
145
146
147;; Without working div and mod implementations and without any example results
148;; from the spec, I have no idea what the results of these functions should
149;; be.  -juliang
150;; UPDATE: div and mod implementations are now working properly  -mhw
151
152(with-test-prefix "fx+/carry" (pass-if "simple" (throw 'unresolved)))
153
154(with-test-prefix "fx-/carry" (pass-if "simple" (throw 'unresolved)))
155
156(with-test-prefix "fx*/carry" (pass-if "simple" (throw 'unresolved)))
157
158(with-test-prefix "fxnot" (pass-if "simple" (fx=? (fxnot 3) -4)))
159
160(with-test-prefix "fxand" (pass-if "simple" (fx=? (fxand 5 6) 4)))
161
162(with-test-prefix "fxior" (pass-if "simple" (fx=? (fxior 2 4) 6)))
163
164(with-test-prefix "fxxor" (pass-if "simple" (fx=? (fxxor 5 4) 1)))
165
166(with-test-prefix "fxif" (pass-if "simple" (fx=? (fxif 5 3 4) 1)))
167
168(with-test-prefix "fxbit-count"
169  (pass-if "simple" (fx=? (fxbit-count 5) 2))
170  (pass-if "negative" (fx=? (fxbit-count -5) -2)))
171
172(with-test-prefix "fxlength" (pass-if "simple" (fx=? (fxlength 5) 3)))
173
174(with-test-prefix "fxfirst-bit-set"
175  (pass-if "simple"
176    (and (eqv? (fxfirst-bit-set 1) 0)
177         (eqv? (fxfirst-bit-set -4) 2)))
178
179  (pass-if "fxfirst-bit-set is -1 on zero"
180    (and (eqv? (fxfirst-bit-set 0) -1))))
181
182(with-test-prefix "fxbit-set?"
183  (pass-if "fxbit-set? is #t on index of set bit" (fxbit-set? 5 2))
184
185  (pass-if "fxbit-set? is #f on index of unset bit" (not (fxbit-set? 5 1))))
186
187(with-test-prefix "fxcopy-bit" (pass-if "simple" (fx=? (fxcopy-bit 2 2 1) 6)))
188
189(with-test-prefix "fxbit-field"
190  (pass-if "simple" (fx=? (fxbit-field 50 1 4) 1)))
191
192(with-test-prefix "fxcopy-bit-field"
193  (pass-if "simple" (fx=? (fxcopy-bit-field 255 2 6 10) 235)))
194
195(with-test-prefix "fxarithmetic-shift"
196  (pass-if "simple"
197    (and (fx=? (fxarithmetic-shift -6 -1) -3)
198         (fx=? (fxarithmetic-shift -5 -1) -3)
199	 (fx=? (fxarithmetic-shift -4 -1) -2)
200	 (fx=? (fxarithmetic-shift -3 -1) -2)
201	 (fx=? (fxarithmetic-shift -2 -1) -1)
202	 (fx=? (fxarithmetic-shift -1 -1) -1))))
203
204(with-test-prefix "fxarithmetic-shift-left"
205  (pass-if "simple" (fx=? (fxarithmetic-shift-left -6 1) -12)))
206
207(with-test-prefix "fxarithmetic-shift-right"
208  (pass-if "simple" (fx=? (fxarithmetic-shift-right -6 1) -3)))
209
210(with-test-prefix "fxrotate-bit-field"
211  (pass-if "simple" (fx=? (fxrotate-bit-field 227 2 6 2) 203)))
212
213(with-test-prefix "fxreverse-bit-field"
214  (pass-if "simple" (fx=? (fxreverse-bit-field 82 1 4) 88)))
215