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

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

Added fx rep chk to /carry routines. Fixed product rep chk. Use of add1/sub1. Made deliberate attempt at over/underflow in test an error.

File size: 37.6 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 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 0 (bitwise-and (expt 2 100) 17))
1089    (test 17 (bitwise-and (- (expt 2 100) 1) 17))
1090    (test (expt 2 90) (bitwise-and (- (expt 2 100) 1) (expt 2 90)))
1091
1092    (test (bitwise-ior (expt 2 100) 17) (bitwise-xor (expt 2 100) 17))
1093    (test (- (expt 2 100) 18) (bitwise-xor (- (expt 2 100) 1) 17))
1094    (test (- (expt 2 100) (expt 2 90) 1) (bitwise-xor (- (expt 2 100) 1) (expt 2 90)))
1095
1096    (test (+ (expt 2 100) 1) (bitwise-if (expt 2 100) -1 1))
1097    (test 1 (bitwise-if (expt 2 100) 1 1) )
1098    (test (+ (expt 2 100) 1) (bitwise-if (expt 2 100) (- (expt 2 200) 1) 1))
1099
1100    (test 1 (bitwise-bit-count (expt 2 300)))
1101    (test 300 (bitwise-bit-count (- (expt 2 300) 1)))
1102    (test -301 (bitwise-bit-count (- (expt 2 300))))
1103
1104    (test 301 (bitwise-length (expt 2 300)))
1105    (test 300 (bitwise-length (- (expt 2 300) 1)))
1106    (test 300 (bitwise-length (- (expt 2 300))))
1107
1108    (test 300 (bitwise-first-bit-set (expt 2 300)))
1109    (test 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-assert (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 (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.