suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

r6rs fixes and tests

Browse Source 
svn: r9549
This commit is contained in:
Matthew Flatt 2008-04-30 21:48:22 +00:00
parent 36d240345c
commit 53144751d2
5 changed files with 383 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/rnrs/arithmetic/bitwise-6.ss
View File

@ -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)

6
collects/rnrs/arithmetic/flonums-6.ss
View File

@ -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)))

56
collects/tests/r6rs/arithmetic/bitwise.ss
View File

@ -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))
;;
))

123
collects/tests/r6rs/arithmetic/fixnums.ss
View File

@ -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)
;;
))

202
collects/tests/r6rs/arithmetic/flonums.ss
View File

@ -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<=? a b c)
(test (fl<? a b) #t)
(test (fl<? b c) #t)
(test (fl<? a c) #t)
(test (fl<? a b c) #t)
(test (fl<? b a) #f)
(test (fl<? c b) #f)
(test (fl<? a c b) #f)
(test (fl<=? a a) #t)
(test (fl<=? a b) #t)
(test (fl<=? a c) #t)
(test (fl<=? b b) #t)
(test (fl<=? b c) #t)
(test (fl<=? c c) #t)
(test (fl<=? a c c) #t)
(test (fl<=? a b c) #t)
(test (fl<=? b b c) #t)
(test (fl<=? c a) #f)
(test (fl<=? b a) #f)
(test (fl<=? a c b) #f)
(test (fl<=? b c a) #f))])
(test-lt fl<? fl<=? a b c)
(test-lt 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)) #t)
(test (fl<=? b (+ 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)) #f)
(test (fl<=? b (- b 1)) #f)
(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)
;;
))