~ chicken-core (chicken-5) /tests/numbers-test-ashinn.scm

  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)