1(include "test.scm")
2
3(import (chicken bitwise))
4
5(current-test-epsilon 0) ;; We want exact comparisons by default
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;; run tests
9
10(test-begin "numbers (Alex Shinn's tests)")
11
12(test-group "basic cases, fixnum base"
13  (test-equal (expt 0 0) 1)
14  (test-equal (expt 2 0) 1)
15  (test-equal (expt 2 1) 2)
16  (test-equal (expt 2 2) 4)
17  (test-equal (expt 3 2) 9)
18  (test-equal (expt 3 2.0) 9.0)
19  (parameterize ((current-test-epsilon 0.001))
20    (test-equal (expt 3 2.1) 10.0451)
21    (test-equal (expt 3 0.1) 1.1161)
22    (test-equal (expt 3 -1) (/ 1 3))
23    (test-equal (expt 3 -2) (/ 1 9))
24    (test-equal (expt 3 -2.1) 0.09955)))
25
26(test-group "basic cases, flonum base"
27  (test-equal (expt 0.0 0) 1.0)
28  (test-equal (expt 3.14 0) 1.0)
29  (test-equal (expt 3.14 1) 3.14)
30  (test-equal (expt 3.14 2) 9.8596)
31  (test-equal (expt 3.14 2.0) 9.8596)
32  (parameterize ((current-test-epsilon 0.001))
33    (test-equal (expt 3.14 2.1) 11.0548)
34    (test-equal (expt 3.14 0.1) 1.1212)
35    (test-equal (expt 3.14 -1) 0.31847)
36    (test-equal (expt 3.14 -2) 0.10142)
37    (test-equal (expt 3.14 -2.1) 0.090458)))
38
39(test-group "overflows into bignums"
40  (test-equal (expt 2 30) 1073741824)
41  (test-equal (expt 2 31) 2147483648)
42  (test-equal (expt 2 32) 4294967296)
43  (test-equal (expt 2 62) 4611686018427387904)
44  (test-equal (expt 2 63) 9223372036854775808)
45  (test-equal (expt 2 64) 18446744073709551616))
46
47(define (one-followed-by-n-zeros n)
48  (string->number (string-append "1" (make-string n #\0))))
49
50(test-group "bug reported on the chicken list"
51  (test-equal (expt 10 100) (one-followed-by-n-zeros 100)))
52
53(test-group "bignum base"
54  (test-equal (expt (one-followed-by-n-zeros 100) 0) 1)
55  (parameterize ((current-test-epsilon 0.001))
56    (test-equal (expt (one-followed-by-n-zeros 100) 1) (one-followed-by-n-zeros 100))
57    (test-equal (expt (one-followed-by-n-zeros 100) 2) (one-followed-by-n-zeros 200))
58    (test-equal (expt (one-followed-by-n-zeros 100) 0.1) 10000000000.0)))
59
60(define (real-approx= expected result)
61  (cond ((zero? result) (< (abs expected) (current-test-epsilon)))
62        ((zero? expected) (< (abs result) (current-test-epsilon)))
63        (else (< (min (abs (- 1 (/ expected result)))
64                      (abs (- 1 (/ result expected))))
65                 (current-test-epsilon)))))
66
67;; test-equal? doesn't work on compnums
68(define (test-equal/comp? a b)
69  (and (real-approx= (real-part a) (real-part b))
70       (real-approx= (imag-part a) (imag-part b))))
71
72(test-group "e^(pi*i) = -1"
73  (parameterize ((current-test-epsilon 0.001)
74                 (current-test-comparator test-equal/comp?))
75    (test-equal (expt (exp 1) (* (acos -1) (sqrt -1))) -1.0)))
76
77(test-group "rational rounding"
78  (test-equal (round (/ 9 10)) 1)
79  (test-equal (round (/ 6 10)) 1)
80  (test-equal (round (/ 5 10)) 0)
81  (test-equal (round (/ 1 10)) 0)
82  (test-equal (round (/ 0 10)) 0)
83  (test-equal (round (/ -1 10)) 0)
84  (test-equal (round (/ -5 10)) 0)
85  (test-equal (round (/ -6 10)) -1)
86  (test-equal (round (/ -9 10)) -1)
87  (test-equal (round (/ (expt 10 10000) (+ (expt 10 10000) 1))) 1)
88  (test-equal (round (/ (+ 1 (expt 10 10000)) (expt 10 100))) (expt 10 9900)))
89
90(test-group "srfi-33"
91  (test-equal (bitwise-and #b0 #b1) 0)
92  (test-equal (bitwise-and #b1 #b1) 1)
93  (test-equal (bitwise-and #b1 #b10) 0)
94  (test-equal (bitwise-and #b11 #b10) #b10)
95  (test-equal (bitwise-and #b101 #b111) #b101)
96  (test-equal (bitwise-and -1 #b111) #b111)
97  (test-equal (bitwise-and -2 #b111) #b110)
98  (test-equal (bitwise-and -4290775858 1694076839) 3769478)
99  (test-equal (bitwise-and -193073517 1689392892) 1680869008)
100  ;; (test-equal (bitwise-ior 1694076839 -4290775858) -2600468497)
101  ;; (test-equal (bitwise-ior -193073517 1689392892) -184549633)
102  ;; (test-equal (bitwise-xor 1694076839 -4290775858) -2604237975)
103  ;; (test-equal (bitwise-xor -193073517 1689392892) -1865418641)
104
105  (test-equal (arithmetic-shift 1 0) 1)
106  (test-equal (arithmetic-shift 1 1) 2)
107  (test-equal (arithmetic-shift 1 2) 4)
108  (test-equal (arithmetic-shift 1 3) 8)
109  (test-equal (arithmetic-shift 1 4) 16)
110  (test-equal (arithmetic-shift 1 31) (expt 2 31))
111  (test-equal (arithmetic-shift 1 32) (expt 2 32))
112  (test-equal (arithmetic-shift 1 33) (expt 2 33))
113  (test-equal (arithmetic-shift 1 63) (expt 2 63))
114  (test-equal (arithmetic-shift 1 64) (expt 2 64))
115  (test-equal (arithmetic-shift 1 65) (expt 2 65))
116  (test-equal (arithmetic-shift 1 127) (expt 2 127))
117  (test-equal (arithmetic-shift 1 128) (expt 2 128))
118  (test-equal (arithmetic-shift 1 129) (expt 2 129))
119  (test-equal (arithmetic-shift 11829675785914119 8) 3028397001194014464)
120
121  (test-equal (arithmetic-shift -1 0) -1)
122  (test-equal (arithmetic-shift -1 1) -2)
123  (test-equal (arithmetic-shift -1 2) -4)
124  (test-equal (arithmetic-shift -1 3) -8)
125  (test-equal (arithmetic-shift -1 4) -16)
126  (test-equal (arithmetic-shift -1 31) (- (expt 2 31)))
127  (test-equal (arithmetic-shift -1 32) (- (expt 2 32)))
128  (test-equal (arithmetic-shift -1 33) (- (expt 2 33)))
129  (test-equal (arithmetic-shift -1 63) (- (expt 2 63)))
130  (test-equal (arithmetic-shift -1 64) (- (expt 2 64)))
131  (test-equal (arithmetic-shift -1 65) (- (expt 2 65)))
132  (test-equal (arithmetic-shift -1 127) (- (expt 2 127)))
133  (test-equal (arithmetic-shift -1 128) (- (expt 2 128)))
134  (test-equal (arithmetic-shift -1 129) (- (expt 2 129)))
135
136  (test-equal (arithmetic-shift 1 -63) 0)
137  (test-equal (arithmetic-shift 1 -64) 0)
138  (test-equal (arithmetic-shift 1 -65) 0)
139
140  (test-equal (arithmetic-shift #x100000000000000010000000000000000 64)
141	      #x1000000000000000100000000000000000000000000000000)
142
143  (test-assert (not (bit->boolean 1 64)))
144  (test-assert (bit->boolean #x10000000000000000 64)))
145
146(test-end)
147
148(test-exit)
149