From c40229f7564b5006bc4603cf4995b5ee011aa5bf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 21 Nov 2015 10:42:42 -0700 Subject: [PATCH] fix reading of extflonums, including with large exponents Fix even basic readind when extflonums are not supported, but also fix reading extflonums with large exponents (related to the other recent changes to number parsing). --- .../racket-test-core/tests/racket/number.rktl | 11 ++++-- racket/src/racket/src/numstr.c | 36 +++++++++++++------ 2 files changed, 34 insertions(+), 13 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/number.rktl b/pkgs/racket-test-core/tests/racket/number.rktl index ffd6bfb059..00b73fbbf6 100644 --- a/pkgs/racket-test-core/tests/racket/number.rktl +++ b/pkgs/racket-test-core/tests/racket/number.rktl @@ -3,6 +3,8 @@ (Section 'numbers) +(require racket/extflonum) + (test #f number? 'a) (test #f complex? 'a) (test #f real? 'a) @@ -2404,6 +2406,9 @@ (err/rt-test (string->number "1" "1")) (err/rt-test (string->number 1 1)) +(define (string->extfl-number s) + (read (open-input-string s))) + ;; Test inexacts with large exponents (test 0.0 string->number "0e401") (test 0.0 string->number "0e6001") @@ -2415,8 +2420,10 @@ (test -inf.0 string->number "-0.1e6001") (test 0.0 string->number (string-append "0." (make-string 400 #\0) "0e400")) (test 0.0 string->number (string-append "0." (make-string 8000 #\0) "0e8000")) +(test #t extflonum? (string->extfl-number (string-append "0." (make-string 400 #\0) "0t9000"))) (test -0.0 string->number (string-append "-0." (make-string 400 #\0) "0e400")) (test -0.0 string->number (string-append "-0." (make-string 8000 #\0) "0e8000")) +(test #t extflonum? (string->extfl-number (string-append "-0." (make-string 400 #\0) "0t9000"))) (test 0.1 string->number (string-append "0." (make-string 400 #\0) "1e400")) (test 0.1 string->number (string-append "0." (make-string 8000 #\0) "1e8000")) (test 1.0e-101 string->number (string-append "0." (make-string 8000 #\0) "1e7900")) @@ -2424,6 +2431,8 @@ (test -inf.0 string->number (string-append "-0." (make-string 400 #\0) "1e1000")) (test +inf.0 string->number (string-append "0." (make-string 8000 #\0) "1e8400")) (test -inf.0 string->number (string-append "-0." (make-string 8000 #\0) "1e8400")) +(test #t extflonum? (string->extfl-number (string-append "0." (make-string 8000 #\0) "1t8400"))) +(test #t extflonum? (string->extfl-number (string-append "-0." (make-string 8000 #\0) "1t8400"))) (test #f string->number (string-append "-0." (make-string 8000 #\0) "9e10000") 8) (test #f string->number (string-append "0." (make-string 8000 #\0) "e1008") 8) @@ -3190,8 +3199,6 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; exact->inexact precision (thanks to Neil Toronto) -(require racket/extflonum) - (define (check start end exact-> ->exact >=?) (define delta (/ (- end start) 300)) (for/fold ([prev (exact-> start)]) ([i (in-range start (+ end delta) delta)]) diff --git a/racket/src/racket/src/numstr.c b/racket/src/racket/src/numstr.c index 5995af1c65..a3817d101b 100644 --- a/racket/src/racket/src/numstr.c +++ b/racket/src/racket/src/numstr.c @@ -495,13 +495,27 @@ START_XFORM_ARITH; # define STRTOD(x, y, extfl) strtod(x, y) #endif -static Scheme_Object *CHECK_SINGLE(Scheme_Object *v, int s, int long_dbl) +#ifdef MZ_LONG_DOUBLE +# define CHECK_SINGLE(v, s, il, l, str, len, radix) do_CHECK_SINGLE(v, s, il, l, NULL, 0, 0) +#else +# define CHECK_SINGLE(v, s, il, l, str, len, radix) do_CHECK_SINGLE(v, s, il, NULL, str, len, radix) +#endif + +static Scheme_Object *do_CHECK_SINGLE(Scheme_Object *v, int s, int long_dbl, + Scheme_Object *lv, const mzchar *str, intptr_t len, int radix) { if (SCHEME_DBLP(v)) { #ifdef MZ_USE_SINGLE_FLOATS if (s) return scheme_make_float((float)SCHEME_DBL_VAL(v)); #endif + if (long_dbl) { +#ifdef MZ_LONG_DOUBLE + return lv; +#else + return wrap_as_long_double(scheme_utf8_encode_to_buffer(str, len, NULL, 0), radix); +#endif + } } return v; @@ -1456,9 +1470,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, /* Zero mantissa => zero inexact result */ if (!non_zero && result_is_float) { if (dcp && (digits[0] == '-')) - return CHECK_SINGLE(scheme_nzerod, sgl, is_long_double); + return CHECK_SINGLE(scheme_nzerod, sgl, is_long_double, scheme_nzerol, str, len, radix); else - return CHECK_SINGLE(scheme_zerod, sgl, is_long_double); + return CHECK_SINGLE(scheme_zerod, sgl, is_long_double, scheme_zerol, str, len, radix); } /* Reduce unnecessary mantissa-reading work for inexact results. */ @@ -1492,14 +1506,14 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (result_is_float) { if (scheme_bin_gt(exponent, scheme_make_integer(CHECK_INF_EXP_THRESHOLD(is_long_double)))) { if (scheme_is_negative(mantissa)) - return CHECK_SINGLE(scheme_minus_inf_object, sgl, is_long_double); + return CHECK_SINGLE(scheme_minus_inf_object, sgl, is_long_double, scheme_long_minus_inf_object, str, len, radix); else - return CHECK_SINGLE(scheme_inf_object, sgl, is_long_double); + return CHECK_SINGLE(scheme_inf_object, sgl, is_long_double, scheme_long_inf_object, str, len, radix); } else if (scheme_bin_lt(exponent, scheme_make_integer(-CHECK_INF_EXP_THRESHOLD(is_long_double)))) { if (scheme_is_negative(mantissa)) - return CHECK_SINGLE(scheme_nzerod, sgl, is_long_double); + return CHECK_SINGLE(scheme_nzerod, sgl, is_long_double, scheme_nzerol, str, len, radix); else - return CHECK_SINGLE(scheme_zerod, sgl, is_long_double); + return CHECK_SINGLE(scheme_zerod, sgl, is_long_double, scheme_zerol, str, len, radix); } } } @@ -1528,7 +1542,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, n = wrap_as_long_double(scheme_utf8_encode_to_buffer(str, len, NULL, 0), radix); #endif } else { - n = CHECK_SINGLE(TO_DOUBLE(n), sgl, 0); + n = CHECK_SINGLE(TO_DOUBLE(n), sgl, 0, NULL, NULL, 0, 0); } } else { if (is_long_double) { @@ -1538,7 +1552,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, str, len); return scheme_false; } - n = CHECK_SINGLE(n, sgl, 0); + n = CHECK_SINGLE(n, sgl, 0, NULL, NULL, 0, 0); } if (SCHEME_FLOATP(n) && str[delta] == '-') { @@ -1633,7 +1647,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else if (is_float) n1 = TO_DOUBLE(n1); - return CHECK_SINGLE(n1, sgl, 0); + return CHECK_SINGLE(n1, sgl, 0, NULL, NULL, 0, 0); } o = scheme_read_bignum(str, delta, radix); @@ -1651,7 +1665,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, return scheme_nzerod; } - return CHECK_SINGLE(TO_DOUBLE(o), sgl, 0); + return CHECK_SINGLE(TO_DOUBLE(o), sgl, 0, NULL, NULL, 0, 0); } return o;