>From 5afefa3c781ef4a9ffa77f880b742b4a47e42d9b Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sat, 7 Apr 2012 15:07:46 +0200 Subject: [PATCH] Add tests for inf and nan values to even?, odd?, arithmetic-shift, lcm, gcd, quotient, modulo and remainder and fix them. Disallow non-integral values for flonums on lcm, gcd and quotient, modulo and remainder and make them consistent across compiled and interpreted code (R5RS/R7RS compat). --- runtime.c | 23 ++++++++++-- tests/library-tests.scm | 89 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 109 insertions(+), 3 deletions(-) diff --git a/runtime.c b/runtime.c index 9db1a4b..8e96255 100644 --- a/runtime.c +++ b/runtime.c @@ -4615,12 +4615,17 @@ C_regparm C_word C_fcall C_u_i_negativep(C_word x) C_regparm C_word C_fcall C_i_evenp(C_word x) { + double val, dummy; if(x & C_FIXNUM_BIT) return C_mk_nbool(x & 0x02); if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) barf(C_BAD_ARGUMENT_TYPE_ERROR, "even?", x); - return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) == 0.0); + val = C_flonum_magnitude(x); + if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0) + barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x); + + return C_mk_bool(fmod(val, 2.0) == 0.0); } @@ -4635,11 +4640,16 @@ C_regparm C_word C_fcall C_u_i_evenp(C_word x) C_regparm C_word C_fcall C_i_oddp(C_word x) { + double val, dummy; if(x & C_FIXNUM_BIT) return C_mk_bool(x & 0x02); if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) barf(C_BAD_ARGUMENT_TYPE_ERROR, "odd?", x); + val = C_flonum_magnitude(x); + if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0) + barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x); + return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) != 0.0); } @@ -5141,7 +5151,7 @@ C_regparm C_word C_fcall C_a_i_arithmetic_shift(C_word **a, int c, C_word n1, C_ f = C_flonum_magnitude(n1); - if(modf(f, &m) != 0.0) + if(C_isnan(f) || C_isinf(f) || modf(f, &m) != 0.0) barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1); if(f < C_WORD_MIN || f > C_UWORD_MAX) @@ -7204,16 +7214,23 @@ void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2 else if(!C_immediatep(n2) && C_block_header(n2) == C_FLONUM_TAG) { f1 = (double)C_unfix(n1); f2 = C_flonum_magnitude(n2); + if(C_isnan(f2) || C_isinf(f2) || C_modf(f2, &r) != 0.0) + barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", n2); } else barf(C_BAD_ARGUMENT_TYPE_ERROR, "quotient", n2); } else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) { f1 = C_flonum_magnitude(n1); + if(C_isnan(f1) || C_isinf(f1) || C_modf(f1, &r) != 0.0) + barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", n1); if(n2 &C_FIXNUM_BIT) f2 = (double)C_unfix(n2); - else if(!C_immediatep(n2) && C_block_header(n2) == C_FLONUM_TAG) + else if(!C_immediatep(n2) && C_block_header(n2) == C_FLONUM_TAG) { f2 = C_flonum_magnitude(n2); + if(C_isnan(f2) || C_isinf(f2) || C_modf(f2, &r) != 0.0) + barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", n2); + } else barf(C_BAD_ARGUMENT_TYPE_ERROR, "quotient", n2); } else barf(C_BAD_ARGUMENT_TYPE_ERROR, "quotient", n1); diff --git a/tests/library-tests.scm b/tests/library-tests.scm index f133f3f..a32b04c 100644 --- a/tests/library-tests.scm +++ b/tests/library-tests.scm @@ -65,6 +65,95 @@ (assert (= 2.5 (/ 5 2))) +(assert (even? 2)) +(assert (even? 2.0)) +(assert (even? 0)) +(assert (even? 0.0)) +(assert (not (even? 3))) +(assert (not (even? 3.0))) +(assert (odd? 1)) +(assert (odd? 1.0)) +(assert (not (odd? 0))) +(assert (not (odd? 0.0))) +(assert (not (odd? 2))) +(assert (not (odd? 2.0))) +(assert-fail (even? 1.2)) +(assert-fail (odd? 1.2)) +(assert-fail (even? +inf.0)) +(assert-fail (odd? +inf.0)) +(assert-fail (even? +nan.0)) +(assert-fail (odd? +nan.0)) +(assert-fail (even? 'x)) +(assert-fail (odd? 'x)) + +(assert (= 60 (arithmetic-shift 15 2))) +(assert (= 3 (arithmetic-shift 15 -2))) +(assert (= -60 (arithmetic-shift -15 2))) +(assert (= -4 (arithmetic-shift -15 -2))) ; 2's complement +(assert-fail (arithmetic-shift 0.1 2)) +;; XXX Do the following two need to fail? Might as well use the integral value +(assert-fail (arithmetic-shift #xf 2.0)) +(assert-fail (arithmetic-shift #xf -2.0)) +(assert-fail (arithmetic-shift #xf 2.1)) +(assert-fail (arithmetic-shift #xf -2.1)) +(assert-fail (arithmetic-shift +inf.0 2)) +(assert-fail (arithmetic-shift +nan.0 2)) + +(assert (= 0 (gcd))) +(assert (= 6 (gcd 6))) +(assert (= 2 (gcd 6 8))) +(assert (= 1 (gcd 6 8 5))) +(assert (= 1 (gcd 6 -8 5))) +(assert (= 2.0 (gcd 6.0 8.0))) +(assert-fail (gcd 6.1 8.0)) +(assert-fail (gcd 6.0 8.1)) +(assert-fail (gcd +inf.0)) +(assert-fail (gcd +nan.0)) +(assert-fail (gcd 6.0 +inf.0)) +(assert-fail (gcd +inf.0 6.0)) +(assert-fail (gcd +nan.0 6.0)) +(assert-fail (gcd 6.0 +nan.0)) + +(assert (= 1 (lcm))) +(assert (= 6 (lcm 6))) +(assert (= 24 (lcm 6 8))) +(assert (= 120 (lcm 6 8 5))) +(assert (= 24.0 (lcm 6.0 8.0))) +(assert-fail (lcm +inf.0)) +(assert-fail (lcm +nan.0)) +(assert-fail (lcm 6.1 8.0)) +(assert-fail (lcm 6.0 8.1)) +(assert-fail (lcm 6.0 +inf.0)) +(assert-fail (lcm +inf.0 6.0)) +(assert-fail (lcm +nan.0 6.0)) +(assert-fail (lcm 6.0 +nan.0)) + +(assert (= 3 (quotient 13 4))) +(assert (= 3.0 (quotient 13.0 4.0))) +(assert-fail (quotient 13.0 4.1)) +(assert-fail (quotient 13.2 4.0)) +(assert-fail (quotient +inf.0 4.0)) +(assert-fail (quotient +nan.0 4.0)) +(assert-fail (quotient 4.0 +inf.0)) +(assert-fail (quotient 4.0 +nan.0)) + +(assert (= 1 (remainder 13 4))) +(assert (= 1.0 (remainder 13.0 4.0))) +(assert-fail (remainder 13.0 4.1)) +(assert-fail (remainder 13.2 4.0)) +(assert-fail (remainder +inf.0 4.0)) +(assert-fail (remainder +nan.0 4.0)) +(assert-fail (remainder 4.0 +inf.0)) +(assert-fail (remainder 4.0 +nan.0)) + +(assert (= 1 (modulo 13 4))) +(assert (= 1.0 (modulo 13.0 4.0))) +(assert-fail (modulo 13.0 4.1)) +(assert-fail (modulo 13.2 4.0)) +(assert-fail (modulo +inf.0 4.0)) +(assert-fail (modulo +nan.0 4.0)) +(assert-fail (modulo 4.0 +inf.0)) +(assert-fail (modulo 4.0 +nan.0)) ;; number->string conversion -- 1.7.9.1