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