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

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

Update inlines. Testing.

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