tests/numbers-test-gauche.scm

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