1;;
2;; test numeric system implementation
3;;
4;; These tests are from Gauche Scheme (v0.9.1), which can be found at
5;; http://practical-scheme.net/gauche/index.html
6;; Some modifications were made to allow it to be used with the "test"
7;; egg for Chicken
8;;
9;;   Copyright (c) 2000-2010  Shiro Kawai  <shiro@acm.org>
10;;
11;;  Redistribution and use in source and binary forms, with or without
12;;  modification, are permitted provided that the following conditions
13;;  are met:
14;;
15;;   1. Redistributions of source code must retain the above copyright
16;;      notice, this list of conditions and the following disclaimer.
17;;
18;;   2. Redistributions in binary form must reproduce the above copyright
19;;      notice, this list of conditions and the following disclaimer in the
20;;      documentation and/or other materials provided with the distribution.
21;;
22;;   3. Neither the name of the authors nor the names of its contributors
23;;      may be used to endorse or promote products derived from this
24;;      software without specific prior written permission.
25;;
26;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
27;;  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
28;;  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
29;;  A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
30;;  OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
31;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
32;;  TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
33;;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
34;;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
35;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
36;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
37;;
38
39(include "test.scm")
40
41(define (exp2 pow)
42  (do ((i 0 (+ i 1))
43       (m 1 (+ m m)))
44      ((>= i pow) m)))
45
46(define (fermat n)                      ;Fermat's number
47  (+ (expt 2 (expt 2 n)) 1))
48
49;; Gauche compat
50
51(import (chicken bitwise) (chicken port) (chicken format) (chicken string) (chicken fixnum))
52
53(define (greatest-fixnum) most-positive-fixnum)
54(define (least-fixnum) most-negative-fixnum)
55(define (fixnum-width) fixnum-precision)
56
57(define ash arithmetic-shift)
58(define logior bitwise-ior)
59(define logand bitwise-and)
60(define lognot bitwise-not)
61(define (logtest a b) (= (bitwise-and a b) b))
62
63(define-syntax let1
64  (syntax-rules ()
65    ((_ var val forms ...)
66     (let ((var val)) forms ...))))
67
68(define (integer->digit i r)
69  (and (< i r)
70       (if (< i 10)
71           (integer->char (+ (char->integer #\0) i))
72           (integer->char (+ (char->integer #\a) (- i 10))))))
73
74(define (read-from-string s) (with-input-from-string s read))
75
76(define (truncate->exact x) (inexact->exact (truncate x)))
77(define (round->exact x) (inexact->exact (round x)))
78(define (floor->exact x) (inexact->exact (floor x)))
79(define (ceiling->exact x) (inexact->exact (ceiling x)))
80
81;; This is probably a bit silly
82(define (+. . args) (if (null? args) 0.0 (apply + (map exact->inexact args))))
83(define (-. . args) (apply - (map exact->inexact args)))
84(define (*. . args) (if (null? args) 1.0 (apply * (map exact->inexact args))))
85(define (/. . args) (apply / (map exact->inexact args)))
86
87(test-begin "Gauche numbers test")
88
89;;==================================================================
90;; Reader/writer
91;;
92
93;;------------------------------------------------------------------
94(test-begin "integer addition & reader")
95
96(define (i-tester x)
97  (list x (+ x -1 x) (+ x x) (- x) (- (+ x -1 x)) (- 0 x x) (- 0 x x 1)))
98
99(test-equal "around 2^28"
100      (i-tester (exp2 28))
101      '(268435456 536870911 536870912
102         -268435456 -536870911 -536870912 -536870913))
103
104(test-equal "around 2^31"
105      (i-tester (exp2 31))
106       '(2147483648 4294967295 4294967296
107         -2147483648 -4294967295 -4294967296 -4294967297))
108
109(test-equal "around 2^60"
110       (i-tester (exp2 60))
111       '(1152921504606846976 2305843009213693951 2305843009213693952
112         -1152921504606846976 -2305843009213693951 -2305843009213693952
113         -2305843009213693953))
114
115(test-equal "around 2^63"
116       (i-tester (exp2 63))
117       '(9223372036854775808 18446744073709551615 18446744073709551616
118         -9223372036854775808 -18446744073709551615 -18446744073709551616
119         -18446744073709551617))
120
121(test-equal "around 2^127"
122       (i-tester (exp2 127))
123       '(170141183460469231731687303715884105728
124         340282366920938463463374607431768211455
125         340282366920938463463374607431768211456
126         -170141183460469231731687303715884105728
127         -340282366920938463463374607431768211455
128         -340282366920938463463374607431768211456
129         -340282366920938463463374607431768211457))
130
131;; test for reader's overflow detection code
132(test-equal "peculiarity around 2^32"
133      (* 477226729 10) 4772267290)
134
135(test-equal "radix" (list #b1010101001010101
136             #o1234567
137             #o12345677654321
138             #d123456789
139             #d123456789987654321
140             #x123456
141             #xdeadbeef
142             #xDeadBeef)
143      '(43605 342391 718048024785
144                 123456789 123456789987654321
145                 1193046 3735928559 3735928559))
146
147(test-equal "exactness" (exact? #e10) #t)
148(test-equal "exactness" (exact? #e10.0) #t)
149(test-equal "exactness" (exact? #e10e10) #t)
150(test-equal "exactness" (exact? #e12.34) #t)
151(test-equal "inexactness" (exact? #i10) #f)
152(test-equal "inexactness" (exact? #i10.0) #f)
153(test-equal "inexactness" (exact? #i12.34) #f)
154
155(test-equal "exactness & radix" (list (exact? #e#xdeadbeef)
156             #e#xdeadbeef
157             (exact? #x#edeadbeef)
158             #x#edeadbeef)
159      '(#t 3735928559 #t 3735928559))
160(test-equal "inexactness & radix" (list (exact? #i#xdeadbeef)
161             #i#xdeadbeef
162             (exact? #x#ideadbeef)
163             #x#ideadbeef)
164      '(#f 3735928559.0 #f 3735928559.0))
165
166(test-equal "invalid exactness/radix spec" (or (string->number "#e")
167           (string->number "#i")
168           (string->number "#e#i3")
169           (string->number "#i#e5")
170           (string->number "#x#o13")
171           (string->number "#e#b#i00101"))
172       #f)
173
174(define (radix-tester radix)
175  (list
176   (let loop ((digits 0)
177              (input "1")
178              (value 1))
179     (cond ((> digits 64) #t)
180           ((eqv? (string->number input radix) value)
181            (loop (+ digits 1) (string-append input "0") (* value radix)))
182           (else #f)))
183   (let loop ((digits 0)
184              (input (string (integer->digit (- radix 1) radix)))
185              (value (- radix 1)))
186     (cond ((> digits 64) #t)
187           ((eqv? (string->number input radix) value)
188            (loop (+ digits 1)
189                  (string-append input (string (integer->digit (- radix 1) radix)))
190                  (+ (* value radix) (- radix 1))))
191           (else #f)))))
192
193(test-equal "base-2 reader" (radix-tester 2) '(#t #t))
194(test-equal "base-3 reader" (radix-tester 3) '(#t #t))
195(test-equal "base-4 reader" (radix-tester 4) '(#t #t))
196(test-equal "base-5 reader" (radix-tester 5) '(#t #t))
197(test-equal "base-6 reader" (radix-tester 6) '(#t #t))
198(test-equal "base-7 reader" (radix-tester 7) '(#t #t))
199(test-equal "base-8 reader" (radix-tester 8) '(#t #t))
200(test-equal "base-9 reader" (radix-tester 9) '(#t #t))
201(test-equal "base-10 reader" (radix-tester 10) '(#t #t))
202(test-equal "base-11 reader" (radix-tester 11) '(#t #t))
203(test-equal "base-12 reader" (radix-tester 12) '(#t #t))
204(test-equal "base-13 reader" (radix-tester 13) '(#t #t))
205(test-equal "base-14 reader" (radix-tester 14) '(#t #t))
206(test-equal "base-15 reader" (radix-tester 15) '(#t #t))
207(test-equal "base-16 reader" (radix-tester 16) '(#t #t))
208(test-equal "base-17 reader" (radix-tester 17) '(#t #t))
209(test-equal "base-18 reader" (radix-tester 18) '(#t #t))
210(test-equal "base-19 reader" (radix-tester 19) '(#t #t))
211(test-equal "base-20 reader" (radix-tester 20) '(#t #t))
212(test-equal "base-21 reader" (radix-tester 21) '(#t #t))
213(test-equal "base-22 reader" (radix-tester 22) '(#t #t))
214(test-equal "base-23 reader" (radix-tester 23) '(#t #t))
215(test-equal "base-24 reader" (radix-tester 24) '(#t #t))
216(test-equal "base-25 reader" (radix-tester 25) '(#t #t))
217(test-equal "base-26 reader" (radix-tester 26) '(#t #t))
218(test-equal "base-27 reader" (radix-tester 27) '(#t #t))
219(test-equal "base-28 reader" (radix-tester 28) '(#t #t))
220(test-equal "base-29 reader" (radix-tester 29) '(#t #t))
221(test-equal "base-30 reader" (radix-tester 30) '(#t #t))
222(test-equal "base-31 reader" (radix-tester 31) '(#t #t))
223(test-equal "base-32 reader" (radix-tester 32) '(#t #t))
224(test-equal "base-33 reader" (radix-tester 33) '(#t #t))
225(test-equal "base-34 reader" (radix-tester 34) '(#t #t))
226(test-equal "base-35 reader" (radix-tester 35) '(#t #t))
227(test-equal "base-36 reader" (radix-tester 36) '(#t #t))
228
229(test-end)
230
231;;------------------------------------------------------------------
232(test-begin "rational reader")
233
234(define (rational-test v)
235  (if (number? v) (list v (exact? v)) v))
236
237(test-equal "rational reader" (rational-test '1234/1) '(1234 #t))
238(test-equal "rational reader" (rational-test '-1234/1) '(-1234 #t))
239(test-equal "rational reader" (rational-test '+1234/1) '(1234 #t))
240;; The following is invalid R5RS syntax, so it's commented out (it fails, too)
241#;(test-equal "rational reader" (rational-test '1234/-1) '|1234/-1|)
242(test-equal "rational reader" (rational-test '2468/2) '(1234 #t))
243(test-equal "rational reader" (rational-test '1/2) '(1/2 #t))
244(test-equal "rational reader" (rational-test '-1/2) '(-1/2 #t))
245(test-equal "rational reader" (rational-test '+1/2) '(1/2 #t))
246(test-equal "rational reader" (rational-test '751/1502) '(1/2 #t))
247
248(test-equal "rational reader" (rational-test (string->number "3/03"))
249       '(1 #t))
250(test-equal "rational reader" (rational-test (string->number "3/0")) #;'(+inf.0 #f) ; <- I think that's wrong in Gauche
251       #f)
252(test-equal "rational reader" (rational-test (string->number "-3/0")) #;'(-inf.0 #f) ; same as above
253       #f)
254(test-equal "rational reader" (rational-test (string->number "3/3/4"))
255       #f)
256(test-equal "rational reader" (rational-test (string->number "1/2."))
257       #f)
258(test-equal "rational reader" (rational-test (string->number "1.3/2"))
259       #f)
260
261(test-error "rational reader" (rational-test (read-from-string "#e3/0")))
262(test-error "rational reader" (rational-test (read-from-string "#e-3/0")))
263
264(test-equal "rational reader w/#e" (rational-test '#e1234/1)
265       '(1234 #t))
266(test-equal "rational reader w/#e" (rational-test '#e-1234/1)
267       '(-1234 #t))
268(test-equal "rational reader w/#e" (rational-test '#e32/7)
269       '(32/7 #t))
270(test-equal "rational reader w/#e" (rational-test '#e-32/7)
271       '(-32/7 #t))
272(test-equal "rational reader w/#i" (rational-test '#i1234/1)
273       '(1234.0 #f))
274(test-equal "rational reader w/#i" (rational-test '#i-1234/1)
275       '(-1234.0 #f))
276(test-equal "rational reader w/#i" (rational-test '#i-4/32)
277       '(-0.125 #f))
278
279(test-equal "rational reader w/radix" (rational-test '#e#xff/11)
280       '(15 #t))
281(test-equal "rational reader w/radix" (rational-test '#o770/11)
282       '(56 #t))
283(test-equal "rational reader w/radix" (rational-test '#x#iff/11)
284       '(15.0 #f))
285
286(test-equal "rational reader edge case" (symbol? (read-from-string "/1")) #t)
287(test-equal "rational reader edge case" (symbol? (read-from-string "-/1")) #t)
288(test-equal "rational reader edge case" (symbol? (read-from-string "+/1")) #t)
289
290(test-end)
291
292;;------------------------------------------------------------------
293(test-begin "flonum reader")
294
295(define (flonum-test v)
296  (if (number? v) (list v (inexact? v)) v))
297
298(test-equal "flonum reader" (flonum-test 3.14)  '(3.14 #t))
299(test-equal "flonum reader" (flonum-test 0.14)  '(0.14 #t))
300(test-equal "flonum reader" (flonum-test .14)  '(0.14 #t))
301(test-equal "flonum reader" (flonum-test 3.)  '(3.0  #t))
302(test-equal "flonum reader" (flonum-test -3.14)  '(-3.14 #t))
303(test-equal "flonum reader" (flonum-test -0.14)  '(-0.14 #t))
304(test-equal "flonum reader" (flonum-test -.14)  '(-0.14 #t))
305(test-equal "flonum reader" (flonum-test -3.)  '(-3.0  #t))
306(test-equal "flonum reader" (flonum-test +3.14)  '(3.14 #t))
307(test-equal "flonum reader" (flonum-test +0.14)  '(0.14 #t))
308(test-equal "flonum reader" (flonum-test +.14)  '(0.14 #t))
309(test-equal "flonum reader" (flonum-test +3.)  '(3.0  #t))
310(test-equal "flonum reader" (flonum-test .0)  '(0.0  #t))
311(test-equal "flonum reader" (flonum-test 0.)  '(0.0  #t))
312(test-equal "flonum reader" (string->number ".") #f)
313(test-equal "flonum reader" (string->number "-.") #f)
314(test-equal "flonum reader" (string->number "+.") #f)
315
316(test-equal "flonum reader (exp)" (flonum-test 3.14e2) '(314.0 #t))
317(test-equal "flonum reader (exp)" (flonum-test .314e3) '(314.0 #t))
318(test-equal "flonum reader (exp)" (flonum-test 314e0) '(314.0 #t))
319(test-equal "flonum reader (exp)" (flonum-test 314e-0) '(314.0 #t))
320(test-equal "flonum reader (exp)" (flonum-test 3140000e-4) '(314.0 #t))
321(test-equal "flonum reader (exp)" (flonum-test -3.14e2) '(-314.0 #t))
322(test-equal "flonum reader (exp)" (flonum-test -.314e3) '(-314.0 #t))
323(test-equal "flonum reader (exp)" (flonum-test -314e0) '(-314.0 #t))
324(test-equal "flonum reader (exp)" (flonum-test -314.e-0) '(-314.0 #t))
325(test-equal "flonum reader (exp)" (flonum-test -3140000e-4) '(-314.0 #t))
326(test-equal "flonum reader (exp)" (flonum-test +3.14e2) '(314.0 #t))
327(test-equal "flonum reader (exp)" (flonum-test +.314e3) '(314.0 #t))
328(test-equal "flonum reader (exp)" (flonum-test +314.e0) '(314.0 #t))
329(test-equal "flonum reader (exp)" (flonum-test +314e-0) '(314.0 #t))
330(test-equal "flonum reader (exp)" (flonum-test +3140000.000e-4) '(314.0 #t))
331
332(test-equal "flonum reader (exp)" (flonum-test .314E3) '(314.0 #t))
333(test-equal "flonum reader (exp)" (flonum-test .314s3) '(314.0 #t))
334(test-equal "flonum reader (exp)" (flonum-test .314S3) '(314.0 #t))
335(test-equal "flonum reader (exp)" (flonum-test .314l3) '(314.0 #t))
336(test-equal "flonum reader (exp)" (flonum-test .314L3) '(314.0 #t))
337(test-equal "flonum reader (exp)" (flonum-test .314f3) '(314.0 #t))
338(test-equal "flonum reader (exp)" (flonum-test .314F3) '(314.0 #t))
339(test-equal "flonum reader (exp)" (flonum-test .314d3) '(314.0 #t))
340(test-equal "flonum reader (exp)" (flonum-test .314D3) '(314.0 #t))
341
342;; Broken for unknown reasons on Mingw
343#;(test-equal "flonum reader (minimum denormalized number 5.0e-324)" (let1 x (expt 2.0 -1074)
344         (= x (string->number (number->string x))))
345       #t)
346#;(test-equal "flonum reader (minimum denormalized number -5.0e-324)" (let1 x (- (expt 2.0 -1074))
347         (= x (string->number (number->string x))))
348       #t)
349
350
351(test-equal "padding" (flonum-test '1#) '(10.0 #t))
352(test-equal "padding" (flonum-test '1#.) '(10.0 #t))
353(test-equal "padding" (flonum-test '1#.#) '(10.0 #t))
354(test-equal "padding" (flonum-test '10#.#) '(100.0 #t))
355(test-equal "padding" (flonum-test '1##.#) '(100.0 #t))
356(test-equal "padding" (flonum-test '100.0#) '(100.0 #t))
357(test-equal "padding" (flonum-test '1.#) '(1.0 #t))
358
359(test-equal "padding" (flonum-test '1#1) '|1#1|)
360(test-equal "padding" (flonum-test '1##1) '|1##1|)
361(test-equal "padding" (flonum-test '1#.1) '|1#.1|)
362(test-equal "padding" (flonum-test '1.#1) '|1.#1|)
363
364(test-equal "padding" (flonum-test '.#) '|.#|)
365(test-equal "padding" (flonum-test '0.#) '(0.0 #t))
366(test-equal "padding" (flonum-test '.0#) '(0.0 #t))
367(test-equal "padding" (flonum-test '0#) '(0.0 #t))
368(test-equal "padding" (flonum-test '0#.#) '(0.0 #t))
369(test-equal "padding" (flonum-test '0#.0) '|0#.0|)
370
371(test-equal "padding" (flonum-test '1#e2) '(1000.0 #t))
372(test-equal "padding" (flonum-test '1##e1) '(1000.0 #t))
373(test-equal "padding" (flonum-test '1#.##e2) '(1000.0 #t))
374(test-equal "padding" (flonum-test '0.#e2) '(0.0 #t))
375(test-equal "padding" (flonum-test '.0#e2) '(0.0 #t))
376(test-equal "padding" (flonum-test '.##e2) '|.##e2|)
377
378(test-equal "padding (exactness)" (flonum-test '#e1##) '(100 #f))
379(test-equal "padding (exactness)" (flonum-test '#e12#) '(120 #f))
380(test-equal "padding (exactness)" (flonum-test '#e12#.#) '(120 #f))
381(test-equal "padding (exactness)" (flonum-test '#i1##) '(100.0 #t))
382(test-equal "padding (exactness)" (flonum-test '#i12#) '(120.0 #t))
383(test-equal "padding (exactness)" (flonum-test '#i12#.#) '(120.0 #t))
384
385(test-equal "exponent out-of-range 1" (flonum-test '1e309) '(+inf.0 #t))
386(test-equal "exponent out-of-range 2" (flonum-test '1e10000) '(+inf.0 #t))
387;; TODO: Figure out what goes wrong here
388;(test-equal "exponent out-of-range 3" (flonum-test '1e1000000000000000000000000000000000000000000000000000000000000000) '(+inf.0 #t))
389(test-equal "exponent out-of-range 4" (flonum-test '-1e309) '(-inf.0 #t))
390(test-equal "exponent out-of-range 5" (flonum-test '-1e10000) '(-inf.0 #t))
391;(test-equal "exponent out-of-range 6" (flonum-test '-1e1000000000000000000000000000000000000000000000000000000000000000) '(-inf.0 #t))
392(test-equal "exponent out-of-range 7" (flonum-test '1e-324) '(0.0 #t))
393(test-equal "exponent out-of-range 8" (flonum-test '1e-1000) '(0.0 #t))
394;(test-equal "exponent out-of-range 9" (flonum-test '1e-1000000000000000000000000000000000000000000000000000000000000000000) '(0.0 #t))
395
396(test-equal "no integral part" (read-from-string ".5") 0.5)
397(test-equal "no integral part" (read-from-string "-.5") -0.5)
398(test-equal "no integral part" (read-from-string "+.5") 0.5)
399(test-end)
400
401;;------------------------------------------------------------------
402(test-begin "exact fractional number")
403
404(test-equal "exact fractonal number" (string->number "#e1.2345e4")
405       12345)
406(test-equal "exact fractonal number" (string->number "#e1.2345e14")
407       123450000000000)
408(test-equal "exact fractonal number" (string->number "#e1.2345e2")
409       12345/100)
410(test-equal "exact fractonal number" (string->number "#e1.2345e-2")
411       12345/1000000)
412(test-equal "exact fractonal number" (string->number "#e-1.2345e4")
413       -12345)
414(test-equal "exact fractonal number" (string->number "#e-1.2345e14")
415       -123450000000000)
416(test-equal "exact fractonal number" (string->number "#e-1.2345e2")
417       -12345/100)
418(test-equal "exact fractonal number" (string->number "#e-1.2345e-2")
419       -12345/1000000)
420
421(test-equal "exact fractonal number" (string->number "#e0.0001e300")
422       (expt 10 296))
423(test-equal "exact fractonal number" (string->number "#e-0.0001e300")
424       (- (expt 10 296)))
425
426(test-equal "exact fractonal number" (read-from-string "#e1e330")
427      (expt 10 330))
428(test-equal "exact fractonal number" (read-from-string "#e1e-330")
429      (expt 10 -330))
430
431(test-end)
432
433;;------------------------------------------------------------------
434(test-begin "complex reader")
435
436(define (decompose-complex z)
437  (cond ((real? z) z)
438        ((complex? z)
439         (list (real-part z) (imag-part z)))
440        (else z)))
441
442;; Fixed for exactness (Gauche's complex numbers are always inexact)
443(test-equal "complex reader" (decompose-complex '1+i) '(1 1))
444(test-equal "complex reader" (decompose-complex '1+1i) '(1 1))
445(test-equal "complex reader" (decompose-complex '1-i) '(1 -1))
446(test-equal "complex reader" (decompose-complex '1-1i) '(1 -1))
447(test-equal "complex reader" (decompose-complex '1.0+1i) '(1.0 1.0))
448(test-equal "complex reader" (decompose-complex '1.0+1.0i) '(1.0 1.0))
449(test-equal "complex reader" (decompose-complex '1e-5+1i) '(1e-5 1.0))
450(test-equal "complex reader" (decompose-complex '1e+5+1i) '(1e+5 1.0))
451(test-equal "complex reader" (decompose-complex '1+1e-5i) '(1.0 1e-5))
452(test-equal "complex reader" (decompose-complex '1+1e+5i) '(1.0 1e+5))
453(test-equal "complex reader" (decompose-complex '0.1+0.1e+5i) '(0.1 1e+4))
454(test-equal "complex reader" (decompose-complex '+i) '(0 1))
455(test-equal "complex reader" (decompose-complex '-i) '(0 -1))
456(test-equal "complex reader" (decompose-complex '+1i) '(0 1))
457(test-equal "complex reader" (decompose-complex '-1i) '(0 -1))
458(test-equal "complex reader" (decompose-complex '+1.i) '(0.0 1.0))
459(test-equal "complex reader" (decompose-complex '-1.i) '(0.0 -1.0))
460(test-equal "complex reader" (decompose-complex '+1.0i) '(0.0 1.0))
461(test-equal "complex reader" (decompose-complex '-1.0i) '(0.0 -1.0))
462(test-equal "complex reader" (decompose-complex '1+0.0i) 1.0)
463(test-equal "complex reader" (decompose-complex '1+.0i) 1.0)
464(test-equal "complex reader" (decompose-complex '1+0.i) 1.0)
465(test-equal "complex reader" (decompose-complex '1+0.0e-43i) 1.0)
466(test-equal "complex reader" (decompose-complex '1e2+0.0e-43i) 100.0)
467
468(test-equal "complex reader" (decompose-complex 'i) 'i)
469(test-equal "complex reader" (decompose-complex (string->number ".i")) #f)
470(test-equal "complex reader" (decompose-complex (string->number "+.i")) #f)
471(test-equal "complex reader" (decompose-complex (string->number "-.i")) #f)
472(test-equal "complex reader" (decompose-complex '33i) '33i)
473(test-equal "complex reader" (decompose-complex 'i+1) 'i+1)
474(test-equal "complex reader" (decompose-complex '++i) '|++i|)
475(test-equal "complex reader" (decompose-complex '--i) '|--i|)
476
477(test-equal "complex reader" (decompose-complex 1/2+1/2i) '(1/2 1/2))
478(test-equal "complex reader" (decompose-complex 0+1/2i) '(0 1/2))
479(test-equal "complex reader" (decompose-complex -1/2i) '(0 -1/2))
480(test-equal "complex reader" (decompose-complex 1/2-0/2i) 1/2)
481;; The following is also invalid R5RS syntax, so it's commented out
482#;(test-equal "complex reader" (decompose-complex (string->number "1/2-1/0i")) '(0.5 -inf.0))
483
484(test-equal "complex reader (polar)" (make-polar 1.0 1.0) 1.0@1.0)
485(test-equal "complex reader (polar)" (make-polar 1.0 -1.0) 1.0@-1.0)
486(test-equal "complex reader (polar)" (make-polar 1.0 1.0) 1.0@+1.0)
487(test-equal "complex reader (polar)" (make-polar -7.0 -3.0) -7@-3.0)
488(test-equal "complex reader (polar)" (make-polar 3.5 -3.0) 7/2@-3.0)
489(test-equal "complex reader (polar)" (string->number "7/2@-3.14i") #f)
490
491(test-end)
492
493;;------------------------------------------------------------------
494(test-begin "integer writer syntax")
495
496(define (i-tester2 x)
497  (map number->string (i-tester x)))
498
499(test-equal "around 2^28"
500      (i-tester2 (exp2 28))
501      '("268435456" "536870911" "536870912"
502        "-268435456" "-536870911" "-536870912" "-536870913"))
503
504(test-equal "around 2^31"
505      (i-tester2 (exp2 31))
506      '("2147483648" "4294967295" "4294967296"
507        "-2147483648" "-4294967295" "-4294967296" "-4294967297"))
508
509(test-equal "around 2^60"
510      (i-tester2 (exp2 60))
511      '("1152921504606846976" "2305843009213693951" "2305843009213693952"
512        "-1152921504606846976" "-2305843009213693951" "-2305843009213693952"
513        "-2305843009213693953"))
514
515(test-equal "around 2^63"
516      (i-tester2 (exp2 63))
517      '("9223372036854775808" "18446744073709551615" "18446744073709551616"
518        "-9223372036854775808" "-18446744073709551615" "-18446744073709551616"
519        "-18446744073709551617"))
520
521(test-equal "around 2^127"
522      (i-tester2 (exp2 127))
523      '("170141183460469231731687303715884105728"
524        "340282366920938463463374607431768211455"
525        "340282366920938463463374607431768211456"
526        "-170141183460469231731687303715884105728"
527        "-340282366920938463463374607431768211455"
528        "-340282366920938463463374607431768211456"
529        "-340282366920938463463374607431768211457"))
530
531(test-end)
532
533;;==================================================================
534;; Conversions
535;;
536
537;; We first test expt, for we need to use it to test exact<->inexact
538;; conversion stuff.
539(test-begin "expt")
540
541(test-equal "exact expt" (expt 5 0) 1)
542(test-equal "exact expt" (expt 5 10) 9765625)
543(test-equal "exact expt" (expt 5 13) 1220703125)
544(test-equal "exact expt" (expt 5 123) 94039548065783000637498922977779654225493244541767001720700136502273380756378173828125)
545(test-equal "exact expt" (expt 5 -123) 1/94039548065783000637498922977779654225493244541767001720700136502273380756378173828125)
546(test-equal "exact expt" (expt -5 0) 1)
547(test-equal "exact expt" (expt -5 10) 9765625)
548(test-equal "exact expt" (expt -5 13) -1220703125)
549(test-equal "exact expt" (expt -5 123) -94039548065783000637498922977779654225493244541767001720700136502273380756378173828125)
550(test-equal "exact expt" (expt -5 -123) -1/94039548065783000637498922977779654225493244541767001720700136502273380756378173828125)
551(test-equal "exact expt" (expt 1 720000) 1)
552(test-equal "exact expt" (expt -1 720000) 1)
553(test-equal "exact expt" (expt -1 720001) -1)
554
555(test-equal "exact expt (ratinoal)" (expt 2/3 33)
556       8589934592/5559060566555523)
557(test-equal "exact expt (rational)" (expt -2/3 33)
558       -8589934592/5559060566555523)
559(test-equal "exact expt (ratinoal)" (expt 2/3 -33)
560       5559060566555523/8589934592)
561
562(test-end)
563
564(parameterize ((current-test-epsilon 10e7))
565  (test-equal "expt (coercion to inexact)" (expt 2 1/2)
566        1.4142135623730951)) ;; NB: pa$ will be tested later
567
568(test-begin "exact<->inexact")
569
570(for-each
571 (lambda (e&i)
572   (let ((e (car e&i))
573         (i (cdr e&i)))
574     (test-equal (format "exact->inexact ~s" i) (exact->inexact e) i)
575     (test-equal (format "exact->inexact ~s" (- i)) (exact->inexact (- e)) (- i))
576     (test-equal (format "inexact->exact ~s" e) (inexact->exact i) e)
577     (test-equal (format "inexact->exact ~s" (- e)) (inexact->exact (- i)) (- e))
578     ))
579 `((0  . 0.0)
580   (1  . 1.0)
581   (-1 . -1.0)
582   (,(expt 2 52) . ,(expt 2.0 52))
583   (,(expt 2 53) . ,(expt 2.0 53))
584   (,(expt 2 54) . ,(expt 2.0 54))
585   ))
586
587;; Rounding bignum to flonum, edge cases.
588;; Test patterns:
589;;
590;;   <------53bits------->
591;;a) 100000000...000000000100000....0000       round down (r0)
592;;b) 100000000...000000000100000....0001       round up (r1)
593;;c) 100000000...000000001100000....0000       round up (r2)
594;;d) 100000000...000000001011111....1111       round down (r1)
595;;e) 111111111...111111111100000....0000       round up, carry over (* r0 2)
596;;f) 101111111...111111111100000....0000       round up, no carry over (r3)
597;;            <--32bits-->
598;;g) 100..0000111.....1111100000....0000       round up; boundary on ILP32 (r4)
599
600(let loop ((n 0)
601           (a (+ (expt 2 53) 1))
602           (c (+ (expt 2 53) 3))
603           (e (- (expt 2 54) 1))
604           (f (+ (expt 2 53) (expt 2 52) -1))
605           (g (+ (expt 2 53) (expt 2 33) -1))
606           (r0 (expt 2.0 53))
607           (r1 (+ (expt 2.0 53) 2.0))
608           (r2 (+ (expt 2.0 53) 4.0))
609           (r3 (+ (expt 2.0 53) (expt 2.0 52)))
610           (r4 (+ (expt 2.0 53) (expt 2.0 33))))
611  (when (< n 32)
612    (test-equal (format "exact->inexact, pattern a: round down (~a)" n)
613           (exact->inexact a) r0)
614    (test-equal (format "exact->inexact, pattern b: round up   (~a)" n)
615           (exact->inexact (+ a 1)) r1)
616    (test-equal (format "exact->inexact, pattern c: round up   (~a)" n)
617           (exact->inexact c) r2)
618    (test-equal (format "exact->inexact, pattern d: round down (~a)" n)
619           (exact->inexact (- c 1)) r1)
620    (test-equal (format "exact->inexact, pattern e: round up   (~a)" n)
621           (exact->inexact e) (* r0 2.0))
622    (test-equal (format "exact->inexact, pattern f: round up   (~a)" n)
623           (exact->inexact f) r3)
624    (test-equal (format "exact->inexact, pattern g: round up   (~a)" n)
625           (exact->inexact g) r4)
626    (loop (+ n 1) (ash a 1) (ash c 1) (ash e 1) (ash f 1) (ash g 1)
627          (* r0 2.0) (* r1 2.0) (* r2 2.0) (* r3 2.0) (* r4 2.0))))
628
629
630(parameterize ((current-test-epsilon 10e12))
631  (test-equal "expt (ratnum with large denom and numer) with inexact conversion 1"
632        (exact->inexact (expt 8/9 342))
633        (expt 8/9 342.0))
634
635  (test-equal "expt (ratnum with large denom and numer) with inexact conversion 2"
636        (exact->inexact (expt -8/9 343))
637        (expt -8/9 343.0)))
638
639;; The following few tests covers RATNUM paths in Scm_GetDouble
640(test-equal "expt (ratnum with large denom and numer) with inexact conversion 3"
641       (exact->inexact (/ (expt 10 20) (expt 10 328))) 1.0e-308)
642;; In the original Gauche test this checked for a return value of 0.0, but
643;; that's quite Gauche-specific.  We return 1.0e-309.
644;; It's probably wrong to test this kind of behaviour in the first place...
645(test-equal "expt (ratnum with large denom and numer) with inexact conversion 4"
646       (exact->inexact (/ (expt 10 20) (expt 10 329))) 1.0e-309)
647(test-equal "expt (ratnum with large denom and numer) with inexact conversion 5"
648       (exact->inexact (/ (expt 10 328) (expt 10 20))) 1.0e308)
649(test-equal "expt (ratnum with large denom and numer) with inexact conversion 6"
650       (exact->inexact (/ (expt 10 329) (expt 10 20))) +inf.0)
651(test-equal "expt (ratnum with large denom and numer) with inexact conversion 7"
652       (exact->inexact (/ (expt -10 329) (expt 10 20))) -inf.0)
653
654(test-end)
655
656;;==================================================================
657;; Predicates
658;;
659
660(test-begin "predicates")
661
662(test-equal "integer?" (integer? 0) #t)
663(test-equal "integer?" (integer? 85736847562938475634534245) #t)
664(test-equal "integer?" (integer? 85736.534245) #f)
665(test-equal "integer?" (integer? 3.14) #f)
666(test-equal "integer?" (integer? 3+4i) #f)
667(test-equal "integer?" (integer? 3+0i) #t)
668(test-equal "integer?" (integer? #f) #f)
669
670(test-equal "rational?" (rational? 0) #t)
671(test-equal "rational?" (rational? 85736847562938475634534245) #t)
672(test-equal "rational?" (rational? 1/2) #t)
673(test-equal "rational?" (rational? 85736.534245) #t)
674(test-equal "rational?" (rational? 3.14) #t)
675(test-equal "rational?" (rational? 3+4i) #f)
676(test-equal "rational?" (rational? 3+0i) #t)
677(test-equal "rational?" (rational? #f) #f)
678(test-equal "rational?" (rational? +inf.0) #f)
679(test-equal "rational?" (rational? -inf.0) #f)
680(test-equal "rational?" (rational? +nan.0) #f)
681
682(test-equal "real?" (real? 0) #t)
683(test-equal "real?" (real? 85736847562938475634534245) #t)
684(test-equal "real?" (real? 857368.4756293847) #t)
685(test-equal "real?" (real? 3+0i) #t)
686(test-equal "real?" (real? 3+4i) #f)
687(test-equal "real?" (real? +4.3i) #f)
688(test-equal "real?" (real? '()) #f)
689(test-equal "real?" (real? +inf.0) #t)
690(test-equal "real?" (real? -inf.0) #t)
691(test-equal "real?" (real? +nan.0) #t)
692
693(test-equal "complex?" (complex? 0) #t)
694(test-equal "complex?" (complex? 85736847562938475634534245) #t)
695(test-equal "complex?" (complex? 857368.4756293847) #t)
696(test-equal "complex?" (complex? 3+0i) #t)
697(test-equal "complex?" (complex? 3+4i) #t)
698(test-equal "complex?" (complex? +4.3i) #t)
699(test-equal "complex?" (complex? '()) #f)
700
701(test-equal "number?" (number? 0) #t)
702(test-equal "number?" (number? 85736847562938475634534245) #t)
703(test-equal "number?" (number? 857368.4756293847) #t)
704(test-equal "number?" (number? 3+0i) #t)
705(test-equal "number?" (number? 3+4i) #t)
706(test-equal "number?" (number? +4.3i) #t)
707(test-equal "number?" (number? '()) #f)
708
709(test-equal "exact?" (exact? 1) #t)
710(test-equal "exact?" (exact? 4304953480349304983049304953804) #t)
711(test-equal "exact?" (exact? 430495348034930/4983049304953804) #t)
712(test-equal "exact?" (exact? 1.0) #f)
713(test-equal "exact?" (exact? 4304953480349304983.049304953804) #f)
714(test-equal "exact?" (exact? 1.0+0i) #f)
715(test-equal "exact?" (exact? 1.0+5i) #f)
716(test-equal "inexact?" (inexact? 1) #f)
717(test-equal "inexact?" (inexact? 4304953480349304983049304953804) #f)
718(test-equal "inexact?" (inexact? 430495348034930/4983049304953804) #f)
719(test-equal "inexact?" (inexact? 1.0) #t)
720(test-equal "inexact?" (inexact? 4304953480349304983.049304953804) #t)
721(test-equal "inexact?" (inexact? 1.0+0i) #t)
722(test-equal "inexact?" (inexact? 1.0+5i) #t)
723
724(test-equal "odd?" (odd? 1) #t)
725(test-equal "odd?" (odd? 2) #f)
726(test-equal "even?" (even? 1) #f)
727(test-equal "even?" (even? 2) #t)
728(test-equal "odd?" (odd? 1.0) #t)
729(test-equal "odd?" (odd? 2.0) #f)
730(test-equal "even?" (even? 1.0) #f)
731(test-equal "even?" (even? 2.0) #t)
732(test-equal "odd?" (odd? 10000000000000000000000000000000000001) #t)
733(test-equal "odd?" (odd? 10000000000000000000000000000000000002) #f)
734(test-equal "even?" (even? 10000000000000000000000000000000000001) #f)
735(test-equal "even?" (even? 10000000000000000000000000000000000002) #t)
736
737(test-equal "zero?" (zero? 0) #t)
738(test-equal "zero?" (zero? 0.0) #t)
739(test-equal "zero?" (zero? (- 10 10.0)) #t)
740(test-equal "zero?" (zero? 0+0i) #t)
741(test-equal "zero?" (zero? 1.0) #f)
742(test-equal "zero?" (zero? +5i) #f)
743(test-equal "positive?" (positive? 1) #t)
744(test-equal "positive?" (positive? -1) #f)
745(test-equal "positive?" (positive? 1/7) #t)
746(test-equal "positive?" (positive? -1/7) #f)
747(test-equal "positive?" (positive? 3.1416) #t)
748(test-equal "positive?" (positive? -3.1416) #f)
749(test-equal "positive?" (positive? 134539485343498539458394) #t)
750(test-equal "positive?" (positive? -134539485343498539458394) #f)
751(test-equal "negative?" (negative? 1) #f)
752(test-equal "negative?" (negative? -1) #t)
753(test-equal "negative?" (negative? 1/7) #f)
754(test-equal "negative?" (negative? -1/7) #t)
755(test-equal "negative?" (negative? 3.1416) #f)
756(test-equal "negative?" (negative? -3.1416) #t)
757(test-equal "negative?" (negative? 134539485343498539458394) #f)
758(test-equal "negative?" (negative? -134539485343498539458394) #t)
759
760(let-syntax ((tester (syntax-rules ()
761                       ((_ name proc result)
762                        (begin (test-error name (proc #t))
763                               (test-equal name (list (proc 1)
764                                                       (proc +inf.0)
765                                                       (proc -inf.0)
766                                                       (proc +nan.0)) result))))))
767  (tester "finite?"   finite?   `(#t #f #f #f))
768  (tester "infinite?" infinite? `(#f #t #t #f))
769  (tester "nan?"      nan?      `(#f #f #f #t))
770  )
771
772
773(test-equal "eqv?" (eqv? 20 20) #t)
774(test-equal "eqv?" (eqv? 20.0 20.00000) #t)
775(test-equal "eqv?" (eqv? 4/5 0.8) #f)
776(test-equal "eqv?" (eqv? (exact->inexact 4/5) 0.8) #t)
777(test-equal "eqv?" (eqv? 4/5 (inexact->exact 0.8)) #f)
778(test-equal "eqv?" (eqv? 20 (inexact->exact 20.0)) #t)
779(test-equal "eqv?" (eqv? 20 20.0) #f)
780
781;; numeric comparison involving nan.  we should test both
782;; inlined case and applied case
783(define-syntax test-nan-cmp
784  (ir-macro-transformer
785   (lambda (e r c)
786     (let ((op (cadr e)))
787       `(begin
788          (test-equal (format "NaN ~a (inlined)" ',op) (list (,op +nan.0 +nan.0) (,op +nan.0 0) (,op 0 +nan.0))
789                '(#f #f #f))
790          (test-equal (format "NaN ~a (applied)" ',op) (list (apply ,op '(+nan.0 +nan.0))
791                      (apply ,op '(+nan.0 0))
792                      (apply ,op '(0 +nan.0)))
793                '(#f #f #f)))))))
794(test-nan-cmp =)
795(test-nan-cmp <)
796(test-nan-cmp <=)
797(test-nan-cmp >)
798(test-nan-cmp >=)
799
800;; the following tests combine instructions for comparison.
801(let ((zz #f))
802  (set! zz 3.14)  ;; prevent the compiler from optimizing constants
803
804  (test-equal "NUMEQF" (list (= 3.14 zz) (= zz 3.14) (= 3.15 zz) (= zz 3.15))
805         '(#t #t #f #f))
806  (test-equal "NLTF" (list (< 3.14 zz) (< zz 3.14)
807               (< 3.15 zz) (< zz 3.15)
808               (< 3.13 zz) (< zz 3.13))
809         '(#f #f #f #t #t #f))
810  (test-equal "NLEF" (list (<= 3.14 zz) (<= zz 3.14)
811               (<= 3.15 zz) (<= zz 3.15)
812               (<= 3.13 zz) (<= zz 3.13))
813         '(#t #t #f #t #t #f))
814  (test-equal "NGTF" (list (> 3.14 zz) (> zz 3.14)
815               (> 3.15 zz) (> zz 3.15)
816               (> 3.13 zz) (> zz 3.13))
817         '(#f #f #t #f #f #t))
818  (test-equal "NGEF" (list (>= 3.14 zz) (>= zz 3.14)
819               (>= 3.15 zz) (>= zz 3.15)
820               (>= 3.13 zz) (>= zz 3.13))
821         '(#t #t #t #f #f #t))
822  )
823
824;; Go through number comparison routines.
825;; assumes a >= b, a > 0, b > 0
826;; we use apply to prevent inlining.
827(define (numcmp-test msg eq a b)
828  (let ((pp (list a b))
829        (pm (list a (- b)))
830        (mp (list (- a) b))
831        (mm (list (- a) (- b))))
832    (define (test4 op opname rev results)
833      (for-each (lambda (result comb args)
834                  (let ((m (conc msg " " (if rev 'rev "") opname "(" comb ")")))
835                   (test-equal m (apply op (if rev (reverse args) args)) result)))
836                results '(++ +- -+ --) (list pp pm mp mm)))
837    (test4 =  '=  #f (list eq #f #f eq))
838    (test4 =  '=  #t (list eq #f #f eq))
839    (test4 >= '>= #f (list #t #t #f eq))
840    (test4 >= '>= #t (list eq #f #t #t))
841    (test4 >  '>  #f (list (not eq) #t #f #f))
842    (test4 >  '>  #t (list #f #f #t (not eq)))
843    (test4 <= '<= #f (list eq #f #t #t))
844    (test4 <= '<= #t (list #t #t #f eq))
845    (test4 <  '<  #f (list #f #f #t (not eq)))
846    (test4 <  '<  #t (list (not eq) #t #f #f))
847    ))
848
849(numcmp-test "fixnum vs fixnum eq" #t 156 156)
850(numcmp-test "fixnum vs fixnum ne" #f 878252 73224)
851(numcmp-test "bignum vs fixnum ne" #f (expt 3 50) 9982425)
852(numcmp-test "bignum vs bignum eq" #t (expt 3 50) (expt 3 50))
853(numcmp-test "bignum vs bignum ne" #f (expt 3 50) (expt 3 49))
854(numcmp-test "flonum vs fixnum eq" #t 314.0 314)
855(numcmp-test "flonum vs fixnum ne" #f 3140.0 314)
856(numcmp-test "flonum vs bignum eq" #t (expt 2.0 64) (expt 2 64))
857(numcmp-test "flonum vs bignum ne" #f (expt 2.0 64) (expt 2 63))
858(numcmp-test "ratnum vs fixnum ne" #f 13/2 6)
859(numcmp-test "ratnum vs ratnum eq" #t 3/5 3/5)
860(numcmp-test "ratnum vs ratnum 1 ne" #f 3/5 4/7)
861(numcmp-test "ratnum vs ratnum 2 ne" #f 4/5 3/7)
862(numcmp-test "ratnum vs ratnum 3 ne" #f 4/7 2/5)
863(numcmp-test "ratnum vs ratnum 4 ne" #f 4/7 3/7)
864(numcmp-test "ratnum vs flonum eq" #t 3/8 0.375)
865(numcmp-test "ratnum vs flonum ne" #f 8/9 0.6)
866(numcmp-test "ratnum vs bignum ne" #f (/ (+ (expt 2 64) 1) 2) (expt 2 63))
867
868;; This is from the bug report from Bill Schottsteadt.  Before 0.8.10
869;; this yielded #t because of the precision loss in fixnum vs ratnum
870;; comparison.
871
872(test-equal "fixnum/ratnum comparison" (= -98781233389595723930250385525631360344437602649022271391716773162526352115087074898920261954897888235939429993829738630297052776667061779065100945771127020439712527398509771853491319737304616607041615012797134365574007368603232768089410097730646360760856052946465578073788924743642391638455649511108051053789425902013657106523269224045822294981391380222050223141347787674321888089837786284947870569165079491411110074602544203383038299901291952931113248943344436935596614205784436844912243069019367149526328612664067719765890897558075277707055756274228634652905751880612235340874976952880431555921814590049070979276358637989837532124647692152520447680373275200239544449293834424643702763974403094033892112967196087310232853165951285609426599617479356206218697586025251765476179158153123631158173662488102357611674821528467825910806391548770908013608889792001203039243914696463472490444573930050190716726220002151679336252008777326482398042427845860796285369622627679324605214987983884122808994422164327311297556122943400093231935477754959547620500784989043704825777186301417894825200797719289692636286337716705491307686644214213732116277102140558505945554566856673724837541141206267647285222293953181717113434757149921850120377706206012113994795124049471433490016083401216757825264766474891405185591236321448744678896448941259668731597494947127423662646933419809756274038044752395708014998820826196523041220918922611359697502638594907608648168849193813197790291360087857093790119162389573209640804111261616771827989939551840471235079945175327536638365874717775169210186608268924244639016270610098894971732892267642318266405837012482726627199088381027028630711279130575230815976484191675172279903609489448225149181063260231957171204855841611039996959582465138269247794842445177715476581512709861409446684911276158067098438009067149531119008707418601627426255891/2063950098473886055933596136103014753954685977787179797499441692283103642150668140884348149132839387663291870239435604463778573480782766958396423322880804442523056530013282118705429274303746421980903580754656364533869319744640130831962767797772323836293079599182477171562218297208495122660799328579852852969560730744211066545295945803939271680397511478811389399527913043145952054883289558914237172406636283114284363301999238526952309439259354223729114988806937903509692118585280437646676248013406270664905997291670857985754768850507766359973207600149782819306010561088246502918148146264806947375101624011387317921439210509902170092173796154464078297852707797984007992277904626058467143192149921546030028316990855470478894515952884526783686210401408859364838148201339959570732480920969000913791571631154267939054105878236201498477027265774680071188764947522112650857013491135901945605796776829525789886482760578142306057177990048751864852763036720112071475134369179525117161001517868525821398753039187062869247457336940152614866298628205010037695017885878296140891234142925514925051385440766473260338168038302226808098439763889250948602137806546736025439919604390464712793474019469457135856879584745805794574609707742445431851999335443724488636749987837445626810087003490329257105472274738811579817454656532496370562155449815456374456838912258383282154811001588175608617475540639254689723629881619252699580383612847920348111900440075645703960104081690968807839189109040568288972353424306876947127635585164905071821419089229871978994388197349499565628906992171901547121903117815637249359328193980583892566359962066242217169190169986105579733710057404319381685578470983838597020624234209884597110721892707818651210378187525863009879314177842634871978427592746452643603586344401223449546482306838947819060455178762434166799996220143825677025686435609179225302671777326568324855229172912876656233006785717920665743720753617646617017219230313226844735567400507490772935145894670445831971526014183234960075574401616682479457962912905141754252265169682318523572680657053374002911007741991220001444440319448034755483178790032581428679303588017268970 0)
873       #f)
874
875
876;;==================================================================
877;; Fixnum stuff
878;;
879
880(test-equal "fixnum? fixnum" (fixnum? 0) #t)
881(test-equal "fixnum? ratnum" (fixnum? 1/2) #f)
882(test-equal "fixnum? bignum" (fixnum? (expt 2 256)) #f)
883(test-equal "fixnum? flonum" (fixnum? 3.14) #f)
884(test-equal "fixnum? compnum" (fixnum? 1+3i) #f)
885
886(test-equal "fixnum? greatest"    (fixnum? (greatest-fixnum)) #t)
887(test-equal "fixnum? greatest+1"  (fixnum? (+ (greatest-fixnum) 1)) #f)
888(test-equal "fixnum? least"       (fixnum? (least-fixnum)) #t)
889(test-equal "fixnum? least-1"     (fixnum? (- (least-fixnum) 1)) #f)
890
891(test-equal "greatest fixnum & width" (- (ash 1 (fixnum-width)) 1)
892       (greatest-fixnum))
893(test-equal "least fixnum & width" (- (ash 1 (fixnum-width)))
894       (least-fixnum))
895
896(test-end)
897
898;;==================================================================
899;; Arithmetics
900;;
901
902;;------------------------------------------------------------------
903(test-begin "integer addition")
904
905(define x #xffffffff00000000ffffffff00000000)
906(define xx (- x))
907(define y #x00000002000000000000000200000000)
908(define yy (- y))
909(define z #x00000000000000010000000000000001)
910(test-equal "bignum + bignum" (+ x y)
911      #x100000001000000010000000100000000)
912(test-equal "bignum + -bignum" (+ x yy)
913      #xfffffffd00000000fffffffd00000000)
914(test-equal "bignum - bignum" (- x z)
915      #xfffffffefffffffffffffffeffffffff)
916(test-equal "bignum - bignum" (- (+ x y) y)
917      x)
918(test-equal "-bignum + bignum" (+ xx y)
919      #x-fffffffd00000000fffffffd00000000)
920(test-equal "-bignum + -bignum" (+ xx yy)
921      #x-100000001000000010000000100000000)
922(test-equal "-bignum - bignum" (- xx y)
923      #x-100000001000000010000000100000000)
924(test-equal "-bignum - -bignum" (- xx yy)
925      #x-fffffffd00000000fffffffd00000000)
926
927;; This test a possible shortcut in Scm_Add etc.  We use apply
928;; to avoid operators from being inlined.
929(test-equal "0 + bignum" (list (apply + (list 0 x)) (apply + (list x 0)))
930       (list x x))
931(test-equal "0 - bignum" (list (apply - (list 0 x)) (apply - (list x 0)))
932       (list (- x) x))
933(test-equal "0 * bignum" (list (apply * (list 0 x)) (apply * (list x 0)))
934       (list 0 0))
935(test-equal "1 * bignum" (list (apply * (list 1 x)) (apply * (list x 1)))
936       (list x x))
937(test-equal "bignum / 1" (apply / (list x 1))
938       x)
939
940(test-end)
941
942;;------------------------------------------------------------------
943(test-begin "small immediate integer constants")
944
945;; pushing small literal integer on the stack may be done
946;; by combined instruction PUSHI.  These test if it works.
947
948(define (foo a b c d e) (list a b c d e))
949
950;; 2^19-1
951(test-equal "PUSHI" (foo 0 524287 524288 -524287 -524288)
952              '(0 524287 524288 -524287 -524288))
953;; 2^51-1
954(test-equal "PUSHI" (foo 0 2251799813685247 2251799813685248
955             -2251799813685247 -2251799813685248)
956              '(0 2251799813685247 2251799813685248
957                  -2251799813685247 -2251799813685248 ))
958
959(test-end)
960
961;;------------------------------------------------------------------
962(test-begin "small immediate integer additions")
963
964;; small literal integer x (-2^19 <= x < 2^19 on 32bit architecture)
965;; in binary addition/subtraction is compiled in special instructuions,
966;; NUMADDI and NUMSUBI.
967
968(define x 2)
969(test-equal "NUMADDI" (+ 3 x) 5)
970(test-equal "NUMADDI" (+ x 3) 5)
971(test-equal "NUMADDI" (+ -1 x) 1)
972(test-equal "NUMADDI" (+ x -1) 1)
973(test-equal "NUMSUBI" (- 3 x) 1)
974(test-equal "NUMSUBI" (- x 3) -1)
975(test-equal "NUMSUBI" (- -3 x) -5)
976(test-equal "NUMSUBI" (- x -3) 5)
977(define x 2.0)
978(test-equal "NUMADDI" (+ 3 x) 5.0)
979(test-equal "NUMADDI" (+ x 3) 5.0)
980(test-equal "NUMADDI" (+ -1 x) 1.0)
981(test-equal "NUMADDI" (+ x -1) 1.0)
982(test-equal "NUMSUBI" (- 3 x) 1.0)
983(test-equal "NUMSUBI" (- x 3) -1.0)
984(test-equal "NUMSUBI" (- -3 x) -5.0)
985(test-equal "NUMSUBI" (- x -3) 5.0)
986(define x #x100000000)
987(test-equal "NUMADDI" (+ 3 x) #x100000003)
988(test-equal "NUMADDI" (+ x 3) #x100000003)
989(test-equal "NUMADDI" (+ -1 x) #xffffffff)
990(test-equal "NUMADDI" (+ x -1) #xffffffff)
991(test-equal "NUMSUBI" (- 3 x) #x-fffffffd)
992(test-equal "NUMSUBI" (- x 3) #xfffffffd)
993(test-equal "NUMSUBI" (- -3 x) #x-100000003)
994(test-equal "NUMSUBI" (- x -3) #x100000003)
995(define x 33/7)
996(test-equal "NUMADDI" (+ 3 x) 54/7)
997(test-equal "NUMADDI" (+ x 3) 54/7)
998(test-equal "NUMADDI" (+ -1 x) 26/7)
999(test-equal "NUMADDI" (+ x -1) 26/7)
1000(test-equal "NUMADDI" (- 3 x) -12/7)
1001(test-equal "NUMADDI" (- x 3) 12/7)
1002(test-equal "NUMADDI" (- -3 x) -54/7)
1003(test-equal "NUMADDI" (- x -3) 54/7)
1004
1005(test-equal "NUMADDI" (+ 10 (if #t 20 25)) 30)
1006(test-equal "NUMADDI" (+ (if #t 20 25) 10) 30)
1007(test-equal "NUMADDI" (+ 10 (if #f 20 25)) 35)
1008(test-equal "NUMADDI" (+ (if #f 20 25) 10) 35)
1009(test-equal "NUMADDI" (let ((x #t)) (+ 10 (if x 20 25))) 30)
1010(test-equal "NUMADDI" (let ((x #t)) (+ (if x 20 25) 10)) 30)
1011(test-equal "NUMADDI" (let ((x #f)) (+ 10 (if x 20 25))) 35)
1012(test-equal "NUMADDI" (let ((x #f)) (+ (if x 20 25) 10)) 35)
1013(test-equal "NUMADDI" (+ 10 (do ((x 0 (+ x 1))) ((> x 10) x))) 21)
1014(test-equal "NUMADDI" (+ (do ((x 0 (+ x 1))) ((> x 10) x)) 10) 21)
1015(test-equal "NUMSUBI" (- 10 (if #t 20 25)) -10)
1016(test-equal "NUMSUBI" (- (if #t 20 25) 10) 10)
1017(test-equal "NUMSUBI" (- 10 (if #f 20 25)) -15)
1018(test-equal "NUMSUBI" (- (if #f 20 25) 10) 15)
1019(test-equal "NUMSUBI" (let ((x #t)) (- 10 (if x 20 25))) -10)
1020(test-equal "NUMSUBI" (let ((x #t)) (- (if x 20 25) 10)) 10)
1021(test-equal "NUMSUBI" (let ((x #f)) (- 10 (if x 20 25))) -15)
1022(test-equal "NUMSUBI" (let ((x #f)) (- (if x 20 25) 10)) 15)
1023(test-equal "NUMSUBI" (- 10 (do ((x 0 (+ x 1))) ((> x 10) x))) -1)
1024(test-equal "NUMSUBI" (- (do ((x 0 (+ x 1))) ((> x 10) x)) 10) 1)
1025
1026(test-end)
1027
1028;;------------------------------------------------------------------
1029(test-begin "immediate flonum integer arith")
1030
1031;; tests special instructions for immediate flonum integer arithmetic
1032
1033
1034(define x 2.0)
1035(test-equal "NUMADDF" (+ 3 x) 5.0)
1036(test-equal "NUMADDF" (+ x 3) 5.0)
1037(test-equal "NUMADDF" (+ -1 x) 1.0)
1038(test-equal "NUMADDF" (+ x -1) 1.0)
1039(test-equal "NUMADDF" (+ +i x) 2.0+1.0i)
1040(test-equal "NUMADDF" (+ x +i) 2.0+1.0i)
1041
1042(test-equal "NUMSUBF" (- 3 x) 1.0)
1043(test-equal "NUMSUBF" (- x 3) -1.0)
1044(test-equal "NUMSUBF" (- -3 x) -5.0)
1045(test-equal "NUMSUBF" (- x -3) 5.0)
1046(test-equal "NUMSUBF" (- +i x) -2.0+1.0i)
1047(test-equal "NUMSUBF" (- x +i) 2.0-1.0i)
1048
1049(test-equal "NUMMULF" (* x 2) 4.0)
1050(test-equal "NUMMULF" (* 2 x) 4.0)
1051(test-equal "NUMMULF" (* x 1.5) 3.0)
1052(test-equal "NUMMULF" (* 1.5 x) 3.0)
1053(test-equal "NUMMULF" (* x +i) 0+2.0i)
1054(test-equal "NUMMULF" (* +i x) 0+2.0i)
1055
1056(test-equal "NUMDIVF" (/ x 4) 0.5)
1057(test-equal "NUMDIVF" (/ 4 x) 2.0)
1058(test-equal "NUMDIVF" (/ x 4.0) 0.5)
1059(test-equal "NUMDIVF" (/ 4.0 x) 2.0)
1060(test-equal "NUMDIVF" (/ x +4i) 0.0-0.5i)
1061(test-equal "NUMDIVF" (/ +4i x) 0.0+2.0i)
1062
1063(test-end)
1064
1065;;------------------------------------------------------------------
1066(test-begin "rational number addition")
1067
1068(test-equal "ratnum +" (+ 11/13 21/19) 482/247)
1069(test-equal "ratnum -" (- 11/13 21/19) -64/247)
1070
1071;; tests possible shortcut in Scm_Add etc.
1072(test-equal "ratnum + 0" (list (apply + '(0 11/13)) (apply + '(11/13 0)))
1073       (list 11/13 11/13))
1074(test-equal "ratnum - 0" (list (apply - '(0 11/13)) (apply - '(11/13 0)))
1075       (list -11/13 11/13))
1076(test-equal "ratnum * 0" (list (apply * '(0 11/13)) (apply * '(11/13 0)))
1077       (list 0 0))
1078(test-equal "ratnum * 1" (list (apply * '(1 11/13)) (apply * '(11/13 1)))
1079       (list 11/13 11/13))
1080(test-equal "ratnum / 1" (apply / '(11/13 1))
1081       11/13)
1082
1083(test-end)
1084
1085;;------------------------------------------------------------------
1086(test-begin "promotions in addition")
1087
1088(define-syntax +-tester
1089  (syntax-rules ()
1090    ((_ (+ args ...))
1091     (let ((inline (+ args ...))
1092           (other  (apply + `(,args ...))))
1093       (and (= inline other)
1094            (list inline (exact? inline)))))))
1095
1096(test-equal "+" (+-tester (+)) '(0 #t))
1097(test-equal "+" (+-tester (+ 1)) '(1 #t))
1098(test-equal "+" (+-tester (+ 1 2)) '(3 #t))
1099(test-equal "+" (+-tester (+ 1 2 3)) '(6 #t))
1100(test-equal "+" (+-tester (+ 1/6 1/3 1/2)) '(1 #t))
1101(test-equal "+" (+-tester (+ 1.0)) '(1.0 #f))
1102(test-equal "+" (+-tester (+ 1.0 2)) '(3.0 #f))
1103(test-equal "+" (+-tester (+ 1 2.0)) '(3.0 #f))
1104(test-equal "+" (+-tester (+ 1 2 3.0)) '(6.0 #f))
1105(test-equal "+" (+-tester (+ 1/6 1/3 0.5)) '(1.0 #f))
1106(test-equal "+" (+-tester (+ 1 +i)) '(1+i #t))
1107(test-equal "+" (+-tester (+ 1 2 +i)) '(3+i #t))
1108(test-equal "+" (+-tester (+ +i 1 2)) '(3+i #t))
1109(test-equal "+" (+-tester (+ 1.0 2 +i)) '(3.0+i #f))
1110(test-equal "+" (+-tester (+ +i 1.0 2)) '(3.0+i #f))
1111(test-equal "+" (+-tester (+ 4294967297 1.0)) '(4294967298.0 #f))
1112(test-equal "+" (+-tester (+ 4294967297 1 1.0)) '(4294967299.0 #f))
1113(test-equal "+" (+-tester (+ 4294967297 1.0 -i)) '(4294967298.0-i #f))
1114(test-equal "+" (+-tester (+ -i 4294967297 1.0)) '(4294967298.0-i #f))
1115(test-equal "+" (+-tester (+ 1.0 4294967297 -i)) '(4294967298.0-i #f))
1116
1117(test-end)
1118
1119;;------------------------------------------------------------------
1120(test-begin "integer multiplication")
1121
1122(define (m-result x) (list x (- x) (- x) x x (- x) (- x) x))
1123(define (m-tester x y)
1124  (list (* x y) (* (- x) y) (* x (- y)) (* (- x) (- y))
1125        (apply * (list x y)) (apply * (list (- x) y))
1126        (apply * (list x (- y))) (apply * (list (- x) (- y)))))
1127
1128(test-equal "fix*fix->big[1]" (m-tester 41943 17353)
1129      (m-result 727836879))
1130(test-equal "fix*fix->big[1]" (m-tester 41943 87353)
1131      (m-result 3663846879))
1132(test-equal "fix*fix->big[2]" (m-tester 65536 65536)
1133      (m-result 4294967296))
1134(test-equal "fix*fix->big[2]" (m-tester 4194303 87353)
1135      (m-result 366384949959))
1136(test-equal "fix*big[1]->big[1]" (m-tester 3 1126270821)
1137      (m-result 3378812463))
1138(test-equal "fix*big[1]->big[2]" (m-tester 85746 4294967296)
1139      (m-result 368276265762816))
1140(test-equal "big[1]*fix->big[1]" (m-tester 1126270821 3)
1141      (m-result 3378812463))
1142(test-equal "big[1]*fix->big[2]" (m-tester 4294967296 85746)
1143      (m-result 368276265762816))
1144(test-equal "big[2]*fix->big[2]" (m-tester 535341266467 23)
1145      (m-result 12312849128741))
1146(test-equal "big[1]*big[1]->big[2]" (m-tester 1194726677 1126270821)
1147      (m-result 1345585795375391817))
1148
1149;; Large number multiplication test using Fermat's number
1150;; The decomposition of Fermat's number is taken from
1151;;   http://www.dd.iij4u.or.jp/~okuyamak/Information/Fermat.html
1152(test-equal "fermat(7)" (* 59649589127497217 5704689200685129054721)
1153      (fermat 7))
1154(test-equal "fermat(8)" (* 1238926361552897
1155           93461639715357977769163558199606896584051237541638188580280321)
1156              (fermat 8))
1157(test-equal "fermat(9)" (* 2424833
1158           7455602825647884208337395736200454918783366342657
1159           741640062627530801524787141901937474059940781097519023905821316144415759504705008092818711693940737)
1160              (fermat 9))
1161(test-equal "fermat(10)" (* 45592577
1162           6487031809
1163           4659775785220018543264560743076778192897
1164           130439874405488189727484768796509903946608530841611892186895295776832416251471863574140227977573104895898783928842923844831149032913798729088601617946094119449010595906710130531906171018354491609619193912488538116080712299672322806217820753127014424577
1165           )
1166              (fermat 10))
1167(test-equal "fermat(11)" (* 319489
1168           974849
1169           167988556341760475137
1170           3560841906445833920513
1171           173462447179147555430258970864309778377421844723664084649347019061363579192879108857591038330408837177983810868451546421940712978306134189864280826014542758708589243873685563973118948869399158545506611147420216132557017260564139394366945793220968665108959685482705388072645828554151936401912464931182546092879815733057795573358504982279280090942872567591518912118622751714319229788100979251036035496917279912663527358783236647193154777091427745377038294584918917590325110939381322486044298573971650711059244462177542540706913047034664643603491382441723306598834177
1172           )
1173              (fermat 11))
1174
1175(test-end)
1176
1177;;------------------------------------------------------------------
1178(test-begin "multiplication short cuts")
1179
1180(parameterize ((current-test-comparator eqv?))
1181;; these test shortcut in Scm_Mul
1182;; note the difference of 0 and 0.0
1183  (let1 big (read-from-string "100000000000000000000")
1184        (test-equal "bignum * 0"  (apply * `(,big 0)) 0)
1185        (test-equal "0 * bignum"  (apply * `(0 ,big)) 0)
1186        (test-equal "bignum * 1"  (apply * `(,big 1)) big)
1187        (test-equal "1 * bignum"  (apply * `(1 ,big)) big)
1188
1189        (test-equal "bignum * 0.0"  (apply * `(,big 0.0)) 0.0)
1190        (test-equal "0.0 * bignum"  (apply * `(0.0 ,big)) 0.0)
1191        (test-equal "bignum * 1.0"  (apply * `(,big 1.0)) 1.0e20)
1192        (test-equal "1.0 * bignum"  (apply * `(1.0 ,big)) 1.0e20)
1193        )
1194
1195(test-equal "ratnum * 0"  (apply * '(1/2 0)) 0)
1196(test-equal "0 * ratnum"  (apply * '(0 1/2)) 0)
1197(test-equal "ratnum * 1"  (apply * '(1/2 1)) 1/2)
1198(test-equal "1 * ratnum"  (apply * '(1 1/2)) 1/2)
1199
1200(test-equal "ratnum * 0.0"  (apply * '(1/2 0.0)) 0.0)
1201(test-equal "0.0 * ratnum"  (apply * '(0.0 1/2)) 0.0)
1202(test-equal "ratnum * 1.0"  (apply * '(1/2 1.0)) 0.5)
1203(test-equal "1.0 * ratnum"  (apply * '(1.0 1/2)) 0.5)
1204
1205;; Fixed for exactness (Gauche represents zero always exactly?)
1206(test-equal "flonum * 0"  (apply * '(3.0 0)) 0.0)
1207(test-equal "0 * flonum"  (apply * '(0 3.0)) 0.0)
1208(test-equal "flonum * 1"  (apply * '(3.0 1)) 3.0)
1209(test-equal "1 * flonum"  (apply * '(1 3.0)) 3.0)
1210
1211(test-equal "flonum * 0.0"  (apply * '(3.0 0.0)) 0.0)
1212(test-equal "0.0 * flonum"  (apply * '(0.0 3.0)) 0.0)
1213(test-equal "flonum * 1.0"  (apply * '(3.0 1.0)) 3.0)
1214(test-equal "1.0 * flonum"  (apply * '(1.0 3.0)) 3.0)
1215
1216(test-equal "compnum * 0" (* 0 +i) 0)
1217(test-equal "0 * compnum" (* +i 0) 0)
1218(test-equal "compnum * 1" (* 1 +i) +i)
1219(test-equal "1 * compnum" (* +i 1) +i)
1220
1221(test-equal "compnum * 0.0" (* 0.0 +i) 0.0)
1222(test-equal "0.0 * compnum" (* +i 0.0) 0.0)
1223(test-equal "compnum * 1.0" (* 1.0 +i) +1.0i)
1224(test-equal "1.0 * compnum" (* +i 1.0) +1.0i))
1225
1226(test-end)
1227
1228;;------------------------------------------------------------------
1229(test-begin "division")
1230
1231(test-equal "exact division" (/ 3 4 5) 3/20)
1232(test-equal "exact division" (/ 9223372036854775808 18446744073709551616)  1/2)
1233(test-equal "exact division" (/ 28153784189046 42)
1234       4692297364841/7)
1235(test-equal "exact division" (/ 42 28153784189046)
1236       7/4692297364841)
1237(test-equal "exact division" (/ 42 -28153784189046)
1238       -7/4692297364841)
1239(test-equal "exact division" (/ -42 -28153784189046)
1240       7/4692297364841)
1241(test-equal "exact reciprocal" (/ 3) 1/3)
1242(test-equal "exact reciprocal" (/ -3) -1/3)
1243(test-equal "exact reciprocal" (/ 6/5) 5/6)
1244(test-equal "exact reciprocal" (/ -6/5) -5/6)
1245(test-equal "exact reciprocal" (/ 4692297364841/7) 7/4692297364841)
1246
1247(define (almost=? x y)
1248  (define (flonum=? x y)
1249    (let ((ax (abs x)) (ay (abs y)))
1250      (< (abs (- x y)) (* (max ax ay) 0.0000000000001))))
1251  (and (flonum=? (car x) (car y))
1252       (flonum=? (cadr x) (cadr y))
1253       (flonum=? (caddr x) (caddr y))
1254       (flonum=? (cadddr x) (cadddr y))
1255       (eq? (list-ref x 4) (list-ref y 4))))
1256
1257(define (d-result x exact?) (list x (- x) (- x) x exact?))
1258(define (d-tester x y)
1259  (list (/ x y) (/ (- x) y) (/ x (- y)) (/ (- x) (- y))
1260        (exact? (/ x y))))
1261
1262;; inexact division
1263(test-equal "exact/inexact -> inexact" (d-tester 13 4.0)
1264      (d-result 3.25 #f))
1265(test-equal "exact/inexact -> inexact" (d-tester 13/2 4.0)
1266      (d-result 1.625 #f))
1267(test-equal "inexact/exact -> inexact" (d-tester 13.0 4)
1268      (d-result 3.25 #f))
1269(test-equal "inexact/exact -> inexact" (d-tester 13.0 4/3)
1270      (d-result 9.75 #f))
1271(test-equal "inexact/inexact -> inexact" (d-tester 13.0 4.0)
1272      (d-result 3.25 #f))
1273
1274;; complex division
1275(test-equal "complex division" (let ((a 3)
1276             (b 4+3i)
1277             (c 7.3))
1278         (- (/ a b c)
1279            (/ (/ a b) c)))
1280       0.0)
1281
1282(test-end)
1283
1284;;------------------------------------------------------------------
1285(test-begin "quotient")
1286
1287(define (q-result x exact?) (list x (- x) (- x) x exact?))
1288(define (q-tester x y)
1289  (list (quotient x y) (quotient (- x) y)
1290        (quotient x (- y)) (quotient (- x) (- y))
1291        (exact? (quotient x y))))
1292
1293
1294;; these uses BignumDivSI -> bignum_sdiv
1295(test-equal "big[1]/fix->fix" (q-tester 727836879 41943)
1296      (q-result 17353 #t))
1297(test-equal "big[1]/fix->fix" (q-tester 3735928559 27353)
1298      (q-result 136582 #t))
1299(test-equal "big[2]/fix->big[1]" (q-tester 12312849128741 23)
1300      (q-result 535341266467 #t))
1301(test-equal "big[2]/fix->big[2]" (q-tester 12312849128741 1)
1302      (q-result 12312849128741 #t))
1303
1304;; these uses BignumDivSI -> bignum_gdiv
1305(test-equal "big[1]/fix->fix" (q-tester 3663846879 87353)
1306      (q-result 41943 #t))
1307(test-equal "big[2]/fix->fix" (q-tester 705986470884353 36984440)
1308      (q-result 19088743 #t))
1309(test-equal "big[2]/fix->fix" (q-tester 12312849128741 132546)
1310      (q-result 92894912 #t))
1311(test-equal "big[2]/fix->big[1]" (q-tester 425897458766735 164900)
1312      (q-result 2582762030 #t))
1313
1314;; these uses BignumDivRem
1315(test-equal "big[1]/big[1]->fix" (q-tester 4020957098 1952679221)
1316      (q-result 2 #t))
1317(test-equal "big[1]/big[1] -> fix" (q-tester 1952679221 4020957098)
1318      (q-result 0 #t))
1319;; this tests loop in estimation phase
1320(test-equal "big[3]/big[2] -> big[1]" (q-tester #x10000000000000000 #x10000ffff)
1321      (q-result #xffff0001 #t))
1322;; this test goes through a rare case handling code ("add back") in
1323;; the algorithm.
1324(test-equal "big[3]/big[2] -> fix" (q-tester #x7800000000000000 #x80008889ffff)
1325      (q-result #xeffe #t))
1326
1327;; inexact quotient
1328(test-equal "exact/inexact -> inexact" (q-tester 13 4.0)
1329      (q-result 3.0 #f))
1330(test-equal "inexact/exact -> inexact" (q-tester 13.0 4)
1331      (q-result 3.0 #f))
1332(test-equal "inexact/inexact -> inexact" (q-tester 13.0 4.0)
1333      (q-result 3.0 #f))
1334(test-equal "exact/inexact -> inexact" (q-tester 727836879 41943.0)
1335      (q-result 17353.0 #f))
1336(test-equal "inexact/exact -> inexact" (q-tester 727836879.0 41943)
1337      (q-result 17353.0 #f))
1338(test-equal "inexact/inexact -> inexact" (q-tester 727836879.0 41943.0)
1339      (q-result 17353.0 #f))
1340
1341;; Test by fermat numbers
1342(test-equal "fermat(7)" (quotient (fermat 7) 5704689200685129054721)
1343      59649589127497217)
1344(test-equal "fermat(8)" (quotient (fermat 8) 93461639715357977769163558199606896584051237541638188580280321)
1345              1238926361552897)
1346(test-equal "fermat(9)" (quotient (quotient (fermat 9) 7455602825647884208337395736200454918783366342657)
1347                  741640062627530801524787141901937474059940781097519023905821316144415759504705008092818711693940737)
1348              2424833)
1349(test-equal "fermat(10)" (quotient (quotient (quotient (fermat 10)
1350                                      130439874405488189727484768796509903946608530841611892186895295776832416251471863574140227977573104895898783928842923844831149032913798729088601617946094119449010595906710130531906171018354491609619193912488538116080712299672322806217820753127014424577)
1351                            6487031809)
1352                  45592577)
1353              4659775785220018543264560743076778192897)
1354(test-equal "fermat(11)" (quotient (quotient (quotient (quotient (fermat 11)
1355                                                167988556341760475137)
1356                                      173462447179147555430258970864309778377421844723664084649347019061363579192879108857591038330408837177983810868451546421940712978306134189864280826014542758708589243873685563973118948869399158545506611147420216132557017260564139394366945793220968665108959685482705388072645828554151936401912464931182546092879815733057795573358504982279280090942872567591518912118622751714319229788100979251036035496917279912663527358783236647193154777091427745377038294584918917590325110939381322486044298573971650711059244462177542540706913047034664643603491382441723306598834177
1357                                      )
1358                            974849)
1359                  319489)
1360              3560841906445833920513)
1361
1362(test-end)
1363
1364;;------------------------------------------------------------------
1365(test-begin "remainder")
1366
1367(define (r-result x exact?) (list x (- x) x (- x) exact?))
1368(define (r-tester x y)
1369  (list (remainder x y) (remainder (- x) y)
1370        (remainder x (- y)) (remainder (- x) (- y))
1371        (exact? (remainder x y))))
1372
1373;; small int
1374(test-equal "fix rem fix -> fix" (r-tester 13 4)
1375      (r-result 1 #t))
1376(test-equal "fix rem fix -> fix" (r-tester 1234 87935)
1377      (r-result 1234 #t))
1378(test-equal "fix rem big[1] -> fix" (r-tester 12345 3735928559)
1379      (r-result 12345 #t))
1380
1381;; these uses BignumDivSI -> bignum_sdiv
1382(test-equal "big[1] rem fix -> fix" (r-tester 727836879 41943)
1383      (r-result 0 #t))
1384(test-equal "big[1] rem fix -> fix" (r-tester 3735928559 27353)
1385      (r-result 1113 #t))
1386(test-equal "big[2] rem fix -> fix" (r-tester 12312849128756 23)
1387      (r-result 15 #t))
1388(test-equal "big[2] rem fix -> fix" (r-tester 12312849128756 1)
1389      (r-result 0 #t))
1390
1391;; these uses BignumDivSI -> bignum_gdiv
1392(test-equal "big[1] rem fix -> fix" (r-tester 3663846879 87353)
1393      (r-result 0 #t))
1394(test-equal "big[2] rem fix -> fix" (r-tester 705986470884353 36984440)
1395      (r-result 725433 #t))
1396(test-equal "big[2] rem fix -> fix" (r-tester 12312849128741 132546)
1397      (r-result 122789 #t))
1398(test-equal "big[2] rem fix -> fix" (r-tester 425897458766735 164900)
1399      (r-result 19735 #t))
1400
1401;; these uses BignumDivRem
1402(test-equal "big[1] rem big[1] -> fix" (r-tester 4020957098 1952679221)
1403      (r-result 115598656 #t))
1404(test-equal "big[1] rem big[1] -> fix" (r-tester 1952679221 4020957098)
1405      (r-result 1952679221 #t))
1406;; this tests loop in estimation phase
1407(test-equal "big[3] rem big[2] -> big[1]" (r-tester #x10000000000000000 #x10000ffff)
1408      (r-result #xfffe0001 #t))
1409;; this tests "add back" code
1410(test-equal "big[3] rem big[2] -> big[2]" (r-tester #x7800000000000000 #x80008889ffff)
1411      (r-result #x7fffb114effe #t))
1412
1413;; inexact remainder
1414(test-equal "exact rem inexact -> inexact" (r-tester 13 4.0)
1415      (r-result 1.0 #f))
1416(test-equal "inexact rem exact -> inexact" (r-tester 13.0 4)
1417      (r-result 1.0 #f))
1418(test-equal "inexact rem inexact -> inexact" (r-tester 13.0 4.0)
1419      (r-result 1.0 #f))
1420(test-equal "exact rem inexact -> inexact" (r-tester 3735928559 27353.0)
1421      (r-result 1113.0 #f))
1422(test-equal "inexact rem exact -> inexact" (r-tester 3735928559.0 27353)
1423      (r-result 1113.0 #f))
1424(test-equal "inexact rem inexact -> inexact" (r-tester 3735928559.0 27353.0)
1425      (r-result 1113.0 #f))
1426
1427(test-end)
1428
1429;;------------------------------------------------------------------
1430(test-begin "modulo")
1431
1432(define (m-result a b exact?) (list a b (- b) (- a) exact?))
1433(define (m-tester x y)
1434  (list (modulo x y) (modulo (- x) y)
1435        (modulo x (- y)) (modulo (- x) (- y))
1436        (exact? (modulo x y))))
1437
1438;; small int
1439(test-equal "fix mod fix -> fix" (m-tester 13 4)
1440      (m-result 1 3 #t))
1441(test-equal "fix mod fix -> fix" (m-tester 1234 87935)
1442      (m-result 1234 86701 #t))
1443(test-equal "fix mod big[1] -> fix/big" (m-tester 12345 3735928559)
1444      (m-result 12345 3735916214 #t))
1445
1446;; these uses BignumDivSI -> bignum_sdiv
1447(test-equal "big[1] mod fix -> fix" (m-tester 727836879 41943)
1448      (m-result 0 0 #t))
1449(test-equal "big[1] mod fix -> fix" (m-tester 3735928559 27353)
1450      (m-result 1113 26240 #t))
1451(test-equal "big[2] mod fix -> fix" (m-tester 12312849128756 23)
1452      (m-result 15 8 #t))
1453(test-equal "big[2] mod fix -> fix" (m-tester 12312849128756 1)
1454      (m-result 0 0 #t))
1455
1456;; these uses BignumDivSI -> bignum_gdiv
1457(test-equal "big[1] mod fix -> fix" (m-tester 3663846879 87353)
1458      (m-result 0 0 #t))
1459(test-equal "big[2] mod fix -> fix" (m-tester 705986470884353 36984440)
1460      (m-result 725433 36259007 #t))
1461(test-equal "big[2] mod fix -> fix" (m-tester 12312849128741 132546)
1462      (m-result 122789 9757 #t))
1463(test-equal "big[2] mod fix -> fix" (m-tester 425897458766735 164900)
1464      (m-result 19735 145165 #t))
1465
1466;; these uses BignumDivRem
1467(test-equal "big[1] mod big[1] -> fix" (m-tester 4020957098 1952679221)
1468      (m-result 115598656 1837080565 #t))
1469(test-equal "big[1] mod big[1] -> fix" (m-tester 1952679221 4020957098)
1470      (m-result 1952679221 2068277877 #t))
1471;; this tests loop in estimation phase
1472(test-equal "big[3] mod big[2] -> big[1]" (m-tester #x10000000000000000 #x10000ffff)
1473      (m-result #xfffe0001 #x2fffe #t))
1474;; this tests "add back" code
1475(test-equal "big[3] mod big[2] -> big[2]" (m-tester #x7800000000000000 #x80008889ffff)
1476      (m-result #x7fffb114effe #xd7751001 #t))
1477
1478;; inexact modulo
1479(test-equal "exact mod inexact -> inexact" (m-tester 13 4.0)
1480      (m-result 1.0 3.0 #f))
1481(test-equal "inexact mod exact -> inexact" (m-tester 13.0 4)
1482      (m-result 1.0 3.0 #f))
1483(test-equal "inexact mod inexact -> inexact" (m-tester 13.0 4.0)
1484      (m-result 1.0 3.0 #f))
1485(test-equal "exact mod inexact -> inexact" (m-tester 3735928559 27353.0)
1486      (m-result 1113.0 26240.0 #f))
1487(test-equal "inexact mod exact -> inexact" (m-tester 3735928559.0 27353)
1488      (m-result 1113.0 26240.0 #f))
1489(test-equal "inexact mod inexact -> inexact" (m-tester 3735928559.0 27353.0)
1490      (m-result 1113.0 26240.0 #f))
1491
1492;; test by mersenne prime? - code by 'hipster'
1493
1494(define (mersenne-prime? p)
1495  (let ((m (- (expt 2 p) 1)))
1496    (do ((i 3 (+ i 1))
1497         (s 4 (modulo (- (* s s) 2) m)))
1498        ((= i (+ p 1)) (= s 0)))))
1499
1500(test-equal "mersenne prime"
1501       (map mersenne-prime? '(3 5 7 13 17 19 31 61 89 107 127 521 607 1279))
1502       '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t))
1503
1504(test-end)
1505
1506;;------------------------------------------------------------------
1507;; R6RS
1508#|
1509(test-begin "div and mod")
1510
1511(let ()
1512  (define (do-quadrants proc)
1513    (lambda (x y =)
1514      (proc x y =)
1515      (proc (- x) y =)
1516      (proc x (- y) =)
1517      (proc (- x) (- y) =)))
1518
1519  (define (test-div x y =)
1520    (test-equal (format "~a div ~a" x y) (receive (d m) (div-and-mod x y)
1521             (let1 z (+ (* d y) m)
1522               (list (or (= x z) z)
1523                     (or (and (<= 0 m) (< m (abs y))) m))))
1524           '(#t #t)))
1525
1526  (define (test-div0 x y =)
1527    (test-equal (format "~a div0 ~a" x y) (receive (d m) (div0-and-mod0 x y)
1528             (let1 z (+ (* d y) m)
1529               (list (or (= x z) z)
1530                     (or (and (<= (- (abs y)) (* m 2))
1531                              (< (* m 2) (abs y)))
1532                         m))))
1533           '(#t #t)))
1534
1535  ((do-quadrants test-div) 123 10 =)
1536  (parameterize ((current-test-epsilon 1e-10))
1537    ((do-quadrants test-div) 123.0 10.0 =))
1538  ((do-quadrants test-div) (read-from-string "123/7") (read-from-string "10/7") =)
1539  ((do-quadrants test-div) (read-from-string "123/7") 5 =)
1540  ((do-quadrants test-div) 123 (read-from-string "5/7") =)
1541  ((do-quadrants test-div) 130.75 10.5 =)
1542
1543  ((do-quadrants test-div0) 123 10 =)
1544  ((do-quadrants test-div0) 129 10 =)
1545  (parameterize ((current-test-epsilon 1e-10))
1546   ((do-quadrants test-div0) 123.0 10.0 =)
1547   ((do-quadrants test-div0) 129.0 10.0 =))
1548  ((do-quadrants test-div0) (read-from-string "123/7") (read-from-string "10/7") =)
1549  ((do-quadrants test-div0) (read-from-string "129/7") (read-from-string "10/7") =)
1550  ((do-quadrants test-div0) (read-from-string "121/7") 5 =)
1551  ((do-quadrants test-div0) (read-from-string "124/7") 5 =)
1552  ((do-quadrants test-div0) 121 (read-from-string "5/7") =)
1553  ((do-quadrants test-div0) 124 (read-from-string "5/7") =)
1554  ((do-quadrants test-div0) 130.75 10.5 =)
1555  ((do-quadrants test-div0) 129.75 10.5 =)
1556  )
1557
1558(test-end)
1559|#
1560;;------------------------------------------------------------------
1561(test-begin "rounding")
1562
1563(define (round-tester value exactness cei flo tru rou)
1564  (test-equal (string-append "rounding " (number->string value))
1565         (let ((c (ceiling value))
1566               (f (floor value))
1567               (t (truncate value))
1568               (r (round value)))
1569           (list (and (exact? c) (exact? f) (exact? t) (exact? r))
1570                 c f t r))
1571         (list exactness cei flo tru rou)))
1572
1573(round-tester 0  #t 0 0 0 0)
1574(round-tester 3  #t 3 3 3 3)
1575(round-tester -3 #t -3 -3 -3 -3)
1576(round-tester (expt 2 99) #t (expt 2 99) (expt 2 99) (expt 2 99) (expt 2 99))
1577(round-tester (- (expt 2 99)) #t
1578              (- (expt 2 99)) (- (expt 2 99)) (- (expt 2 99)) (- (expt 2 99)))
1579
1580(round-tester 9/4  #t 3 2 2 2)
1581(round-tester -9/4 #t -2 -3 -2 -2)
1582(round-tester 34985495387484938453495/17 #t
1583              2057970316910878732559
1584              2057970316910878732558
1585              2057970316910878732558
1586              2057970316910878732559)
1587(round-tester -34985495387484938453495/17 #t
1588              -2057970316910878732558
1589              -2057970316910878732559
1590              -2057970316910878732558
1591              -2057970316910878732559)
1592
1593(round-tester 35565/2 #t 17783 17782 17782 17782)
1594(round-tester -35565/2 #t -17782 -17783 -17782 -17782)
1595(round-tester 35567/2 #t 17784 17783 17783 17784)
1596(round-tester -35567/2 #t -17783 -17784 -17783 -17784)
1597
1598(test-equal "round->exact" (round->exact 3.4) 3)
1599(test-equal "round->exact" (round->exact 3.5) 4)
1600(test-equal "floor->exact" (floor->exact 3.4) 3)
1601(test-equal "floor->exact" (floor->exact -3.5) -4)
1602(test-equal "ceiling->exact" (ceiling->exact 3.4) 4)
1603(test-equal "ceiling->exact" (ceiling->exact -3.5) -3)
1604(test-equal "truncate->exact" (truncate->exact 3.4) 3)
1605(test-equal "truncate->exact" (truncate->exact -3.5) -3)
1606
1607(test-end)
1608
1609;;------------------------------------------------------------------
1610
1611#|
1612;; Nonstandard and Gauche-specific
1613(test-begin "clamping")
1614
1615(parameterize ((current-test-comparator eqv?))
1616 (test-equal "clamp (1)"   (clamp 1)   1)
1617 (test-equal "clamp (1 #f)" (clamp 1 #f)  1)
1618 (test-equal "clamp (1 #f #f)" (clamp 1 #f #f)  1)
1619 (test-equal "clamp (1.0)"   (clamp 1.0)   1.0)
1620 (test-equal "clamp (1.0 #f)" (clamp 1.0 #f)  1.0)
1621 (test-equal "clamp (1.0 #f #f)" (clamp 1.0 #f #f)  1.0)
1622
1623 (test-equal "clamp (1 0)" (clamp 1 0)   1)
1624 (test-equal "clamp (1 0 #f)" (clamp 1 0 #f) 1)
1625 (test-equal "clamp (1 0 2)" (clamp 1 0 2) 1)
1626 (test-equal "clamp (1 5/4)" (clamp 1 5/4) 5/4)
1627 (test-equal "clamp (1 5/4 #f)" (clamp 1 5/4 #f) 5/4)
1628 (test-equal "clamp (1 #f 5/4)" (clamp 1 #f 5/4) 1)
1629 (test-equal "clamp (1 0 3/4)" (clamp 1 0 3/4) 3/4)
1630 (test-equal "clamp (1 #f 3/4)" (clamp 1 #f 3/4) 3/4)
1631
1632 (test-equal "clamp (1.0 0)" (clamp 1.0 0)   1.0)
1633 (test-equal "clamp (1.0 0 #f)" (clamp 1.0 0 #f) 1.0)
1634 (test-equal "clamp (1.0 0 2)" (clamp 1.0 0 2) 1.0)
1635 (test-equal "clamp (1.0 5/4)" (clamp 1.0 5/4) 1.25)
1636 (test-equal "clamp (1.0 5/4 #f)" (clamp 1.0 5/4 #f) 1.25)
1637 (test-equal "clamp (1.0 #f 5/4)" (clamp 1.0 #f 5/4) 1.0)
1638 (test-equal "clamp (1.0 0 3/4)" (clamp 1.0 0 3/4) 0.75)
1639 (test-equal "clamp (1.0 #f 3/4)" (clamp 1.0 #f 3/4) 0.75)
1640
1641 (test-equal "clamp (1 0.0)" (clamp 1 0.0)   1.0)
1642 (test-equal "clamp (1 0.0 #f)" (clamp 1 0.0 #f) 1.0)
1643 (test-equal "clamp (1 0.0 2)" (clamp 1 0.0 2) 1.0)
1644 (test-equal "clamp (1 0 2.0)" (clamp 1 0 2.0) 1.0)
1645 (test-equal "clamp (1 1.25)" (clamp 1 1.25) 1.25)
1646 (test-equal "clamp (1 #f 1.25)" (clamp 1 #f 1.25) 1.0)
1647 (test-equal "clamp (1 1.25 #f)" (clamp 1 1.25 #f) 1.25)
1648 (test-equal "clamp (1 0.0 3/4)" (clamp 1 0.0 3/4) 0.75)
1649 (test-equal "clamp (1 0 0.75)" (clamp 1 0 0.75) 0.75)
1650
1651 (test-equal "clamp (1 -inf.0 +inf.0)" (clamp 1 -inf.0 +inf.0) 1.0))
1652
1653(test-end)
1654|#
1655
1656;;------------------------------------------------------------------
1657(test-begin "logical operations")
1658
1659(test-equal "ash (fixnum)" (ash #x81 15)           ;fixnum
1660      #x408000)
1661(test-equal "ash (fixnum)" (ash #x408000 -15)
1662      #x81)
1663(test-equal "ash (fixnum)" (ash #x408000 -22)
1664      #x01)
1665(test-equal "ash (fixnum)" (ash #x408000 -23)
1666      0)
1667(test-equal "ash (fixnum)" (ash #x408000 -24)
1668      0)
1669(test-equal "ash (fixnum)" (ash #x408000 -100)
1670      0)
1671(test-equal "ash (fixnum)" (ash #x81 0)
1672      #x81)
1673(test-equal "ash (neg. fixnum)" (ash #x-81 15)  ;negative fixnum
1674      #x-408000)
1675(test-equal "ash (neg. fixnum)" (ash #x-408000 -15)      ;nagative fixnum
1676      #x-81)
1677(test-equal "ash (fixnum)" (ash #x-408000 -22)
1678      -2)
1679(test-equal "ash (fixnum)" (ash #x-408000 -23)
1680      -1)
1681(test-equal "ash (fixnum)" (ash #x-408000 -24)
1682      -1)
1683(test-equal "ash (fixnum)" (ash #x-408000 -100)
1684      -1)
1685(test-equal "ash (fixnum)" (ash #x-408000 0)
1686      #x-408000)
1687
1688
1689(test-equal "ash (fixnum->bignum)" (ash #x81 24)
1690      #x81000000)
1691(test-equal "ash (fixnum->bignum)" (ash #x81 31)
1692      #x4080000000)
1693(test-equal "ash (fixnum->bignum)" (ash #x81 32)
1694      #x8100000000)
1695(test-equal "ash (fixnum->bignum)" (ash #x81 56)
1696      #x8100000000000000)
1697(test-equal "ash (fixnum->bignum)" (ash #x81 63)
1698      #x408000000000000000)
1699(test-equal "ash (fixnum->bignum)" (ash #x81 64)
1700      #x810000000000000000)
1701(test-equal "ash (neg.fixnum->bignum)" (ash #x-81 24)
1702      #x-81000000)
1703(test-equal "ash (neg.fixnum->bignum)" (ash #x-81 31)
1704      #x-4080000000)
1705(test-equal "ash (neg.fixnum->bignum)" (ash #x-81 32)
1706      #x-8100000000)
1707(test-equal "ash (neg.fixnum->bignum)" (ash #x-81 56)
1708      #x-8100000000000000)
1709(test-equal "ash (neg.fixnum->bignum)" (ash #x-81 63)
1710      #x-408000000000000000)
1711(test-equal "ash (neg.fixnum->bignum)" (ash #x-81 64)
1712      #x-810000000000000000)
1713
1714(test-equal "ash (bignum->fixnum)" (ash  #x81000000 -24)
1715      #x81)
1716(test-equal "ash (bignum->fixnum)" (ash  #x81000000 -25)
1717      #x40)
1718(test-equal "ash (bignum->fixnum)" (ash  #x81000000 -31)
1719      1)
1720(test-equal "ash (bignum->fixnum)" (ash  #x81000000 -32)
1721      0)
1722(test-equal "ash (bignum->fixnum)" (ash  #x81000000 -100)
1723      0)
1724(test-equal "ash (bignum->fixnum)" (ash #x4080000000 -31)
1725      #x81)
1726(test-equal "ash (bignum->fixnum)" (ash #x8100000000 -32)
1727      #x81)
1728(test-equal "ash (bignum->fixnum)" (ash #x8100000000 -33)
1729      #x40)
1730(test-equal "ash (bignum->fixnum)" (ash #x8100000000 -39)
1731      1)
1732(test-equal "ash (bignum->fixnum)" (ash #x8100000000 -40)
1733      0)
1734(test-equal "ash (bignum->fixnum)" (ash #x8100000000 -100)
1735      0)
1736(test-equal "ash (bignum->fixnum)" (ash #x8100000000000000 -56)
1737      #x81)
1738(test-equal "ash (bignum->fixnum)" (ash #x408000000000000000 -63)
1739      #x81)
1740(test-equal "ash (bignum->fixnum)" (ash #x408000000000000000 -64)
1741      #x40)
1742(test-equal "ash (bignum->fixnum)" (ash #x408000000000000000 -65)
1743      #x20)
1744(test-equal "ash (bignum->fixnum)" (ash #x408000000000000000 -70)
1745      1)
1746(test-equal "ash (bignum->fixnum)" (ash #x408000000000000000 -71)
1747      0)
1748(test-equal "ash (bignum->fixnum)" (ash #x408000000000000000 -100)
1749      0)
1750
1751(test-equal "ash (neg.bignum->fixnum)" (ash #x-81000000 -24)
1752      #x-81)
1753(test-equal "ash (neg.bignum->fixnum)" (ash #x-81000000 -25)
1754      #x-41)
1755(test-equal "ash (neg.bignum->fixnum)" (ash #x-81000000 -26)
1756      #x-21)
1757(test-equal "ash (neg.bignum->fixnum)" (ash #x-81000000 -31)
1758      -2)
1759(test-equal "ash (neg.bignum->fixnum)" (ash #x-81000000 -32)
1760      -1)
1761(test-equal "ash (neg.bignum->fixnum)" (ash #x-81000000 -33)
1762      -1)
1763(test-equal "ash (neg.bignum->fixnum)" (ash #x-81000000 -100)
1764      -1)
1765(test-equal "ash (neg.bignum->fixnum)" (ash #x-4080000000 -31)
1766      #x-81)
1767(test-equal "ash (neg.bignum->fixnum)" (ash #x-4080000000 -32)
1768      #x-41)
1769(test-equal "ash (neg.bignum->fixnum)" (ash #x-4080000000 -33)
1770      #x-21)
1771(test-equal "ash (neg.bignum->fixnum)" (ash #x-4080000000 -38)
1772      -2)
1773(test-equal "ash (neg.bignum->fixnum)" (ash #x-4080000000 -39)
1774      -1)
1775(test-equal "ash (neg.bignum->fixnum)" (ash #x-4080000000 -100)
1776      -1)
1777(test-equal "ash (neg.bignum->fixnum)" (ash #x-408000000000000000 -63)
1778      #x-81)
1779(test-equal "ash (neg.bignum->fixnum)" (ash #x-408000000000000000 -64)
1780      #x-41)
1781(test-equal "ash (neg.bignum->fixnum)" (ash #x-408000000000000000 -65)
1782      #x-21)
1783(test-equal "ash (neg.bignum->fixnum)" (ash #x-408000000000000000 -70)
1784      -2)
1785(test-equal "ash (neg.bignum->fixnum)" (ash #x-408000000000000000 -71)
1786      -1)
1787(test-equal "ash (neg.bignum->fixnum)" (ash #x-408000000000000000 -72)
1788      -1)
1789
1790(test-equal "ash (bignum->bignum)" (ash #x1234567812345678 4)
1791      #x12345678123456780)
1792(test-equal "ash (bignum->bignum)" (ash #x1234567812345678 60)
1793      #x1234567812345678000000000000000)
1794(test-equal "ash (bignum->bignum)" (ash #x1234567812345678 64)
1795      #x12345678123456780000000000000000)
1796(test-equal "ash (bignum->bignum)" (ash #x1234567812345678 -4)
1797      #x123456781234567)
1798(test-equal "ash (bignum->bignum)" (ash #x1234567812345678 -32)
1799      #x12345678)
1800(test-equal "ash (neg.bignum->bignum)" (ash #x-1234567812345678 -4)
1801      #x-123456781234568)
1802(test-equal "ash (bignum->bignum)" (ash #x-1234567812345678 -32)
1803      #x-12345679)
1804
1805(test-equal "lognot (fixnum)" (lognot 0) -1)
1806(test-equal "lognot (fixnum)" (lognot -1) 0)
1807(test-equal "lognot (fixnum)" (lognot 65535) -65536)
1808(test-equal "lognot (fixnum)" (lognot -65536) 65535)
1809(test-equal "lognot (bignum)" (lognot #x1000000000000000000)
1810      #x-1000000000000000001)
1811(test-equal "lognot (bignum)" (lognot #x-1000000000000000001)
1812      #x1000000000000000000)
1813
1814(test-equal "logand (+fix & 0)" (logand #x123456 0)
1815      0)
1816(test-equal "logand (+big & 0)" (logand #x1234567812345678 0)
1817      0)
1818(test-equal "logand (+fix & -1)" (logand #x123456 -1)
1819      #x123456)
1820(test-equal "logand (+big & -1)" (logand #x1234567812345678 -1)
1821      #x1234567812345678)
1822(test-equal "logand (+fix & +fix)" (logand #xaa55 #x6666)
1823      #x2244)
1824(test-equal "logand (+fix & +big)" (logand #xaa55 #x6666666666)
1825      #x2244)
1826(test-equal "logand (+big & +fix)" (logand #xaa55aa55aa #x6666)
1827      #x4422)
1828(test-equal "logand (+big & +big)" (logand #xaa55aa55aa #x6666666666)
1829      #x2244224422)
1830(test-equal "logand (+big & +big)" (logand #x123456789abcdef #xfedcba987654321fedcba987654321fedcba)
1831      #x103454301aaccaa)
1832(test-equal "logand (+big & +big)" (logand #xaa55ea55aa #x55aa55aa55)
1833      #x400000)
1834(test-equal "logand (+fix & -fix)" (logand #xaa55 #x-6666)
1835      #x8810)
1836(test-equal "logand (+fix & -big)" (logand #xaa55 #x-6666666666)
1837      #x8810)
1838(test-equal "logand (+big & -fix)" (logand #xaa55aa55aa #x-6666)
1839      #xaa55aa118a)
1840(test-equal "logand (+big & -big)" (logand #xaa55aa55aa #x-6666666666)
1841      #x881188118a)
1842(test-equal "logand (+big & -big)" (logand #x123456789abcdef #x-fedcba987654321fedcba987654321fedcba)
1843      #x20002488010146)
1844(test-equal "logand (-fix & +fix)" (logand #x-aa55 #x6666)
1845      #x4422)
1846(test-equal "logand (-fix & +big)" (logand #x-aa55 #x6666666666)
1847      #x6666664422)
1848(test-equal "logand (-big & +fix)" (logand #x-aa55aa55aa #x6666)
1849      #x2246)
1850(test-equal "logand (-big & +big)" (logand #x-aa55aa55aa #x6666666666)
1851      #x4422442246)
1852(test-equal "logand (-big & +big)" (logand #x-123456789abcdef #xfedcba987654321fedcba987654321fedcba)
1853      #xfedcba987654321fedcba884200020541010)
1854(test-equal "logand (-fix & -fix)" (logand #x-aa55 #x-6666)
1855      #x-ee76)
1856(test-equal "logand (-fix & -big)" (logand #x-aa55 #x-6666666666)
1857      #x-666666ee76)
1858(test-equal "logand (-big & -fix)" (logand #x-aa55aa55aa #x-6666)
1859      #x-aa55aa77ee)
1860(test-equal "logand (-big & -big)" (logand #x-aa55aa55aa #x-6666666666)
1861      #x-ee77ee77ee)
1862(test-equal "logand (-big & -big)" (logand #x-123456789abcdef #x-fedcba987654321fedcba987654321fedcba)
1863      #x-fedcba987654321fedcba9a76567a9ffde00)
1864
1865(test-equal "logior (+fix | 0)" (logior #x123456 0)
1866      #x123456)
1867(test-equal "logior (+big | 0)" (logior #x1234567812345678 0)
1868      #x1234567812345678)
1869(test-equal "logior (+fix | -1)" (logior #x123456 -1)
1870      -1)
1871(test-equal "logior (+big | -1)" (logior #x1234567812345678 -1)
1872      -1)
1873(test-equal "logior (+fix | +fix)" (logior #xaa55 #x6666)
1874      #xee77)
1875(test-equal "logior (+fix | +big)" (logior #xaa55 #x6666666666)
1876      #x666666ee77)
1877(test-equal "logior (+big | +fix)" (logior #xaa55aa55aa #x6666)
1878      #xaa55aa77ee)
1879(test-equal "logior (+big | +big)" (logior #xaa55aa55aa #x6666666666)
1880      #xee77ee77ee)
1881(test-equal "logior (+big | +big)" (logior #x123456789abcdef #xfedcba987654321fedcba987654321fedcba)
1882      #xfedcba987654321fedcba9a76567a9ffddff)
1883(test-equal "logior (+fix | -fix)" (logior #xaa55 #x-6666)
1884      #x-4421)
1885(test-equal "logior (+fix | -big)" (logior #xaa55 #x-6666666666)
1886      #x-6666664421)
1887(test-equal "logior (+big | -fix)" (logior #xaa55aa55aa #x-6666)
1888      #x-2246)
1889(test-equal "logior (+big | -big)" (logior #xaa55aa55aa #x-6666666666)
1890      #x-4422442246)
1891(test-equal "logior (+big | -big)" (logior #x123456789abcdef #x-fedcba987654321fedcba987654321fedcba)
1892      #x-fedcba987654321fedcba884200020541011)
1893(test-equal "logior (-fix | +fix)" (logior #x-aa55 #x6666)
1894      #x-8811)
1895(test-equal "logior (-fix | +big)" (logior #x-aa55 #x6666666666)
1896      #x-8811)
1897(test-equal "logior (-big | +fix)" (logior #x-aa55aa55aa #x6666)
1898      #x-aa55aa118a)
1899(test-equal "logior (-big | +big)" (logior #x-aa55aa55aa #x6666666666)
1900      #x-881188118a)
1901(test-equal "logior (-big | +big)" (logior #x-123456789abcdef #xfedcba987654321fedcba987654321fedcba)
1902      #x-20002488010145)
1903(test-equal "logior (-fix | -fix)" (logior #x-aa55 #x-6666)
1904      #x-2245)
1905(test-equal "logior (-fix | -big)" (logior #x-aa55 #x-6666666666)
1906      #x-2245)
1907(test-equal "logior (-big | -fix)" (logior #x-aa55aa55aa #x-6666)
1908      #x-4422)
1909(test-equal "logior (-big | -big)" (logior #x-aa55aa55aa #x-6666666666)
1910      #x-2244224422)
1911(test-equal "logior (-big | -big)" (logior #x-123456789abcdef #x-fedcba987654321fedcba987654321fedcba)
1912      #x-103454301aacca9)
1913
1914(test-equal "logtest" (logtest #xfeedbabe #x10000000)
1915      #t)
1916(test-equal "logtest" (logtest #xfeedbabe #x01100101)
1917      #f)
1918
1919#|
1920
1921;; TODO: We don't have these procedures (yet?). Should there be compat
1922;; versions at the top?
1923(let loop ((a 1)   ; 1, 10, 100, ...
1924           (b 1)   ; 1, 11, 111, ...
1925           (c 2)   ; 10, 101, 1001, ...
1926           (n 1))  ; counter
1927  (when (< n 69)
1928    (test-equal (format "logcount (positive, 100...) ~a" n) (logcount a) 1)
1929    (test-equal (format "logcount (positive, 111...) ~a" n) (logcount b) n)
1930    (test-equal (format "logcount (negative, 100...) ~a" n) (logcount (- a)) (- n 1))
1931    (test-equal (format "logcount (negative, 100..1) ~a" n) (logcount (- c)) 1)
1932    (loop (+ b 1) (+ b b 1) (+ b b 3) (+ n 1))))
1933
1934(test-equal "logbit?" (map (lambda (i) (logbit? i #b10110)) '(0 1 2 3 4 5 6))
1935              '(#f #t #t #f #t #f #f))
1936(test-equal "logbit?" (map (lambda (i) (logbit? i #b-10110)) '(0 1 2 3 4 5 6))
1937              '(#f #t #f #t #f #t #t))
1938
1939(test-equal "copy-bit" (copy-bit 4 #b11000110 #t)
1940      #b11010110)
1941(test-equal "copy-bit" (copy-bit 4 #b11000110 #f)
1942      #b11000110)
1943(test-equal "copy-bit" (copy-bit 6 #b11000110 #f)
1944      #b10000110)
1945
1946(test-equal "bit-field" (bit-field #b1101101010 0 4)
1947      #b1010)
1948(test-equal "bit-field" (bit-field #b1101101010 4 9)
1949      #b10110)
1950
1951(test-equal "copy-bit-field" (copy-bit-field #b1101101010 0 4 0)
1952      #b1101100000)
1953(test-equal "copy-bit-field" (copy-bit-field #b1101101010 0 4 -1)
1954      #b1101101111)
1955(test-equal "copy-bit-field" (copy-bit-field #b1101101010 5 16 -1)
1956      #b1111111111101010)
1957|#
1958
1959(test-equal "integer-length" (integer-length #b10101010)
1960      8)
1961(test-equal "integer-length" (integer-length #b1111)
1962      4)
1963
1964(test-end)
1965
1966;;------------------------------------------------------------------
1967(test-begin "inexact arithmetics")
1968
1969(test-equal "+. (0)" (+.) 0.0)
1970(test-equal "+. (1)" (+. 1) 1.0)
1971(test-equal "+. (1big)" (+. 100000000000000000000) 1.0e20)
1972(test-equal "+. (1rat)" (+. 3/2) 1.5)
1973(test-equal "+. (1cmp)" (+. 1+i) 1.0+i)
1974(test-equal "+. (2)" (+. 0 1) 1.0)
1975(test-equal "+. (2big)" (+. 1 100000000000000000000) 1.0e20)
1976(test-equal "+. (2rat)" (+. 1 1/2) 1.5)
1977(test-equal "+. (many)" (+. 1 2 3 4 5) 15.0)
1978
1979(test-equal "-. (1)" (-. 1) -1.0)
1980(test-equal "-. (1big)" (-. 100000000000000000000) -1.0e20)
1981(test-equal "-. (1rat)" (-. 3/2) -1.5)
1982(test-equal "-. (1cmp)" (-. 1+i) -1.0-i)
1983(test-equal "-. (2)" (-. 0 1) -1.0)
1984(test-equal "-. (2big)" (-. 1 100000000000000000000) -1.0e20)
1985(test-equal "-. (2rat)" (-. 1 1/2) 0.5)
1986(test-equal "-. (many)" (-. 1 2 3 4 5) -13.0)
1987
1988(test-equal "*. (0)" (*.) 1.0)
1989(test-equal "*. (1)" (*. 1) 1.0)
1990(test-equal "*. (1big)" (*. 100000000000000000000) 1.0e20)
1991(test-equal "*. (1rat)" (*. 3/2) 1.5)
1992(test-equal "*. (1cmp)" (*. 1+i) 1.0+i)
1993(test-equal "*. (2)"  (*. 0 1) 0.0)
1994(test-equal "*. (2big)" (*. 1 100000000000000000000) 1.0e20)
1995(test-equal "*. (2rat)" (*. 1 1/2) 0.5)
1996(test-equal "*. (many)" (*. 1 2 3 4 5) 120.0)
1997
1998(test-equal "/. (1)" (/. 1) 1.0)
1999(test-equal "/. (1big)" (/. 100000000000000000000) 1.0e-20)
2000(test-equal "/. (1rat)" (/. 3/2) 0.6666666666666666)
2001(test-equal "/. (1cmp)" (/. 1+i) 0.5-0.5i)
2002(test-equal "/. (2)"  (/. 0 1) 0.0)
2003(test-equal "/. (2big)" (/. 1 100000000000000000000) 1.0e-20)
2004(test-equal "/. (2rat)" (/. 1 1/2) 2.0)
2005(test-equal "/. (many)" (/. 1 2 5) 0.1)
2006
2007(test-end)
2008
2009;;------------------------------------------------------------------
2010(test-begin "sqrt")
2011
2012;; R6RS and R7RS
2013(define (integer-sqrt-tester k)
2014  (test-equal (format "exact-integer-sqrt ~a" k) (receive (s r) (exact-integer-sqrt k)
2015           (list (= k (+ (* s s) r))
2016                 (< k (* (+ s 1) (+ s 1)))))
2017         '(#t #t)))
2018
2019(integer-sqrt-tester 0)
2020(integer-sqrt-tester 1)
2021(integer-sqrt-tester 2)
2022(integer-sqrt-tester 3)
2023(integer-sqrt-tester 4)
2024(integer-sqrt-tester 10)
2025(integer-sqrt-tester (expt 2 32))
2026(integer-sqrt-tester (- (expt 2 53) 1))
2027(integer-sqrt-tester (expt 2 53))
2028(integer-sqrt-tester (+ (expt 2 53) 1))
2029(integer-sqrt-tester 9999999999999999999999999999999999999999999999999999)
2030(integer-sqrt-tester (+ (expt 10 400) 3141592653589)) ; double range overflow
2031
2032(test-error "exact-integer-sqrt -1" (exact-integer-sqrt -1))
2033(test-error "exact-integer-sqrt 1.0" (exact-integer-sqrt 1.0))
2034(test-error "exact-integer-sqrt 1/4" (exact-integer-sqrt (read-from-string "1/4")))
2035
2036(parameterize ((current-test-comparator eqv?))
2037 (test-equal "sqrt, exact" (sqrt 0) 0)
2038 (test-equal "sqrt, exact" (sqrt 16) 4)
2039 (test-equal "sqrt, inexact" (sqrt 16.0) 4.0)
2040 (test-equal "sqrt, inexact" (sqrt -16.0) (read-from-string "+4.0i"))
2041 (test-equal "sqrt, exact" (sqrt (read-from-string "1/16")) (read-from-string "1/4"))
2042 (test-equal "sqrt, inexact" (sqrt (exact->inexact (read-from-string "1/16"))) 0.25))
2043
2044(test-end)
2045
2046;;------------------------------------------------------------------
2047(test-begin "ffx optimization")
2048
2049;; This code is provided by naoya_t to reproduce the FFX bug
2050;; existed until r6714.   The bug was that the ARGP words of
2051;; in-stack continuations were not scanned when flonum register
2052;; bank was cleared.  This code exhibits the case by putting
2053;; the result of (sqrt 2) as an unfinished argument, then calling
2054;; inverse-erf which caused flushing flonum regs (see "NG" line).
2055
2056;; (use math.const)
2057(define-constant pi     3.141592653589793)
2058
2059
2060(let ()
2061  (define *epsilon* 1e-12)
2062
2063  ;;
2064  ;; normal quantile function (probit function)
2065  ;;
2066  (define (probit p)
2067    (define (probit>0 p)
2068      (* (inverse-erf (- (* p 2) 1)) (sqrt 2))) ;; OK
2069    (if (< p 0)
2070      (- 1 (probit>0 (- p)))
2071      (probit>0 p) ))
2072
2073  (define (probit p)
2074    (define (probit>0 p)
2075      (* (sqrt 2) (inverse-erf (- (* p 2) 1)))) ;; NG
2076    (if (< p 0)
2077      (- 1 (probit>0 (- p)))
2078      (probit>0 p) ))
2079
2080  ;;
2081  ;; inverse error function (erf-1)
2082  ;;
2083  (define (inverse-erf z)
2084    (define (calc-next-ck k c)
2085      (let loop ((m 0) (sum 0) (ca c) (cz (reverse c)))
2086        (if (= m k) sum
2087            (loop (+ m 1)
2088                  (+ sum (/. (* (car ca) (car cz)) (+ m 1) (+ m m 1)))
2089                  (cdr ca) (cdr cz)))))
2090    (define (calc-cks k)
2091      (let loop ((i 0) (cks '(1)))
2092        (if (= i k) cks
2093            (loop (+ i 1) (cons (calc-next-ck (+ i 1) cks) cks)))))
2094    (define (calc-ck k) (car (calc-cks k)))
2095
2096    (define (inverse-erf>0 z)
2097      (let1 r (* pi z z 1/4) ; (pi*z^2)/4
2098        (let loop ((k 0) (cks '(1)) (sum 0) (a 1))
2099          (let1 delta (* a (/ (car cks) (+ k k 1)))
2100            (if (< delta (* sum *epsilon*))
2101              (* 1/2 z (sqrt pi) sum)
2102              (loop (+ k 1)
2103                    (cons (calc-next-ck (+ k 1) cks) cks)
2104                    (+ sum delta)
2105                    (* a r)))))))
2106
2107    (cond [(< z 0) (- (inverse-erf>0 (- z)))]
2108          [(= z 0) 0]
2109          [else (inverse-erf>0 z)]) )
2110
2111  (define ~= (lambda (x y) (< (abs (- x y)) 1e-7)))
2112  ;;
2113  ;; TEST
2114  ;;
2115  (parameterize ((current-test-comparator ~=))
2116    (test-equal "probit(0.025)" (probit 0.025) -1.959964)
2117    (test-equal "probit(0.975)" (probit 0.975) 1.959964))
2118  )
2119
2120(test-end)
2121
2122(test-exit)
2123