1;;
2;; test numeric system implementation
3;;
4
5(use gauche.test)
6
7(define (exp2 pow)
8  (do ((i 0 (+ i 1))
9       (m 1 (+ m m)))
10      ((>= i pow) m)))
11
12(define (fermat n)                      ;Fermat's number
13  (+ (expt 2 (expt 2 n)) 1))
14
15(define Apply apply)  ; avoid inline expansion
16
17(test-start "numbers")
18
19;;==================================================================
20;; Reader/writer
21;;
22
23;;------------------------------------------------------------------
24(test-section "integer addition & reader")
25
26(define (i-tester x)
27  (list x (+ x -1 x) (+ x x) (- x) (- (+ x -1 x)) (- 0 x x) (- 0 x x 1)))
28
29(test* "around 2^28"
30       '(268435456 536870911 536870912
31         -268435456 -536870911 -536870912 -536870913)
32       (i-tester (exp2 28)))
33
34(test* "around 2^31"
35       '(2147483648 4294967295 4294967296
36         -2147483648 -4294967295 -4294967296 -4294967297)
37       (i-tester (exp2 31)))
38
39(test* "around 2^60"
40       '(1152921504606846976 2305843009213693951 2305843009213693952
41         -1152921504606846976 -2305843009213693951 -2305843009213693952
42         -2305843009213693953)
43       (i-tester (exp2 60)))
44
45(test* "around 2^63"
46       '(9223372036854775808 18446744073709551615 18446744073709551616
47         -9223372036854775808 -18446744073709551615 -18446744073709551616
48         -18446744073709551617)
49       (i-tester (exp2 63)))
50
51(test* "around 2^127"
52       '(170141183460469231731687303715884105728
53         340282366920938463463374607431768211455
54         340282366920938463463374607431768211456
55         -170141183460469231731687303715884105728
56         -340282366920938463463374607431768211455
57         -340282366920938463463374607431768211456
58         -340282366920938463463374607431768211457)
59       (i-tester (exp2 127)))
60
61;; test for reader's overflow detection code
62(test* "peculiarity around 2^32"
63      (* 477226729 10) 4772267290)
64
65(test* "radix" '(43605 342391 718048024785
66                 123456789 123456789987654321
67                 1193046 3735928559 3735928559
68                 1049836114599 8455360875
69                 1049836114599 1049836114599 -668 668 -668)
70       (list #b1010101001010101
71             #o1234567
72             #o12345677654321
73             #d123456789
74             #d123456789987654321
75             #x123456
76             #xdeadbeef
77             #xDeadBeef
78             #36rdeadbeef
79             #18RDeadBeef
80             #36r#edeadbeef
81             #e#36rdeadbeef
82             #8r-1234
83             #8r#e+1234
84             #e#8r-1234))
85
86(test* "exactness" #t (exact? #e10))
87(test* "exactness" #t (exact? #e10.0))
88(test* "exactness" #t (exact? #e10e10))
89(test* "exactness" #t (exact? #e12.34))
90(test* "inexactness" #f (exact? #i10))
91(test* "inexactness" #f (exact? #i10.0))
92(test* "inexactness" #f (exact? #i12.34))
93
94(test* "exactness & radix" '(#t 3735928559 #t 3735928559)
95       (list (exact? #e#xdeadbeef)
96             #e#xdeadbeef
97             (exact? #x#edeadbeef)
98             #x#edeadbeef))
99(test* "inexactness & radix" '(#f 3735928559.0 #f 3735928559.0)
100       (list (exact? #i#xdeadbeef)
101             #i#xdeadbeef
102             (exact? #x#ideadbeef)
103             #x#ideadbeef))
104
105(test* "invalid exactness/radix spec" #f
106       (or (string->number "#e")
107           (string->number "#i")
108           (string->number "#e#i3")
109           (string->number "#i#e5")
110           (string->number "#x#o13")
111           (string->number "#e#b#i00101")
112           (string->number "#123r15")
113           (string->number "#x#12r15")
114           (string->number "#12r#x15")))
115
116(test* "radix prefix not allowed in strict r7rs"
117       (test-error <read-error> #/Radix prefix isn't allowed/)
118       (read-from-string "#!r7rs #12r123"))
119
120(test* "string->number exact argument" #t
121       (eqv? (string->number "0.1234567890123" 10 'exact)
122             1234567890123/10000000000000))
123(test* "string->number exact argument (override)" #t
124       (eqv? (string->number "#i0.1234567890123" 10 'exact)
125             0.1234567890123))
126(test* "string->number inexact argument" #t
127       (eqv? (string->number "1/3" 10 'inexact)
128             0.3333333333333333))
129(test* "string->number inexact argument" #t
130       (eqv? (string->number "#e1/3" 10 'inexact)
131             1/3))
132
133(define (radix-tester radix)
134  (list
135   (let loop ((digits 0)
136              (input "1")
137              (value 1))
138     (cond ((> digits 64) #t)
139           ((eqv? (string->number input radix) value)
140            (loop (+ digits 1) (string-append input "0") (* value radix)))
141           (else #f)))
142   (let loop ((digits 0)
143              (input (string (integer->digit (- radix 1) radix)))
144              (value (- radix 1)))
145     (cond ((> digits 64) #t)
146           ((eqv? (string->number input radix) value)
147            (loop (+ digits 1)
148                  (string-append input (string (integer->digit (- radix 1) radix)))
149                  (+ (* value radix) (- radix 1))))
150           (else #f)))))
151
152(test* "base-2 reader" '(#t #t) (radix-tester 2))
153(test* "base-3 reader" '(#t #t) (radix-tester 3))
154(test* "base-4 reader" '(#t #t) (radix-tester 4))
155(test* "base-5 reader" '(#t #t) (radix-tester 5))
156(test* "base-6 reader" '(#t #t) (radix-tester 6))
157(test* "base-7 reader" '(#t #t) (radix-tester 7))
158(test* "base-8 reader" '(#t #t) (radix-tester 8))
159(test* "base-9 reader" '(#t #t) (radix-tester 9))
160(test* "base-10 reader" '(#t #t) (radix-tester 10))
161(test* "base-11 reader" '(#t #t) (radix-tester 11))
162(test* "base-12 reader" '(#t #t) (radix-tester 12))
163(test* "base-13 reader" '(#t #t) (radix-tester 13))
164(test* "base-14 reader" '(#t #t) (radix-tester 14))
165(test* "base-15 reader" '(#t #t) (radix-tester 15))
166(test* "base-16 reader" '(#t #t) (radix-tester 16))
167(test* "base-17 reader" '(#t #t) (radix-tester 17))
168(test* "base-18 reader" '(#t #t) (radix-tester 18))
169(test* "base-19 reader" '(#t #t) (radix-tester 19))
170(test* "base-20 reader" '(#t #t) (radix-tester 20))
171(test* "base-21 reader" '(#t #t) (radix-tester 21))
172(test* "base-22 reader" '(#t #t) (radix-tester 22))
173(test* "base-23 reader" '(#t #t) (radix-tester 23))
174(test* "base-24 reader" '(#t #t) (radix-tester 24))
175(test* "base-25 reader" '(#t #t) (radix-tester 25))
176(test* "base-26 reader" '(#t #t) (radix-tester 26))
177(test* "base-27 reader" '(#t #t) (radix-tester 27))
178(test* "base-28 reader" '(#t #t) (radix-tester 28))
179(test* "base-29 reader" '(#t #t) (radix-tester 29))
180(test* "base-30 reader" '(#t #t) (radix-tester 30))
181(test* "base-31 reader" '(#t #t) (radix-tester 31))
182(test* "base-32 reader" '(#t #t) (radix-tester 32))
183(test* "base-33 reader" '(#t #t) (radix-tester 33))
184(test* "base-34 reader" '(#t #t) (radix-tester 34))
185(test* "base-35 reader" '(#t #t) (radix-tester 35))
186(test* "base-36 reader" '(#t #t) (radix-tester 36))
187
188(test* "Gauche extended format" #x123456789
189       (string->number "#x1_2345_6789"))
190(test* "Gauche extended format" #x-123456789
191       (string->number "#x-123_456_789"))
192(test* "Gauche extended format" #f
193       (string->number "123_456_789"))
194(test* "Gauche extended format not allowed in r7rs strict mode"
195       (test-error <read-error> #/bad numeric format/)
196       (read-from-string "#!r7rs #x1234_5678"))
197
198;;------------------------------------------------------------------
199(test-section "rational reader")
200
201(define (rational-test v)
202  (if (number? v) (list v (exact? v)) v))
203
204(test* "rational reader" '(1234 #t) (rational-test '1234/1))
205(test* "rational reader" '(-1234 #t) (rational-test '-1234/1))
206(test* "rational reader" '(1234 #t) (rational-test '+1234/1))
207(test* "rational reader" '|1234/-1| (rational-test '1234/-1))
208(test* "rational reader" '(1234 #t) (rational-test '2468/2))
209(test* "rational reader" '(1/2 #t) (rational-test '1/2))
210(test* "rational reader" '(-1/2 #t) (rational-test '-1/2))
211(test* "rational reader" '(1/2 #t) (rational-test '+1/2))
212(test* "rational reader" '(1/2 #t) (rational-test '751/1502))
213
214(test* "rational reader" '(1 #t)
215       (rational-test (string->number "3/03")))
216(test* "rational reader" #f
217       (rational-test (string->number "3/0")))
218(test* "rational reader" #f
219       (rational-test (string->number "-3/0")))
220(test* "rational reader" #f
221       (rational-test (string->number "0/0")))
222(test* "rational reader" '(+inf.0 #f)
223       (rational-test (string->number "#i3/0")))
224(test* "rational reader" '(-inf.0 #f)
225       (rational-test (string->number "#i-3/0")))
226(test* "rational reader" '(+nan.0 #f)
227       (rational-test (string->number "#i0/0")))
228(test* "rational reader" #f
229       (rational-test (string->number "3/3/4")))
230(test* "rational reader" #f
231       (rational-test (string->number "1/2.")))
232(test* "rational reader" #f
233       (rational-test (string->number "1.3/2")))
234
235(test* "rational reader" (test-error)
236       (rational-test (read-from-string "#e3/0")))
237(test* "rational reader" (test-error)
238       (rational-test (read-from-string "#e-3/0")))
239
240(test* "rational reader w/#e" '(1234 #t)
241       (rational-test '#e1234/1))
242(test* "rational reader w/#e" '(-1234 #t)
243       (rational-test '#e-1234/1))
244(test* "rational reader w/#e" '(32/7 #t)
245       (rational-test '#e32/7))
246(test* "rational reader w/#e" '(-32/7 #t)
247       (rational-test '#e-32/7))
248(test* "rational reader w/#i" '(1234.0 #f)
249       (rational-test '#i1234/1))
250(test* "rational reader w/#i" '(-1234.0 #f)
251       (rational-test '#i-1234/1))
252(test* "rational reader w/#i" '(-0.125 #f)
253       (rational-test '#i-4/32))
254
255(test* "rational reader w/radix" '(15 #t)
256       (rational-test '#e#xff/11))
257(test* "rational reader w/radix" '(56 #t)
258       (rational-test '#o770/11))
259(test* "rational reader w/radix" '(15.0 #f)
260       (rational-test '#x#iff/11))
261
262(test* "rational reader edge case" #t (symbol? (read-from-string "/1")))
263(test* "rational reader edge case" #t (symbol? (read-from-string "-/1")))
264(test* "rational reader edge case" #t (symbol? (read-from-string "+/1")))
265
266;;------------------------------------------------------------------
267(test-section "flonum reader")
268
269(define (flonum-test s)
270  (let1 v (read-from-string s)
271    (if (number? v) (list v (inexact? v)) v)))
272
273(test* "flonum reader" '(3.14 #t)  (flonum-test "3.14"))
274(test* "flonum reader" '(0.14 #t)  (flonum-test "0.14"))
275(test* "flonum reader" '(0.14 #t)  (flonum-test ".14"))
276(test* "flonum reader" '(3.0  #t)  (flonum-test "3."))
277(test* "flonum reader" '(-3.14 #t)  (flonum-test "-3.14"))
278(test* "flonum reader" '(-0.14 #t)  (flonum-test "-0.14"))
279(test* "flonum reader" '(-0.14 #t)  (flonum-test "-.14"))
280(test* "flonum reader" '(-3.0  #t)  (flonum-test "-3."))
281(test* "flonum reader" '(3.14 #t)  (flonum-test "+3.14"))
282(test* "flonum reader" '(0.14 #t)  (flonum-test "+0.14"))
283(test* "flonum reader" '(0.14 #t)  (flonum-test "+.14"))
284(test* "flonum reader" '(3.0  #t)  (flonum-test "+3."))
285(test* "flonum reader" '(0.0  #t)  (flonum-test ".0"))
286(test* "flonum reader" '(0.0  #t)  (flonum-test "0."))
287(test* "flonum reader" #f (string->number "."))
288(test* "flonum reader" #f (string->number "-."))
289(test* "flonum reader" #f (string->number "+."))
290
291(test* "flonum reader (exp)" '(314.0 #t) (flonum-test "3.14e2"))
292(test* "flonum reader (exp)" '(314.0 #t) (flonum-test ".314e3"))
293(test* "flonum reader (exp)" '(314.0 #t) (flonum-test "314e0"))
294(test* "flonum reader (exp)" '(314.0 #t) (flonum-test "314e-0"))
295(test* "flonum reader (exp)" '(314.0 #t) (flonum-test "3140000e-4"))
296(test* "flonum reader (exp)" '(-314.0 #t) (flonum-test "-3.14e2"))
297(test* "flonum reader (exp)" '(-314.0 #t) (flonum-test "-.314e3"))
298(test* "flonum reader (exp)" '(-314.0 #t) (flonum-test "-314e0"))
299(test* "flonum reader (exp)" '(-314.0 #t) (flonum-test "-314.e-0"))
300(test* "flonum reader (exp)" '(-314.0 #t) (flonum-test "-3140000e-4"))
301(test* "flonum reader (exp)" '(314.0 #t) (flonum-test "+3.14e2"))
302(test* "flonum reader (exp)" '(314.0 #t) (flonum-test "+.314e3"))
303(test* "flonum reader (exp)" '(314.0 #t) (flonum-test "+314.e0"))
304(test* "flonum reader (exp)" '(314.0 #t) (flonum-test "+314e-0"))
305(test* "flonum reader (exp)" '(314.0 #t) (flonum-test "+3140000.000e-4"))
306
307(test* "flonum reader (exp)" '(314.0 #t) (flonum-test ".314E3"))
308(test* "flonum reader (exp)" '(314.0 #t) (flonum-test ".314s3"))
309(test* "flonum reader (exp)" '(314.0 #t) (flonum-test ".314S3"))
310(test* "flonum reader (exp)" '(314.0 #t) (flonum-test ".314l3"))
311(test* "flonum reader (exp)" '(314.0 #t) (flonum-test ".314L3"))
312(test* "flonum reader (exp)" '(314.0 #t) (flonum-test ".314f3"))
313(test* "flonum reader (exp)" '(314.0 #t) (flonum-test ".314F3"))
314(test* "flonum reader (exp)" '(314.0 #t) (flonum-test ".314d3"))
315(test* "flonum reader (exp)" '(314.0 #t) (flonum-test ".314D3"))
316
317(test* "flonum reader (minimum denormalized number 5.0e-324)" #t
318       (let1 x (expt 2.0 -1074)
319         (= x (string->number (number->string x)))))
320(test* "flonum reader (minimum denormalized number -5.0e-324)" #t
321       (let1 x (- (expt 2.0 -1074))
322         (= x (string->number (number->string x)))))
323
324(test* "flonum reader lots of digits" 1.0
325       (read-from-string
326        "1.000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001"))
327(test* "flonum reader lots of digits" 1.0e308
328       (read-from-string
329        "1.000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001e308"))
330
331;; This hanged in 0.9.1.  See Jens Thiele's message in gauche-devel
332;; in Feb. 2011.
333(test* "flonum reader (minimum normalized number)" #t
334       (= (expt 2.0 (- 52 1074))
335          (string->number "2.2250738585072012e-308")))
336
337;; Bugs reported
338(test* "flonum reader (zero with big exponent)" '(#t #t)
339       (list (= 0.0 (string->number "0e324"))
340             (= 0.0 (string->number "0e325"))))
341
342;; We used to allow 1#1 to be read as a symbol.  As of 0.9.4, it is an error.
343(test* "padding" '(10.0 #t) (flonum-test "1#"))
344(test* "padding" '(10.0 #t) (flonum-test "1#."))
345(test* "padding" '(10.0 #t) (flonum-test "1#.#"))
346(test* "padding" '(100.0 #t) (flonum-test "10#.#"))
347(test* "padding" '(100.0 #t) (flonum-test "1##.#"))
348(test* "padding" '(100.0 #t) (flonum-test "100.0#"))
349(test* "padding" '(1.0 #t) (flonum-test "1.#"))
350
351(test* "padding" (test-error) (flonum-test "1#1"))
352(test* "padding" (test-error) (flonum-test "1##1"))
353(test* "padding" (test-error) (flonum-test "1#.1"))
354(test* "padding" (test-error) (flonum-test "1.#1"))
355
356(test* "padding" (test-error) (flonum-test ".#"))
357(test* "padding" '(0.0 #t) (flonum-test "0.#"))
358(test* "padding" '(0.0 #t) (flonum-test ".0#"))
359(test* "padding" '(0.0 #t) (flonum-test "0#"))
360(test* "padding" '(0.0 #t) (flonum-test "0#.#"))
361(test* "padding" (test-error) (flonum-test "0#.0"))
362
363(test* "padding" '(1000.0 #t) (flonum-test "1#e2"))
364(test* "padding" '(1000.0 #t) (flonum-test "1##e1"))
365(test* "padding" '(1000.0 #t) (flonum-test "1#.##e2"))
366(test* "padding" '(0.0 #t) (flonum-test "0.#e2"))
367(test* "padding" '(0.0 #t) (flonum-test ".0#e2"))
368(test* "padding" (test-error) (flonum-test ".##e2"))
369
370(test* "padding (exactness)" '(100 #f) (flonum-test "#e1##"))
371(test* "padding (exactness)" '(120 #f) (flonum-test "#e12#"))
372(test* "padding (exactness)" '(120 #f) (flonum-test "#e12#.#"))
373(test* "padding (exactness)" '(100.0 #t) (flonum-test "#i1##"))
374(test* "padding (exactness)" '(120.0 #t) (flonum-test "#i12#"))
375(test* "padding (exactness)" '(120.0 #t) (flonum-test "#i12#.#"))
376
377(test* "exponent out-of-range 1" '(+inf.0 #t) (flonum-test "1e309"))
378(test* "exponent out-of-range 2" '(+inf.0 #t) (flonum-test "1e10000"))
379(test* "exponent out-of-range 3" '(+inf.0 #t) (flonum-test "1e1000000000000000000000000000000000000000000000000000000000000000"))
380(test* "exponent out-of-range 4" '(-inf.0 #t) (flonum-test "-1e309"))
381(test* "exponent out-of-range 5" '(-inf.0 #t) (flonum-test "-1e10000"))
382(test* "exponent out-of-range 6" '(-inf.0 #t) (flonum-test "-1e1000000000000000000000000000000000000000000000000000000000000000"))
383(test* "exponent out-of-range 7" '(0.0 #t) (flonum-test "1e-324"))
384(test* "exponent out-of-range 8" '(0.0 #t) (flonum-test "1e-1000"))
385(test* "exponent out-of-range 9" '(0.0 #t) (flonum-test "1e-1000000000000000000000000000000000000000000000000000000000000000000"))
386
387(test* "no integral part" 0.5 (read-from-string ".5"))
388(test* "no integral part" -0.5 (read-from-string "-.5"))
389(test* "no integral part" 0.5 (read-from-string "+.5"))
390
391;;------------------------------------------------------------------
392(test-section "exact fractional number")
393
394(test* "exact fractonal number" 12345
395       (string->number "#e1.2345e4"))
396(test* "exact fractonal number" 123450000000000
397       (string->number "#e1.2345e14"))
398(test* "exact fractonal number" 12345/100
399       (string->number "#e1.2345e2"))
400(test* "exact fractonal number" 12345/1000000
401       (string->number "#e1.2345e-2"))
402(test* "exact fractonal number" -12345
403       (string->number "#e-1.2345e4"))
404(test* "exact fractonal number" -123450000000000
405       (string->number "#e-1.2345e14"))
406(test* "exact fractonal number" -12345/100
407       (string->number "#e-1.2345e2"))
408(test* "exact fractonal number" -12345/1000000
409       (string->number "#e-1.2345e-2"))
410
411(test* "exact fractonal number" (%expt 10 296)
412       (string->number "#e0.0001e300"))
413(test* "exact fractonal number" (- (%expt 10 296))
414       (string->number "#e-0.0001e300"))
415
416(test* "exact fractonal number" (test-error)
417       (read-from-string "#e1e330"))
418(test* "exact fractonal number" (test-error)
419       (read-from-string "#e1e-330"))
420
421
422;;------------------------------------------------------------------
423(test-section "complex reader")
424
425(define (decompose-complex z)
426  (cond ((real? z) z)
427        ((complex? z)
428         (list (real-part z) (imag-part z)))
429        (else z)))
430
431(test* "complex reader" '(1.0 1.0) (decompose-complex '1+i))
432(test* "complex reader" '(1.0 1.0) (decompose-complex '1+1i))
433(test* "complex reader" '(1.0 -1.0) (decompose-complex '1-i))
434(test* "complex reader" '(1.0 -1.0) (decompose-complex '1-1i))
435(test* "complex reader" '(1.0 1.0) (decompose-complex '1.0+1i))
436(test* "complex reader" '(1.0 1.0) (decompose-complex '1.0+1.0i))
437(test* "complex reader" '(1e-5 1.0) (decompose-complex '1e-5+1i))
438(test* "complex reader" '(1e+5 1.0) (decompose-complex '1e+5+1i))
439(test* "complex reader" '(1.0 1e-5) (decompose-complex '1+1e-5i))
440(test* "complex reader" '(1.0 1e+5) (decompose-complex '1+1e+5i))
441(test* "complex reader" '(0.1 1e+4) (decompose-complex '0.1+0.1e+5i))
442(test* "complex reader" '(0.0 1.0) (decompose-complex '+i))
443(test* "complex reader" '(0.0 -1.0) (decompose-complex '-i))
444(test* "complex reader" '(0.0 1.0) (decompose-complex '+1i))
445(test* "complex reader" '(0.0 -1.0) (decompose-complex '-1i))
446(test* "complex reader" '(0.0 1.0) (decompose-complex '+1.i))
447(test* "complex reader" '(0.0 -1.0) (decompose-complex '-1.i))
448(test* "complex reader" '(0.0 1.0) (decompose-complex '+1.0i))
449(test* "complex reader" '(0.0 -1.0) (decompose-complex '-1.0i))
450(test* "complex reader" 1.0 (decompose-complex '1+0.0i))
451(test* "complex reader" 1.0 (decompose-complex '1+.0i))
452(test* "complex reader" 1.0 (decompose-complex '1+0.i))
453(test* "complex reader" 1.0 (decompose-complex '1+0.0e-43i))
454(test* "complex reader" 100.0 (decompose-complex '1e2+0.0e-43i))
455
456(test* "complex reader" 'i (decompose-complex 'i))
457(test* "complex reader" #f (decompose-complex (string->number ".i")))
458(test* "complex reader" #f (decompose-complex (string->number "+.i")))
459(test* "complex reader" #f (decompose-complex (string->number "-.i")))
460(test* "complex reader" '33i (decompose-complex '33i))
461(test* "complex reader" 'i+1 (decompose-complex 'i+1))
462(test* "complex reader" '|++i| (decompose-complex '++i))
463(test* "complex reader" '|--i| (decompose-complex '--i))
464
465(test* "complex reader" '(0.5 0.5) (decompose-complex 1/2+1/2i))
466(test* "complex reader" '(0.0 0.5) (decompose-complex 0+1/2i))
467(test* "complex reader" '(0.0 -0.5) (decompose-complex -1/2i))
468(test* "complex reader" 1/2 (decompose-complex 1/2-0/2i))
469(test* "complex reader" #f (decompose-complex (string->number "1/2-1/0i")))
470
471(test* "complex reader (polar)" (make-polar 1.0 1.0) 1.0@1.0)
472(test* "complex reader (polar)" (make-polar 1.0 -1.0) 1.0@-1.0)
473(test* "complex reader (polar)" (make-polar 1.0 1.0) 1.0@+1.0)
474(test* "complex reader (polar)" (make-polar -7.0 -3.0) -7@-3.0)
475(test* "complex reader (polar)" (make-polar 3.5 -3.0) 7/2@-3.0)
476(test* "complex reader (polar)" #f (string->number "7/2@-3.14i"))
477
478;;------------------------------------------------------------------
479(test-section "integer writer syntax")
480
481(define (i-tester2 x)
482  (map number->string (i-tester x)))
483
484(test* "around 2^28"
485      '("268435456" "536870911" "536870912"
486        "-268435456" "-536870911" "-536870912" "-536870913")
487      (i-tester2 (exp2 28)))
488
489(test* "around 2^31"
490      '("2147483648" "4294967295" "4294967296"
491        "-2147483648" "-4294967295" "-4294967296" "-4294967297")
492      (i-tester2 (exp2 31)))
493
494(test* "around 2^60"
495      '("1152921504606846976" "2305843009213693951" "2305843009213693952"
496        "-1152921504606846976" "-2305843009213693951" "-2305843009213693952"
497        "-2305843009213693953")
498      (i-tester2 (exp2 60)))
499
500(test* "around 2^63"
501      '("9223372036854775808" "18446744073709551615" "18446744073709551616"
502        "-9223372036854775808" "-18446744073709551615" "-18446744073709551616"
503        "-18446744073709551617")
504      (i-tester2 (exp2 63)))
505
506(test* "around 2^127"
507      '("170141183460469231731687303715884105728"
508        "340282366920938463463374607431768211455"
509        "340282366920938463463374607431768211456"
510        "-170141183460469231731687303715884105728"
511        "-340282366920938463463374607431768211455"
512        "-340282366920938463463374607431768211456"
513        "-340282366920938463463374607431768211457")
514      (i-tester2 (exp2 127)))
515
516;;------------------------------------------------------------------
517(test-section "number->string radix")
518
519(test* "number->string radix 1"
520       '("100101" "1101" "211" "122" "101" "52" "45" "41" "37" "34"
521         "31" "2b" "29" "27" "25" "23" "21" "1i" "1h" "1g"
522         "1f" "1e" "1d" "1c" "1b" "1a" "19" "18" "17" "16"
523         "15" "14" "13" "12" "11")
524       (map (cut number->string <> <>) (make-list 35 37) (iota 35 2)))
525
526(test* "number->string radix error 1" (test-error) (number->string 42 0))
527(test* "number->string radix error 2" (test-error) (number->string 42 1))
528(test* "number->string radix error 3" (test-error) (number->string 42 37))
529
530;;------------------------------------------------------------------
531(test-section "number->string customization")
532
533(test* "number->string flags"
534       '(("cafe" "CAFE" "CAFE" "+cafe" "#xcafe" "#x+CAFE")
535         ("cafebabedeadbeef" "CAFEBABEDEADBEEF" "CAFEBABEDEADBEEF"
536          "+cafebabedeadbeef" "#xcafebabedeadbeef" "#x+CAFEBABEDEADBEEF")
537         ("0" "0" "0" "+0" "#x0" "#x+0")
538         ("-e" "-E" "-E" "-e" "#x-e" "#x-E")
539         ("a/b" "A/B" "A/B" "+a/b" "#xa/b" "#x+A/B")
540         ("1.0+1.0i" "1.0+1.0i" "1.0+1.0i" "+1.0+1.0i" "1.0+1.0i" "+1.0+1.0i"))
541       (map (^n (map (cut number->string n 16 <>)
542                     '(#f #t (uppercase) (plus) (radix) (uppercase plus radix))))
543            '(#xcafe #xcafebabedeadbeef 0 -14 10/11 1+i)))
544
545;; Precision
546(dolist [n '((0.123456789 "0.12346" "0.1235" "0.123" "0.12" "0.1" "0.")
547             (1.23456789 "1.23457" "1.2346" "1.235" "1.23" "1.2" "1.")
548             (12.3456789 "12.34568" "12.3457" "12.346" "12.35" "12.3" "12.")
549             (-123.456789 "-123.45679" "-123.4568" "-123.457"
550                          "-123.46" "-123.5" "-123.")
551             (1.23456789e100 "1.23457e100" "1.2346e100" "1.235e100"
552                             "1.23e100" "1.2e100" "1.e100")
553             (12.3456789e-101 "1.23457e-100" "1.2346e-100" "1.235e-100"
554                              "1.23e-100" "1.2e-100" "1.e-100")
555             (1. "1.00000" "1.0000" "1.000" "1.00" "1.0" "1.")
556             (1.1 "1.10000" "1.1000" "1.100" "1.10" "1.1" "1.")
557             (1e100 "1.00000e100" "1.0000e100" "1.000e100"
558                    "1.00e100" "1.0e100" "1.e100"))]
559  (define (runs flags)
560    (map (cut number->string (car n) 10 flags <>)
561         '(5 4 3 2 1 0)))
562  (test* "number->string digits (effective)" (cdr n) (runs #f))
563  (test* "number->string digits (notational)" (cdr n) (runs '(notational))))
564
565;; Difference between effective/notational rounding
566(dolist [data '((1.15 1 "1.1" "1.2")
567                (4.15 1 "4.2" "4.2"))]
568  (test* "effective / notational rounding"
569         (cddr data)
570         (list (number->string (car data) 10 #f (cadr data))
571               (number->string (car data) 10 '(notational) (cadr data)))))
572
573;; notational rounding carry propagation, round-to-even
574(dolist [data '((1.99999 (5 4 3 2 1) ("1.99999" "2.0000" "2.000" "2.00" "2.0"))
575                (-9.999 (4 3 2 1) ("-9.9990" "-9.999" "-10.00" "-10.0"))
576                (0.999 (4 3 2 1) ("0.9990" "0.999" "1.00" "1.0"))
577                ;(0.25 (1) ("0.2")) ; if we use banker's rounding
578                (0.25 (1) ("0.3")) ; if we use commercial rounding
579                (0.135 (2) ("0.14")))]
580  (test* "notational rounding carry over"
581         (caddr data)
582         (map (cut number->string (car data) 10 '(notational) <>)
583              (cadr data))))
584
585;;==================================================================
586;; Conversions
587;;
588
589;; We first test expt, for we need to use it to test exact<->inexact
590;; conversion stuff.
591(test-section "expt")
592
593(test* "exact expt" 1 (expt 5 0))
594(test* "exact expt" 9765625 (expt 5 10))
595(test* "exact expt" 1220703125 (expt 5 13))
596(test* "exact expt" 94039548065783000637498922977779654225493244541767001720700136502273380756378173828125 (expt 5 123))
597(test* "exact expt" 1/94039548065783000637498922977779654225493244541767001720700136502273380756378173828125 (expt 5 -123))
598(test* "exact expt" 1 (expt -5 0))
599(test* "exact expt" 9765625 (expt -5 10))
600(test* "exact expt" -1220703125 (expt -5 13))
601(test* "exact expt" -94039548065783000637498922977779654225493244541767001720700136502273380756378173828125 (expt -5 123))
602(test* "exact expt" -1/94039548065783000637498922977779654225493244541767001720700136502273380756378173828125 (expt -5 -123))
603(test* "exact expt" 1 (expt 1 720000))
604(test* "exact expt" 1 (expt -1 720000))
605(test* "exact expt" -1 (expt -1 720001))
606
607(test* "exact expt (ratinoal)" 8589934592/5559060566555523
608       (expt 2/3 33))
609(test* "exact expt (rational)" -8589934592/5559060566555523
610       (expt -2/3 33))
611(test* "exact expt (ratinoal)" 5559060566555523/8589934592
612       (expt 2/3 -33))
613
614(test* "expt (0 raised to a complex power)" 0 (expt 0 5+.0000312i))
615(test* "expt (0.0 raised to a complex power)" 0.0 (expt 0.0 5+.0000312i))
616
617(test* "expt (coercion to inexact)" 1.4142135623730951
618       (expt 2 1/2)
619       (lambda (x y) (approx=? x y))) ;; NB: pa$ will be tested later
620
621(let ()
622  (define (exact-expt-tester x y)
623    (let1 x^y (expt x y)
624      (test* "exact expt (non-integral power)" x (expt x^y (/ y)))
625      (test* "exact expt (non-integral power)" (* x x) (expt x^y (/ 2 y)))
626      (test* "exact expt (non-integral power, inexact fallback)"
627             (expt (+ x^y 1.0) (/ y)) (expt (+ x^y 1) (/ y)))
628      ))
629
630  (exact-expt-tester 3 7)
631  (exact-expt-tester 5 3)
632  (exact-expt-tester 13 17)
633  (exact-expt-tester 101 103)
634  (exact-expt-tester 11/13 23)
635  )
636
637;; expt-mod
638(define (test-expt-mod base mod)
639  ;; NB: we haven't tested iota.
640  (let1 es (do ([e 1 (+ e 3)] [r '() (cons e r)])
641               [(> e 100) (reverse r)])
642    (test* (format "expt-mod(~a, e, ~a)" base mod)
643           (map (^e (modulo (expt base e) mod)) es)
644           (map (^e (expt-mod base e mod)) es))))
645
646(test-expt-mod 35 41)
647(test-expt-mod 15841875 319999357)
648(test-expt-mod 915151975010144550184898988758 1775619891701751758948583493979350)
649(test-expt-mod -324574950475018750175057087501 100184859387038471089598349534598)
650(test-expt-mod 324574950475018750175057087501 -100184859387038471089598349534598)
651
652(test-section "exact<->inexact")
653
654(for-each
655 (lambda (e&i)
656   (let ((e (car e&i))
657         (i (cdr e&i)))
658     (test* (format "exact->inexact ~s" i) i (exact->inexact e))
659     (test* (format "exact->inexact ~s" (- i)) (- i) (exact->inexact (- e)))
660     (test* (format "inexact->exact ~s" e) e (inexact->exact i))
661     (test* (format "inexact->exact ~s" (- e)) (- e) (inexact->exact (- i)))
662     ))
663 `((0  . 0.0)
664   (1  . 1.0)
665   (,(%expt 2 52) . ,(%expt 2.0 52))
666   (,(%expt 2 53) . ,(%expt 2.0 53))
667   (,(%expt 2 54) . ,(%expt 2.0 54))
668
669   (1/2 . 0.5)
670   (3/4 . 0.75)
671
672   (1/3 . 0.3333333333333333)
673   ))
674
675;; Boundary conditions for exact->inexact
676;; If greatest-fixnum may be larger than the range the double can exactly
677;; represent, we'll lose precision.
678(test* "exact (greatest-fixnum)"
679       (if (> (greatest-fixnum) (expt 2 53))
680         (+ (greatest-fixnum) 1)
681         (greatest-fixnum))
682       (exact (inexact (greatest-fixnum))))
683(test* "exact (least-fixnum)" (least-fixnum) (exact (inexact (least-fixnum))))
684(test* "exact (64bit long max)" (expt 2 63) (exact (- (expt 2.0 63) 1)))
685(test* "exact (64bit long min)" (- (expt 2 63)) (exact (- (expt 2.0 63))))
686
687;; Boundary conditions for inexact->exact
688;; Since inexact->exact returns a simplest rational within the flonum precision,
689;; the roundtrip of exact -> inexact -> exact isn't necessary kept, but
690;; inexact -> exact -> inexact is.
691(let ([one-plus-delta 1.0000000000000002]
692      [one-minus-half-delta 0.9999999999999999])
693  (define (t what orig expect)
694    (test* (format "inexact->exact->inexact roundtrip ~s" what)
695           expect (exact->inexact (inexact->exact orig))))
696  (t "1+d" one-plus-delta one-plus-delta)
697  (t "1-d" one-minus-half-delta one-minus-half-delta))
698
699;; Rounding bignum to flonum, edge cases.
700;; Test patterns:
701;;
702;;   <------53bits------->
703;;a) 100000000...000000000100000....0000       round down (r0)
704;;b) 100000000...000000000100000....0001       round up (r1)
705;;c) 100000000...000000001100000....0000       round up (r2)
706;;d) 100000000...000000001011111....1111       round down (r1)
707;;e) 111111111...111111111100000....0000       round up, carry over (* r0 2)
708;;f) 101111111...111111111100000....0000       round up, no carry over (r3)
709;;            <--32bits-->
710;;g) 100..0000111.....1111100000....0000       round up; boundary on ILP32 (r4)
711
712(let loop ((n 0)
713           (a (+ (expt 2 53) 1))
714           (c (+ (expt 2 53) 3))
715           (e (- (expt 2 54) 1))
716           (f (+ (expt 2 53) (expt 2 52) -1))
717           (g (+ (expt 2 53) (expt 2 33) -1))
718           (r0 (expt 2.0 53))
719           (r1 (+ (expt 2.0 53) 2.0))
720           (r2 (+ (expt 2.0 53) 4.0))
721           (r3 (+ (expt 2.0 53) (expt 2.0 52)))
722           (r4 (+ (expt 2.0 53) (expt 2.0 33))))
723  (when (< n 32)
724    (test* (format "exact->inexact, pattern a: round down (~d)" n)
725           r0 (exact->inexact a))
726    (test* (format "exact->inexact, pattern b: round up   (~d)" n)
727           r1 (exact->inexact (+ a 1)))
728    (test* (format "exact->inexact, pattern c: round up   (~d)" n)
729           r2 (exact->inexact c))
730    (test* (format "exact->inexact, pattern d: round down (~d)" n)
731           r1 (exact->inexact (- c 1)))
732    (test* (format "exact->inexact, pattern e: round up   (~d)" n)
733           (* r0 2.0) (exact->inexact e))
734    (test* (format "exact->inexact, pattern f: round up   (~d)" n)
735           r3 (exact->inexact f))
736    (test* (format "exact->inexact, pattern g: round up   (~d)" n)
737           r4 (exact->inexact g))
738    (loop (+ n 1) (ash a 1) (ash c 1) (ash e 1) (ash f 1) (ash g 1)
739          (* r0 2.0) (* r1 2.0) (* r2 2.0) (* r3 2.0) (* r4 2.0))))
740
741(test* "expt (ratnum with large denom and numer) with inexact conversion 1"
742       (expt 8/9 342.0)
743       (exact->inexact (expt 8/9 342))
744       (lambda (x y) (approx=? x y (* 100 (flonum-epsilon)))))
745
746(test* "expt (ratnum with large denom and numer) with inexact conversion 2"
747       (expt -8/9 343.0)
748       (exact->inexact (expt -8/9 343))
749       (lambda (x y) (approx=? x y (* 100 (flonum-epsilon)))))
750
751;; The following few tests covers RATNUM paths in Scm_GetDouble
752(test* "expt (ratnum with large denom and numer) with inexact conversion 3"
753       1.0e-308 (exact->inexact (/ (expt 10 20) (expt 10 328))))
754(test* "expt (ratnum with large denom and numer) with inexact conversion 4"
755       1.0e-310 (exact->inexact (/ (expt 10 20) (expt 10 330))))
756(test* "expt (ratnum with large denom and numer) with inexact conversion 5"
757       1.0e308 (exact->inexact (/ (expt 10 328) (expt 10 20))))
758(test* "expt (ratnum with large denom and numer) with inexact conversion 6"
759       +inf.0 (exact->inexact (/ (expt 10 329) (expt 10 20))))
760(test* "expt (ratnum with large denom and numer) with inexact conversion 7"
761       -inf.0 (exact->inexact (/ (expt -10 329) (expt 10 20))))
762(test* "expt (ratnum with large denom and numer) with inexact conversion 8"
763       -inf.0 (exact->inexact (/ (expt 10 329) (- (expt 10 20)))))
764(test* "expt (ratnum with large denom and numer) with inexact conversion 9"
765       +inf.0 (exact->inexact (/ (expt -10 329) (- (expt 10 20)))))
766;; denormalized range
767(let ()
768  (define data '(5.0e-324   ; minimum positive denormalized flonum
769                 -5.0e-324
770                 1.0e-323
771                 1.5e-323
772                 2.0e-323
773                 1.0e-322
774                 1.04e-322
775                 1.1e-322))
776  (dolist [d data]
777    (test* #"inexact conversion in subnormal range ~d" d
778           (inexact (exact d)))))
779;; close to inifinity (but not quite)
780(test* "ratnum -> flonum, close to infinity 1" 1.0e308
781       (inexact (/ (+ (expt 10 309) 1) 10)))
782(test* "ratnum -> flonum, close to infinity 2" 1.0e308
783       (inexact (/ (+ (expt 10 310) 1) 100)))
784
785;; Double-rounding issue in ratnum->flonum
786;; http://blog.practical-scheme.net/gauche/20200722-ratnum-flonum
787(test* "rat->flo" '()
788       (rlet1 offending '()
789         (dotimes [k 100]
790           (let1 r (exact (+ 1 (* k 1/100 (exact (flonum-epsilon)))))
791             (unless (eqv? (inexact r)
792                           (if (<= k 50) 1.0 (+ 1.0 (flonum-epsilon))))
793               (push! offending (vector k (inexact r) r))))
794           (let1 r (exact (- -1 (* k 1/100 (exact (flonum-epsilon)))))
795             (unless (eqv? (inexact r)
796                           (if (<= k 50) -1.0 (- -1.0 (flonum-epsilon))))
797               (push! offending (vector k (inexact r) r)))))))
798
799;; this exhibits a bug fixed on 9/12/2013.
800(test* "real->rational" '(1/3 2/3)
801       (list (real->rational 3/10 1/10 1/10)
802             (real->rational 24/35 4/35 4/35)))
803
804(test* "rationalize (edge cases)" '(#t #t #t +inf.0 -inf.0 0.0)
805       (list (nan? (rationalize +nan.0 0))
806             (nan? (rationalize 0 +nan.0))
807             (nan? (rationalize +inf.0 +inf.0))
808             (rationalize +inf.0 0)
809             (rationalize -inf.0 0)
810             (rationalize 1234 +inf.0)))
811(test* "rationalize (integers)" '(1 2 0 -1 -2 0)
812       (list (rationalize 1 1/2)
813             (rationalize 5 3)
814             (rationalize 1 3)
815             (rationalize -1 1/2)
816             (rationalize -5 3)
817             (rationalize -1 3)))
818(test* "rationalize (exactness)" '(#t #f #f #f)
819       (list (exact? (rationalize 1/2 1/3))
820             (exact? (rationalize 0.5 1/3))
821             (exact? (rationalize 1/2 0.1))
822             (exact? (rationalize 0.5 0.1))))
823
824;;==================================================================
825;; Predicates
826;;
827
828(test-section "predicates")
829
830(test* "integer?" #t (integer? 0))
831(test* "integer?" #t (integer? 85736847562938475634534245))
832(test* "integer?" #f (integer? 85736.534245))
833(test* "integer?" #f (integer? 3.14))
834(test* "integer?" #f (integer? 3+4i))
835(test* "integer?" #t (integer? 3+0i))
836(test* "integer?" #f (integer? #f))
837(test* "integer?" #f (integer? +inf.0))
838(test* "integer?" #f (integer? -inf.0))
839(test* "integer?" #f (integer? +nan.0))
840
841(test* "rational?" #t (rational? 0))
842(test* "rational?" #t (rational? 85736847562938475634534245))
843(test* "rational?" #t (rational? 1/2))
844(test* "rational?" #t (rational? 85736.534245))
845(test* "rational?" #t (rational? 3.14))
846(test* "rational?" #f (rational? 3+4i))
847(test* "rational?" #t (rational? 3+0i))
848(test* "rational?" #f (rational? #f))
849(test* "rational?" #f (rational? +inf.0))
850(test* "rational?" #f (rational? -inf.0))
851(test* "rational?" #f (rational? +nan.0))
852
853(test* "real?" #t (real? 0))
854(test* "real?" #t (real? 85736847562938475634534245))
855(test* "real?" #t (real? 857368.4756293847))
856(test* "real?" #t (real? 3+0i))
857(test* "real?" #f (real? 3+4i))
858(test* "real?" #f (real? +4.3i))
859(test* "real?" #f (real? '()))
860(test* "real?" #t (real? +inf.0))
861(test* "real?" #t (real? -inf.0))
862(test* "real?" #t (real? +nan.0))
863
864(test* "complex?" #t (complex? 0))
865(test* "complex?" #t (complex? 85736847562938475634534245))
866(test* "complex?" #t (complex? 857368.4756293847))
867(test* "complex?" #t (complex? 3+0i))
868(test* "complex?" #t (complex? 3+4i))
869(test* "complex?" #t (complex? +4.3i))
870(test* "complex?" #f (complex? '()))
871
872(test* "number?" #t (number? 0))
873(test* "number?" #t (number? 85736847562938475634534245))
874(test* "number?" #t (number? 857368.4756293847))
875(test* "number?" #t (number? 3+0i))
876(test* "number?" #t (number? 3+4i))
877(test* "number?" #t (number? +4.3i))
878(test* "number?" #f (number? '()))
879
880(test* "exact?" #t (exact? 1))
881(test* "exact?" #t (exact? 4304953480349304983049304953804))
882(test* "exact?" #t (exact? 430495348034930/4983049304953804))
883(test* "exact?" #f (exact? 1.0))
884(test* "exact?" #f (exact? 4304953480349304983.049304953804))
885(test* "exact?" #f (exact? 1.0+0i))
886(test* "exact?" #f (exact? 1.0+5i))
887(test* "inexact?" #f (inexact? 1))
888(test* "inexact?" #f (inexact? 4304953480349304983049304953804))
889(test* "inexact?" #f (inexact? 430495348034930/4983049304953804))
890(test* "inexact?" #t (inexact? 1.0))
891(test* "inexact?" #t (inexact? 4304953480349304983.049304953804))
892(test* "inexact?" #t (inexact? 1.0+0i))
893(test* "inexact?" #t (inexact? 1.0+5i))
894
895(test* "odd?" #t (odd? 1))
896(test* "odd?" #f (odd? 2))
897(test* "even?" #f (even? 1))
898(test* "even?" #t (even? 2))
899(test* "odd?" #t (odd? 1.0))
900(test* "odd?" #f (odd? 2.0))
901(test* "even?" #f (even? 1.0))
902(test* "even?" #t (even? 2.0))
903(test* "odd?" #t (odd? 10000000000000000000000000000000000001))
904(test* "odd?" #f (odd? 10000000000000000000000000000000000002))
905(test* "even?" #f (even? 10000000000000000000000000000000000001))
906(test* "even?" #t (even? 10000000000000000000000000000000000002))
907
908(test* "zero?" #t (zero? 0))
909(test* "zero?" #t (zero? 0.0))
910(test* "zero?" #t (zero? (- 10 10.0)))
911(test* "zero?" #t (zero? 0+0i))
912(test* "zero?" #f (zero? 1.0))
913(test* "zero?" #f (zero? +5i))
914(test* "zero?" #f (zero? +nan.0))
915(test* "positive?" #t (positive? 1))
916(test* "positive?" #f (positive? -1))
917(test* "positive?" #t (positive? 1/7))
918(test* "positive?" #f (positive? -1/7))
919(test* "positive?" #t (positive? 3.1416))
920(test* "positive?" #f (positive? -3.1416))
921(test* "positive?" #t (positive? 134539485343498539458394))
922(test* "positive?" #f (positive? -134539485343498539458394))
923(test* "positive?" #f (positive? +nan.0))
924(test* "negative?" #f (negative? 1))
925(test* "negative?" #t (negative? -1))
926(test* "negative?" #f (negative? 1/7))
927(test* "negative?" #t (negative? -1/7))
928(test* "negative?" #f (negative? 3.1416))
929(test* "negative?" #t (negative? -3.1416))
930(test* "negative?" #f (negative? 134539485343498539458394))
931(test* "negative?" #t (negative? -134539485343498539458394))
932(test* "negative?" #f (negative? +nan.0))
933
934(let1 tester
935    (lambda (name proc result)
936      (test* name (test-error) (proc #t))
937      (test* name result
938             (list (proc 1) (proc +inf.0) (proc -inf.0) (proc +nan.0))))
939  (tester "finite?"   finite?   `(#t #f #f #f))
940  (tester "infinite?" infinite? `(#f #t #t #f))
941  (tester "nan?"      nan?      `(#f #f #f #t))
942  )
943
944
945(test* "eqv?" #t (eqv? 20 20))
946(test* "eqv?" #t (eqv? 20.0 20.00000))
947(test* "eqv?" #f (eqv? 4/5 0.8))
948(test* "eqv?" #t (eqv? (exact->inexact 4/5) 0.8))
949;(test* "eqv?" #f (eqv? 4/5 (inexact->exact 0.8)))
950(test* "eqv?" #t (eqv? 20 (inexact->exact 20.0)))
951(test* "eqv?" #f (eqv? 20 20.0))
952
953;; numeric comparison involving nan.  we should test both
954;; inlined case and applied case
955(define-macro (test-nan-cmp op)
956  `(begin
957     (test* (format "NaN ~a (inlined)" ',op) '(#f #f #f)
958            (list (,op +nan.0 +nan.0) (,op +nan.0 0) (,op 0 +nan.0)))
959     (test* (format "NaN ~a (applied)" ',op) '(#f #f #f)
960            (list (Apply ,op '(+nan.0 +nan.0))
961                  (Apply ,op '(+nan.0 0))
962                  (Apply ,op '(0 +nan.0))))))
963(test-nan-cmp =)
964(test-nan-cmp <)
965(test-nan-cmp <=)
966(test-nan-cmp >)
967(test-nan-cmp >=)
968
969;; the following tests combine instructions for comparison.
970(let ((zz #f))
971  (set! zz 3.14)  ;; prevent the compiler from optimizing constants
972
973  (test* "NUMEQF" '(#t #t #f #f)
974         (list (= 3.14 zz) (= zz 3.14) (= 3.15 zz) (= zz 3.15)))
975  (test* "NLTF" '(#f #f #f #t #t #f)
976         (list (< 3.14 zz) (< zz 3.14)
977               (< 3.15 zz) (< zz 3.15)
978               (< 3.13 zz) (< zz 3.13)))
979  (test* "NLEF" '(#t #t #f #t #t #f)
980         (list (<= 3.14 zz) (<= zz 3.14)
981               (<= 3.15 zz) (<= zz 3.15)
982               (<= 3.13 zz) (<= zz 3.13)))
983  (test* "NGTF" '(#f #f #t #f #f #t)
984         (list (> 3.14 zz) (> zz 3.14)
985               (> 3.15 zz) (> zz 3.15)
986               (> 3.13 zz) (> zz 3.13)))
987  (test* "NGEF" '(#t #t #t #f #f #t)
988         (list (>= 3.14 zz) (>= zz 3.14)
989               (>= 3.15 zz) (>= zz 3.15)
990               (>= 3.13 zz) (>= zz 3.13)))
991  )
992
993;; Go through number comparison routines.
994;; assumes a >= b, a > 0, b > 0
995;; we use apply to prevent inlining.
996(define (numcmp-test msg eq a b)
997  (let ((pp (list a b))
998        (pm (list a (- b)))
999        (mp (list (- a) b))
1000        (mm (list (- a) (- b))))
1001    (define (test4 op opname rev results)
1002      (for-each (lambda (result comb args)
1003                  (test* #"~msg ~(if rev 'rev \"\") ~opname(~comb)" result
1004                         (Apply op (if rev (reverse args) args))))
1005                results '(++ +- -+ --) (list pp pm mp mm)))
1006    (test4 =  '=  #f (list eq #f #f eq))
1007    (test4 =  '=  #t (list eq #f #f eq))
1008    (test4 >= '>= #f (list #t #t #f eq))
1009    (test4 >= '>= #t (list eq #f #t #t))
1010    (test4 >  '>  #f (list (not eq) #t #f #f))
1011    (test4 >  '>  #t (list #f #f #t (not eq)))
1012    (test4 <= '<= #f (list eq #f #t #t))
1013    (test4 <= '<= #t (list #t #t #f eq))
1014    (test4 <  '<  #f (list #f #f #t (not eq)))
1015    (test4 <  '<  #t (list (not eq) #t #f #f))
1016    ))
1017
1018(numcmp-test "fixnum vs fixnum eq" #t 156 156)
1019(numcmp-test "fixnum vs fixnum ne" #f 878252 73224)
1020(numcmp-test "bignum vs fixnum ne" #f (expt 3 50) 9982425)
1021(numcmp-test "bignum vs bignum eq" #t (expt 3 50) (expt 3 50))
1022(numcmp-test "bignum vs bignum ne" #f (expt 3 50) (expt 3 49))
1023(numcmp-test "flonum vs fixnum eq" #t 314.0 314)
1024(numcmp-test "flonum vs fixnum ne" #f 3140.0 314)
1025(numcmp-test "flonum vs bignum eq" #t (expt 2.0 64) (expt 2 64))
1026(numcmp-test "flonum vs bignum ne" #f (expt 2.0 64) (expt 2 63))
1027(numcmp-test "flonum (inf) vs bignum ne" #f +inf.0 (expt 2 64))
1028(numcmp-test "ratnum vs fixnum ne" #f 13/2 6)
1029(numcmp-test "ratnum vs ratnum eq" #t 3/5 3/5)
1030(numcmp-test "ratnum vs ratnum 1 ne" #f 3/5 4/7)
1031(numcmp-test "ratnum vs ratnum 2 ne" #f 4/5 3/7)
1032(numcmp-test "ratnum vs ratnum 3 ne" #f 4/7 2/5)
1033(numcmp-test "ratnum vs ratnum 4 ne" #f 4/7 3/7)
1034(numcmp-test "ratnum vs flonum eq" #t 3/8 0.375)
1035(numcmp-test "ratnum vs flonum ne" #f 8/9 0.6)
1036(numcmp-test "ratnum vs bignum ne" #f (/ (+ (expt 2 64) 1) 2) (expt 2 63))
1037
1038(test* "numcmp -inf vs bignum" #t (Apply > (list (expt 2 64) -inf.0)))
1039
1040;; This tests variable number of arguments.  The current stub code accepts
1041;; up to 4 args in stack and the rest by list, so we want to test the
1042;; boundary case.
1043(define (numcmp-multiarg-test lis eq lt le gt ge)
1044  (test* #"=~lis" eq (Apply = lis))
1045  (test* #"<~lis" lt (Apply < lis))
1046  (test* #"<=~lis" le (Apply <= lis))
1047  (test* #">~lis" gt (Apply > lis))
1048  (test* #">=~lis" ge (Apply >= lis)))
1049
1050;;                                      =  <  <= >  >=
1051(numcmp-multiarg-test '(1 2 3 4)        #f #t #t #f #f)
1052(numcmp-multiarg-test '(1 2 3 3)        #f #f #t #f #f)
1053(numcmp-multiarg-test '(1 2 3 2)        #f #f #f #f #f)
1054(numcmp-multiarg-test '(1 2 3 4 5)      #f #t #t #f #f)
1055(numcmp-multiarg-test '(1 2 3 4 4)      #f #f #t #f #f)
1056(numcmp-multiarg-test '(1 2 3 4 3)      #f #f #f #f #f)
1057(numcmp-multiarg-test '(1 2 3 4 5 6)    #f #t #t #f #f)
1058(numcmp-multiarg-test '(1 2 3 4 5 5)    #f #f #t #f #f)
1059(numcmp-multiarg-test '(1 2 3 4 5 4)    #f #f #f #f #f)
1060(numcmp-multiarg-test '(4 3 2 1)        #f #f #f #t #t)
1061(numcmp-multiarg-test '(4 3 2 2)        #f #f #f #f #t)
1062(numcmp-multiarg-test '(4 3 2 3)        #f #f #f #f #f)
1063(numcmp-multiarg-test '(5 4 3 2 1)      #f #f #f #t #t)
1064(numcmp-multiarg-test '(5 4 3 2 2)      #f #f #f #f #t)
1065(numcmp-multiarg-test '(5 4 3 2 3)      #f #f #f #f #f)
1066(numcmp-multiarg-test '(6 5 4 3 2 1)    #f #f #f #t #t)
1067(numcmp-multiarg-test '(6 5 4 3 2 2)    #f #f #f #f #t)
1068(numcmp-multiarg-test '(6 5 4 3 2 3)    #f #f #f #f #f)
1069(numcmp-multiarg-test '(1 1 1 1 1)      #t #f #t #f #t)
1070(numcmp-multiarg-test '(1 1 1 1 2)      #f #f #t #f #f)
1071(numcmp-multiarg-test '(1 1 1 1 0)      #f #f #f #f #t)
1072(numcmp-multiarg-test '(1 1 1 1 1 1)    #t #f #t #f #t)
1073(numcmp-multiarg-test '(1 1 1 1 1 2)    #f #f #t #f #f)
1074(numcmp-multiarg-test '(1 1 1 1 1 0)    #f #f #f #f #t)
1075
1076;; This is from the bug report from Bill Schottsteadt.  Before 0.8.10
1077;; this yielded #t because of the precision loss in fixnum vs ratnum
1078;; comparison.
1079
1080(test* "fixnum/ratnum comparison" #f
1081       (= -98781233389595723930250385525631360344437602649022271391716773162526352115087074898920261954897888235939429993829738630297052776667061779065100945771127020439712527398509771853491319737304616607041615012797134365574007368603232768089410097730646360760856052946465578073788924743642391638455649511108051053789425902013657106523269224045822294981391380222050223141347787674321888089837786284947870569165079491411110074602544203383038299901291952931113248943344436935596614205784436844912243069019367149526328612664067719765890897558075277707055756274228634652905751880612235340874976952880431555921814590049070979276358637989837532124647692152520447680373275200239544449293834424643702763974403094033892112967196087310232853165951285609426599617479356206218697586025251765476179158153123631158173662488102357611674821528467825910806391548770908013608889792001203039243914696463472490444573930050190716726220002151679336252008777326482398042427845860796285369622627679324605214987983884122808994422164327311297556122943400093231935477754959547620500784989043704825777186301417894825200797719289692636286337716705491307686644214213732116277102140558505945554566856673724837541141206267647285222293953181717113434757149921850120377706206012113994795124049471433490016083401216757825264766474891405185591236321448744678896448941259668731597494947127423662646933419809756274038044752395708014998820826196523041220918922611359697502638594907608648168849193813197790291360087857093790119162389573209640804111261616771827989939551840471235079945175327536638365874717775169210186608268924244639016270610098894971732892267642318266405837012482726627199088381027028630711279130575230815976484191675172279903609489448225149181063260231957171204855841611039996959582465138269247794842445177715476581512709861409446684911276158067098438009067149531119008707418601627426255891/2063950098473886055933596136103014753954685977787179797499441692283103642150668140884348149132839387663291870239435604463778573480782766958396423322880804442523056530013282118705429274303746421980903580754656364533869319744640130831962767797772323836293079599182477171562218297208495122660799328579852852969560730744211066545295945803939271680397511478811389399527913043145952054883289558914237172406636283114284363301999238526952309439259354223729114988806937903509692118585280437646676248013406270664905997291670857985754768850507766359973207600149782819306010561088246502918148146264806947375101624011387317921439210509902170092173796154464078297852707797984007992277904626058467143192149921546030028316990855470478894515952884526783686210401408859364838148201339959570732480920969000913791571631154267939054105878236201498477027265774680071188764947522112650857013491135901945605796776829525789886482760578142306057177990048751864852763036720112071475134369179525117161001517868525821398753039187062869247457336940152614866298628205010037695017885878296140891234142925514925051385440766473260338168038302226808098439763889250948602137806546736025439919604390464712793474019469457135856879584745805794574609707742445431851999335443724488636749987837445626810087003490329257105472274738811579817454656532496370562155449815456374456838912258383282154811001588175608617475540639254689723629881619252699580383612847920348111900440075645703960104081690968807839189109040568288972353424306876947127635585164905071821419089229871978994388197349499565628906992171901547121903117815637249359328193980583892566359962066242217169190169986105579733710057404319381685578470983838597020624234209884597110721892707818651210378187525863009879314177842634871978427592746452643603586344401223449546482306838947819060455178762434166799996220143825677025686435609179225302671777326568324855229172912876656233006785717920665743720753617646617017219230313226844735567400507490772935145894670445831971526014183234960075574401616682479457962912905141754252265169682318523572680657053374002911007741991220001444440319448034755483178790032581428679303588017268970 0))
1082
1083(let ()
1084  (define (test-minmax mi ma data)
1085    (test* (format "min, max ~s" data)
1086           (list mi ma)
1087           (list (Apply min data) (Apply max data))))
1088  (test-minmax 0 10 '(3 10 2 0 5))
1089  (test-minmax -1/3 99/5 '(2 6 99/5 0 -1/6 -1/3))
1090  (test-minmax -10.0 10.0 '(3 10 2.0 -10 5))
1091  (test-minmax -inf.0 +inf.0 '(5 -inf.0 2 +inf.0 1))
1092  (test-minmax +nan.0 +nan.0 '(5 -inf.0 +nan.0 +inf.0 1))
1093  (test-minmax +nan.0 +nan.0 '(+nan.0 -inf.0 3 +inf.0 1))
1094  )
1095
1096;;==================================================================
1097;; Fixnum stuff
1098;;
1099
1100(test* "fixnum? fixnum" #t (fixnum? 0))
1101(test* "fixnum? ratnum" #f (fixnum? 1/2))
1102(test* "fixnum? bignum" #f (fixnum? (expt 2 256)))
1103(test* "fixnum? flonum" #f (fixnum? 3.14))
1104(test* "fixnum? compnum" #f (fixnum? 1+3i))
1105
1106(test* "fixnum? greatest"    #t (fixnum? (greatest-fixnum)))
1107(test* "fixnum? greatest+1"  #f (fixnum? (+ (greatest-fixnum) 1)))
1108(test* "fixnum? least"       #t (fixnum? (least-fixnum)))
1109(test* "fixnum? least-1"     #f (fixnum? (- (least-fixnum) 1)))
1110
1111(test* "greatest fixnum & width" (greatest-fixnum)
1112       (- (ash 1 (- (fixnum-width) 1)) 1))
1113(test* "least fixnum & width" (least-fixnum)
1114       (- (ash 1 (- (fixnum-width) 1))))
1115
1116;;==================================================================
1117;; Arithmetics
1118;;
1119
1120;;------------------------------------------------------------------
1121(test-section "integer addition")
1122
1123(define x #xffffffff00000000ffffffff00000000)
1124(define xx (- x))
1125(define y #x00000002000000000000000200000000)
1126(define yy (- y))
1127(define z #x00000000000000010000000000000001)
1128(test* "bignum + bignum" #x100000001000000010000000100000000
1129      (+ x y))
1130(test* "bignum + -bignum" #xfffffffd00000000fffffffd00000000
1131      (+ x yy))
1132(test* "bignum - bignum" #xfffffffefffffffffffffffeffffffff
1133      (- x z))
1134(test* "bignum - bignum" x
1135      (- (+ x y) y))
1136(test* "-bignum + bignum" #x-fffffffd00000000fffffffd00000000
1137      (+ xx y))
1138(test* "-bignum + -bignum" #x-100000001000000010000000100000000
1139      (+ xx yy))
1140(test* "-bignum - bignum" #x-100000001000000010000000100000000
1141      (- xx y))
1142(test* "-bignum - -bignum" #x-fffffffd00000000fffffffd00000000
1143      (- xx yy))
1144
1145;; This test a possible shortcut in Scm_Add etc.  We use apply
1146;; to avoid operators from being inlined.
1147(test* "0 + bignum" (list x x)
1148       (list (Apply + (list 0 x)) (Apply + (list x 0))))
1149(test* "0 - bignum" (list (- x) x)
1150       (list (Apply - (list 0 x)) (Apply - (list x 0))))
1151(test* "0 * bignum" (list 0 0)
1152       (list (Apply * (list 0 x)) (Apply * (list x 0))))
1153(test* "1 * bignum" (list x x)
1154       (list (Apply * (list 1 x)) (Apply * (list x 1))))
1155(test* "bignum / 1" x
1156       (Apply / (list x 1)))
1157
1158;;------------------------------------------------------------------
1159(test-section "small immediate integer constants")
1160
1161;; pushing small literal integer on the stack may be done
1162;; by combined instruction PUSHI.  These test if it works.
1163
1164(define (foo a b c d e) (list a b c d e))
1165
1166;; 2^19-1
1167(test* "PUSHI" '(0 524287 524288 -524287 -524288)
1168              (foo 0 524287 524288 -524287 -524288))
1169;; 2^51-1
1170(test* "PUSHI" '(0 2251799813685247 2251799813685248
1171                  -2251799813685247 -2251799813685248 )
1172              (foo 0 2251799813685247 2251799813685248
1173             -2251799813685247 -2251799813685248))
1174
1175;;------------------------------------------------------------------
1176(test-section "small immediate integer additions")
1177
1178;; small literal integer x (-2^19 <= x < 2^19 on 32bit architecture)
1179;; in binary addition/subtraction is compiled in special instructuions,
1180;; NUMADDI and NUMSUBI.
1181
1182(define x 2)
1183(test* "NUMADDI" 5 (+ 3 x))
1184(test* "NUMADDI" 5 (+ x 3))
1185(test* "NUMADDI" 1 (+ -1 x))
1186(test* "NUMADDI" 1 (+ x -1))
1187(test* "NUMSUBI" 1 (- 3 x))
1188(test* "NUMSUBI" -1 (- x 3))
1189(test* "NUMSUBI" -5 (- -3 x))
1190(test* "NUMSUBI" 5 (- x -3))
1191(define x 2.0)
1192(test* "NUMADDI" 5.0 (+ 3 x))
1193(test* "NUMADDI" 5.0 (+ x 3))
1194(test* "NUMADDI" 1.0 (+ -1 x))
1195(test* "NUMADDI" 1.0 (+ x -1))
1196(test* "NUMSUBI" 1.0 (- 3 x))
1197(test* "NUMSUBI" -1.0 (- x 3))
1198(test* "NUMSUBI" -5.0 (- -3 x))
1199(test* "NUMSUBI" 5.0 (- x -3))
1200(define x #x100000000)
1201(test* "NUMADDI" #x100000003 (+ 3 x))
1202(test* "NUMADDI" #x100000003 (+ x 3))
1203(test* "NUMADDI" #xffffffff (+ -1 x))
1204(test* "NUMADDI" #xffffffff (+ x -1))
1205(test* "NUMSUBI" #x-fffffffd (- 3 x))
1206(test* "NUMSUBI" #xfffffffd (- x 3))
1207(test* "NUMSUBI" #x-100000003 (- -3 x))
1208(test* "NUMSUBI" #x100000003 (- x -3))
1209(define x 33/7)
1210(test* "NUMADDI" 54/7 (+ 3 x))
1211(test* "NUMADDI" 54/7 (+ x 3))
1212(test* "NUMADDI" 26/7 (+ -1 x))
1213(test* "NUMADDI" 26/7 (+ x -1))
1214(test* "NUMADDI" -12/7 (- 3 x))
1215(test* "NUMADDI" 12/7 (- x 3))
1216(test* "NUMADDI" -54/7 (- -3 x))
1217(test* "NUMADDI" 54/7 (- x -3))
1218
1219(test* "NUMADDI" 30 (+ 10 (if #t 20 25)))
1220(test* "NUMADDI" 30 (+ (if #t 20 25) 10))
1221(test* "NUMADDI" 35 (+ 10 (if #f 20 25)))
1222(test* "NUMADDI" 35 (+ (if #f 20 25) 10))
1223(test* "NUMADDI" 30 (let ((x #t)) (+ 10 (if x 20 25))))
1224(test* "NUMADDI" 30 (let ((x #t)) (+ (if x 20 25) 10)))
1225(test* "NUMADDI" 35 (let ((x #f)) (+ 10 (if x 20 25))))
1226(test* "NUMADDI" 35 (let ((x #f)) (+ (if x 20 25) 10)))
1227(test* "NUMADDI" 21 (+ 10 (do ((x 0 (+ x 1))) ((> x 10) x))))
1228(test* "NUMADDI" 21 (+ (do ((x 0 (+ x 1))) ((> x 10) x)) 10))
1229(test* "NUMSUBI" -10 (- 10 (if #t 20 25)))
1230(test* "NUMSUBI" 10 (- (if #t 20 25) 10))
1231(test* "NUMSUBI" -15 (- 10 (if #f 20 25)))
1232(test* "NUMSUBI" 15 (- (if #f 20 25) 10))
1233(test* "NUMSUBI" -10 (let ((x #t)) (- 10 (if x 20 25))))
1234(test* "NUMSUBI" 10 (let ((x #t)) (- (if x 20 25) 10)))
1235(test* "NUMSUBI" -15 (let ((x #f)) (- 10 (if x 20 25))))
1236(test* "NUMSUBI" 15 (let ((x #f)) (- (if x 20 25) 10)))
1237(test* "NUMSUBI" -1 (- 10 (do ((x 0 (+ x 1))) ((> x 10) x))))
1238(test* "NUMSUBI" 1 (- (do ((x 0 (+ x 1))) ((> x 10) x)) 10))
1239
1240;;------------------------------------------------------------------
1241(test-section "immediate flonum integer arith")
1242
1243;; tests special instructions for immediate flonum integer arithmetic
1244
1245
1246(define x 2.0)
1247(test* "NUMADDF" 5.0 (+ 3 x))
1248(test* "NUMADDF" 5.0 (+ x 3))
1249(test* "NUMADDF" 1.0 (+ -1 x))
1250(test* "NUMADDF" 1.0 (+ x -1))
1251(test* "NUMADDF" 2.0+1.0i (+ +i x))
1252(test* "NUMADDF" 2.0+1.0i (+ x +i))
1253
1254(test* "NUMSUBF" 1.0 (- 3 x))
1255(test* "NUMSUBF" -1.0 (- x 3))
1256(test* "NUMSUBF" -5.0 (- -3 x))
1257(test* "NUMSUBF" 5.0 (- x -3))
1258(test* "NUMSUBF" -2.0+1.0i (- +i x))
1259(test* "NUMSUBF" 2.0-1.0i (- x +i))
1260
1261(test* "NUMMULF" 4.0 (* x 2))
1262(test* "NUMMULF" 4.0 (* 2 x))
1263(test* "NUMMULF" 3.0 (* x 1.5))
1264(test* "NUMMULF" 3.0 (* 1.5 x))
1265(test* "NUMMULF" 0+2.0i (* x +i))
1266(test* "NUMMULF" 0+2.0i (* +i x))
1267
1268(test* "NUMDIVF" 0.5 (/ x 4))
1269(test* "NUMDIVF" 2.0 (/ 4 x))
1270(test* "NUMDIVF" 0.5 (/ x 4.0))
1271(test* "NUMDIVF" 2.0 (/ 4.0 x))
1272(test* "NUMDIVF" 0.0-0.5i (/ x +4i))
1273(test* "NUMDIVF" 0.0+2.0i (/ +4i x))
1274
1275;;------------------------------------------------------------------
1276(test-section "rational number addition")
1277
1278(test* "ratnum +" 482/247 (+ 11/13 21/19))
1279(test* "ratnum -" -64/247 (- 11/13 21/19))
1280
1281;; tests possible shortcut in Scm_Add etc.
1282(test* "ratnum + 0" (list 11/13 11/13)
1283       (list (Apply + '(0 11/13)) (Apply + '(11/13 0))))
1284(test* "ratnum - 0" (list -11/13 11/13)
1285       (list (Apply - '(0 11/13)) (Apply - '(11/13 0))))
1286(test* "ratnum * 0" (list 0 0)
1287       (list (Apply * '(0 11/13)) (Apply * '(11/13 0))))
1288(test* "ratnum * 1" (list 11/13 11/13)
1289       (list (Apply * '(1 11/13)) (Apply * '(11/13 1))))
1290(test* "ratnum / 1" 11/13
1291       (Apply / '(11/13 1)))
1292
1293;;------------------------------------------------------------------
1294(test-section "promotions in addition")
1295
1296(define-syntax +-tester
1297  (syntax-rules ()
1298    ((_ (+ . args))
1299     (let ((inline (+ . args))
1300           (other  (Apply + 'args)))
1301       (and (= inline other)
1302            (list inline (exact? inline)))))))
1303
1304(test* "+" '(0 #t) (+-tester (+)))
1305(test* "+" '(1 #t) (+-tester (+ 1)))
1306(test* "+" '(3 #t) (+-tester (+ 1 2)))
1307(test* "+" '(6 #t) (+-tester (+ 1 2 3)))
1308(test* "+" '(1 #t) (+-tester (+ 1/6 1/3 1/2)))
1309(test* "+" '(1.0 #f) (+-tester (+ 1.0)))
1310(test* "+" '(3.0 #f) (+-tester (+ 1.0 2)))
1311(test* "+" '(3.0 #f) (+-tester (+ 1 2.0)))
1312(test* "+" '(6.0 #f) (+-tester (+ 1 2 3.0)))
1313(test* "+" '(1.0 #f) (+-tester (+ 1/6 1/3 0.5)))
1314(test* "+" '(1+i #f) (+-tester (+ 1 +i)))
1315(test* "+" '(3+i #f) (+-tester (+ 1 2 +i)))
1316(test* "+" '(3+i #f) (+-tester (+ +i 1 2)))
1317(test* "+" '(3+i #f) (+-tester (+ 1.0 2 +i)))
1318(test* "+" '(3+i #f) (+-tester (+ +i 1.0 2)))
1319(test* "+" '(4294967298.0 #f) (+-tester (+ 4294967297 1.0)))
1320(test* "+" '(4294967299.0 #f) (+-tester (+ 4294967297 1 1.0)))
1321(test* "+" '(4294967298.0-i #f) (+-tester (+ 4294967297 1.0 -i)))
1322(test* "+" '(4294967298.0-i #f) (+-tester (+ -i 4294967297 1.0)))
1323(test* "+" '(4294967298.0-i #f) (+-tester (+ 1.0 4294967297 -i)))
1324
1325;;------------------------------------------------------------------
1326(test-section "integer multiplication")
1327
1328(define (m-result x) (list x (- x) (- x) x x (- x) (- x) x))
1329(define (m-tester x y)
1330  (list (* x y) (* (- x) y) (* x (- y)) (* (- x) (- y))
1331        (Apply * (list x y)) (Apply * (list (- x) y))
1332        (Apply * (list x (- y))) (Apply * (list (- x) (- y)))))
1333
1334(test* "fix*fix->big[1]" (m-result 727836879)
1335      (m-tester 41943 17353))
1336(test* "fix*fix->big[1]" (m-result 3663846879)
1337      (m-tester 41943 87353))
1338(test* "fix*fix->big[2]" (m-result 4294967296)
1339      (m-tester 65536 65536))
1340(test* "fix*fix->big[2]" (m-result 366384949959)
1341      (m-tester 4194303 87353))
1342(test* "fix*big[1]->big[1]" (m-result 3378812463)
1343      (m-tester 3 1126270821))
1344(test* "fix*big[1]->big[2]" (m-result 368276265762816)
1345      (m-tester 85746 4294967296))
1346(test* "big[1]*fix->big[1]" (m-result 3378812463)
1347      (m-tester 1126270821 3))
1348(test* "big[1]*fix->big[2]" (m-result 368276265762816)
1349      (m-tester 4294967296 85746))
1350(test* "big[2]*fix->big[2]" (m-result 12312849128741)
1351      (m-tester 535341266467 23))
1352(test* "big[1]*big[1]->big[2]" (m-result 1345585795375391817)
1353      (m-tester 1194726677 1126270821))
1354
1355;; Large number multiplication test using Fermat's number
1356;; The decomposition of Fermat's number is taken from
1357;;   http://www.dd.iij4u.or.jp/~okuyamak/Information/Fermat.html
1358(test* "fermat(7)" (fermat 7)
1359      (* 59649589127497217 5704689200685129054721))
1360(test* "fermat(8)" (fermat 8)
1361              (* 1238926361552897
1362           93461639715357977769163558199606896584051237541638188580280321))
1363(test* "fermat(9)" (fermat 9)
1364              (* 2424833
1365           7455602825647884208337395736200454918783366342657
1366           741640062627530801524787141901937474059940781097519023905821316144415759504705008092818711693940737))
1367(test* "fermat(10)" (fermat 10)
1368              (* 45592577
1369           6487031809
1370           4659775785220018543264560743076778192897
1371           130439874405488189727484768796509903946608530841611892186895295776832416251471863574140227977573104895898783928842923844831149032913798729088601617946094119449010595906710130531906171018354491609619193912488538116080712299672322806217820753127014424577
1372           ))
1373(test* "fermat(11)" (fermat 11)
1374              (* 319489
1375           974849
1376           167988556341760475137
1377           3560841906445833920513
1378           173462447179147555430258970864309778377421844723664084649347019061363579192879108857591038330408837177983810868451546421940712978306134189864280826014542758708589243873685563973118948869399158545506611147420216132557017260564139394366945793220968665108959685482705388072645828554151936401912464931182546092879815733057795573358504982279280090942872567591518912118622751714319229788100979251036035496917279912663527358783236647193154777091427745377038294584918917590325110939381322486044298573971650711059244462177542540706913047034664643603491382441723306598834177
1379           ))
1380
1381;;------------------------------------------------------------------
1382(test-section "multiplication short cuts")
1383
1384;; these test shortcut in Scm_Mul
1385;; note the difference of 0 and 0.0
1386(let1 big 100000000000000000000
1387  (test* "bignum * 0"  0 (Apply * `(,big 0)) eqv?)
1388  (test* "0 * bignum"  0 (Apply * `(0 ,big)) eqv?)
1389  (test* "bignum * 1"  big (Apply * `(,big 1)) eqv?)
1390  (test* "1 * bignum"  big (Apply * `(1 ,big)) eqv?)
1391
1392  (test* "bignum * 0.0"  0.0 (Apply * `(,big 0.0)) eqv?)
1393  (test* "0.0 * bignum"  0.0 (Apply * `(0.0 ,big)) eqv?)
1394  (test* "bignum * 1.0"  1.0e20 (Apply * `(,big 1.0)) eqv?)
1395  (test* "1.0 * bignum"  1.0e20 (Apply * `(1.0 ,big)) eqv?)
1396  )
1397
1398(test* "ratnum * 0"  0 (Apply * '(1/2 0)) eqv?)
1399(test* "0 * ratnum"  0 (Apply * '(0 1/2)) eqv?)
1400(test* "ratnum * 1"  1/2 (Apply * '(1/2 1)) eqv?)
1401(test* "1 * ratnum"  1/2 (Apply * '(1 1/2)) eqv?)
1402
1403(test* "ratnum * 0.0"  0.0 (Apply * '(1/2 0.0)) eqv?)
1404(test* "0.0 * ratnum"  0.0 (Apply * '(0.0 1/2)) eqv?)
1405(test* "ratnum * 1.0"  0.5 (Apply * '(1/2 1.0)) eqv?)
1406(test* "1.0 * ratnum"  0.5 (Apply * '(1.0 1/2)) eqv?)
1407
1408(test* "flonum * 0"  0 (Apply * '(3.0 0)) eqv?)
1409(test* "0 * flonum"  0 (Apply * '(0 3.0)) eqv?)
1410(test* "flonum * 1"  3.0 (Apply * '(3.0 1)) eqv?)
1411(test* "1 * flonum"  3.0 (Apply * '(1 3.0)) eqv?)
1412
1413(test* "flonum * 0.0"  0.0 (Apply * '(3.0 0.0)) eqv?)
1414(test* "0.0 * flonum"  0.0 (Apply * '(0.0 3.0)) eqv?)
1415(test* "flonum * 1.0"  3.0 (Apply * '(3.0 1.0)) eqv?)
1416(test* "1.0 * flonum"  3.0 (Apply * '(1.0 3.0)) eqv?)
1417
1418(test* "compnum * 0" 0 (* 0 +i) eqv?)
1419(test* "0 * compnum" 0 (* +i 0) eqv?)
1420(test* "compnum * 1" +i (* 1 +i) eqv?)
1421(test* "1 * compnum" +i (* +i 1) eqv?)
1422
1423(test* "compnum * 0.0" 0.0 (* 0.0 +i) eqv?)
1424(test* "0.0 * compnum" 0.0 (* +i 0.0) eqv?)
1425(test* "compnum * 1.0" +i (* 1.0 +i) eqv?)
1426(test* "1.0 * compnum" +i (* +i 1.0) eqv?)
1427
1428;;------------------------------------------------------------------
1429(test-section "division")
1430
1431(test* "exact division" 3/20 (/ 3 4 5))
1432(test* "exact division" 1/2  (/ 9223372036854775808 18446744073709551616))
1433(test* "exact division" 4692297364841/7
1434       (/ 28153784189046 42))
1435(test* "exact division" 7/4692297364841
1436       (/ 42 28153784189046))
1437(test* "exact division" -7/4692297364841
1438       (/ 42 -28153784189046))
1439(test* "exact division" 7/4692297364841
1440       (/ -42 -28153784189046))
1441(test* "exact reciprocal" 1/3 (/ 3))
1442(test* "exact reciprocal" -1/3 (/ -3))
1443(test* "exact reciprocal" 5/6 (/ 6/5))
1444(test* "exact reciprocal" -5/6 (/ -6/5))
1445(test* "exact reciprocal" 7/4692297364841 (/ 4692297364841/7))
1446
1447;; avoid inlining
1448(define (divide . args)
1449  (Apply / args))
1450
1451(define (divide. . args)
1452  (Apply /. args))
1453
1454(test* "division by zero" (test-error) (divide 0))
1455(test* "division by zero" (test-error) (divide 0 0))
1456(test* "division by zero" (test-error) (divide 3 0))
1457(test* "division by zero" (test-error) (divide 1/2 0))
1458(test* "division by zero" +inf.0 (divide 0.0))
1459(test* "division by zero" #t (nan? (divide 0.0 0)))
1460(test* "division by zero" #t (nan? (divide 0 0.0)))
1461(test* "division by zero" #t (nan? (divide 0.0 0.0)))
1462(test* "division by zero" +inf.0 (divide 0.5 0))
1463
1464(test* "division by zero" +inf.0 (divide. 0))
1465(test* "division by zero" #t (nan? (divide. 0 0)))
1466(test* "division by zero" +inf.0 (divide. 3 0))
1467(test* "division by zero" +inf.0 (divide. 1/2 0))
1468(test* "division by zero" #t (nan? (divide. 0.0 0)))
1469(test* "division by zero" #t (nan? (divide. 0 0.0)))
1470(test* "division by zero" #t (nan? (divide. 0.0 0.0)))
1471(test* "division by zero" #t (nan? (divide. +nan.0 0)))
1472(test* "division by zero" #t (nan? (divide. +nan.0 0.0)))
1473(test* "division by zero" +inf.0 (divide. 0.5 0))
1474
1475(test* "division by zero" +inf.0+inf.0i (/ 1+2i 0.0))
1476(test* "division by zero" +inf.0-inf.0i (/ 1-2i 0.0))
1477(test* "division by zero" -inf.0+inf.0i (/ -1+2i 0.0))
1478(test* "division by zero" -inf.0-inf.0i (/ -1-2i 0.0))
1479
1480(test* "division by zero" #t
1481       (let ((r (/ 0+1i 0)))
1482         (and (nan? (real-part r))
1483              (= (imag-part r) +inf.0))))
1484
1485(test* "division by zero" #t
1486       (let ((r (/ 0+1i 0.0)))
1487         (and (nan? (real-part r))
1488              (= (imag-part r) +inf.0))))
1489
1490;; See if we don't fold exact divide-by-zero case.  If compile blindly
1491;; fold constant division, the following causes compile-time error
1492;; rather than runtime error.
1493(let ()
1494  (define (recip x) (or x (/ 0)))
1495  (define (two x) (or x (/ 2 0)))
1496  (define (three x) (or x (/ 2 4 0)))
1497  (define (four x) (or x (/ 2 0 4 3)))
1498
1499  (define (tests exp arg)
1500    (test* "div-by-zero constant folding 1" exp (recip arg))
1501    (test* "div-by-zero constant folding 2" exp (two arg))
1502    (test* "div-by-zero constant folding 3" exp (three arg))
1503    (test* "div-by-zero constant folding 4" exp (four arg)))
1504
1505  (tests 10 10)
1506  (tests (test-error) #f)
1507  )
1508
1509(define (d-result x exact?) (list x (- x) (- x) x exact?))
1510(define (d-tester x y)
1511  (list (/ x y) (/ (- x) y) (/ x (- y)) (/ (- x) (- y))
1512        (exact? (/ x y))))
1513
1514;; inexact division
1515(test* "exact/inexact -> inexact" (d-result 3.25 #f)
1516      (d-tester 13 4.0))
1517(test* "exact/inexact -> inexact" (d-result 1.625 #f)
1518      (d-tester 13/2 4.0))
1519(test* "inexact/exact -> inexact" (d-result 3.25 #f)
1520      (d-tester 13.0 4))
1521(test* "inexact/exact -> inexact" (d-result 9.75 #f)
1522      (d-tester 13.0 4/3))
1523(test* "inexact/inexact -> inexact" (d-result 3.25 #f)
1524      (d-tester 13.0 4.0))
1525
1526;; complex division
1527(test* "complex division" 0.0
1528       (let ((a 3)
1529             (b 4+3i)
1530             (c 7.3))
1531         (- (/ a b c)
1532            (/ (/ a b) c))))
1533
1534;;------------------------------------------------------------------
1535(test-section "quotient")
1536
1537(define (q-result x exact?) (list x (- x) (- x) x exact?))
1538(define (q-tester x y)
1539  (list (quotient x y) (quotient (- x) y)
1540        (quotient x (- y)) (quotient (- x) (- y))
1541        (exact? (quotient x y))))
1542
1543;; these uses BignumDivSI -> bignum_sdiv
1544(test* "big[1]/fix->fix" (q-result 17353 #t)
1545      (q-tester 727836879 41943))
1546(test* "big[1]/fix->fix" (q-result 136582 #t)
1547      (q-tester 3735928559 27353))
1548(test* "big[2]/fix->big[1]" (q-result 535341266467 #t)
1549      (q-tester 12312849128741 23))
1550(test* "big[2]/fix->big[2]" (q-result 12312849128741 #t)
1551      (q-tester 12312849128741 1))
1552
1553;; these uses BignumDivSI -> bignum_gdiv
1554(test* "big[1]/fix->fix" (q-result 41943 #t)
1555      (q-tester 3663846879 87353))
1556(test* "big[2]/fix->fix" (q-result 19088743 #t)
1557      (q-tester 705986470884353 36984440))
1558(test* "big[2]/fix->fix" (q-result 92894912 #t)
1559      (q-tester 12312849128741 132546))
1560(test* "big[2]/fix->big[1]" (q-result 2582762030 #t)
1561      (q-tester 425897458766735 164900))
1562
1563;; these uses BignumDivRem
1564(test* "big[1]/big[1]->fix" (q-result 2 #t)
1565      (q-tester 4020957098 1952679221))
1566(test* "big[1]/big[1] -> fix" (q-result 0 #t)
1567      (q-tester 1952679221 4020957098))
1568;; this tests loop in estimation phase
1569(test* "big[3]/big[2] -> big[1]" (q-result #xffff0001 #t)
1570      (q-tester #x10000000000000000 #x10000ffff))
1571;; this test goes through a rare case handling code ("add back") in
1572;; the algorithm.
1573(test* "big[3]/big[2] -> fix" (q-result #xeffe #t)
1574      (q-tester #x7800000000000000 #x80008889ffff))
1575
1576;; inexact quotient
1577(test* "exact/inexact -> inexact" (q-result 3.0 #f)
1578      (q-tester 13 4.0))
1579(test* "inexact/exact -> inexact" (q-result 3.0 #f)
1580      (q-tester 13.0 4))
1581(test* "inexact/inexact -> inexact" (q-result 3.0 #f)
1582      (q-tester 13.0 4.0))
1583(test* "exact/inexact -> inexact" (q-result 17353.0 #f)
1584      (q-tester 727836879 41943.0))
1585(test* "inexact/exact -> inexact" (q-result 17353.0 #f)
1586      (q-tester 727836879.0 41943))
1587(test* "inexact/inexact -> inexact" (q-result 17353.0 #f)
1588      (q-tester 727836879.0 41943.0))
1589
1590;; Test by fermat numbers
1591(test* "fermat(7)" 59649589127497217
1592      (quotient (fermat 7) 5704689200685129054721))
1593(test* "fermat(8)" 1238926361552897
1594              (quotient (fermat 8) 93461639715357977769163558199606896584051237541638188580280321))
1595(test* "fermat(9)" 2424833
1596              (quotient (quotient (fermat 9) 7455602825647884208337395736200454918783366342657)
1597                  741640062627530801524787141901937474059940781097519023905821316144415759504705008092818711693940737))
1598(test* "fermat(10)" 4659775785220018543264560743076778192897
1599              (quotient (quotient (quotient (fermat 10)
1600                                      130439874405488189727484768796509903946608530841611892186895295776832416251471863574140227977573104895898783928842923844831149032913798729088601617946094119449010595906710130531906171018354491609619193912488538116080712299672322806217820753127014424577)
1601                            6487031809)
1602                  45592577))
1603(test* "fermat(11)" 3560841906445833920513
1604              (quotient (quotient (quotient (quotient (fermat 11)
1605                                                167988556341760475137)
1606                                      173462447179147555430258970864309778377421844723664084649347019061363579192879108857591038330408837177983810868451546421940712978306134189864280826014542758708589243873685563973118948869399158545506611147420216132557017260564139394366945793220968665108959685482705388072645828554151936401912464931182546092879815733057795573358504982279280090942872567591518912118622751714319229788100979251036035496917279912663527358783236647193154777091427745377038294584918917590325110939381322486044298573971650711059244462177542540706913047034664643603491382441723306598834177
1607                                      )
1608                            974849)
1609                  319489))
1610
1611;;------------------------------------------------------------------
1612(test-section "modulo and remainder")
1613
1614;; invariance:
1615;; suppose (modulo x y) = m
1616;;         (remainder x y) = r
1617;;         (quotient x y) = q
1618;; then
1619;;         (sign r) = (sign x)
1620;;         (sign m) = (sign y)
1621;;         (+ (* q y) r) = x
1622;;         (+ (* q y) m) = x       if (sign (* x y)) >= 0,
1623;;                         (+ x y) if (sign (* x y)) < 0
1624;;         (exact? m) = (and (exact? x) (exact? y))
1625;;         (exact? r) = (and (exact? x) (exact? y))
1626
1627(define (mr-tester msg x y)
1628  (define (sign a) (cond [(< a 0) -1] [(= a 0) 0] [else 1]))
1629  (define (mr-tester-1 x y)
1630    ;; We don't use quotient&remainder, for we want to test remainder-only path.
1631    (let1 adjust-exactness (if (and (exact? x) (exact? y)) exact inexact)
1632      (test* (format "modulo and remainder (~a) ~s ~s" msg x y)
1633             `(:rem (,(sign x)
1634                     ,(adjust-exactness x)
1635                     ,(and (exact? x) (exact? y)))
1636               :mod (,(sign y)
1637                     ,(adjust-exactness (if (>= (sign (* x y)) 0) x (+ x y)))
1638                     ,(and (exact? x) (exact? y))))
1639             (let ([q (quotient x y)]
1640                   [m (modulo x y)]
1641                   [r (remainder x y)]
1642                   [e? (and (exact? x) (exact? y))])
1643               `(:rem (,(sign r) ,(+ (* q y) r) ,(exact? r))
1644                      :mod (,(sign m) ,(+ (* q y) m) ,(exact? m)))))))
1645  (mr-tester-1 x y)
1646  (mr-tester-1 (- x) y)
1647  (mr-tester-1 x (- y))
1648  (mr-tester-1 (- x) (- y)))
1649
1650(mr-tester "fix op fix -> fix" 13 4)
1651(mr-tester "fix op fix -> fix" 1234 87935)
1652(mr-tester "fix op big -> fix" 12345 3735928559) ;32bit
1653(mr-tester "fix op big -> fix" 8478574387345 #x7fffffffffffffff) ;64bit
1654
1655;; These go through Scm_BignumRemSI
1656(mr-tester "big op fix -> fix" #x7f245637 41943) ;32bit
1657(mr-tester "big op fix -> fix" #x7f787486ff73cacb 41943) ;64bit
1658(mr-tester "big2 op big1 -> big1" #x9aa9bbcb #x50053343) ; 32bit
1659(mr-tester "big2 op big1 -> big1" #x9aa9bbcb10013303 #x50053343cafebabe) ; 64bit
1660
1661;; These go through BignumDivRem
1662(mr-tester "big op big -> big"
1663           #x78ab76d8aa7787a78963556174babdccade44e54e543232ab
1664           #xabcbdbdbcbdabefbebfbebbbababba)
1665
1666;; this tests loop in estimation phase (32bit)
1667(mr-tester "big[3] rem big[2] -> big[1]" #x10000000000000000 #x10000ffff)
1668;; this tests "add back" code (32bit)
1669(mr-tester "big[3] rem big[2] -> big[2]" #x7800000000000000 #x80008889ffff)
1670
1671;; Inexact
1672(mr-tester "exact rem inexact -> inexact" 13 4.0)
1673(mr-tester "inexact rem exact -> inexact" 13.0 4)
1674(mr-tester "inexact rem inexact -> inexact" 13.0 4.0)
1675(mr-tester "exact rem inexact -> inexact" 3735928559 27353.0)
1676(mr-tester "inexact rem exact -> inexact" 3735928559.0 27353)
1677(mr-tester "inexact rem inexact -> inexact" 3735928559.0 27353.0)
1678
1679;; test by mersenne prime? - code by 'hipster'
1680
1681(define (mersenne-prime? p)
1682  (let ((m (- (expt 2 p) 1)))
1683    (do ((i 3 (+ i 1))
1684         (s 4 (modulo (- (* s s) 2) m)))
1685        ((= i (+ p 1)) (= s 0)))))
1686
1687(test* "mersenne prime"
1688       '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t)
1689       (map mersenne-prime? '(3 5 7 13 17 19 31 61 89 107 127 521 607 1279)))
1690
1691;;------------------------------------------------------------------
1692(test-section "quotient&remainder")
1693
1694(let ()
1695  (define (check x y)
1696    (test* (format "quotient&remainder ~s ~s" x y)
1697           (list (quotient x y) (remainder x y))
1698           (receive (q r) (quotient&remainder x y) (list q r))))
1699  (define (do-quadrants p)
1700    (lambda (x y) (p x y) (p (- x) y) (p x (- y)) (p (- x) (- y))))
1701  (define do-exactness
1702    (let1 p (do-quadrants check)
1703      (lambda (x y) (p x y) (p (inexact x) y) (p x (inexact y)))))
1704
1705  (do-exactness 3 2)
1706  (do-exactness 7 3)
1707  (do-exactness 7 9)
1708  )
1709
1710;;------------------------------------------------------------------
1711(test-section "div and mod")
1712
1713(let ()
1714  (define (do-quadrants proc)
1715    (lambda (x y =)
1716      (proc x y =)
1717      (proc (- x) y =)
1718      (proc x (- y) =)
1719      (proc (- x) (- y) =)))
1720
1721  (define (test-div x y =)
1722    (test* (format "~a div ~a" x y) '(#t #t)
1723           (receive (d m) (div-and-mod x y)
1724             (let1 z (+ (* d y) m)
1725               (list (or (= x z) z)
1726                     (or (and (<= 0 m) (< m (abs y))) m))))))
1727
1728  (define (test-div0 x y =)
1729    (test* (format "~a div0 ~a" x y) '(#t #t)
1730           (receive (d m) (div0-and-mod0 x y)
1731             (let1 z (+ (* d y) m)
1732               (list (or (= x z) z)
1733                     (or (and (<= (- (abs y)) (* m 2))
1734                              (< (* m 2) (abs y)))
1735                         m))))))
1736
1737  ((do-quadrants test-div) 3 2 =)
1738  ((do-quadrants test-div) 3.0 2 (lambda (a b) (approx=? a b)))
1739  ((do-quadrants test-div) 123 10 =)
1740  ((do-quadrants test-div) 123.0 10.0 (lambda (a b) (approx=? a b)))
1741  ((do-quadrants test-div) 123/7 10/7 =)
1742  ((do-quadrants test-div) 123/7 5 =)
1743  ((do-quadrants test-div) 123 5/7 =)
1744  ((do-quadrants test-div) 130.75 10.5 =)
1745
1746  ((do-quadrants test-div0) 123 10 =)
1747  ((do-quadrants test-div0) 129 10 =)
1748  ((do-quadrants test-div0) 123.0 10.0 (lambda (a b) (approx=? a b)))
1749  ((do-quadrants test-div0) 129.0 10.0 (lambda (a b) (approx=? a b)))
1750  ((do-quadrants test-div0) 123/7 10/7 =)
1751  ((do-quadrants test-div0) 129/7 10/7 =)
1752  ((do-quadrants test-div0) 121/7 5 =)
1753  ((do-quadrants test-div0) 124/7 5 =)
1754  ((do-quadrants test-div0) 121 5/7 =)
1755  ((do-quadrants test-div0) 124 5/7 =)
1756  ((do-quadrants test-div0) 130.75 10.5 =)
1757  ((do-quadrants test-div0) 129.75 10.5 =)
1758  )
1759
1760
1761;;------------------------------------------------------------------
1762(test-section "absolute values")
1763
1764(test* "abs (minimum negative of 30-bit wide fixnum)" (expt 2 29) (abs (- (expt 2 29))))
1765(test* "abs (minimum negative of 62-bit wide fixnum)" (expt 2 61) (abs (- (expt 2 61))))
1766
1767(test* "magnitude (exact real)" 1 (magnitude 1))
1768
1769
1770;;------------------------------------------------------------------
1771(test-section "rounding")
1772
1773(define (round-tester value exactness cei flo tru rou)
1774  (test* (string-append "rounding " (number->string value))
1775         (list exactness cei flo tru rou)
1776         (let ((c (ceiling value))
1777               (f (floor value))
1778               (t (truncate value))
1779               (r (round value)))
1780           (list (and (exact? c) (exact? f) (exact? t) (exact? r))
1781                 c f t r))))
1782
1783(round-tester 0  #t 0 0 0 0)
1784(round-tester 3  #t 3 3 3 3)
1785(round-tester -3 #t -3 -3 -3 -3)
1786(round-tester (expt 2 99) #t (expt 2 99) (expt 2 99) (expt 2 99) (expt 2 99))
1787(round-tester (- (expt 2 99)) #t
1788              (- (expt 2 99)) (- (expt 2 99)) (- (expt 2 99)) (- (expt 2 99)))
1789
1790(round-tester 9/4  #t 3 2 2 2)
1791(round-tester -9/4 #t -2 -3 -2 -2)
1792(round-tester 34985495387484938453495/17 #t
1793              2057970316910878732559
1794              2057970316910878732558
1795              2057970316910878732558
1796              2057970316910878732559)
1797(round-tester -34985495387484938453495/17 #t
1798              -2057970316910878732558
1799              -2057970316910878732559
1800              -2057970316910878732558
1801              -2057970316910878732559)
1802
1803(round-tester 35565/2 #t 17783 17782 17782 17782)
1804(round-tester -35565/2 #t -17782 -17783 -17782 -17782)
1805(round-tester 35567/2 #t 17784 17783 17783 17784)
1806(round-tester -35567/2 #t -17783 -17784 -17783 -17784)
1807
1808(test* "round->exact" 3 (round->exact 3.4) =)
1809(test* "round->exact" 4 (round->exact 3.5) =)
1810(test* "round->exact"
1811       (if (> (greatest-fixnum) (expt 2 53)) ; same as "exact (greatest-fixnum)"
1812         (+ (greatest-fixnum) 1)
1813         (greatest-fixnum))
1814       (round->exact (inexact (greatest-fixnum))))
1815(test* "round->exact" (least-fixnum) (round->exact (inexact (least-fixnum))))
1816(test* "round->exact" (expt 2 63) (round->exact (- (expt 2.0 63) 1)))
1817(test* "round->exact" (- (expt 2 63)) (round->exact (- (expt 2.0 63))))
1818(test* "floor->exact" 3 (floor->exact 3.4) =)
1819(test* "floor->exact" -4 (floor->exact -3.5) =)
1820(test* "floor->exact"
1821       (if (> (greatest-fixnum) (expt 2 53)) ; same as "exact (greatest-fixnum)"
1822         (+ (greatest-fixnum) 1)
1823         (greatest-fixnum))
1824       (floor->exact (inexact (greatest-fixnum))))
1825(test* "floor->exact" (least-fixnum) (floor->exact (inexact (least-fixnum))))
1826(test* "floor->exact" (expt 2 63) (floor->exact (- (expt 2.0 63) 1)))
1827(test* "floor->exact" (- (expt 2 63)) (floor->exact (- (expt 2.0 63))))
1828(test* "ceiling->exact" 4 (ceiling->exact 3.4) =)
1829(test* "ceiling->exact" -3 (ceiling->exact -3.5) =)
1830(test* "ceiling->exact"
1831       (if (> (greatest-fixnum) (expt 2 53)) ; same as "exact (greatest-fixnum)"
1832         (+ (greatest-fixnum) 1)
1833         (greatest-fixnum))
1834       (ceiling->exact (inexact (greatest-fixnum))))
1835(test* "ceiling->exact" (least-fixnum) (ceiling->exact (inexact (least-fixnum))))
1836(test* "ceiling->exact" (expt 2 63) (ceiling->exact (- (expt 2.0 63) 1)))
1837(test* "ceiling->exact" (- (expt 2 63)) (ceiling->exact (- (expt 2.0 63))))
1838(test* "truncate->exact" 3 (truncate->exact 3.4) =)
1839(test* "truncate->exact" -3 (truncate->exact -3.5) =)
1840(test* "truncate->exact"
1841       (if (> (greatest-fixnum) (expt 2 53)) ; same as "exact (greatest-fixnum)"
1842         (+ (greatest-fixnum) 1)
1843         (greatest-fixnum))
1844       (truncate->exact (inexact (greatest-fixnum))))
1845(test* "truncate->exact" (least-fixnum) (truncate->exact (inexact (least-fixnum))))
1846(test* "truncate->exact" (expt 2 63) (truncate->exact (- (expt 2.0 63) 1)))
1847(test* "truncate->exact" (- (expt 2 63)) (truncate->exact (- (expt 2.0 63))))
1848
1849;;------------------------------------------------------------------
1850(test-section "clamping")
1851
1852(test* "clamp (1)"   1   (clamp 1) eqv?)
1853(test* "clamp (1 #f)" 1  (clamp 1 #f) eqv?)
1854(test* "clamp (1 #f #f)" 1  (clamp 1 #f #f) eqv?)
1855(test* "clamp (1.0)"   1.0   (clamp 1.0) eqv?)
1856(test* "clamp (1.0 #f)" 1.0  (clamp 1.0 #f) eqv?)
1857(test* "clamp (1.0 #f #f)" 1.0  (clamp 1.0 #f #f) eqv?)
1858
1859(test* "clamp (1 0)" 1   (clamp 1 0) eqv?)
1860(test* "clamp (1 0 #f)" 1 (clamp 1 0 #f) eqv?)
1861(test* "clamp (1 0 2)" 1 (clamp 1 0 2) eqv?)
1862(test* "clamp (1 5/4)" 5/4 (clamp 1 5/4) eqv?)
1863(test* "clamp (1 5/4 #f)" 5/4 (clamp 1 5/4 #f) eqv?)
1864(test* "clamp (1 #f 5/4)" 1 (clamp 1 #f 5/4) eqv?)
1865(test* "clamp (1 0 3/4)" 3/4 (clamp 1 0 3/4) eqv?)
1866(test* "clamp (1 #f 3/4)" 3/4 (clamp 1 #f 3/4) eqv?)
1867
1868(test* "clamp (1.0 0)" 1.0   (clamp 1.0 0) eqv?)
1869(test* "clamp (1.0 0 #f)" 1.0 (clamp 1.0 0 #f) eqv?)
1870(test* "clamp (1.0 0 2)" 1.0 (clamp 1.0 0 2) eqv?)
1871(test* "clamp (1.0 5/4)" 1.25 (clamp 1.0 5/4) eqv?)
1872(test* "clamp (1.0 5/4 #f)" 1.25 (clamp 1.0 5/4 #f) eqv?)
1873(test* "clamp (1.0 #f 5/4)" 1.0 (clamp 1.0 #f 5/4) eqv?)
1874(test* "clamp (1.0 0 3/4)" 0.75 (clamp 1.0 0 3/4) eqv?)
1875(test* "clamp (1.0 #f 3/4)" 0.75 (clamp 1.0 #f 3/4) eqv?)
1876
1877(test* "clamp (1 0.0)" 1.0   (clamp 1 0.0) eqv?)
1878(test* "clamp (1 0.0 #f)" 1.0 (clamp 1 0.0 #f) eqv?)
1879(test* "clamp (1 0.0 2)" 1.0 (clamp 1 0.0 2) eqv?)
1880(test* "clamp (1 0 2.0)" 1.0 (clamp 1 0 2.0) eqv?)
1881(test* "clamp (1 1.25)" 1.25 (clamp 1 1.25) eqv?)
1882(test* "clamp (1 #f 1.25)" 1.0 (clamp 1 #f 1.25) eqv?)
1883(test* "clamp (1 1.25 #f)" 1.25 (clamp 1 1.25 #f) eqv?)
1884(test* "clamp (1 0.0 3/4)" 0.75 (clamp 1 0.0 3/4) eqv?)
1885(test* "clamp (1 0 0.75)" 0.75 (clamp 1 0 0.75) eqv?)
1886
1887(test* "clamp (1 -inf.0 +inf.0)" 1.0 (clamp 1 -inf.0 +inf.0) eqv?)
1888
1889;;------------------------------------------------------------------
1890(test-section "logical operations")
1891
1892;; covers
1893(define bitwise-tester-x 0)
1894(define bitwise-tester-y 0)
1895
1896(define-macro (ash-tester msg expect x y)
1897  `(begin
1898     (set! bitwise-tester-x ,x)
1899     (set! bitwise-tester-y ,y)
1900     (test* ,(format "ash (~a) compile-time constant, inlined, generic1, generic2" msg)
1901            (list ,expect ,expect ,expect ,expect)
1902            (list (ash ,x ,y)
1903                  (ash bitwise-tester-x ,y)
1904                  (ash ,x bitwise-tester-y)
1905                  (ash bitwise-tester-x bitwise-tester-y)))))
1906
1907(ash-tester "fixnum" #x408000 #x81 15)
1908(ash-tester "fixnum" #x81 #x408000 -15)
1909(ash-tester "fixnum" #x01 #x408000 -22)
1910(ash-tester "fixnum" 0 #x408000 -23)
1911(ash-tester "fixnum" 0 #x408000 -24)
1912(ash-tester "fixnum" 0 #x408000 -100)
1913(ash-tester "fixnum" #x81 #x81 0)
1914(ash-tester "neg. fixnum" #x-408000 #x-81 15)
1915(ash-tester "neg. fixnum" #x-81 #x-408000 -15)
1916(ash-tester "fixnum" -2 #x-408000 -22)
1917(ash-tester "fixnum" -1 #x-408000 -23)
1918(ash-tester "fixnum" -1 #x-408000 -24)
1919(ash-tester "fixnum" -1 #x-408000 -100)
1920(ash-tester "fixnum" #x-408000 #x-408000 0)
1921
1922(ash-tester "fixnum->bignum" #x81000000 #x81 24)
1923(ash-tester "fixnum->bignum" #x4080000000 #x81 31)
1924(ash-tester "fixnum->bignum" #x8100000000 #x81 32)
1925(ash-tester "fixnum->bignum" #x8100000000000000 #x81 56)
1926(ash-tester "fixnum->bignum" #x408000000000000000 #x81 63)
1927(ash-tester "fixnum->bignum" #x810000000000000000 #x81 64)
1928(ash-tester "neg.fixnum->bignum" #x-81000000 #x-81 24)
1929(ash-tester "neg.fixnum->bignum" #x-4080000000 #x-81 31)
1930(ash-tester "neg.fixnum->bignum" #x-8100000000 #x-81 32)
1931(ash-tester "neg.fixnum->bignum" #x-8100000000000000 #x-81 56)
1932(ash-tester "neg.fixnum->bignum" #x-408000000000000000 #x-81 63)
1933(ash-tester "neg.fixnum->bignum" #x-810000000000000000 #x-81 64)
1934
1935(ash-tester "bignum->fixnum" #x81  #x81000000 -24)
1936(ash-tester "bignum->fixnum" #x40  #x81000000 -25)
1937(ash-tester "bignum->fixnum" 1  #x81000000 -31)
1938(ash-tester "bignum->fixnum" 0  #x81000000 -32)
1939(ash-tester "bignum->fixnum" 0  #x81000000 -100)
1940(ash-tester "bignum->fixnum" #x81 #x4080000000 -31)
1941(ash-tester "bignum->fixnum" #x81 #x8100000000 -32)
1942(ash-tester "bignum->fixnum" #x40 #x8100000000 -33)
1943(ash-tester "bignum->fixnum" 1 #x8100000000 -39)
1944(ash-tester "bignum->fixnum" 0 #x8100000000 -40)
1945(ash-tester "bignum->fixnum" 0 #x8100000000 -100)
1946(ash-tester "bignum->fixnum" #x81 #x8100000000000000 -56)
1947(ash-tester "bignum->fixnum" #x81 #x408000000000000000 -63)
1948(ash-tester "bignum->fixnum" #x40 #x408000000000000000 -64)
1949(ash-tester "bignum->fixnum" #x20 #x408000000000000000 -65)
1950(ash-tester "bignum->fixnum" 1 #x408000000000000000 -70)
1951(ash-tester "bignum->fixnum" 0 #x408000000000000000 -71)
1952(ash-tester "bignum->fixnum" 0 #x408000000000000000 -100)
1953
1954(ash-tester "neg.bignum->fixnum" #x-81 #x-81000000 -24)
1955(ash-tester "neg.bignum->fixnum" #x-41 #x-81000000 -25)
1956(ash-tester "neg.bignum->fixnum" #x-21 #x-81000000 -26)
1957(ash-tester "neg.bignum->fixnum" -2 #x-81000000 -31)
1958(ash-tester "neg.bignum->fixnum" -1 #x-81000000 -32)
1959(ash-tester "neg.bignum->fixnum" -1 #x-81000000 -33)
1960(ash-tester "neg.bignum->fixnum" -1 #x-81000000 -100)
1961(ash-tester "neg.bignum->fixnum" #x-81 #x-4080000000 -31)
1962(ash-tester "neg.bignum->fixnum" #x-41 #x-4080000000 -32)
1963(ash-tester "neg.bignum->fixnum" #x-21 #x-4080000000 -33)
1964(ash-tester "neg.bignum->fixnum" -2 #x-4080000000 -38)
1965(ash-tester "neg.bignum->fixnum" -1 #x-4080000000 -39)
1966(ash-tester "neg.bignum->fixnum" -1 #x-4080000000 -100)
1967(ash-tester "neg.bignum->fixnum" #x-81 #x-408000000000000000 -63)
1968(ash-tester "neg.bignum->fixnum" #x-41 #x-408000000000000000 -64)
1969(ash-tester "neg.bignum->fixnum" #x-21 #x-408000000000000000 -65)
1970(ash-tester "neg.bignum->fixnum" -2 #x-408000000000000000 -70)
1971(ash-tester "neg.bignum->fixnum" -1 #x-408000000000000000 -71)
1972(ash-tester "neg.bignum->fixnum" -1 #x-408000000000000000 -72)
1973
1974(ash-tester "bignum->bignum" #x12345678123456780 #x1234567812345678 4)
1975(ash-tester "bignum->bignum" #x1234567812345678000000000000000 #x1234567812345678 60)
1976(ash-tester "bignum->bignum" #x12345678123456780000000000000000 #x1234567812345678 64)
1977(ash-tester "bignum->bignum" #x123456781234567 #x1234567812345678 -4)
1978(ash-tester "bignum->bignum" #x12345678 #x1234567812345678 -32)
1979(ash-tester "neg.bignum->bignum" #x-123456781234568 #x-1234567812345678 -4)
1980(ash-tester "bignum->bignum" #x-12345679 #x-1234567812345678 -32)
1981
1982(test* "lognot (fixnum)" -1 (lognot 0))
1983(test* "lognot (fixnum)" 0 (lognot -1))
1984(test* "lognot (fixnum)" -65536 (lognot 65535))
1985(test* "lognot (fixnum)" 65535 (lognot -65536))
1986(test* "lognot (bignum)" #x-1000000000000000001
1987      (lognot #x1000000000000000000))
1988(test* "lognot (bignum)" #x1000000000000000000
1989      (lognot #x-1000000000000000001))
1990
1991(define-macro (logop-tester op msg expect x y)
1992  `(begin
1993     (set! bitwise-tester-x ,x)
1994     (set! bitwise-tester-y ,y)
1995     (test* (format "~a (~a)" ',op ,msg)
1996            (list ,expect ,expect ,expect ,expect ,expect ,expect)
1997            (list (,op ,x ,y)
1998                  (,op bitwise-tester-x ,y)
1999                  (,op ,x bitwise-tester-y)
2000                  (,op bitwise-tester-x bitwise-tester-y)
2001                  (,op bitwise-tester-x ,y bitwise-tester-x)
2002                  (,op ,x bitwise-tester-x ,y bitwise-tester-y)))))
2003
2004(logop-tester logand "+fix & 0" 0 #x123456 0)
2005(logop-tester logand "+big & 0" 0 #x1234567812345678 0)
2006(logop-tester logand "+fix & -1" #x123456 #x123456 -1)
2007(logop-tester logand "+big & -1" #x1234567812345678 #x1234567812345678 -1)
2008(logop-tester logand "+fix & +fix" #x2244 #xaa55 #x6666)
2009(logop-tester logand "+fix & +big" #x2244 #xaa55 #x6666666666)
2010(logop-tester logand "+big & +fix" #x4422 #xaa55aa55aa #x6666)
2011(logop-tester logand "+big & +big" #x2244224422 #xaa55aa55aa #x6666666666)
2012(logop-tester logand "+big & +big" #x103454301aaccaa #x123456789abcdef #xfedcba987654321fedcba987654321fedcba)
2013(logop-tester logand "+big & +big" #x400000 #xaa55ea55aa #x55aa55aa55)
2014(logop-tester logand "+fix & -fix" #x8810 #xaa55 #x-6666)
2015(logop-tester logand "+fix & -big" #x8810 #xaa55 #x-6666666666)
2016(logop-tester logand "+big & -fix" #xaa55aa118a #xaa55aa55aa #x-6666)
2017(logop-tester logand "+big & -big" #x881188118a #xaa55aa55aa #x-6666666666)
2018(logop-tester logand "+big & -big" #x20002488010146 #x123456789abcdef #x-fedcba987654321fedcba987654321fedcba)
2019(logop-tester logand "-fix & +fix" #x4422 #x-aa55 #x6666)
2020(logop-tester logand "-fix & +big" #x6666664422 #x-aa55 #x6666666666)
2021(logop-tester logand "-big & +fix" #x2246 #x-aa55aa55aa #x6666)
2022(logop-tester logand "-big & +big" #x4422442246 #x-aa55aa55aa #x6666666666)
2023(logop-tester logand "-big & +big" #xfedcba987654321fedcba884200020541010 #x-123456789abcdef #xfedcba987654321fedcba987654321fedcba)
2024(logop-tester logand "-fix & -fix" #x-ee76 #x-aa55 #x-6666)
2025(logop-tester logand "-fix & -big" #x-666666ee76 #x-aa55 #x-6666666666)
2026(logop-tester logand "-big & -fix" #x-aa55aa77ee #x-aa55aa55aa #x-6666)
2027(logop-tester logand "-big & -big" #x-ee77ee77ee #x-aa55aa55aa #x-6666666666)
2028(logop-tester logand "-big & -big" #x-fedcba987654321fedcba9a76567a9ffde00 #x-123456789abcdef #x-fedcba987654321fedcba987654321fedcba)
2029
2030(logop-tester logior "+fix | 0" #x123456 #x123456 0)
2031(logop-tester logior "+big | 0" #x1234567812345678 #x1234567812345678 0)
2032(logop-tester logior "+fix | -1" -1 #x123456 -1)
2033(logop-tester logior "+big | -1" -1 #x1234567812345678 -1)
2034(logop-tester logior "+fix | +fix" #xee77 #xaa55 #x6666)
2035(logop-tester logior "+fix | +big" #x666666ee77 #xaa55 #x6666666666)
2036(logop-tester logior "+big | +fix" #xaa55aa77ee #xaa55aa55aa #x6666)
2037(logop-tester logior "+big | +big" #xee77ee77ee #xaa55aa55aa #x6666666666)
2038(logop-tester logior "+big | +big" #xfedcba987654321fedcba9a76567a9ffddff #x123456789abcdef #xfedcba987654321fedcba987654321fedcba)
2039(logop-tester logior "+fix | -fix" #x-4421 #xaa55 #x-6666)
2040(logop-tester logior "+fix | -big" #x-6666664421 #xaa55 #x-6666666666)
2041(logop-tester logior "+big | -fix" #x-2246 #xaa55aa55aa #x-6666)
2042(logop-tester logior "+big | -big" #x-4422442246 #xaa55aa55aa #x-6666666666)
2043(logop-tester logior "+big | -big" #x-fedcba987654321fedcba884200020541011 #x123456789abcdef #x-fedcba987654321fedcba987654321fedcba)
2044(logop-tester logior "-fix | +fix" #x-8811 #x-aa55 #x6666)
2045(logop-tester logior "-fix | +big" #x-8811 #x-aa55 #x6666666666)
2046(logop-tester logior "-big | +fix" #x-aa55aa118a #x-aa55aa55aa #x6666)
2047(logop-tester logior "-big | +big" #x-881188118a #x-aa55aa55aa #x6666666666)
2048(logop-tester logior "-big | +big" #x-20002488010145 #x-123456789abcdef #xfedcba987654321fedcba987654321fedcba)
2049(logop-tester logior "-fix | -fix" #x-2245 #x-aa55 #x-6666)
2050(logop-tester logior "-fix | -big" #x-2245 #x-aa55 #x-6666666666)
2051(logop-tester logior "-big | -fix" #x-4422 #x-aa55aa55aa #x-6666)
2052(logop-tester logior "-big | -big" #x-2244224422 #x-aa55aa55aa #x-6666666666)
2053(logop-tester logior "-big | -big" #x-103454301aacca9 #x-123456789abcdef #x-fedcba987654321fedcba987654321fedcba)
2054
2055;; regression test for incorrect check till 0.9.1
2056(test* "lognot (error)" (test-error) (lognot 1/2))
2057(test* "logand (error)" (test-error) (logand 3 1/2))
2058(test* "logior (error)" (test-error) (logior 3 1/2))
2059(test* "logxor (error)" (test-error) (logxor 3 1/2))
2060
2061;; zero and one-argument bitops a la srfi-60
2062(test* "logand (0arg)" -1 (logand))
2063(test* "logand (1arg)" 1 (logand 1))
2064(test* "logand (1arg)" (test-error) (logand 3.14))
2065(test* "logior (0arg)" 0 (logior))
2066(test* "logior (1arg)" 1 (logior 1))
2067(test* "logior (1arg)" (test-error) (logior 3.14))
2068(test* "logxor (0arg)" 0 (logxor))
2069(test* "logxor (1arg)" 1 (logxor 1))
2070(test* "logxor (1arg)" (test-error) (logxor 3.14))
2071
2072(test* "logtest" #t
2073      (logtest #xfeedbabe #x10000000))
2074(test* "logtest" #f
2075      (logtest #xfeedbabe #x01100101))
2076
2077(let loop ((a 1)   ; 1, 10, 100, ...
2078           (b 1)   ; 1, 11, 111, ...
2079           (c 2)   ; 10, 101, 1001, ...
2080           (n 1))  ; counter
2081  (when (< n 69)
2082    (test* (format "logcount (positive, 100...) ~a" n) 1 (logcount a))
2083    (test* (format "logcount (positive, 111...) ~a" n) n (logcount b))
2084    (test* (format "logcount (negative, 100...) ~a" n) (- n 1) (logcount (- a)))
2085    (test* (format "logcount (negative, 100..1) ~a" n) 1 (logcount (- c)))
2086    (loop (+ b 1) (+ b b 1) (+ b b 3) (+ n 1))))
2087
2088(test* "logbit?" '(#f #t #t #f #t #f #f)
2089              (map (^i (logbit? i #b10110)) '(0 1 2 3 4 5 6)))
2090(test* "logbit?" '(#f #t #f #t #f #t #t)
2091              (map (^i (logbit? i #b-10110)) '(0 1 2 3 4 5 6)))
2092
2093(test* "copy-bit" #b11010110
2094      (copy-bit 4 #b11000110 #t))
2095(test* "copy-bit" #b11000110
2096      (copy-bit 4 #b11000110 #f))
2097(test* "copy-bit" #b10000110
2098      (copy-bit 6 #b11000110 #f))
2099
2100(test* "bit-field" #b1010
2101      (bit-field #b1101101010 0 4))
2102(test* "bit-field" #b10110
2103      (bit-field #b1101101010 4 9))
2104
2105(test* "copy-bit-field" #b1101100000
2106      (copy-bit-field #b1101101010 0 0 4))
2107(test* "copy-bit-field" #b1101101111
2108      (copy-bit-field #b1101101010 -1 0 4))
2109(test* "copy-bit-field" #b1111111111101010
2110      (copy-bit-field #b1101101010 -1 5 16))
2111
2112(test* "integer-length" 8 (integer-length #b10101010))
2113(test* "integer-length" 4 (integer-length #b1111))
2114(test* "integer-length" 0 (integer-length 0))
2115(test* "integer-length" 0 (integer-length -1))
2116(test* "integer-length" 1 (integer-length 1))
2117(test* "integer-length" 1 (integer-length -2))
2118(test* "integer-length" 29 (integer-length (- (expt 2 29) 1)))
2119(test* "integer-length" 30 (integer-length (expt 2 29)))
2120(test* "integer-length" 61 (integer-length (- (expt 2 61) 1)))
2121(test* "integer-length" 62 (integer-length (expt 2 61)))
2122(test* "integer-length" 29 (integer-length (- (expt 2 29))))
2123(test* "integer-length" 30 (integer-length (- (- (expt 2 29)) 1)))
2124(test* "integer-length" 61 (integer-length (- (expt 2 61))))
2125(test* "integer-length" 62 (integer-length (- (- (expt 2 61)) 1)))
2126(test* "integer-length" 1025 (integer-length (expt 2 1024)))
2127
2128(let1 2s-exponent-factor-tests `((0 -1) (-1 0) (1 0) (2 1) (-2 1)
2129                                 (1048576 20) (-1048576 20)
2130                                 (,(expt 2 100) 100)
2131                                 (,(- (expt 2 100)) 100)
2132                                 (,(* 7 (expt 2 50)) 50))
2133  (test* "twos-exponent-factor" 2s-exponent-factor-tests
2134         (map (lambda [t] (list (car t) (twos-exponent-factor (car t))))
2135              2s-exponent-factor-tests)))
2136
2137(let1 2s-exponent-tests `(0 1 -1 2 -2 4 8 65535 65536
2138                          131072 ,(* 3 131072)
2139                          ,(expt 2 80) ,(- (expt 2 80))
2140                          ,(* 3 (expt 2 80)))
2141  (define (dumb-test n k)
2142    (cond [(<= n 0) #f]
2143          [(= n 1) k]
2144          [(odd? n) #f]
2145          [else (dumb-test (/ n 2) (+ k 1))]))
2146  (test* "twos-exponent"
2147         (map (lambda [k] (cons k (dumb-test k 0))) 2s-exponent-tests)
2148         (map (lambda [k] (cons k (twos-exponent k))) 2s-exponent-tests)))
2149
2150;;------------------------------------------------------------------
2151(test-section "inexact arithmetics")
2152
2153;; +. etc are inlined, so we want to test both inlined case and
2154;; explicitly called case.
2155(define-syntax inexact-arith-test
2156  (syntax-rules ()
2157    [(_ msg exp (op . args))
2158     (begin
2159       (test* (string-append msg " inlined") exp (op . args))
2160       (test* (string-append msg " applied") exp (Apply op (list . args))))]))
2161
2162(inexact-arith-test "+. (0)" 0.0 (+.))
2163(inexact-arith-test "+. (1)" 1.0 (+. 1))
2164(inexact-arith-test "+. (1big)" 1.0e20 (+. 100000000000000000000))
2165(inexact-arith-test "+. (1rat)" 1.5 (+. 3/2))
2166(inexact-arith-test "+. (1cmp)" 1.0+i (+. 1+i))
2167(inexact-arith-test "+. (2)" 1.0 (+. 0 1))
2168(inexact-arith-test "+. (2big)" 1.0e20 (+. 1 100000000000000000000))
2169(inexact-arith-test "+. (2rat)" 1.5 (+. 1 1/2))
2170(inexact-arith-test "+. (many)" 15.0 (+. 1 2 3 4 5))
2171
2172(inexact-arith-test "-. (1)" -1.0 (-. 1))
2173(inexact-arith-test "-. (1big)" -1.0e20 (-. 100000000000000000000))
2174(inexact-arith-test "-. (1rat)" -1.5 (-. 3/2))
2175(inexact-arith-test "-. (1cmp)" -1.0-i (-. 1+i))
2176(inexact-arith-test "-. (2)" -1.0 (-. 0 1))
2177(inexact-arith-test "-. (2big)" -1.0e20 (-. 1 100000000000000000000))
2178(inexact-arith-test "-. (2rat)" 0.5 (-. 1 1/2))
2179(inexact-arith-test "-. (many)" -13.0 (-. 1 2 3 4 5))
2180
2181(inexact-arith-test "*. (0)" 1.0 (*.))
2182(inexact-arith-test "*. (1)" 1.0 (*. 1))
2183(inexact-arith-test "*. (1big)" 1.0e20 (*. 100000000000000000000))
2184(inexact-arith-test "*. (1rat)" 1.5 (*. 3/2))
2185(inexact-arith-test "*. (1cmp)" 1.0+i (*. 1+i))
2186(inexact-arith-test "*. (2)"  0.0 (*. 0 1))
2187(inexact-arith-test "*. (2big)" 1.0e20 (*. 1 100000000000000000000))
2188(inexact-arith-test "*. (2rat)" 0.5 (*. 1 1/2))
2189(inexact-arith-test "*. (many)" 120.0 (*. 1 2 3 4 5))
2190
2191(inexact-arith-test "/. (1)" 1.0 (/. 1))
2192(inexact-arith-test "/. (1big)" 1.0e-20 (/. 100000000000000000000))
2193(inexact-arith-test "/. (1rat)" 0.6666666666666666 (/. 3/2))
2194(inexact-arith-test "/. (1cmp)" 0.5-0.5i (/. 1+i))
2195(inexact-arith-test "/. (2)"  0.0 (/. 0 1))
2196(inexact-arith-test "/. (2big)" 1.0e-20 (/. 1 100000000000000000000))
2197(inexact-arith-test "/. (2rat)" 2.0 (/. 1 1/2))
2198(inexact-arith-test "/. (2rat1)" 0.5 (/. 1/2 1))
2199(inexact-arith-test "/. (2rat2)" 2.0 (/. 1/2 1/4))
2200(inexact-arith-test "/. (many)" 0.1 (/. 1 2 5))
2201
2202;; The following takes a special path to avoid overflow.
2203(inexact-arith-test "/. fixnum bignum" 0.0 (/. (expt 10 400)))
2204(inexact-arith-test "/. bignum fixnum" +inf.0 (/. (expt 10 400) 1))
2205(inexact-arith-test "/. bignum fixnum" -inf.0 (/. (expt 10 400) -1))
2206(inexact-arith-test "/. bignum bignum" 10.0 (/. (expt 10 401) (expt 10 400)))
2207
2208;;------------------------------------------------------------------
2209(test-section "sqrt")
2210
2211(define (integer-sqrt-tester k)
2212  (test* (format "exact-integer-sqrt ~a" k) '(#t #t #t)
2213         (receive (s r) (exact-integer-sqrt k)
2214           (list (>= r 0)
2215                 (= k (+ (* s s) r))
2216                 (< k (* (+ s 1) (+ s 1)))))))
2217
2218(integer-sqrt-tester 0)
2219(integer-sqrt-tester 1)
2220(integer-sqrt-tester 2)
2221(integer-sqrt-tester 3)
2222(integer-sqrt-tester 4)
2223(integer-sqrt-tester 10)
2224(integer-sqrt-tester (expt 2 32))
2225(integer-sqrt-tester (- (expt 2 52) 1))
2226(integer-sqrt-tester (expt 2 52))
2227(integer-sqrt-tester (+ (expt 2 52) 1))
2228(integer-sqrt-tester 9007199136250224)
2229(integer-sqrt-tester 9007199136250226)
2230(integer-sqrt-tester (- (expt 2 53) 1))
2231(integer-sqrt-tester (expt 2 53))
2232(integer-sqrt-tester (+ (expt 2 53) 1))
2233(integer-sqrt-tester 9999999999999999999999999999999999999999999999999999)
2234(integer-sqrt-tester (+ (expt 10 400) 3141592653589)) ; double range overflow
2235
2236(test* "exact-integer-sqrt -1" (test-error) (exact-integer-sqrt -1))
2237(test* "exact-integer-sqrt 1.0" (test-error) (exact-integer-sqrt 1.0))
2238(test* "exact-integer-sqrt 1/4" (test-error) (exact-integer-sqrt 1/4))
2239
2240;; try to cover various paths in sqrt of exact numbers
2241(test* "sqrt, exact" 0 (sqrt 0) eqv?)
2242(test* "sqrt, exact" 4 (sqrt 16) eqv?)
2243(test* "sqrt, exact" (expt 2 64) (sqrt (expt 2 128)) eqv?)
2244
2245(test* "sqrt, inexact" 4.0 (sqrt 16.0) eqv?)
2246(test* "sqrt, inexact" +4.0i (sqrt -16.0) eqv?)
2247(test* "sqrt, inexact" (%sqrt (- (expt 2 64) 1))
2248       (sqrt (- (expt 2 64) 1)) eqv?)
2249
2250(test* "sqrt, exact" 1/4 (sqrt 1/16) eqv?)
2251(test* "sqrt, exact" (/ 1 (expt 2 64)) (sqrt (/ 1 (expt 2 128))) eqv?)
2252(test* "sqrt, exact" (/ (expt 2 64) 3) (sqrt (/ (expt 2 128) 9)) eqv?)
2253(test* "sqrt, exact" (/ (expt 2 64) (expt 3 30))
2254       (sqrt (/ (expt 2 128) (expt 3 60))) eqv?)
2255
2256(test* "sqrt, inexact" 0.25 (sqrt (exact->inexact 1/16)) eqv?)
2257(test* "sqrt, inexact" (%sqrt (/ (- (expt 2 64) 1) (expt 3 30)))
2258       (sqrt (/ (- (expt 2 64) 1) (expt 3 30))) eqv?)
2259
2260;;------------------------------------------------------------------
2261(test-section "posix math functions")
2262
2263(test* "fmod" 0.25 (fmod 5.25 1) (^[x y] (approx=? x y (* 8 (flonum-epsilon)))))
2264(test* "fmod" 2.3  (fmod 8.3 3)  (^[x y] (approx=? x y (* 8 (flonum-epsilon)))))
2265(test* "fmod" 8.3  (fmod 8.3 33) (^[x y] (approx=? x y (* 8 (flonum-epsilon)))))
2266
2267(test* "frexp" '(0.785 2)
2268       (values->list (frexp 3.14))
2269       (^[x y] (and (approx=? (car x) (car y))
2270                    (approx=? (cadr x) (cadr y)))))
2271
2272(test* "ldexp" 3.14 (ldexp 0.785 2) (^[x y] (approx=? x y)))
2273
2274(test* "modf" '(0.14 3.0)
2275       (values->list (modf 3.14))
2276       (^[x y] (and (approx=? (car x) (car y) (* 4 (flonum-epsilon)))
2277                    (approx=? (cadr x) (cadr y)))))
2278
2279;; This is to check alternative gamma implementation assuming we can use
2280;; system's tgamma and lgamma.
2281'(let ()
2282  (define (test-gamma name fn0 fn1)
2283    (test* #"alt-~name" #f
2284           (any (^[x] (let* ([y0 (fn0 x)]
2285                             [y1 (fn1 x)]
2286                             [e  (/ (abs (- y0 y1)) y0)])
2287                        (and (> e 1e-6)
2288                             (format "Error too big (~s) at x=~s (~a=~s alt-~a=~s"
2289                                     e x name y0 name y1))))
2290                (map (cut expt 10 <>) (iota 150 -5 0.05)))))
2291  (test-gamma "gamma"
2292              (with-module gauche.internal %gamma)
2293              (with-module gauche.internal %alt-gamma))
2294  (test-gamma "lgamma"
2295              (with-module gauche.internal %lgamma)
2296              (with-module gauche.internal %alt-lgamma))
2297  )
2298
2299;; log on huge number - naive use of Scm_GetDouble overflows
2300(let-syntax ([log-tester
2301              (syntax-rules ()
2302                [(_ input)
2303                 (let1 factor (expt 2 (integer-length input))
2304                   (test* (write-to-string '(log input))
2305                          (+ (log factor) (log (/ input factor)))
2306                          (log input)))])])
2307  (log-tester (expt 2 2048))
2308  (log-tester (- (expt 2 2048)))
2309  (log-tester (+ (expt 3 2048) (expt 3 2047)))
2310  (log-tester (- (expt 7 7715)))
2311  )
2312
2313;; log on infinities
2314(test* "log on infinities" '(+inf.0 +inf.0+3.141592653589793i)
2315       (list (log +inf.0) (log -inf.0)))
2316
2317;;------------------------------------------------------------------
2318(test-section "trigonometric functions")
2319
2320;; Exactness
2321(let ()
2322  (define (check msg fn %fn val)
2323    (test* msg (exact (%fn val)) (fn val) eqv?))
2324  (check "exact (sin 0)" sin %sin 0)
2325  (check "exact (cos 0)" cos %cos 0)
2326  (check "exact (tan 0)" tan %tan 0)
2327  (check "exact (sinh 0)" sinh %sinh 0)
2328  (check "exact (cosh 0)" cosh %cosh 0)
2329  (check "exact (tanh 0)" tanh %tanh 0)
2330  (check "exact (asin 0)" asin %asin 0)
2331  (check "exact (acos 1)" acos %acos 1)
2332  (check "exact (atan 0)" atan %atan 0))
2333
2334(let ()
2335  (define (check trig trig-pi)
2336    (let loop ([x -4])
2337      (if (> x 4)
2338        #f
2339        (let ([t0 (trig (* x 3.141592653589793))]
2340              [t1 (trig-pi x)])
2341          (if (or (and (> (abs t0) 1e15)
2342                       (> (abs t1) 1e15))
2343                  (< (abs (- t0 t1)) 1e-10))
2344            (loop (+ x 1/16))
2345            `(((,trig (* pi ,x)) ,t0)
2346              ((,trig-pi ,x) ,t1)))))))
2347  (test* "sin vs sinpi" #f (check %sin %sinpi))
2348  (test* "cos vs cospi" #f (check %cos %cospi))
2349  (test* "tan vs tanpi" #f (check %tan %tanpi)))
2350
2351;;------------------------------------------------------------------
2352(test-section "ffx optimization")
2353
2354;; This code is provided by naoya_t to reproduce the FFX bug
2355;; existed until r6714.   The bug was that the ARGP words of
2356;; in-stack continuations were not scanned when flonum register
2357;; bank was cleared.  This code exhibits the case by putting
2358;; the result of (sqrt 2) as an unfinished argument, then calling
2359;; inverse-erf which caused flushing flonum regs (see "NG" line).
2360
2361(use math.const)
2362(let ()
2363  (define *epsilon* 1e-12)
2364
2365  ;;
2366  ;; normal quantile function (probit function)
2367  ;;
2368  (define (probit p)
2369    (define (probit>0 p)
2370      (* (inverse-erf (- (* p 2) 1)) (sqrt 2))) ;; OK
2371    (if (< p 0)
2372      (- 1 (probit>0 (- p)))
2373      (probit>0 p) ))
2374
2375  (define (probit p)
2376    (define (probit>0 p)
2377      (* (sqrt 2) (inverse-erf (- (* p 2) 1)))) ;; NG
2378    (if (< p 0)
2379      (- 1 (probit>0 (- p)))
2380      (probit>0 p) ))
2381
2382  ;;
2383  ;; inverse error function (erf-1)
2384  ;;
2385  (define (inverse-erf z)
2386    (define (calc-next-ck k c)
2387      (let loop ((m 0) (sum 0) (ca c) (cz (reverse c)))
2388        (if (= m k) sum
2389            (loop (+ m 1)
2390                  (+ sum (/. (* (car ca) (car cz)) (+ m 1) (+ m m 1)))
2391                  (cdr ca) (cdr cz)))))
2392    (define (calc-cks k)
2393      (let loop ((i 0) (cks '(1)))
2394        (if (= i k) cks
2395            (loop (+ i 1) (cons (calc-next-ck (+ i 1) cks) cks)))))
2396    (define (calc-ck k) (car (calc-cks k)))
2397
2398    (define (inverse-erf>0 z)
2399      (let1 r (* pi z z 1/4) ; (pi*z^2)/4
2400        (let loop ((k 0) (cks '(1)) (sum 0) (a 1))
2401          (let1 delta (* a (/ (car cks) (+ k k 1)))
2402            (if (< delta (* sum *epsilon*))
2403              (* 1/2 z (sqrt pi) sum)
2404              (loop (+ k 1)
2405                    (cons (calc-next-ck (+ k 1) cks) cks)
2406                    (+ sum delta)
2407                    (* a r)))))))
2408
2409    (cond [(< z 0) (- (inverse-erf>0 (- z)))]
2410          [(= z 0) 0]
2411          [else (inverse-erf>0 z)]) )
2412
2413  (define ~= (lambda (x y) (< (abs (- x y)) 1e-7)))
2414  ;;
2415  ;; TEST
2416  ;;
2417  (test* "probit(0.025)" -1.959964 (probit 0.025) ~=)
2418  (test* "probit(0.975)" 1.959964 (probit 0.975) ~=)
2419  )
2420
2421;;------------------------------------------------------------------
2422(test-section "arithmetic operation overload")
2423
2424;; NB: these tests requires the object system working.
2425
2426;; These code are only for tests, and do not suggest the real use of
2427;; arithmetic operation override.  For practical use, it is important
2428;; to define those operations consistently.  Note that Gauche's compiler
2429;; may reorder or change operations based on the assumption of the
2430;; normal definition of those arithmetic operations.
2431
2432(define-method object-+ ((a <string>) b) #"~|a|+~|b|")
2433(define-method object-+ (a (b <string>)) #"~|a|+~|b|")
2434(define-method object-- ((a <string>) b) #"~|a|-~|b|")
2435(define-method object-- (a (b <string>)) #"~|a|-~|b|")
2436(define-method object-* ((a <string>) b) #"~|a|*~|b|")
2437(define-method object-* (a (b <string>)) #"~|a|*~|b|")
2438(define-method object-/ ((a <string>) b) #"~|a|/~|b|")
2439(define-method object-/ (a (b <string>)) #"~|a|/~|b|")
2440
2441(define-method object-- ((a <string>)) #"-~|a|")
2442(define-method object-/ ((a <string>)) #"/~|a|")
2443
2444(test* "object-+" "a+b" (+ "a" "b"))
2445(test* "object-+" "a+b" (+ "a" 'b))
2446(test* "object-+" "a+b" (+ 'a "b"))
2447(test* "object-+" "3+a" (+ 3 "a"))
2448;; NB: this becomes "3+a" instead of "a+3", because of compiler optimization.
2449;; DO NOT COUNT ON THIS BEHAVIOR IN THE REAL CODE.   Might be changed in
2450;; the future release.
2451(test* "object-+" "3+a" (+ "a" 3))
2452
2453(test* "object--" "a-b" (- "a" "b"))
2454(test* "object--" "a-b" (- "a" 'b))
2455(test* "object--" "a-b" (- 'a "b"))
2456(test* "object--" "3-a" (- 3 "a"))
2457;; NB: this becomes "-3+a" instead of "a-3", because of compiler optimization
2458;; DO NOT COUNT ON THIS BEHAVIOR IN THE REAL CODE.   Might be changed in
2459;; the future release.
2460(test* "object--" "-3+a" (- "a" 3))
2461
2462(test* "object--" "-a"  (- "a"))
2463
2464(test* "object-*" "a*b" (* "a" "b"))
2465(test* "object-*" "a*b" (* "a" 'b))
2466(test* "object-*" "a*b" (* 'a "b"))
2467(test* "object-*" "3*a" (* 3 "a"))
2468(test* "object-*" "a*3" (* "a" 3))
2469
2470(test* "object-/" "a/b" (/ "a" "b"))
2471(test* "object-/" "a/b" (/ "a" 'b))
2472(test* "object-/" "a/b" (/ 'a "b"))
2473(test* "object-/" "3/a" (/ 3 "a"))
2474(test* "object-/" "a/3" (/ "a" 3))
2475
2476(test* "object-/" "/a"  (/ "a"))
2477
2478(test-end)
2479