~ chicken-core (chicken-5) fa911bd5828863a81075dc3527602af1d41c6b11
commit fa911bd5828863a81075dc3527602af1d41c6b11
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Sat Apr 7 15:07:46 2012 +0200
Commit: Jim Ursetto <zbigniewsz@gmail.com>
CommitDate: Mon Apr 23 23:05:58 2012 -0500
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).
Signed-off-by: Jim Ursetto <zbigniewsz@gmail.com>
diff --git a/runtime.c b/runtime.c
index 9db1a4b5..8e96255c 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 a7c17e51..542eed6f 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -74,6 +74,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
Trap