From 53144751d279dc49437f94c76cde73ba2d7668a2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 30 Apr 2008 21:48:22 +0000 Subject: [PATCH] r6rs fixes and tests svn: r9549 --- collects/rnrs/arithmetic/bitwise-6.ss | 2 +- collects/rnrs/arithmetic/flonums-6.ss | 6 +- collects/tests/r6rs/arithmetic/bitwise.ss | 56 ++++++ collects/tests/r6rs/arithmetic/fixnums.ss | 123 +++++++++++++ collects/tests/r6rs/arithmetic/flonums.ss | 202 +++++++++++++++++++++- 5 files changed, 383 insertions(+), 6 deletions(-) diff --git a/collects/rnrs/arithmetic/bitwise-6.ss b/collects/rnrs/arithmetic/bitwise-6.ss index 051c2056a2..af4e80e79a 100644 --- a/collects/rnrs/arithmetic/bitwise-6.ss +++ b/collects/rnrs/arithmetic/bitwise-6.ss @@ -53,7 +53,7 @@ (raise-type-error 'bitwise-copy-bit "0 or 1" bit)) (if (eq? bit 1) (bitwise-ior b (arithmetic-shift 1 n)) - (bitwise-xor b (arithmetic-shift 1 n)))) + (bitwise-and b (bitwise-not (arithmetic-shift 1 n))))) (define (bitwise-bit-field b start end) (unless (exact-nonnegative-integer? start) diff --git a/collects/rnrs/arithmetic/flonums-6.ss b/collects/rnrs/arithmetic/flonums-6.ss index 2e6863ce03..4d5ca26dfc 100644 --- a/collects/rnrs/arithmetic/flonums-6.ss +++ b/collects/rnrs/arithmetic/flonums-6.ss @@ -142,6 +142,6 @@ (exact->inexact r)) (define (fixnum->flonum fx) - (unless (fixnum? fx) - (raise-type-error 'fixnum->flonum "fixnum" fx) - (exact->inexact fx))) + (if (fixnum? fx) + (exact->inexact fx) + (raise-type-error 'fixnum->flonum "fixnum" fx))) diff --git a/collects/tests/r6rs/arithmetic/bitwise.ss b/collects/tests/r6rs/arithmetic/bitwise.ss index d086bc83ac..7707b5a6ea 100644 --- a/collects/tests/r6rs/arithmetic/bitwise.ss +++ b/collects/tests/r6rs/arithmetic/bitwise.ss @@ -246,6 +246,62 @@ (test (bitwise-not #x-1000000000000000000000000) 79228162514264337593543950335) + ;; ---------------------------------------- + + (test (bitwise-and (expt 2 100) 17) 0) + (test (bitwise-and (- (expt 2 100) 1) 17) 17) + (test (bitwise-and (- (expt 2 100) 1) (expt 2 90)) (expt 2 90)) + + (test (bitwise-xor (expt 2 100) 17) (bitwise-ior (expt 2 100) 17)) + (test (bitwise-xor (- (expt 2 100) 1) 17) (- (expt 2 100) 18)) + (test (bitwise-xor (- (expt 2 100) 1) (expt 2 90)) (- (expt 2 100) (expt 2 90) 1)) + + (test (bitwise-if (expt 2 100) -1 1) (+ (expt 2 100) 1)) + (test (bitwise-if (expt 2 100) 1 1) 1) + (test (bitwise-if (expt 2 100) (- (expt 2 200) 1) 1) (+ (expt 2 100) 1)) + + (test (bitwise-bit-count (expt 2 300)) 1) + (test (bitwise-bit-count (- (expt 2 300) 1)) 300) + (test (bitwise-bit-count (- (expt 2 300))) -301) + + (test (bitwise-length (expt 2 300)) 301) + (test (bitwise-length (- (expt 2 300) 1)) 300) + (test (bitwise-length (- (expt 2 300))) 300) + + (test (bitwise-first-bit-set (expt 2 300)) 300) + (test (bitwise-first-bit-set (- (expt 2 300) 1)) 0) + + (test (bitwise-bit-set? (expt 2 300) 300) #t) + (test (bitwise-bit-set? (expt 2 300) 0) #f) + (test (bitwise-bit-set? (- (expt 2 300) 1) 300) #f) + (test (bitwise-bit-set? (- (expt 2 300) 1) 299) #t) + (test (bitwise-bit-set? (- (expt 2 300) 1) 298) #t) + (test (bitwise-bit-set? (- (expt 2 300) 2) 0) #f) + (test (bitwise-bit-set? -1 300) #t) + (test (bitwise-bit-set? -1 0) #t) + (test (bitwise-bit-set? -2 0) #f) + + (test (bitwise-copy-bit-field (expt 2 300) 300 302 0) 0) + (test (bitwise-copy-bit-field (expt 2 300) 300 302 1) (expt 2 300)) + (test (bitwise-copy-bit-field (expt 2 300) 300 302 2) (expt 2 301)) + (test (bitwise-copy-bit-field (expt 2 300) 300 302 3) (+ (expt 2 300) + (expt 2 301))) + + (test (bitwise-arithmetic-shift (expt 2 300) 1) (expt 2 301)) + (test (bitwise-arithmetic-shift (expt 2 300) -1) (expt 2 299)) + (test (bitwise-arithmetic-shift (expt 2 300) 300) (expt 2 600)) + (test (bitwise-arithmetic-shift (expt 2 300) -300) 1) + + (test (bitwise-arithmetic-shift-left (expt 2 300) 1) (expt 2 301)) + (test (bitwise-arithmetic-shift-right (expt 2 300) 1) (expt 2 299)) + (test (bitwise-arithmetic-shift-left (expt 2 300) 300) (expt 2 600)) + (test (bitwise-arithmetic-shift-right (expt 2 300) 300) 1) + + (test (bitwise-rotate-bit-field (expt 2 300) 299 304 2) (expt 2 302)) + (test (bitwise-rotate-bit-field (expt 2 300) 299 304 4) (expt 2 299)) + + (test (bitwise-reverse-bit-field (expt 2 300) 299 304) (expt 2 302)) + ;; )) diff --git a/collects/tests/r6rs/arithmetic/fixnums.ss b/collects/tests/r6rs/arithmetic/fixnums.ss index 2e58863d41..32dc95e515 100644 --- a/collects/tests/r6rs/arithmetic/fixnums.ss +++ b/collects/tests/r6rs/arithmetic/fixnums.ss @@ -181,6 +181,129 @@ ;; If you put N numbers here, it expads to N^3 tests! (carry-tests 0 [0 1 2 -1 -2 38734 -3843 2484598 -348732487 (greatest-fixnum) (least-fixnum)]) + (test (fxdiv 123 10) 12) + (test (fxmod 123 10) 3) + (test (fxdiv 123 -10) -12) + (test (fxmod 123 -10) 3) + (test (fxdiv -123 10) -13) + (test (fxmod -123 10) 7) + (test (fxdiv -123 -10) 13) + (test (fxmod -123 -10) 7) + + (test/values (fxdiv-and-mod -123 10) -13 7) + + (test (fxdiv0 123 10) 12) + (test (fxmod0 123 10) 3) + (test (fxdiv0 123 -10) -12) + (test (fxmod0 123 -10) 3) + (test (fxdiv0 -123 10) -12) + (test (fxmod0 -123 10) -3) + (test (fxdiv0 -123 -10) 12) + (test (fxmod0 -123 -10) -3) + + (test/values (fxdiv0-and-mod0 -123 10) -12 -3) + + (test (fxnot 0) -1) + (test (fxnot -2) 1) + (test (fxnot 1) -2) + + (test (fxand 7) 7) + (test (fxand 7 0) 0) + (test (fxand 7 1) 1) + (test (fxand 7 5) 5) + (test (fxand 7 4 5) 4) + (test (fxand 7 5 4) 4) + + (test (fxior 7) 7) + (test (fxior 7 0) 7) + (test (fxior 5 4) 5) + (test (fxior 5 3) 7) + (test (fxior 5 3 32) 39) + + (test (fxxor 7) 7) + (test (fxxor 7 0) 7) + (test (fxxor 5 4) 1) + (test (fxxor 5 3) 6) + (test (fxxor 5 1 32) 36) + + (test (fxif 5 15 0) 5) + (test (fxif 5 0 15) 10) + (test (fxif 5 0 1) 0) + (test (fxif 5 0 3) 2) + (test (fxif 5 3 0) 1) + + (test (fxbit-count 5) 2) + (test (fxbit-count 6) 2) + (test (fxbit-count 7) 3) + (test (fxbit-count -7) -3) + + (test (fxlength 1) 1) + (test (fxlength 255) 8) + (test (fxlength 0) 0) + (test (fxlength -2) 1) + (test (fxlength -255) 8) + + (test (fxfirst-bit-set 0) -1) + (test (fxfirst-bit-set 1) 0) + (test (fxfirst-bit-set 16) 4) + (test (fxfirst-bit-set -2) 1) + (test (fxfirst-bit-set (expt 2 17)) 17) + + (test (fxbit-set? 15 0) #t) + (test (fxbit-set? 14 0) #f) + (test (fxbit-set? 14 3) #t) + (test (fxbit-set? 14 10) #f) + (test (fxbit-set? -1 10) #t) + + (test (fxcopy-bit 0 0 1) 1) + (test (fxcopy-bit 0 1 1) 2) + (test (fxcopy-bit 0 4 1) 16) + (test (fxcopy-bit 0 4 0) 0) + (test (fxcopy-bit 31 4 0) 15) + + (test (fxbit-field 30 1 3) 3) + (test (fxbit-field 30 1 4) 7) + (test (fxbit-field 30 1 5) 15) + (test (fxbit-field 30 1 6) 15) + (test (fxbit-field 30 0 3) 6) + + (test (fxcopy-bit-field 0 0 3 30) 6) + (test (fxcopy-bit-field 7 0 3 30) 6) + (test (fxcopy-bit-field 15 0 3 30) 14) + (test (fxcopy-bit-field 0 2 5 30) 24) + (test (fxcopy-bit-field 1 2 5 30) 25) + (test (fxcopy-bit-field 7 2 5 30) 27) + (test (fxcopy-bit-field 15 2 5 30) 27) + (test (fxcopy-bit-field 0 2 5 120) 0) + (test (fxcopy-bit-field 1 2 5 120) 1) + + (test (fxarithmetic-shift 1 1) 2) + (test (fxarithmetic-shift 1 -1) 0) + (test (fxarithmetic-shift 10 2) 40) + (test (fxarithmetic-shift 40 -2) 10) + (test (fxarithmetic-shift -1 1) -2) + (test (fxarithmetic-shift -1 -1) -1) + (test (fxarithmetic-shift -10 2) -40) + (test (fxarithmetic-shift -40 -2) -10) + + (test (fxarithmetic-shift-left 1 1) 2) + (test (fxarithmetic-shift-right 1 1) 0) + (test (fxarithmetic-shift-left 10 2) 40) + (test (fxarithmetic-shift-right 40 2) 10) + (test (fxarithmetic-shift-left -1 1) -2) + (test (fxarithmetic-shift-right -1 1) -1) + (test (fxarithmetic-shift-left -10 2) -40) + (test (fxarithmetic-shift-right -40 2) -10) + + (test (fxrotate-bit-field 10 0 2 0) 10) + (test (fxrotate-bit-field 10 0 2 1) 9) + + (test (fxrotate-bit-field 10 2 4 0) 10) + (test (fxrotate-bit-field 10 2 4 1) 6) + (test (fxrotate-bit-field 10 1 4 2) 12) + (test (fxrotate-bit-field 10 1 4 1) 6) + (test (fxrotate-bit-field 10 2 4 1) 6) + ;; )) diff --git a/collects/tests/r6rs/arithmetic/flonums.ss b/collects/tests/r6rs/arithmetic/flonums.ss index 4bbd951a1f..97f7708e42 100644 --- a/collects/tests/r6rs/arithmetic/flonums.ss +++ b/collects/tests/r6rs/arithmetic/flonums.ss @@ -30,6 +30,8 @@ (test (flfinite? 5.0) #t) (test (flinfinite? 5.0) #f) (test (flinfinite? +inf.0) #t) + (test (flinfinite? -inf.0) #t) + (test (flinfinite? +nan.0) #f) (test (fl+ +inf.0 -inf.0) +nan.0) (try-flonums @@ -48,8 +50,8 @@ (test (fldenominator +inf.0) 1.0) (test (fldenominator -inf.0) 1.0) - ; (test (flnumerator 0.75) 3.0) ; probably - ; (test (fldenominator 0.75) 4.0) ; probably + ;; (test (flnumerator 0.75) 3.0) ; probably + ;; (test (fldenominator 0.75) 4.0) ; probably (test (flnumerator -0.0) -0.0) @@ -68,7 +70,203 @@ (test (flsqrt +inf.0) +inf.0) (test (flsqrt -0.0) -0.0) + + ;; ---------------------------------------- + (let ([test-ordered + (lambda (a b c) + (test (fl=? a a) #t) + (test (fl=? b b) #t) + (test (fl=? c c) #t) + + (test (fl=? a b) #f) + (test (fl=? b a) #f) + (test (fl=? b c) #f) + (test (fl=? c b) #f) + + (test (fl=? a c b) #f) + (test (fl=? a a b) #f) + (test (fl=? a b b) #f) + + (let ([test-lt + (lambda (fl? fl>=? c b a)) + + ;; Since b is between a and c, we can add or subtract 1: + (test (fl=? (+ b 1) (+ b 1)) #t) + (test (fl? b (+ b 1)) #f) + (test (fl>=? b (+ b 1)) #f) + (test (fl=? (- b 1) (- b 1)) #t) + (test (fl? b (- b 1)) #t) + (test (fl>=? b (- b 1)) #t) + + ;; Check min & max while we have ordered values: + (test (flmin a b) a) + (test (flmin b c) b) + (test (flmin a c) a) + (test (flmin b a c) a) + (test (flmax a b) b) + (test (flmax b c) c) + (test (flmax a c) c) + (test (flmax b c a) c))]) + (test-ordered 1.0 2.0 3.0) + (test-ordered -1.0 0.0 1.0) + (test-ordered -1.0e5 0.0 1.0e-5)) + + (test (flinteger? 4.0) #t) + (test (flinteger? 4.1) #f) + (test (flzero? 4.1) #f) + (test (flzero? 0.0) #t) + (test (flzero? -4.1) #f) + (test (flpositive? 4.1) #t) + (test (flpositive? 0.0) #f) + (test (flpositive? -4.1) #f) + (test (flnegative? 4.1) #f) + (test (flnegative? 0.0) #f) + (test (flnegative? -4.1) #t) + + (test (fleven? 2.0) #t) + (test (fleven? -2.0) #t) + (test (fleven? 0.0) #t) + (test (fleven? -0.0) #t) + (test (fleven? 3.0) #f) + (test (fleven? -3.0) #f) + + (test (flodd? 3.0) #t) + (test (flodd? -3.0) #t) + (test (flodd? 0.0) #f) + (test (flodd? -0.0) #f) + (test (flodd? 2.0) #f) + (test (flodd? -2.0) #f) + + (test (flnan? +inf.0) #f) + (test (flnan? 0.0) #f) + (test (flnan? -0.0) #f) + (test (flnan? -inf.0) #f) + (test (flnan? +nan.0) #t) + + (test (fl+ 2.3) 2.3) + (test/approx (fl+ 2.3 3.1) 5.4) + (test/approx (fl+ 2.3 3.1 -1.1) 4.3) + (test/approx (fl+ 2.3e2 3.1e1) 261) + + (test (fl* 2.3) 2.3) + (test/approx (fl* 2.3 2.1) 4.83) + (test/approx (fl* 2.3 2.1 1.1) 5.313) + (test/approx (fl* 2.3 2.1 -1.1) -5.313) + + (test/approx (fl- 0.0 2.3) -2.3) + (test/approx (fl- 0.0 2.3 -1.1) -1.2) + (test/approx (fl- 2.3) -2.3) + (test (fl- 0.0) -0.0) + + (test/approx (fl/ 5.0 2.0) 2.5) + (test/approx (fl/ 5.0 2.0 2.5) 1.0) + (test/approx (fl/ 2.0) 0.5) + (test/approx (fl/ -2.0) -0.5) + + (test (flabs 0.0) 0.0) + (test/approx (flabs 1.0) 1.0) + (test/approx (flabs -1.0) 1.0) + (test/approx (flabs -0.1) 0.1) + + (test (fldiv 123.0 10.0) 12.0) + (test (flmod 123.0 10.0) 3.0) + (test (fldiv 123.0 -10.0) -12.0) + (test (flmod 123.0 -10.0) 3.0) + (test (fldiv -123.0 10.0) -13.0) + (test (flmod -123.0 10.0) 7.0) + (test (fldiv -123.0 -10.0) 13.0) + (test (flmod -123.0 -10.0) 7.0) + + (test/values (fldiv-and-mod -123.0 10.0) -13.0 7.0) + + (test (fldiv0 123.0 10.0) 12.0) + (test (flmod0 123.0 10.0) 3.0) + (test (fldiv0 123.0 -10.0) -12.0) + (test (flmod0 123.0 -10.0) 3.0) + (test (fldiv0 -123.0 10.0) -12.0) + (test (flmod0 -123.0 10.0) -3.0) + (test (fldiv0 -123.0 -10.0) 12.0) + (test (flmod0 -123.0 -10.0) -3.0) + + (test/values (fldiv0-and-mod0 -123.0 10.0) -12.0 -3.0) + + (test (flfloor 3.1) 3.0) + (test (flfloor -3.1) -4.0) + (test (flceiling 3.1) 4.0) + (test (flceiling -3.1) -3.0) + (test (fltruncate 3.1) 3.0) + (test (fltruncate -3.1) -3.0) + (test (flround 3.1) 3.0) + (test (flround -3.1) -3.0) + (test (flround 3.8) 4.0) + (test (flround -3.8) -4.0) + ;; (test (flround 3.5) 4.0) ; probably + ;; (test (flround -3.5) -4.0) ; probably + ;; (test (flround 2.5) 2.0) ; probably + ;; (test (flround -2.5) -2.0) ; probably + + (test/approx (flexp 2.0) 7.389) + (test/approx (fllog 7.389) 2.0) + (test/approx (fllog 1024.0 2.0) 10.0) + + (test/approx (flsin 0.0) 0.0) + (test/approx (flsin 1.570796) 1.0) + (test/approx (flcos 1.570796) 0.0) + (test/approx (flcos 0.0) 1.0) + (test/approx (flatan 0.0 1.0) 0.0) + (test/approx (flatan 0.0 -1.0) (* 1.570796 2.0)) + (test/approx (flatan 1.0 0.0) 1.570796) + (test/approx (flatan -1.0 0.0) -1.570796) + (test/approx (flatan 1.0 1.0) (/ 1.570796 2.0)) + (test/approx (flatan -1.0 1.0) (/ -1.570796 2.0)) + (test/approx (flatan 0.0) 0.0) + (test/approx (flatan 1.0) (/ 1.570796 2.0)) + (test/approx (flatan 10.0) 1.47113) + (test/approx (flatan 0.1) 0.0996687) + + (test/approx (flsqrt 4.0) 2.0) + (test/approx (flsqrt 5.0) 2.23607) + + (test/approx (flexpt 2.0 3.0) 8.0) + (test/approx (flexpt 10.0 3.0) 1000.0) + + (test (no-infinities-violation? (make-no-infinities-violation)) #t) + (test ((record-predicate &no-infinities) (make-no-infinities-violation)) #t) + (test (no-nans-violation? (make-no-nans-violation)) #t) + (test ((record-predicate &no-nans) (make-no-nans-violation)) #t) + + (test/approx (fixnum->flonum 2) 2.0) + ;; ))