294 lines
9.1 KiB
Scheme
294 lines
9.1 KiB
Scheme
#!r6rs
|
|
|
|
(library (tests r6rs arithmetic flonums)
|
|
(export run-arithmetic-flonums-tests)
|
|
(import (rnrs)
|
|
(tests r6rs test))
|
|
|
|
(define (try-flonums proc)
|
|
(proc 0.0)
|
|
(proc 1.0)
|
|
(proc -1.0)
|
|
(proc +inf.0)
|
|
(proc -inf.0)
|
|
(proc +nan.0))
|
|
|
|
(define-syntax try-bad-divs
|
|
(syntax-rules ()
|
|
[(_ op)
|
|
'nothing
|
|
;; The spec is unclear whether the following
|
|
;; are allowed to raise exceptions.
|
|
#;
|
|
(begin
|
|
(test/unspec (op 1.0 0.0))
|
|
(test/unspec (op +inf.0 1.0))
|
|
(test/unspec (op -inf.0 1.0))
|
|
(test/unspec (op +nan.0 1.0)))]))
|
|
|
|
(define (run-arithmetic-flonums-tests)
|
|
|
|
(test (fl=? +inf.0 +inf.0) #t)
|
|
(test (fl=? -inf.0 +inf.0) #f)
|
|
(test (fl=? -inf.0 -inf.0) #t)
|
|
(test (fl=? 0.0 -0.0) #t)
|
|
(test (fl<? 0.0 -0.0) #f)
|
|
(try-flonums
|
|
(lambda (fl)
|
|
(test (fl=? +nan.0 fl) #f)
|
|
(test (fl<? +nan.0 fl) #f)))
|
|
|
|
(test (flnegative? -0.0) #f)
|
|
(test (flfinite? +inf.0) #f)
|
|
(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
|
|
(lambda (fl)
|
|
(test (fl+ +nan.0 fl) +nan.0)
|
|
(test (fl* +nan.0 fl) +nan.0)))
|
|
|
|
(test (fl- +inf.0 +inf.0) +nan.0)
|
|
|
|
(test (fl/ 1.0 0.0) +inf.0)
|
|
(test (fl/ -1.0 0.0) -inf.0)
|
|
(test (fl/ 0.0 0.0) +nan.0)
|
|
|
|
(test (flnumerator +inf.0) +inf.0)
|
|
(test (flnumerator -inf.0) -inf.0)
|
|
(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.0) -0.0)
|
|
|
|
(test (flfloor +inf.0) +inf.0)
|
|
(test (flceiling -inf.0) -inf.0)
|
|
(test (fltruncate +nan.0) +nan.0)
|
|
|
|
(test (flexp +inf.0) +inf.0)
|
|
(test (flexp -inf.0) 0.0)
|
|
(test (fllog +inf.0) +inf.0)
|
|
(test (fllog 0.0) -inf.0)
|
|
(test/unspec (fllog -0.0)) ; if -0.0 is distinguished
|
|
(test (fllog -inf.0) +nan.0)
|
|
(test/approx (flatan -inf.0) -1.5707963267948965)
|
|
(test/approx (flatan +inf.0) 1.5707963267948965)
|
|
|
|
(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)
|
|
|
|
(try-bad-divs fldiv)
|
|
(try-bad-divs flmod)
|
|
(try-bad-divs fldiv-and-mod)
|
|
|
|
(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)
|
|
|
|
(try-bad-divs fldiv0)
|
|
(try-bad-divs flmod0)
|
|
(try-bad-divs fldiv0-and-mod0)
|
|
|
|
(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 (record-type-descriptor &no-infinities)) (make-no-infinities-violation)) #t)
|
|
(test (no-nans-violation? (make-no-nans-violation)) #t)
|
|
(test ((record-predicate (record-type-descriptor &no-nans)) (make-no-nans-violation)) #t)
|
|
|
|
(test/approx (fixnum->flonum 2) 2.0)
|
|
|
|
;;
|
|
))
|
|
|