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

Add numeric tests from Gambit.

Browse Source 
Thanks to @gambiteer for help with them.
This commit is contained in:
Sam Tobin-Hochstadt 2021-05-07 11:52:49 -04:00 committed by Sam Tobin-Hochstadt
parent 0db8353d6b
commit a156607832
2 changed files with 328 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

325
pkgs/racket-test-core/tests/racket/gambit-numeric.rktl Normal file
View File

@ -0,0 +1,325 @@
(load-relative "loadtest.rktl")
(Section 'gambit-numeric)
;; tests adapted from Gambit numeric unit tests, see gambit/unit-tests/03-number
(require racket/flonum
racket/fixnum
racket/function
racket/list
racket/symbol
racket/keyword
(prefix-in k: '#%kernel))
(define =~ (lambda (a b)
(or (eqv? a b)
(and (< (abs (- (real-part a) (real-part b))) epsilon)
(< (abs (- (imag-part a) (imag-part b))) epsilon)))))
(define epsilon 1e-12)
(define (macro-cpxnum-+1/2+sqrt3/2i)
(make-rectangular 1/2 (/ (sqrt 3) 2)))
(define (macro-cpxnum-+1/2-sqrt3/2i)
(make-rectangular 1/2 (- (/ (sqrt 3) 2))))
(define (macro-cpxnum--1/2+sqrt3/2i)
(make-rectangular -1/2 (/ (sqrt 3) 2)))
(define (macro-cpxnum--1/2-sqrt3/2i)
(make-rectangular -1/2 (- (/ (sqrt 3) 2))))
(define (macro-cpxnum-+sqrt3/2+1/2i)
(make-rectangular (/ (sqrt 3) 2) 1/2))
(define (macro-cpxnum-+sqrt3/2-1/2i)
(make-rectangular (/ (sqrt 3) 2) -1/2))
(define (macro-cpxnum--sqrt3/2+1/2i)
(make-rectangular (- (/ (sqrt 3) 2)) 1/2))
(define (macro-cpxnum--sqrt3/2-1/2i)
(make-rectangular (- (/ (sqrt 3) 2)) -1/2))
(define (test-atanh z)
(* 1/2 (- (log (+ 1 z)) (log (- 1 z)))))
(define (test-atan z)
(/ (test-atanh (* +i z)) +i))
(define (test-asinh z)
(log (+ z (sqrt (+ (* z z) 1)))))
(define (test-asin z)
(/ (test-asinh (* +i z)) +i))
(define (test-acos z)
(- (macro-inexact-+pi/2) (test-asin z)))
(define (test-acosh z)
(* 2 (log (+ (sqrt (/ (+ z 1) 2)) (sqrt (/ (- z 1) 2))))))
(define (test-complex-+ x y)
(let ((a (real-part x)) (b (imag-part x))
(c (real-part y)) (d (imag-part y)))
(make-rectangular (+ a c)
(+ b d))))
(define (test-complex-- x y)
(let ((a (real-part x)) (b (imag-part x))
(c (real-part y)) (d (imag-part y)))
(make-rectangular (- a c)
(- b d))))
(define (test-complex-* x y)
(let ((a (real-part x)) (b (imag-part x))
(c (real-part y)) (d (imag-part y)))
(make-rectangular (- (* a c) (* b d))
(+ (* a d) (* b c)))))
(set! epsilon 1e-12)
(define (test-bitwise-ior x y)
(cond ((or (= x -1)
(= y -1))
-1)
((and (= x 0)
(= y 0))
0)
(else (+ (* 2 (test-bitwise-ior (arithmetic-shift x -1)
(arithmetic-shift y -1)))
(if (or (odd? x) (odd? y))
1
0)))))
(define (test-bitwise-and x y)
(cond ((or (= x 0)
(= y 0))
0)
((and (= x -1)
(= y -1))
-1)
(else (+ (* 2 (test-bitwise-and (arithmetic-shift x -1)
(arithmetic-shift y -1)))
(if (and (odd? x) (odd? y))
1
0)))))
(define (test-bitwise-xor x y)
(cond ((= x y)
0)
((or (and (= x -1)
(= y 0))
(and (= x 0)
(= y -1)))
-1)
(else
(+ (* 2 (test-bitwise-xor (arithmetic-shift x -1)
(arithmetic-shift y -1)))
(if (eq? (odd? x) (odd? y))
0
1)))))
(define (test-bitwise-not x)
(- -1 x))
(define (test-bitwise-andc1 x y)
(test-bitwise-and (test-bitwise-not x) y))
(define (test-bitwise-andc2 x y)
(test-bitwise-and x (test-bitwise-not y)))
(define (test-bitwise-eqv x y)
(test-bitwise-not (test-bitwise-xor x y)))
(define (test-bitwise-nand x y)
(test-bitwise-not (test-bitwise-and x y)))
(define (test-bitwise-nor x y)
(test-bitwise-not (test-bitwise-ior x y)))
(define (test-bitwise-orc1 x y)
(test-bitwise-ior (test-bitwise-not x) y))
(define (test-bitwise-orc2 x y)
(test-bitwise-ior x (test-bitwise-not y)))
(define (test-arithmetic-shift x n)
(if (negative? n)
(let* ((q (expt 2 (- n)))
(bits (modulo x q)))
(quotient (- x bits) q))
(* x (expt 2 n))))
(define (test-extract-bit-field size position n)
(bitwise-and (arithmetic-shift n (- position))
(bitwise-not (arithmetic-shift -1 size))))
(define (test-test-bit-field? size position n)
(not (eqv? (test-extract-bit-field size position n)
0)))
(define (test-clear-bit-field size position n)
(bitwise-ior (arithmetic-shift (arithmetic-shift n (- (+ size position))) (+ size position))
(test-extract-bit-field position 0 n)))
(define (macro-inexact-+pi) 3.141592653589793)
(define (macro-inexact--pi) -3.141592653589793)
(define (macro-inexact-+pi/2) 1.5707963267948966)
(define (macro-inexact--pi/2) -1.5707963267948966)
(define (macro-inexact-+pi/4) .7853981633974483)
(define (macro-inexact--pi/4) -.7853981633974483)
(define (macro-inexact-+3pi/4) 2.356194490192345)
(define (macro-inexact--3pi/4) -2.356194490192345)
(define (exact v) (if (exact? v) v (inexact->exact v)))
(define (inexact v) (if (inexact? v) v (exact->inexact v)))
(define (isnan? x) (not (= x x)))
(err/rt-test (abs #\c))
(err/rt-test (abs 0+1i))
(test 0 acos 1)
(test/compare =~ (test-acos 2) acos 2)
(test/compare =~ (test-acos 2.0+0.0i) acos 2.0+0.0i)
(test/compare =~ (test-acos 2.0-0.0i) acos 2.0-0.0i)
(test/compare =~ (test-acos -2) acos -2)
(test/compare =~ (test-acos -2.0+0.0i) acos -2.0+0.0i)
(test/compare =~ (test-acos -2.0-0.0i) acos -2.0-0.0i)
(test/compare =~ (test-acos -1234000000.0-0.0i) acos -1234000000.0-0.0i)
(err/rt-test (acos 'a))
(err/rt-test (angle 'a))
(test 0 asin 0)
(test/compare =~ (test-asin 2) asin 2)
(test/compare =~ (test-asin 2.0+0.0i) asin 2.0+0.0i)
(test/compare =~ (test-asin 2.0-0.0i) asin 2.0-0.0i)
(test/compare =~ (test-asin -2) asin -2)
(test/compare =~ (test-asin -2.0+0.0i) asin -2.0+0.0i)
(test/compare =~ (test-asin -2.0-0.0i) asin -2.0-0.0i)
(test 1e-30+1e-40i asin 1e-30+1e-40i)
(test/compare =~ (test-asin -1234000000.0-0.0i) asin -1234000000.0-0.0i)
(err/rt-test (asin 'a))
(test (test-complex-+ 1.0+2.0i 6.4+8.2i) + 1.0+2.0i 6.4+8.2i)
(test (test-complex-- 1.0+2.0i 6.4+8.2i) - 1.0+2.0i 6.4+8.2i)
(test (test-complex-* 1.0+2.0i 64.0+82.0i) * 1.0+2.0i 64.0+82.0i)
(test (test-complex-+ 1+2i 64+82i) + 1+2i 64+82i)
(test (test-complex-- 1+2i 64+82i) - 1+2i 64+82i)
(test (test-complex-* 1+2i 64+82i) * 1+2i 64+82i)
(err/rt-test (conjugate 'a))
(test 1 cos 0)
(err/rt-test (cos 'a))
(test 5 denominator (/ -12 -10))
(test 123.0 exact->inexact 123.0)
(test 0.5 exact->inexact 0.5)
(test 123.0 exact->inexact 123)
(test 0.5 exact->inexact 1/2)
(test 0.5+0.75i exact->inexact 1/2+3/4i)
(err/rt-test (exact->inexact 'a))
(test #f exact-integer? 123.0)
(test #f exact-integer? 0.5)
(test #t exact-integer? 123)
(test #t exact-integer? 100000000000000000000)
(test #f exact-integer? 1/2)
(test #f exact-integer? 1/2+3/4i)
(test #f exact-integer? 123.0+0.0i)
(err/rt-test (exact-integer?))
(err/rt-test (exact-integer? 0 0))
(test 123 exact 123)
(test 1/2 exact 1/2)
(test 123 exact 123.0)
(test 1/2 exact 0.5)
(test 1/2+3/4i exact 0.5+0.75i)
(err/rt-test (exact 'a))
(err/rt-test (exp #\c))
(err/rt-test (imag-part 'a))
(test 123 inexact->exact 123)
(test 1/2 inexact->exact 1/2)
(test 123 inexact->exact 123.0)
(test 1/2 inexact->exact 0.5)
(test 1/2+3/4i inexact->exact 0.5+0.75i)
(err/rt-test (inexact->exact 'a))
(test 123.0 inexact 123.0)
(test 0.5 inexact 0.5)
(test 123.0 inexact 123)
(test 0.5 inexact 1/2)
(test 0.5+0.75i inexact 1/2+3/4i)
(err/rt-test (inexact 'a))
(test 0 integer-sqrt 0)
(test 31 integer-sqrt 1000)
(test 31622776601 integer-sqrt 1000000000000000000000)
(err/rt-test (integer-sqrt #f))
(err/rt-test (integer-sqrt))
(err/rt-test (integer-sqrt 0 0))
(test/compare =~ +inf.0 magnitude (make-rectangular +nan.0 +inf.0))
(test/compare =~ +inf.0 magnitude (make-rectangular +inf.0 +nan.0))
(err/rt-test (magnitude 'a))
(err/rt-test (make-polar 'a 2))
(err/rt-test (make-polar 2 'a))
(err/rt-test (make-polar 2 0+1i))
(err/rt-test (make-polar 0+1i 2))
(err/rt-test (make-rectangular 'a 2))
(err/rt-test (make-rectangular 2 'a))
(err/rt-test (make-rectangular 2 0+1i))
(err/rt-test (make-rectangular 0+1i 2))
(test "0" number->string 0)
(test "123" number->string 123)
(test "-123" number->string -123)
(test "1111011" number->string 123 2)
(test "-1111011" number->string -123 2)
(test "7b" number->string 123 16)
(test "-7b" number->string -123 16)
(test "123456789012345678901234567890" number->string 123456789012345678901234567890)
(test "2/7" number->string 2/7)
(test "-inf.0" number->string -inf.0)
(err/rt-test (number->string 'a))
(err/rt-test (number->string 1 'a))
(err/rt-test (number->string 1 30))
(err/rt-test (real-part 'a))
(test 0 sinh 0)
(test (imag-part (sin 0+1i)) sinh 1)
(test 1e-30+1e-40i sinh 1e-30+1e-40i)
(err/rt-test (asinh 'a))
(test 0 sin 0)
(test 1e-30+1e-40i sin 1e-30+1e-40i)
(err/rt-test (sin 'a))
(test 0+1i sqrt -1)
(test/compare =~ 0+1i sqrt -1.0+0.0i)
(test/compare =~ 0-1i sqrt -1.0-0.0i)
(test 0+1i sqrt -1)
(test 1+1i sqrt 0+2i)
(test 1-1i sqrt 0-2i)
(err/rt-test (sqrt #\c))
(test 0 string->number "0")
(test 123 string->number "123")
(test -123 string->number "-123")
(test 123 string->number "1111011" 2)
(test -123 string->number "-1111011" 2)
(test 123 string->number "7b" 16)
(test -123 string->number "-7b" 16)
(test 123456789012345678901234567890 string->number "123456789012345678901234567890")
(test 2/7 string->number "2/7")
(test -0.0 string->number "-0.")
(test -inf.0 string->number "-inf.0")
(test 0.001953125 string->number ".001953125")
(test 0.0009765625 string->number "9.765625e-4")
(test -1.5+0.6666666666666666i string->number "-1.5+2/3i")
(err/rt-test (string->number 1))
(err/rt-test (string->number "" 'a))
(err/rt-test (string->number "" 30))
(test 0 tanh 0)
(test (imag-part (tan 0+1i)) tanh 1)
(test 1e-30+1e-40i tanh 1e-30+1e-40i)
(err/rt-test (tanh 'a))
(test 0 tan 0)
(test 1e-30+1e-40i tan 1e-30+1e-40i)
(err/rt-test (tan 'a))
;; these tests differ from the gambit behavior
(test 0+1i integer-sqrt -1)
(test +inf.0 magnitude (make-rectangular +nan.0 (expt 2 5000)))
(test +inf.0 magnitude (make-rectangular (expt 2 5000) +nan.0))
(test "-0.0" number->string -0.0)
(test "0.001953125" number->string 0.001953125)
(test "0.0009765625" number->string 0.0009765625)
(test "-1.5+0.6666666666666666i" number->string -1.5+0.6666666666666666i)

3
pkgs/racket-test-core/tests/racket/number.rktl
View File

@ -3724,4 +3724,7 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(load-relative "gambit-numeric.rktl")
(report-errs)