~ chicken-core (chicken-5) e6671cd00ead26bb01d39930ea557124f439f042
commit e6671cd00ead26bb01d39930ea557124f439f042
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Fri Mar 23 23:06:17 2012 +0100
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Sat Mar 24 19:17:19 2012 +0100
Add number syntax tests from John Cowan and fix these cases.
Furthermore, string->number shouldn't raise errors but return #f if
given a number we can't represent. Finally, fix C_i_finitep for nan
values and add entries for it to the library tests (without this the
numbers test won't succeed)
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/chicken.h b/chicken.h
index cd73152a..8b1d7519 100644
--- a/chicken.h
+++ b/chicken.h
@@ -2224,8 +2224,13 @@ C_inline C_word C_i_flonump(C_word x)
C_inline C_word C_i_finitep(C_word x)
{
+ double val;
+
if((x & C_FIXNUM_BIT) != 0) return C_SCHEME_TRUE;
- else return C_mk_bool(!C_isinf(C_flonum_magnitude(x)));
+
+ val = C_flonum_magnitude(x);
+ if(C_isnan(val) || C_isinf(val)) return C_SCHEME_FALSE;
+ else return C_SCHEME_TRUE;
}
diff --git a/library.scm b/library.scm
index cc84da10..c85c98a2 100644
--- a/library.scm
+++ b/library.scm
@@ -1083,7 +1083,10 @@ EOF
(let ((num (##core#inline_allocate ("C_a_i_string_to_number" 4) str radix)))
(case exactness
((i) (##core#inline_allocate ("C_a_i_exact_to_inexact" 4) num))
- ((e) (##core#inline "C_i_inexact_to_exact" num))
+ ;; If inf/nan, don't error but just return #f
+ ((e) (and num
+ (##core#inline "C_i_finitep" num)
+ (##core#inline "C_i_inexact_to_exact" num)))
(else num))))
(define string->number ##sys#string->number)
diff --git a/runtime.c b/runtime.c
index ef8cf8e7..9db1a4b5 100644
--- a/runtime.c
+++ b/runtime.c
@@ -475,6 +475,7 @@ static C_word C_fcall hash_string(int len, C_char *str, C_word m, C_word r, int
static C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
static double compute_symbol_table_load(double *avg_bucket_len, int *total);
static C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo) C_regparm;
+static C_word C_fcall maybe_inexact_to_exact(C_word n) C_regparm;
static void C_fcall remark_system_globals(void) C_regparm;
static void C_fcall really_remark(C_word *x) C_regparm;
static C_word C_fcall intern0(C_char *name) C_regparm;
@@ -4966,22 +4967,30 @@ C_regparm C_word C_fcall C_u_i_length(C_word lst)
return C_fix(n);
}
-
-C_regparm C_word C_fcall C_i_inexact_to_exact(C_word n)
+C_regparm C_word maybe_inexact_to_exact(C_word n)
{
double m;
C_word r;
-
- if(n & C_FIXNUM_BIT) return n;
- else if(C_immediatep(n) || C_block_header(n) != C_FLONUM_TAG)
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "inexact->exact", n);
-
+
if(modf(C_flonum_magnitude(n), &m) == 0.0) {
r = (C_word)m;
if(r == m && C_fitsinfixnump(r))
return C_fix(r);
}
+ return C_SCHEME_FALSE;
+}
+
+C_regparm C_word C_fcall C_i_inexact_to_exact(C_word n)
+{
+ C_word r;
+
+ if(n & C_FIXNUM_BIT) return n;
+ else if(C_immediatep(n) || C_block_header(n) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "inexact->exact", n);
+
+ r = maybe_inexact_to_exact(n);
+ if (r != C_SCHEME_FALSE) return r;
barf(C_CANT_REPRESENT_INEXACT_ERROR, "inexact->exact", n);
return 0;
@@ -7336,7 +7345,7 @@ C_a_i_string_to_number(C_word **a, int c, C_word str, C_word radix0)
if(sharpf || ratf || (exactpf && !exactf)) {
n = C_flonum(a, ratf ? fn1 / (double)n : (double)n);
- if(exactpf && exactf) n = C_i_inexact_to_exact(n);
+ if(exactpf && exactf) n = maybe_inexact_to_exact(n);
}
else n = C_fix(n);
@@ -7345,7 +7354,7 @@ C_a_i_string_to_number(C_word **a, int c, C_word str, C_word radix0)
case 2: /* flonum */
n = C_flonum(a, ratf ? fn1 / fn : fn);
- if(exactpf && exactf) n = C_i_inexact_to_exact(n);
+ if(exactpf && exactf) n = maybe_inexact_to_exact(n);
break;
}
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index 6e9fdad8..f133f3fe 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -19,18 +19,23 @@
(assert (zero? (round 0.3)))
(assert (= 1.0 (round 0.6)))
(assert (rational? 1))
+(assert (finite? 1))
(assert (rational? 1.0))
-(assert (not (rational? +inf.)))
-(assert (not (rational? -inf.)))
-(assert (not (rational? +nan)))
+(assert (finite? 1.0))
+(assert (not (rational? +inf.0)))
+(assert (not (finite? +inf.0)))
+(assert (not (rational? -inf.0)))
+(assert (not (finite? -inf.0)))
+(assert (not (rational? +nan.0)))
+(assert (not (finite? +nan.0)))
(assert (not (rational? 'foo)))
(assert (not (rational? "foo")))
(assert (integer? 2))
(assert (integer? 2.0))
(assert (not (integer? 1.1)))
-(assert (not (integer? +inf.)))
-(assert (not (integer? -inf.)))
-(assert (not (integer? +nan)))
+(assert (not (integer? +inf.0)))
+(assert (not (integer? -inf.0)))
+(assert (not (integer? +nan.0)))
(assert (not (integer? 'foo)))
(assert (not (integer? "foo")))
; XXX number missing
diff --git a/tests/numbers-string-conversion-tests.scm b/tests/numbers-string-conversion-tests.scm
index 815798d8..09d8ee8f 100644
--- a/tests/numbers-string-conversion-tests.scm
+++ b/tests/numbers-string-conversion-tests.scm
@@ -185,6 +185,13 @@
("-inf.1" #f)
("+inf.0/1" #f)
("1/+inf.0" #f)
+ ;; Thanks to John Cowan for these
+ ("#e+nan.0" #f)
+ ("#e+inf.0" #f)
+ ("#e-inf.0" #f)
+ ("#i+nan.0" the-nan "+nan.0" "+NaN.0")
+ ("#i+inf.0" pos-inf "+inf.0" "+Inf.0")
+ ("#i-inf.0" neg-inf "-inf.0" "-Inf.0")
#|
;; DEPRECATED (Disabled during deprecation period of "[+-]nan", "[+-]inf")
("+nan" #f)
@@ -196,22 +203,37 @@
"Fractions"
("1/2" (/ 1 2) "0.5" ".5" "500.0e-3")
+ ("#e1/2" #f)
("10/2" 5.0 "5.0" "5.")
+ ("#i10/2" 5.0 "5.0" "5.")
("-1/2" (- (/ 1 2)) "-0.5" "-.5" "-500.0e-3")
("1/-2" #f)
+ ("10/0" +inf.0 "+inf.0")
+ ("0/10" 0.0 "0.0")
+ ("#e0/10" 0 "0")
+ ("#e1#/2" 5 "5")
+ ("#e1/2#" #f)
("1.0/2" #f)
("1/2.0" #f)
("1/2e2" #f)
("1/2e2" #f)
("1#/2" 5.0 7.5 "5.0" "5." "7.5")
("1/2#" 0.05 "0.05" ".05" "50.0e-3" "5.e-002")
+ ("#i3/2" (/ 3.0 2.0) "1.5")
("1#/#" #f)
("1/" #f)
("1/+" #f)
("+/1" #f)
("/1" #f)
("/" #f)
-
+ ("#i1/0" pos-inf "+inf.0" "+Inf.0")
+ ("#i-1/0" neg-inf "-inf.0" "-Inf.0")
+ ("#i0/0" the-nan "+nan.0" "+NaN.0")
+ ;; This _could_ be valid (but isn't as pretty)
+ ;("#i1/0" #f)
+ ;("#i-1/0" #f)
+ ;("#i0/0" #f)
+
"Some invalid complex numbers syntax (not supported at all)"
("2i" #f)
("+-i" #f)
Trap