source: project/release/4/err5rs-arithmetic/trunk/tests/run.scm @ 14025

Last change on this file since 14025 was 14025, checked in by Kon Lovett, 11 years ago

Save.

File size: 37.7 KB
Line 
1;;;; err5rs-arithmetic-test
2
3(require-extension test int-limits)
4(require-extension err5rs-arithmetic-fixnums err5rs-arithmetic-flonums err5rs-arithmetic-bitwise)
5
6;;
7
8(define (div0 n d)
9  (let* ((quo (quotient n d))
10         (rem (- n (* quo d))))
11    (cond ((<= 0 d)
12           (if (< (* rem 2) d)
13               (if (<= (* rem -2) d) quo
14                   (- quo 1) )
15               (+ quo 1) ) )
16          ((< d (* rem -2))
17           (if (<= d (* rem 2)) quo
18               (+ quo 1) ) )
19          (else
20           (- quo 1) ) ) ) )
21
22(define (mod0 n d)
23  (let* ((quo (quotient n d))
24         (rem (- n (* quo d))))
25    (cond ((<= 0 d)
26           (if (< (* rem 2) d)
27               (if (<= (* rem -2) d) rem
28                   (+ rem d) )
29               (- rem d) ) )
30          ((< d (* rem -2))
31           (if (<= d (* rem 2)) rem
32               (- rem d) ) )
33          (else
34           (+ rem d) ) ) ) )
35
36(define (run-arithmetic-fixnums-tests)
37
38  ;; Originally from Ikarus test suite:
39
40  (define (fx*/carry-reference fx1 fx2 fx3)
41    (let* ((s (+ (* fx1 fx2) fx3))
42           (s0 (mod0 s (expt 2 (fixnum-width))))
43           (s1 (div0 s (expt 2 (fixnum-width)))))
44      (values (inexact->exact s0) (inexact->exact s1))))
45
46  (define (fx+/carry-reference fx1 fx2 fx3)
47    (let* ((s (+ (+ fx1 fx2) fx3))
48           (s0 (mod0 s (expt 2 (fixnum-width))))
49           (s1 (div0 s (expt 2 (fixnum-width)))))
50      (values (inexact->exact s0) (inexact->exact s1))))
51
52  (define (fx-/carry-reference fx1 fx2 fx3)
53    (let* ((s (- (- fx1 fx2) fx3))
54           (s0 (mod0 s (expt 2 (fixnum-width))))
55           (s1 (div0 s (expt 2 (fixnum-width)))))
56      (values (inexact->exact s0) (inexact->exact s1))))
57
58  (define (vals->list f a b c)
59    (call-with-values (lambda () (f a b c)) list))
60
61  (define-syntax carry-test
62    (syntax-rules ()
63      ((_ fxop/carry fxop/carry-reference fx1 fx2 fx3)
64       (test (conc 'fxop/carry #\space fx1 #\space fx2 #\space fx3)
65             (vals->list fxop/carry-reference fx1 fx2 fx3)
66             (vals->list fxop/carry fx1 fx2 fx3)))))
67
68  (define (carry-tests l)
69    (for-each
70     (lambda (n)
71       (for-each
72        (lambda (m)
73          (for-each
74           (lambda (p)
75             (carry-test fx*/carry fx*/carry-reference n m p)
76             (carry-test fx+/carry fx+/carry-reference n m p)
77             (carry-test fx-/carry fx-/carry-reference n m p))
78           l))
79        l))
80     l))
81
82  (test-group "Fixnum Functions"
83
84    (test 4 ($fx+ 2 2))
85    (test -26 ($fx+ 74 -100))
86    (test (greatest-fixnum) ($fx+ #x3ffffffe 1))
87    (test-error ($fx+ #x3fffffff 1))
88    (test 4 ($fx- 6 2))
89    (test -4 ($fx- 1000 1004))
90    (test 2004 ($fx- 1000 -1004))
91    (test (least-fixnum) ($fx- (- #x3fffffff) 1))
92    (test-error ($fx- (- #x3fffffff) 2))
93  )
94
95  (test-group "R6RS Fixnum Test Suite"
96
97    (test -1 (fxfirst-bit-set 0))
98    (test 0 (fxfirst-bit-set 1))
99    (test 2 (fxfirst-bit-set -4))
100
101    (test 88 (fxreverse-bit-field #b1010010 1 4)) ; #b1011000
102
103    ;; ----------------------------------------
104
105    (test (least-fixnum) (inexact->exact (- (expt 2 (- (fixnum-width) 1)))))
106    (test (greatest-fixnum) (inexact->exact (- (expt 2 (- (fixnum-width) 1)) 1)))
107
108    (test-assert (not (fixnum? 1.0)))
109    ;;(test-assert (not (fixnum? 1+1i)))
110
111    (test-assert (fixnum? 0))
112    (test-assert (fixnum? 1))
113    (test-assert (fixnum? -1))
114    (test-assert (fixnum? (- (expt 2 23))))
115    (test-assert (fixnum? (- (expt 2 23) 1)))
116
117    (test-assert (fixnum? (least-fixnum)))
118    (test-assert (not (fixnum? (- (least-fixnum) 1))))
119    (test-assert (fixnum? (greatest-fixnum)))
120    (test-assert (not (fixnum? (+ 1 (greatest-fixnum)))))
121
122    (let ((test-ordered
123           (lambda (a b c)
124             (test-assert (fx=? a a))
125             (test-assert (fx=? b b))
126             (test-assert (fx=? c c))
127
128             (test-assert (not (fx=? a b)))
129             (test-assert (not (fx=? b a)))
130             (test-assert (not (fx=? b c)))
131             (test-assert (not (fx=? c b)))
132
133             (test-assert (not (fx=? a c b)))
134             (test-assert (not (fx=? a a b)))
135             (test-assert (not (fx=? a b b)))
136
137             (let ((test-lt
138                    (lambda (fx<? fx<=? a b c)
139                      (test-assert (fx<? a b))
140                      (test-assert (fx<? b c))
141                      (test-assert (fx<? a c))
142                      (test-assert (fx<? a b c))
143
144                      (test-assert (not (fx<? b a)))
145                      (test-assert (not (fx<? c b)))
146                      (test-assert (not (fx<? a c b)))
147
148                      (test-assert (fx<=? a a))
149                      (test-assert (fx<=? a b))
150                      (test-assert (fx<=? a c))
151                      (test-assert (fx<=? b b))
152                      (test-assert (fx<=? b c))
153                      (test-assert (fx<=? c c))
154                      (test-assert (fx<=? a c c))
155                      (test-assert (fx<=? a b c))
156                      (test-assert (fx<=? b b c))
157
158                      (test-assert (not (fx<=? c a)))
159                      (test-assert (not (fx<=? b a)))
160                      (test-assert (not (fx<=? a c b)))
161                      (test-assert (not (fx<=? b c a))))))
162               (test-lt fx<? fx<=? a b c)
163               (test-lt fx>? fx>=? c b a))
164
165             ;; Since b is between a and c, we can add or subtract 1:
166             (test-assert (fx=? (+ b 1) (+ b 1)))
167             (test-assert (fx<? b (+ b 1)))
168             (test-assert (fx<=? b (+ b 1)))
169             (test-assert (not (fx>? b (+ b 1))))
170             (test-assert (not (fx>=? b (+ b 1))))
171             (test-assert (fx=? (- b 1) (- b 1)))
172             (test-assert (not (fx<? b (- b 1))))
173             (test-assert (not (fx<=? b (- b 1))))
174             (test-assert (fx>? b (- b 1)))
175             (test-assert (fx>=? b (- b 1)))
176
177             ;; Check min & max while we have ordered values:
178             (test a (fxmin a b))
179             (test b (fxmin b c))
180             (test a (fxmin a c))
181             (test a (fxmin b a c))
182             (test b (fxmax a b))
183             (test c (fxmax b c))
184             (test c (fxmax a c))
185             (test c (fxmax b c a)))))
186      (test-ordered 1 2 3)
187      (test-ordered -1 0 1)
188      (test-ordered (least-fixnum) 1 (greatest-fixnum)))
189
190    (test-assert (fxzero? 0))
191    (test-assert (not (fxzero? 1)))
192    (test-assert (not (fxzero? (greatest-fixnum))))
193    (test-assert (not (fxzero? (least-fixnum))))
194
195    (test-assert (not (fxpositive? 0)))
196    (test-assert (not (fxpositive? (least-fixnum))))
197    (test-assert (fxpositive? (greatest-fixnum)))
198
199    (test-assert (not (fxnegative? 0)))
200    (test-assert (fxnegative? (least-fixnum)))
201    (test-assert (not (fxnegative? (greatest-fixnum))))
202
203    (test-assert (not (fxodd? 0)))
204    (test-assert (not (fxodd? 2)))
205    (test-assert (fxodd? 1))
206    (test-assert (fxodd? -1))
207    (test-assert (fxodd? (greatest-fixnum)))
208    (test-assert (not (fxodd? (least-fixnum))))
209
210    (test-assert (fxeven? 0))
211    (test-assert (fxeven? 2))
212    (test-assert (not (fxeven? 1)))
213    (test-assert (not (fxeven? -1)))
214    (test-assert (not (fxeven? (greatest-fixnum))))
215    (test-assert (fxeven? (least-fixnum)))
216
217    (test 20 (fx+ 3 17))
218    (test -1 (fx+ (greatest-fixnum) (least-fixnum)))
219    (test (greatest-fixnum) (fx+ 0 (greatest-fixnum)))
220    (test (least-fixnum) (fx+ 0 (least-fixnum)))
221    (test-error "&implementation-restriction" (fx+ (greatest-fixnum) 1))
222    (test-error "&implementation-restriction" (fx+ (least-fixnum) -1))
223
224    (test 51 (fx* 3 17))
225    (test (least-fixnum) (fx* 1 (least-fixnum)))
226    (test (greatest-fixnum) (fx* 1 (greatest-fixnum)))
227    (test (+ (least-fixnum) 1) (fx* -1 (greatest-fixnum)))
228    (test-error "&implementation-restriction" (fx* (greatest-fixnum) 2))
229    (test-error "implementation-restriction" (fx* (least-fixnum) -1))
230
231    (test -1 (fx- 1))
232    (test 1 (fx- -1))
233    (test 0 (fx- 0))
234    (test (+ 1 (least-fixnum)) (fx- (greatest-fixnum)))
235
236    (test (fx- (greatest-fixnum) 1) (- (greatest-fixnum) 1))
237    (test 0 (fx- (greatest-fixnum) (greatest-fixnum)))
238    (test 0 (fx- (least-fixnum) (least-fixnum)))
239
240    (test-error "&implementation-restriction" (fx- (least-fixnum)))
241    (test-error "&implementation-restriction" (fx- (least-fixnum) 1))
242
243    ;; If you put N numbers here, it runs to O(N^3) tests!
244    (carry-tests (list 0 1 2 -1 -2 38734 -3843 2484598 -348732487 (greatest-fixnum) (least-fixnum)))
245
246    (test 12 (fxdiv 123 10))
247    (test 3 (fxmod 123 10))
248    (test -12 (fxdiv 123 -10))
249    (test 3 (fxmod 123 -10))
250    (test -13 (fxdiv -123 10))
251    (test 7 (fxmod -123 10))
252    (test 13 (fxdiv -123 -10))
253    (test 7 (fxmod -123 -10))
254
255    (test (values -13 7) (fxdiv-and-mod -123 10))
256
257    (test 12 (fxdiv0 123 10))
258    (test 3 (fxmod0 123 10))
259    (test -12 (fxdiv0 123 -10))
260    (test 3 (fxmod0 123 -10))
261    (test -12 (fxdiv0 -123 10))
262    (test -3 (fxmod0 -123 10))
263    (test 12 (fxdiv0 -123 -10))
264    (test -3 (fxmod0 -123 -10))
265
266    (test (values -12 -3) (fxdiv0-and-mod0 -123 10))
267
268    (test-error "&assertion" (fxdiv 1 0))
269    (test-error "&assertion" (fxmod 1 0))
270    (test-error "&assertion" (fxdiv-and-mod 1 0))
271    (test-error "&assertion" (fxdiv0 1 0))
272    (test-error "&assertion" (fxmod0 1 0))
273    (test-error "&assertion" (fxdiv0-and-mod0 1 0))
274
275    (test-error "&implementation-restriction" (fxdiv (least-fixnum) -1))
276    (test-error "&implementation-restriction" (fxdiv-and-mod (least-fixnum) -1))
277    (test-error "&implementation-restriction" (fxdiv0 (least-fixnum) -1))
278    (test-error "&implementation-restriction" (fxdiv0-and-mod0 (least-fixnum) -1))
279
280    (test -1 (fxnot 0))
281    (test 1 (fxnot -2))
282    (test -2 (fxnot 1))
283
284    (test 7 (fxand 7))
285    (test 0 (fxand 7 0))
286    (test 1 (fxand 7 1))
287    (test 5 (fxand 7 5))
288    (test 4 (fxand 7 4 5))
289    (test 4 (fxand 7 5 4))
290
291    (test 7 (fxior 7))
292    (test 7 (fxior 7 0))
293    (test 5 (fxior 5 4))
294    (test 7 (fxior 5 3))
295    (test 39 (fxior 5 3 32))
296
297    (test 7 (fxxor 7))
298    (test 7 (fxxor 7 0))
299    (test 1 (fxxor 5 4))
300    (test 6 (fxxor 5 3))
301    (test 36 (fxxor 5 1 32))
302
303    (test 5 (fxif 5 15 0))
304    (test 10 (fxif 5 0 15))
305    (test 0 (fxif 5 0 1))
306    (test 2 (fxif 5 0 3))
307    (test 1 (fxif 5 3 0))
308
309    (test 2 (fxbit-count 5))
310    (test 2 (fxbit-count 6))
311    (test 3 (fxbit-count 7))
312    (test -3 (fxbit-count -7))
313
314    (test 1 (fxlength 1))
315    (test 8 (fxlength 255))
316    (test 0 (fxlength 0))
317    (test 1 (fxlength -2))
318    (test 8 (fxlength -255))
319
320    (test -1 (fxfirst-bit-set 0))
321    (test 0 (fxfirst-bit-set 1))
322    (test 4 (fxfirst-bit-set 16))
323    (test 1 (fxfirst-bit-set -2))
324    (test 17 (fxfirst-bit-set (expt 2 17)))
325
326    (test-assert (fxbit-set? 15 0))
327    (test-assert (not (fxbit-set? 14 0)))
328    (test-assert (fxbit-set? 14 3))
329    (test-assert (not (fxbit-set? 14 10)))
330    (test-assert (fxbit-set? -1 10))
331
332    (test 1 (fxcopy-bit 0 0 1))
333    (test 2 (fxcopy-bit 0 1 1))
334    (test 16 (fxcopy-bit 0 4 1))
335    (test 0 (fxcopy-bit 0 4 0))
336    (test 15 (fxcopy-bit 31 4 0))
337
338    (test 3 (fxbit-field 30 1 3))
339    (test 7 (fxbit-field 30 1 4))
340    (test 15 (fxbit-field 30 1 5))
341    (test 15 (fxbit-field 30 1 6))
342    (test 6 (fxbit-field 30 0 3))
343
344    (test 6 (fxcopy-bit-field 0 0 3 30))
345    (test 6 (fxcopy-bit-field 7 0 3 30))
346    (test 14 (fxcopy-bit-field 15 0 3 30))
347    (test 24 (fxcopy-bit-field 0 2 5 30))
348    (test 25 (fxcopy-bit-field 1 2 5 30))
349    (test 27 (fxcopy-bit-field 7 2 5 30))
350    (test 27 (fxcopy-bit-field 15 2 5 30))
351    (test 0 (fxcopy-bit-field 0 2 5 120))
352    (test 1 (fxcopy-bit-field 1 2 5 120))
353
354    (test 2 (fxarithmetic-shift 1 1))
355    (test 0 (fxarithmetic-shift 1 -1))
356    (test 40 (fxarithmetic-shift 10 2))
357    (test 10 (fxarithmetic-shift 40 -2))
358    (test -2 (fxarithmetic-shift -1 1))
359    (test -1 (fxarithmetic-shift -1 -1))
360    (test -40 (fxarithmetic-shift -10 2))
361    (test -10 (fxarithmetic-shift -40 -2))
362    (test-error "&implementation-restriction" (fxarithmetic-shift (greatest-fixnum) 1))
363
364    (test 2 (fxarithmetic-shift-left 1 1))
365    (test 0 (fxarithmetic-shift-right 1 1))
366    (test 40 (fxarithmetic-shift-left 10 2))
367    (test 10 (fxarithmetic-shift-right 40 2))
368    (test -2 (fxarithmetic-shift-left -1 1))
369    (test -1 (fxarithmetic-shift-right -1 1))
370    (test -40 (fxarithmetic-shift-left -10 2))
371    (test -10 (fxarithmetic-shift-right -40 2))
372    (test-error "&implementation-restriction" (fxarithmetic-shift-left (greatest-fixnum) 1))
373
374    (test 10 (fxrotate-bit-field 10 0 2 0))
375    (test 9 (fxrotate-bit-field 10 0 2 1))
376
377    (test 10 (fxrotate-bit-field 10 2 4 0))
378    (test 6 (fxrotate-bit-field 10 2 4 1))
379    (test 12 (fxrotate-bit-field 10 1 4 2))
380    (test 6 (fxrotate-bit-field 10 1 4 1))
381    (test 6 (fxrotate-bit-field 10 2 4 1))
382  )
383)
384
385;;
386
387(define (run-arithmetic-flonums-tests)
388
389  (define (try-flonums proc)
390    (proc 0.0)
391    (proc 1.0)
392    (proc -1.0)
393    (proc +inf)
394    (proc -inf)
395    (proc +nan))
396
397  (define-syntax try-bad-divs
398    (syntax-rules ()
399      ((_ op)
400       'nothing
401       ;; The spec is unclear whether the following
402       ;; are allowed to raise exceptions.
403       #;
404       (begin
405         (test-error "&assertion" (op 1.0 0.0))
406         (test-error "&assertion" (op +inf 1.0))
407         (test-error "&assertion" (op -inf 1.0))
408         (test-error "&assertion" (op +nan 1.0))))))
409
410  (test-group "Flonum Functions"
411
412    (test -4.0 (flround -4.3))
413    (test 4.0 (flround 3.5))
414    (test 4.0 (flround (fl/ 7.0 2.0)))
415    (test 7.0 (flround 7.0))
416    (test-assert (fl=? -0.0 (flround -0.5)))
417    (test-assert (flzero? (flround -0.5)))
418    (test-assert (flzero? (flround -0.3)))
419    (test -1.0 (flround -0.6))
420    (test-assert (flzero? (flround 0.5)))
421    (test-assert (flzero? (flround 0.3)))
422    (test 1.0 (flround 0.6))
423
424    (current-test-epsilon 0.001)
425
426    ;; basic cases, fixnum base
427    (test 1.0 (flexpt 0.0 0.0))
428    (test 1.0 (flexpt 2.0 0.0))
429    (test 2.0 (flexpt 2.0 1.0))
430    (test 4.0 (flexpt 2.0 2.0))
431    (test 9.0 (flexpt 3.0 2.0))
432    (test 9.0 (flexpt 3.0 2.0))
433    (test 10.0451 (flexpt 3.0 2.1))
434    (test 1.1161 (flexpt 3.0 0.1))
435    (test (fl/ 1.0 3.0) (flexpt 3.0 -1.0))
436    (test (fl/ 1.0 9.0) (flexpt 3.0 -2.0))
437    (test 0.09955 (flexpt 3.0 -2.1))
438
439    ;; basic cases, flonum base
440    (test 1.0 (flexpt 0.0 0.0))
441    (test 1.0 (flexpt 3.14 0.0))
442    (test 3.14 (flexpt 3.14 1.0))
443    (test 9.8596 (flexpt 3.14 2.0))
444    (test 9.8596 (flexpt 3.14 2.0))
445    (test 11.0548 (flexpt 3.14 2.1))
446    (test 1.1212 (flexpt 3.14 0.1))
447    (test 0.31847 (flexpt 3.14 -1.0))
448    (test 0.10142 (flexpt 3.14 -2.0))
449    (test 0.090458 (flexpt 3.14 -2.1))
450
451    ;; check overflows into bignums
452    (test (string->number "1073741824") (flexpt 2.0 30.0))
453    (test (string->number "2147483648") (flexpt 2.0 31.0))
454    (test (string->number "4294967296") (flexpt 2.0 32.0))
455    (test (string->number "4611686018427387904") (flexpt 2.0 62.0))
456    (test (string->number "9223372036854775808") (flexpt 2.0 63.0))
457    (test (string->number "18446744073709551616") (flexpt 2.0 64.0))
458
459    (define (one-followed-by-n-zeros n)
460      (exact->inexact (string->number (string-append "1" (make-string n #\0)))))
461
462    ;; bug reported on the chicken list
463    (test (one-followed-by-n-zeros 100) (flexpt 10.0 100.0))
464
465    ;; bignum base
466    (test 1.0 (flexpt (one-followed-by-n-zeros 100) 0.0))
467    (test (one-followed-by-n-zeros 100) (flexpt (one-followed-by-n-zeros 100) 1.0))
468    (test (one-followed-by-n-zeros 200) (flexpt (one-followed-by-n-zeros 100) 2.0))
469    (test 10000000000.0 (flexpt (one-followed-by-n-zeros 100) 0.1))
470
471    ;; cannot compute e^(pi*i) = -1 in domain FL
472    (test-assert (flnan? (flexpt (flexp 1.0) (* (flacos -1.0) (flsqrt -1.0)))))
473
474    ;; rational rounding
475    (test 1.0 (flround (fl/ 9.0 10.0)))
476    (test 1.0 (flround (fl/ 6.0 10.0)))
477    (test 0.0 (flround (fl/ 5.0 10.0)))
478    (test 0.0 (flround (fl/ 1.0 10.0)))
479    (test 0.0 (flround (fl/ 0.0 10.0)))
480    (test 0.0 (flround (fl/ -1.0 10.0)))
481    (test 0.0 (flround (fl/ -5.0 10.0)))
482    (test -1.0 (flround (fl/ -6.0 10.0)))
483    (test -1.0 (flround (fl/ -9.0 10.0)))
484    (test-assert (flnan? (flround (fl/ (flexpt 10.0 10000.0) (fl+ (flexpt 10.0 10000.0) 1.0)))))
485    (test 1.0 (flround (fl/ (flexpt 10.0 100.0) (fl+ (flexpt 10.0 100.0) 1.0))))
486    (test (flexpt 10.0 9900.0) (flround (fl/ (fl+ 1.0 (flexpt 10.0 10000.0)) (flexpt 10.0 100.0))))
487  )
488
489  (test-group "R6RS Flonum Test Suite"
490
491    (current-test-epsilon 0.001)
492
493    (test-assert (fl=? +inf +inf))
494    (test-assert (not (fl=? -inf +inf)))
495    (test-assert (fl=? -inf -inf))
496    (test-assert (fl=? 0.0 -0.0))
497    (test-assert (not (fl<? 0.0 -0.0)))
498    (try-flonums
499     (lambda (fl)
500       (test-assert (not (fl=? +nan fl)))
501       (test-assert (not (fl<? +nan fl)))))
502
503    (test-assert (flnegative? -0.0))
504    (test-assert (not (flfinite? +inf)))
505    (test-assert (flfinite? 5.0))
506    (test-assert (not (flinfinite? 5.0)))
507    (test-assert (flinfinite? +inf))
508    (test-assert (flinfinite? -inf))
509    (test-assert (not (flinfinite? +nan)))
510
511    (test-assert (flnan? (fl+ +inf -inf)))
512    (try-flonums
513     (lambda (fl)
514       (test-assert (flnan? (fl+ +nan fl)))
515       (test-assert (flnan? (fl* +nan fl)))))
516
517    (test-assert (flnan? (fl- +inf +inf)))
518
519    (test +inf (fl/ 1.0 0.0))
520    (test -inf (fl/ -1.0 0.0))
521    (test-assert (flnan? (fl/ 0.0 0.0)))
522
523    (test +inf (flnumerator +inf))
524    (test -inf (flnumerator -inf))
525    (test 1.0 (fldenominator +inf))
526    (test 1.0 (fldenominator -inf))
527
528    (test 3.0 (flnumerator 0.75))
529    (test 4.0 (fldenominator 0.75))
530
531    (test -0.0 (flnumerator -0.0))
532
533    (test +inf (flfloor +inf))
534    (test -inf (flceiling -inf))
535    (test-assert (flnan? (fltruncate +nan)))
536
537    (test +inf (flexp +inf))
538    (test 0.0 (flexp -inf))
539    (test +inf (fllog +inf))
540    (test -inf (fllog 0.0))
541    (test -0.0 (fllog -0.0))
542    (test-assert (flnan? (fllog -inf)))
543    (test -1.5707963267948965 (flatan -inf))
544    (test 1.5707963267948965 (flatan +inf))
545
546    (test +inf (flsqrt +inf))
547    (test -0.0 (flsqrt -0.0))
548
549    ;; ----------------------------------------
550
551    (let ((test-ordered
552           (lambda (a b c)
553             (test-assert (fl=? a a))
554             (test-assert (fl=? b b))
555             (test-assert (fl=? c c))
556
557             (test-assert (not (fl=? a b)))
558             (test-assert (not (fl=? b a)))
559             (test-assert (not (fl=? b c)))
560             (test-assert (not (fl=? c b)))
561
562             (test-assert (not (fl=? a c b)))
563             (test-assert (not (fl=? a a b)))
564             (test-assert (not (fl=? a b b)))
565
566             (let ((test-lt
567                    (lambda (fl<? fl<=? a b c)
568                      (test-assert (fl<? a b))
569                      (test-assert (fl<? b c))
570                      (test-assert (fl<? a c))
571                      (test-assert (fl<? a b c))
572
573                      (test-assert (not (fl<? b a)))
574                      (test-assert (not (fl<? c b)))
575                      (test-assert (not (fl<? a c b)))
576
577                      (test-assert (fl<=? a a))
578                      (test-assert (fl<=? a b))
579                      (test-assert (fl<=? a c))
580                      (test-assert (fl<=? b b))
581                      (test-assert (fl<=? b c))
582                      (test-assert (fl<=? c c))
583                      (test-assert (fl<=? a c c))
584                      (test-assert (fl<=? a b c))
585                      (test-assert (fl<=? b b c))
586
587                      (test-assert (not (fl<=? c a)))
588                      (test-assert (not (fl<=? b a)))
589                      (test-assert (not (fl<=? a c b)))
590                      (test-assert (not (fl<=? b c a))))))
591               (test-lt fl<? fl<=? a b c)
592               (test-lt fl>? fl>=? c b a))
593
594             ;; Since b is between a and c, we can add or subtract 1:
595             (test-assert (fl=? (+ b 1) (+ b 1)))
596             (test-assert (fl<? b (+ b 1)))
597             (test-assert (fl<=? b (+ b 1)))
598             (test-assert (not (fl>? b (+ b 1))))
599             (test-assert (not (fl>=? b (+ b 1))))
600             (test-assert (fl=? (- b 1) (- b 1)))
601             (test-assert (not (fl<? b (- b 1))))
602             (test-assert (not (fl<=? b (- b 1))))
603             (test-assert (fl>? b (- b 1)))
604             (test-assert (fl>=? b (- b 1)))
605
606             ;; Check min & max while we have ordered values:
607             (test a (flmin a b))
608             (test b (flmin b c))
609             (test a (flmin a c))
610             (test a (flmin b a c))
611             (test b (flmax a b))
612             (test c (flmax b c))
613             (test c (flmax a c))
614             (test c (flmax b c a)))))
615      (test-ordered 1.0 2.0 3.0)
616      (test-ordered -1.0 0.0 1.0)
617      (test-ordered -1.0e5 0.0 1.0e-5))
618
619    (test-assert (flinteger? 4.0))
620    (test-assert (not (flinteger? 4.1)))
621    (test-assert (not (flzero? 4.1)))
622    (test-assert (flzero? 0.0))
623    (test-assert (not (flzero? -4.1)))
624    (test-assert (flpositive? 4.1))
625    (test-assert (not (flpositive? 0.0)))
626    (test-assert (not (flpositive? -4.1)))
627    (test-assert (not (flnegative? 4.1)))
628    (test-assert (not (flnegative? 0.0)))
629    (test-assert (flnegative? -4.1))
630
631    (test-assert (fleven? 2.0))
632    (test-assert (fleven? -2.0))
633    (test-assert (fleven? 0.0))
634    (test-assert (fleven? -0.0))
635    (test-assert (not (fleven? 3.0)))
636    (test-assert (not (fleven? -3.0)))
637
638    (test-assert (flodd? 3.0))
639    (test-assert (flodd? -3.0))
640    (test-assert (not (flodd? 0.0)))
641    (test-assert (not (flodd? -0.0)))
642    (test-assert (not (flodd? 2.0)))
643    (test-assert (not (flodd? -2.0)))
644
645    (test-assert (not (flnan? +inf)))
646    (test-assert (not (flnan? 0.0)))
647    (test-assert (not (flnan? -0.0)))
648    (test-assert (not (flnan? -inf)))
649    (test-assert (flnan? +nan))
650
651    (test 2.3 (fl+ 2.3))
652    (test 5.4 (fl+ 2.3 3.1))
653    (test 4.3 (fl+ 2.3 3.1 -1.1))
654    (test 261.0 (fl+ 2.3e2 3.1e1))
655
656    (test 2.3 (fl* 2.3))
657    (test 4.83 (fl* 2.3 2.1))
658    (test 5.313 (fl* 2.3 2.1 1.1))
659    (test -5.313 (fl* 2.3 2.1 -1.1))
660
661    (test -2.3 (fl- 0.0 2.3))
662    (test -1.2 (fl- 0.0 2.3 -1.1))
663    (test -2.3 (fl- 2.3))
664    (test -0.0 (fl- 0.0))
665
666    (test 2.5 (fl/ 5.0 2.0))
667    (test 1.0 (fl/ 5.0 2.0 2.5))
668    (test 0.5 (fl/ 2.0))
669    (test -0.5 (fl/ -2.0))
670
671    (test 0.0 (flabs 0.0))
672    (test 1.0 (flabs 1.0))
673    (test 1.0 (flabs -1.0))
674    (test 0.1 (flabs -0.1))
675
676    (test 12.0 (fldiv 123.0 10.0))
677    (test 3.0 (flmod 123.0 10.0))
678    (test -12.0 (fldiv 123.0 -10.0))
679    (test 3.0 (flmod 123.0 -10.0))
680    (test -13.0 (fldiv -123.0 10.0))
681    (test 7.0 (flmod -123.0 10.0))
682    (test 13.0 (fldiv -123.0 -10.0))
683    (test 7.0 (flmod -123.0 -10.0))
684
685    (test (values -13.0 7.0) (fldiv-and-mod -123.0 10.0))
686
687    (try-bad-divs fldiv)
688    (try-bad-divs flmod)
689    (try-bad-divs fldiv-and-mod)
690
691    (test 12.0 (fldiv0 123.0 10.0))
692    (test 3.0 (flmod0 123.0 10.0))
693    (test -12.0 (fldiv0 123.0 -10.0))
694    (test 3.0 (flmod0 123.0 -10.0))
695    (test -12.0 (fldiv0 -123.0 10.0))
696    (test -3.0 (flmod0 -123.0 10.0))
697    (test 12.0 (fldiv0 -123.0 -10.0))
698    (test -3.0 (flmod0 -123.0 -10.0))
699
700    (test (values -12.0 -3.0) (fldiv0-and-mod0 -123.0 10.0))
701
702    (try-bad-divs fldiv0)
703    (try-bad-divs flmod0)
704    (try-bad-divs fldiv0-and-mod0)
705
706    (test 3.0 (flfloor 3.1))
707    (test -4.0 (flfloor -3.1))
708    (test 4.0 (flceiling 3.1))
709    (test -3.0 (flceiling -3.1))
710    (test 3.0 (fltruncate 3.1))
711    (test -3.0 (fltruncate -3.1))
712    (test 3.0 (flround 3.1))
713    (test -3.0 (flround -3.1))
714    (test 4.0 (flround 3.8))
715    (test -4.0 (flround -3.8))
716    (test 4.0 (flround 3.5))
717    (test -4.0 (flround -3.5))
718    (test 2.0 (flround 2.5))
719    (test -2.0 (flround -2.5))
720
721    (test 7.389 (flexp 2.0))
722    (test 2.0 (fllog 7.389))
723    (test 10.0 (fllog 1024.0 2.0))
724
725    (test 0.0 (flsin 0.0))
726    (test 1.0 (flsin 1.570796))
727    (test 0.0 (flcos 1.570796))
728    (test 1.0 (flcos 0.0))
729    (test 0.0 (flatan 0.0 1.0))
730    (test (* 1.570796 2.0) (flatan 0.0 -1.0))
731    (test 1.570796 (flatan 1.0 0.0))
732    (test -1.570796 (flatan -1.0 0.0))
733    (test (/ 1.570796 2.0) (flatan 1.0 1.0))
734    (test (/ -1.570796 2.0) (flatan -1.0 1.0))
735    (test 0.0 (flatan 0.0))
736    (test (/ 1.570796 2.0) (flatan 1.0))
737    (test 1.47113 (flatan 10.0))
738    (test 0.0996687 (flatan 0.1))
739
740    (test 2.0 (flsqrt 4.0))
741    (test 2.23607 (flsqrt 5.0))
742
743    (test 8.0 (flexpt 2.0 3.0))
744    (test 1000.0 (flexpt 10.0 3.0))
745
746    #;(test (no-infinities-violation? (make-no-infinities-violation)) #t)
747    #;(test ((record-predicate (record-type-descriptor &no-infinities)) (make-no-infinities-violation)) #t)
748    #;(test (no-nans-violation? (make-no-nans-violation)) #t)
749    #;(test ((record-predicate (record-type-descriptor &no-nans)) (make-no-nans-violation)) #t)
750
751    (test 2.0 (fixnum->flonum 2))
752  )
753)
754
755;;
756
757(define (run-arithmetic-bitwise-tests)
758
759  ;; Helpers originally from Ikarus test suite:
760  (define (ref ei)
761    (do ((result 0 (+ result 1))
762         (bits (if (negative? ei) (bitwise-not ei) ei) (bitwise-arithmetic-shift bits -1)))
763        ((zero? bits) result)))
764
765  (define-syntax len-test
766    (syntax-rules ()
767      ((_ n) (test (ref n) (bitwise-length n)))))
768
769  (define (count-bits n)
770    (define (pos-count-bits n)
771      (if (zero? n) 0
772          (let ((c (count-bits (bitwise-arithmetic-shift-right n 1))))
773            (if (even? n) c (+ c 1)))))
774    (if (>= n 0) (pos-count-bits n)
775        (bitwise-not (pos-count-bits (bitwise-not n)))))
776
777  (define-syntax count-test
778    (syntax-rules ()
779      ((_ n) (test (count-bits n) (bitwise-bit-count n)))))
780
781  (test-group "Bitwise Functions"
782
783    (test #b011 (bitwise-if #b100 #b000 #b111))
784    (test #b100 (bitwise-if #b011 #b000 #b100))
785
786    (test #b100 (bitwise-if-not #b100 #b000 #b111))
787    (test #b000 (bitwise-if-not #b011 #b000 #b100))
788    (test #b110 (bitwise-if-not #b011 #b101 #b010))
789
790    (test-assert (bitwise-test? #b0010 #b0111))
791    (test-assert (not (bitwise-test? #b0001 #b0100)))
792    (test-assert (not (bitwise-test? #b0100 #b1011)))
793    (test-assert (bitwise-test? #b0100 #b0111))
794
795    (test 4 (bitwise-bit-count #b10101010))
796    (test 0 (bitwise-bit-count 0))
797    (test 1 (bitwise-bit-count -2))
798
799    (test 8 (bitwise-length #b10101010))
800    (test 0 (bitwise-length 0))
801    (test 4 (bitwise-length #b1111))
802    (test 5 (bitwise-length -27))
803
804    (test-assert (bitwise-bit-set? #b1101 0))
805    (test-assert (not (bitwise-bit-set? #b1101 1)))
806    (test-assert (bitwise-bit-set? #b1101 2))
807    (test-assert (bitwise-bit-set? #b1101 3))
808    (test-assert (not (bitwise-bit-set? #b1101 4)))
809
810    (test 0 (bitwise-last-bit-set 0))
811    (test 8 (bitwise-last-bit-set #b10111100))
812    (test (sub1 machine-word-bits) (bitwise-last-bit-set -1))
813
814    (test -1 (bitwise-first-bit-set 0))
815    (test 0 (bitwise-first-bit-set -1))
816    (test 0 (bitwise-first-bit-set 1))
817    (test 1 (bitwise-first-bit-set -2))
818    (test 1 (bitwise-first-bit-set 2))
819    (test 0 (bitwise-first-bit-set -3))
820    (test 0 (bitwise-first-bit-set 3))
821    (test 2 (bitwise-first-bit-set -4))
822    (test 2 (bitwise-first-bit-set 4))
823    (test 0 (bitwise-first-bit-set -5))
824    (test 0 (bitwise-first-bit-set 5))
825    (test 1 (bitwise-first-bit-set -6))
826    (test 1 (bitwise-first-bit-set 6))
827    (test 0 (bitwise-first-bit-set -7))
828    (test 0 (bitwise-first-bit-set 7))
829    (test 3 (bitwise-first-bit-set -8))
830    (test 3 (bitwise-first-bit-set 8))
831    (test 0 (bitwise-first-bit-set -9))
832    (test 0 (bitwise-first-bit-set 9))
833    (test 1 (bitwise-first-bit-set -10))
834    (test 1 (bitwise-first-bit-set 10))
835    (test 0 (bitwise-first-bit-set -11))
836    (test 0 (bitwise-first-bit-set 11))
837    (test 2 (bitwise-first-bit-set -12))
838    (test 2 (bitwise-first-bit-set 12))
839    (test 0 (bitwise-first-bit-set -13))
840    (test 0 (bitwise-first-bit-set 13))
841    (test 1 (bitwise-first-bit-set -14))
842    (test 1 (bitwise-first-bit-set 14))
843    (test 0 (bitwise-first-bit-set -15))
844    (test 0 (bitwise-first-bit-set 15))
845    (test 4 (bitwise-first-bit-set -16))
846    (test 4 (bitwise-first-bit-set 16))
847
848    (test #b1 (bitwise-copy-bit 0 0 1))
849    (test #b100 (bitwise-copy-bit 0 2 1))
850    (test #b1011 (bitwise-copy-bit #b1111 2 0))
851
852    (test #b1 (bitwise-copy-bit 0 0 #t))
853    (test #b100 (bitwise-copy-bit 0 2 #t))
854    (test #b1011 (bitwise-copy-bit #b1111 2 #f))
855
856    (test #b1010 (bitwise-bit-field #b1101101010 0 4))
857    (test #b10110 (bitwise-bit-field #b1101101010 4 9))
858
859    (test #b1101100000 (bitwise-copy-bit-field #b1101101010 0 4 0))
860    (test #b1101101111 (bitwise-copy-bit-field #b1101101010 0 4 -1))
861    (test #b110100111110000 (bitwise-copy-bit-field #b110100100010000 5 9 -1))
862
863    (test #b10 (bitwise-rotate-bit-field #b0100 0 4 3) )
864    (test #b10 (bitwise-rotate-bit-field #b0100 0 4 -1))
865    ;                    9   5
866    (test #b110100010010000 (bitwise-rotate-bit-field #b110100100010000 5 9 -1))
867    (test #b110100000110000 (bitwise-rotate-bit-field #b110100100010000 5 9 1) )
868
869    (test #b11100101 (bitwise-reverse-bit-field #b10100111 0 8))
870
871    (test 0 (bitwise-list->integer '()))
872    (test #b101 (bitwise-list->integer '(#t #f #t)))
873
874    (test '() (bitwise-integer->list #b0 0))
875    (test (make-list machine-word-bits #f) (bitwise-integer->list #b0))
876    (test '(#t #f #t) (bitwise-integer->list #b101))
877    (test '(#t #t #f #t) (bitwise-integer->list #b11101 4))
878  )
879
880  (test-group "R6RS Bitwise Test Suite"
881
882    (test -1 (bitwise-first-bit-set 0))
883    (test 0 (bitwise-first-bit-set 1))
884    (test 2 (bitwise-first-bit-set -4))
885
886    (test -3 (bitwise-arithmetic-shift -6 -1))
887    (test -3 (bitwise-arithmetic-shift -5 -1))
888    (test -2 (bitwise-arithmetic-shift -4 -1))
889    (test -2 (bitwise-arithmetic-shift -3 -1))
890    (test -1 (bitwise-arithmetic-shift -2 -1))
891    (test -1 (bitwise-arithmetic-shift -1 -1))
892
893    (test #b1011000 (bitwise-reverse-bit-field #b1010010 1 4)) ; 88
894
895    ;; Originally from Ikarus test suite:
896    (len-test #xF)
897    (len-test #xFF)
898    (len-test #xFFF)
899    (len-test #xFFFF)
900    (len-test #xFFFFF)
901    (len-test #xFFFFFF)
902    (len-test #xFFFFFFF)
903    (len-test #xFFFFFFFF)
904    ;;(len-test #xFFFFFFFFF)
905    ;;(len-test #xFFFFFFFFFF)
906    ;;(len-test #xFFFFFFFFFFF)
907    ;;(len-test #xFFFFFFFFFFFF)
908    ;;(len-test #xFFFFFFFFFFFFF)
909    ;;(len-test #xFFFFFFFFFFFFFF)
910    ;;(len-test #xFFFFFFFFFFFFFFF)
911    ;;(len-test #xFFFFFFFFFFFFFFFF)
912    (len-test #x-F)
913    (len-test #x-FF)
914    (len-test #x-FFF)
915    (len-test #x-FFFF)
916    (len-test #x-FFFFF)
917    (len-test #x-FFFFFF)
918    (len-test #x-FFFFFFF)
919    (len-test #x-FFFFFFFF)
920    ;;(len-test #x-FFFFFFFFF)
921    ;;(len-test #x-FFFFFFFFFF)
922    ;;(len-test #x-FFFFFFFFFFF)
923    ;;(len-test #x-FFFFFFFFFFFF)
924    ;;(len-test #x-FFFFFFFFFFFFF)
925    ;;(len-test #x-FFFFFFFFFFFFFF)
926    ;;(len-test #x-FFFFFFFFFFFFFFF)
927    ;;(len-test #x-FFFFFFFFFFFFFFFF)
928
929    (len-test #xE)
930    (len-test #xFE)
931    (len-test #xFFE)
932    (len-test #xFFFE)
933    (len-test #xFFFFE)
934    (len-test #xFFFFFE)
935    (len-test #xFFFFFFE)
936    (len-test #xFFFFFFFE)
937    ;;(len-test #xFFFFFFFFE)
938    ;;(len-test #xFFFFFFFFFE)
939    ;;(len-test #xFFFFFFFFFFE)
940    ;;(len-test #xFFFFFFFFFFFE)
941    ;;(len-test #xFFFFFFFFFFFFE)
942    ;;(len-test #xFFFFFFFFFFFFFE)
943    ;;(len-test #xFFFFFFFFFFFFFFE)
944    ;;(len-test #xFFFFFFFFFFFFFFFE)
945    (len-test #x-E)
946    (len-test #x-FE)
947    (len-test #x-FFE)
948    (len-test #x-FFFE)
949    (len-test #x-FFFFE)
950    (len-test #x-FFFFFE)
951    (len-test #x-FFFFFFE)
952    (len-test #x-FFFFFFFE)
953    ;;(len-test #x-FFFFFFFFE)
954    ;;(len-test #x-FFFFFFFFFE)
955    ;;(len-test #x-FFFFFFFFFFE)
956    ;;(len-test #x-FFFFFFFFFFFE)
957    ;;(len-test #x-FFFFFFFFFFFFE)
958    ;;(len-test #x-FFFFFFFFFFFFFE)
959    ;;(len-test #x-FFFFFFFFFFFFFFE)
960    ;;(len-test #x-FFFFFFFFFFFFFFFE)
961
962    (len-test #x1)
963    (len-test #x1F)
964    (len-test #x1FF)
965    (len-test #x1FFF)
966    (len-test #x1FFFF)
967    (len-test #x1FFFFF)
968    (len-test #x1FFFFFF)
969    (len-test #x1FFFFFFF)
970    ;;(len-test #x1FFFFFFFF)
971    ;;(len-test #x1FFFFFFFFF)
972    ;;(len-test #x1FFFFFFFFFF)
973    ;;(len-test #x1FFFFFFFFFFF)
974    ;;(len-test #x1FFFFFFFFFFFF)
975    ;;(len-test #x1FFFFFFFFFFFFF)
976    ;;(len-test #x1FFFFFFFFFFFFFF)
977    ;;(len-test #x1FFFFFFFFFFFFFFF)
978    (len-test #x-1)
979    (len-test #x-1F)
980    (len-test #x-1FF)
981    (len-test #x-1FFF)
982    (len-test #x-1FFFF)
983    (len-test #x-1FFFFF)
984    (len-test #x-1FFFFFF)
985    (len-test #x-1FFFFFFF)
986    ;;(len-test #x-1FFFFFFFF)
987    ;;(len-test #x-1FFFFFFFFF)
988    ;;(len-test #x-1FFFFFFFFFF)
989    ;;(len-test #x-1FFFFFFFFFFF)
990    ;;(len-test #x-1FFFFFFFFFFFF)
991    ;;(len-test #x-1FFFFFFFFFFFFF)
992    ;;(len-test #x-1FFFFFFFFFFFFFF)
993    ;;(len-test #x-1FFFFFFFFFFFFFFF)
994
995    (len-test #x1)
996    (len-test #x10)
997    (len-test #x100)
998    (len-test #x1000)
999    (len-test #x10000)
1000    (len-test #x100000)
1001    (len-test #x1000000)
1002    (len-test #x10000000)
1003    ;;(len-test #x100000000)
1004    ;;(len-test #x1000000000)
1005    ;;(len-test #x10000000000)
1006    ;;(len-test #x100000000000)
1007    ;;(len-test #x1000000000000)
1008    ;;(len-test #x10000000000000)
1009    ;;(len-test #x100000000000000)
1010    ;;(len-test #x1000000000000000)
1011    (len-test #x-1)
1012    (len-test #x-10)
1013    (len-test #x-100)
1014    (len-test #x-1000)
1015    (len-test #x-10000)
1016    (len-test #x-100000)
1017    (len-test #x-1000000)
1018    (len-test #x-10000000)
1019    ;;(len-test #x-100000000)
1020    ;;(len-test #x-1000000000)
1021    ;;(len-test #x-10000000000)
1022    ;;(len-test #x-100000000000)
1023    ;;(len-test #x-1000000000000)
1024    ;;(len-test #x-10000000000000)
1025    ;;(len-test #x-100000000000000)
1026    ;;(len-test #x-1000000000000000)
1027
1028    (len-test #x1)
1029    (len-test #x11)
1030    (len-test #x101)
1031    (len-test #x1001)
1032    (len-test #x10001)
1033    (len-test #x100001)
1034    (len-test #x1000001)
1035    (len-test #x10000001)
1036    ;;(len-test #x100000001)
1037    ;;(len-test #x1000000001)
1038    ;;(len-test #x10000000001)
1039    ;;(len-test #x100000000001)
1040    ;;(len-test #x1000000000001)
1041    ;;(len-test #x10000000000001)
1042    ;;(len-test #x100000000000001)
1043    ;;(len-test #x1000000000000001)
1044    (len-test #x-1)
1045    (len-test #x-11)
1046    (len-test #x-101)
1047    (len-test #x-1001)
1048    (len-test #x-10001)
1049    (len-test #x-100001)
1050    (len-test #x-1000001)
1051    (len-test #x-10000001)
1052    ;;(len-test #x-100000001)
1053    ;;(len-test #x-1000000001)
1054    ;;(len-test #x-10000000001)
1055    ;;(len-test #x-100000000001)
1056    ;;(len-test #x-1000000000001)
1057    ;;(len-test #x-10000000000001)
1058    ;;(len-test #x-100000000000001)
1059    ;;(len-test #x-1000000000000001)
1060
1061    (len-test (greatest-fixnum))
1062    (len-test (least-fixnum))
1063
1064    (count-test 1)
1065    ;;(count-test 28472347823493290482390849023840928390482309480923840923840983)
1066    ;;(count-test -847234234903290482390849023840928390482309480923840923840983)
1067    (count-test (greatest-fixnum))
1068    (count-test (least-fixnum))
1069
1070    (test -13 (bitwise-not 12))
1071    (test 11 (bitwise-not -12))
1072    (test 0 (bitwise-not -1))
1073    (test -1 (bitwise-not 0))
1074    (test (least-fixnum) (bitwise-not (greatest-fixnum)))
1075    (test (greatest-fixnum) (bitwise-not (least-fixnum)))
1076
1077    ;;(test -38947389478348937489375 (bitwise-not 38947389478348937489374))
1078    ;;(test -22300745198530623141535718272648361505980416 (bitwise-not #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
1079    ;;(test 38947389478348937489374 (bitwise-not -38947389478348937489375))
1080    ;;(test 22300745198530623141535718272648361505980414 (bitwise-not #x-FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
1081    ;;(test -340282366920938463463374607431768211456 (bitwise-not #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
1082    ;;(test 340282366920938463463374607431768211454 (bitwise-not #x-FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
1083    ;;(test -79228162514264337593543950337 (bitwise-not #x1000000000000000000000000))
1084    ;;(test 79228162514264337593543950335 (bitwise-not #x-1000000000000000000000000))
1085
1086    ;; ----------------------------------------
1087
1088    (test-error #;0 (bitwise-and (expt 2 100) 17))
1089    (test-error #;17 (bitwise-and (- (expt 2 100) 1) 17))
1090    (test-error #;(expt 2 90) (bitwise-and (- (expt 2 100) 1) (expt 2 90)))
1091
1092    (test-error #;(bitwise-ior (expt 2 100) 17) (bitwise-xor (expt 2 100) 17))
1093    (test-error #;(- (expt 2 100) 18) (bitwise-xor (- (expt 2 100) 1) 17))
1094    (test-error #;(- (expt 2 100) (expt 2 90) 1) (bitwise-xor (- (expt 2 100) 1) (expt 2 90)))
1095
1096    (test-error #;(+ (expt 2 100) 1) (bitwise-if (expt 2 100) -1 1))
1097    (test-error #;1 (bitwise-if (expt 2 100) 1 1) )
1098    (test-error #;(+ (expt 2 100) 1) (bitwise-if (expt 2 100) (- (expt 2 200) 1) 1))
1099
1100    (test-error #;1 (bitwise-bit-count (expt 2 300)))
1101    (test-error #;300 (bitwise-bit-count (- (expt 2 300) 1)))
1102    (test-error #;-301 (bitwise-bit-count (- (expt 2 300))))
1103
1104    (test-error #;301 (bitwise-length (expt 2 300)))
1105    (test-error #;300 (bitwise-length (- (expt 2 300) 1)))
1106    (test-error #;300 (bitwise-length (- (expt 2 300))))
1107
1108    (test-error #;300 (bitwise-first-bit-set (expt 2 300)))
1109    (test-error #;0 (bitwise-first-bit-set (- (expt 2 300) 1)))
1110
1111    (test-error (bitwise-bit-set? (expt 2 300) 300))
1112    (test-error (not (bitwise-bit-set? (expt 2 300) 0)))
1113    (test-error (not (bitwise-bit-set? (- (expt 2 300) 1) 300)))
1114    (test-error (bitwise-bit-set? (- (expt 2 300) 1) 299))
1115    (test-error (bitwise-bit-set? (- (expt 2 300) 1) 298))
1116    (test-error (not (bitwise-bit-set? (- (expt 2 300) 2) 0)))
1117    (test-error (bitwise-bit-set? -1 300))
1118    (test-assert (bitwise-bit-set? -1 0))
1119    (test-assert (not (bitwise-bit-set? -2 0)))
1120
1121    (test-error #;0 (bitwise-copy-bit-field (expt 2 300) 300 302 0))
1122    (test-error #;(expt 2 300) (bitwise-copy-bit-field (expt 2 300) 300 302 1))
1123    (test-error #;(expt 2 301) (bitwise-copy-bit-field (expt 2 300) 300 302 2))
1124    (test-error #;(+ (expt 2 300) (expt 2 301)) (bitwise-copy-bit-field (expt 2 300) 300 302 3))
1125
1126    (test-error #;(expt 2 301) (bitwise-arithmetic-shift (expt 2 300) 1))
1127    (test-error #;(expt 2 299) (bitwise-arithmetic-shift (expt 2 300) -1))
1128    (test-error #;(expt 2 600) (bitwise-arithmetic-shift (expt 2 300) 300))
1129    (test-error #;1 (bitwise-arithmetic-shift (expt 2 300) -300))
1130
1131    (test-error #;(expt 2 301) (bitwise-arithmetic-shift-left (expt 2 300) 1))
1132    (test-error #;(expt 2 299) (bitwise-arithmetic-shift-right (expt 2 300) 1))
1133    (test-error #;(expt 2 600) (bitwise-arithmetic-shift-left (expt 2 300) 300))
1134    (test-error #;1 (bitwise-arithmetic-shift-right (expt 2 300) 300))
1135
1136    (test-error #;(expt 2 302) (bitwise-rotate-bit-field (expt 2 300) 299 304 2))
1137    (test-error #;(expt 2 299) (bitwise-rotate-bit-field (expt 2 300) 299 304 4))
1138
1139    (test-error #;(expt 2 302) (bitwise-reverse-bit-field (expt 2 300) 299 304))
1140  )
1141)
1142
1143;;;
1144
1145(run-arithmetic-fixnums-tests)
1146(run-arithmetic-flonums-tests)
1147(run-arithmetic-bitwise-tests)
Note: See TracBrowser for help on using the repository browser.