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