From 2cf6691439e109d8008f502b0d6aa44e2a599135 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 13 Jan 2017 06:31:33 -0800 Subject: [PATCH] expose `read` capabilities of `string->number` Extend the `string->number` parser for use by readers, which need error messages and/or extflonum results. --- .../scribblings/reference/numbers.scrbl | 45 ++- .../racket-test-core/tests/racket/number.rktl | 2 +- pkgs/racket-test-core/tests/racket/read.rktl | 11 +- racket/src/racket/src/error.c | 25 ++ racket/src/racket/src/numstr.c | 341 +++++++++++------- racket/src/racket/src/schpriv.h | 5 + 6 files changed, 274 insertions(+), 155 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/numbers.scrbl b/pkgs/racket-doc/scribblings/reference/numbers.scrbl index 042abe06a5..2d174bf494 100644 --- a/pkgs/racket-doc/scribblings/reference/numbers.scrbl +++ b/pkgs/racket-doc/scribblings/reference/numbers.scrbl @@ -1007,20 +1007,43 @@ evaluates the entire sequence. @mz-examples[(number->string 3.0) (number->string 255 8)]} -@defproc[(string->number [s string?] [radix (integer-in 2 16) 10]) - (or/c number? #f)]{ +@defproc[(string->number [s string?] + [radix (integer-in 2 16) 10] + [convert-mode (or/c 'number-or-false 'read) 'number-or-false] + [decimal-mode (or/c 'decimal-as-inexact 'decimal-as-exact) + (if (read-decimal-as-inexact) + 'decimal-as-inexact + 'decimal-as-exact)]) + (or/c number? #f string? extflonum?)]{ Reads and returns a number datum from @racket[s] (see -@secref["parse-number"]), returning @racket[#f] if @racket[s] does not -parse exactly as a number datum (with no whitespace). The optional -@racket[radix] argument specifies the default base for the number, -which can be overridden by @litchar{#b}, @litchar{#o}, @litchar{#d}, or -@litchar{#x} in the string. The @racket[read-decimal-as-inexact] -parameter affects @racket[string->number] in the same as way as @racket[read]. +@secref["parse-number"]). The optional @racket[radix] argument +specifies the default base for the number, which can be overridden by +@litchar{#b}, @litchar{#o}, @litchar{#d}, or @litchar{#x} in the +string. + +If @racket[convert-mode] is @racket['number-or-false], the result is +@racket[#f] if @racket[s] does not parse exactly as a number datum +(with no whitespace). If @racket[convert-mode] is @racket['read], the +result can be an @tech{extflonum}, and it can be a string that +contains an error message if @racket[read] of @racket[s] would report +a reader exception (but the result can still be @racket[#f] if +@racket[read] would report a symbol). + +The @racket[decimal-mode] argument controls number parsing the same +way that the @racket[read-decimal-as-inexact] parameter affects +@racket[read]. + +@mz-examples[(string->number "3.0+2.5i") + (string->number "hello") + (string->number "111" 7) + (string->number "#b111" 7) + (string->number "#e+inf.0" 10 'read) + (string->number "10.3" 10 'read 'decimal-as-exact)] + +@history[#:changed "6.8.0.2" @elem{Added the @racket[convert-mode] and + @racket[decimal-mode] arguments.}]} -@mz-examples[(string->number "3.0+2.5i") (string->number "hello") - (string->number "111" 7) (string->number "#b111" 7)] -} @defproc[(real->decimal-string [n real?] [decimal-digits exact-nonnegative-integer? 2]) string?]{ diff --git a/pkgs/racket-test-core/tests/racket/number.rktl b/pkgs/racket-test-core/tests/racket/number.rktl index ff4a0db29e..7e814768be 100644 --- a/pkgs/racket-test-core/tests/racket/number.rktl +++ b/pkgs/racket-test-core/tests/racket/number.rktl @@ -2411,7 +2411,7 @@ (test #f inexact? (string->number "#e4@5")) (test #f inexact? (string->number "#e4.0@5.0")) -(arity-test string->number 1 2) +(arity-test string->number 1 4) (arity-test number->string 1 2) (err/rt-test (number->string 'a)) diff --git a/pkgs/racket-test-core/tests/racket/read.rktl b/pkgs/racket-test-core/tests/racket/read.rktl index 603304ef6a..de3a76accb 100644 --- a/pkgs/racket-test-core/tests/racket/read.rktl +++ b/pkgs/racket-test-core/tests/racket/read.rktl @@ -245,17 +245,20 @@ (cond [(memq v '(X DBZ NOE)) (err/rt-test (readstr s) exn:fail:read?) - (test #f string->number s)] + (test #f string->number s) + (test #t string? (string->number s 10 'read))] [v - (printf "here ~a\n" test) (test v readstr s) - (test (if (symbol? v) #f v) string->number s)] + (test (if (symbol? v) #f v) string->number s) + (test (if (symbol? v) #f v) string->number s 10 'read)] [else (test (string->symbol s) readstr s) (test #f string->number s) + (test #f string->number s 10 'read) (unless (regexp-match "#" s) (err/rt-test (readstr (string-append "#d" s)) exn:fail:read?) - (test #f string->number (string-append "#d" s)))])) + (test #f string->number (string-append "#d" s)) + (test #t string? (string->number (string-append "#d" s) 10 'read)))])) (loop (cdr l)))) (test 5 readstr "#| hi |# 5") diff --git a/racket/src/racket/src/error.c b/racket/src/racket/src/error.c index 3bacf2abe7..2c445ab001 100644 --- a/racket/src/racket/src/error.c +++ b/racket/src/racket/src/error.c @@ -2239,6 +2239,31 @@ void scheme_read_err(Scheme_Object *port, (*suggests ? "\n possible cause: " : ""), suggests); } +Scheme_Object *scheme_numr_err(Scheme_Object *complain, + Scheme_Object *stxsrc, + intptr_t line, intptr_t col, intptr_t pos, intptr_t span, + Scheme_Object *indentation, + const char *detail, ...) +{ + GC_CAN_IGNORE va_list args; + char *s; + intptr_t slen; + + HIDE_FROM_XFORM(va_start(args, detail)); + slen = sch_vsprintf(NULL, 0, detail, args, &s, NULL); + HIDE_FROM_XFORM(va_end(args)); + + if (SCHEME_FALSEP(complain)) + return scheme_make_sized_utf8_string(s, slen); + + scheme_read_err(complain, + stxsrc, + line, col, pos, span, + 0, indentation, + "read: %s", s); + ESCAPED_BEFORE_HERE; +} + static void do_wrong_syntax(const char *where, Scheme_Object *detail_form, Scheme_Object *form, diff --git a/racket/src/racket/src/numstr.c b/racket/src/racket/src/numstr.c index d826368d37..2a7ec81722 100644 --- a/racket/src/racket/src/numstr.c +++ b/racket/src/racket/src/numstr.c @@ -35,6 +35,11 @@ #include #include +static Scheme_Object *decimal_as_inexact_symbol; +static Scheme_Object *decimal_as_exact_symbol; +static Scheme_Object *read_symbol; +static Scheme_Object *number_or_false_symbol; + static Scheme_Object *number_to_string (int argc, Scheme_Object *argv[]); static Scheme_Object *string_to_number (int argc, Scheme_Object *argv[]); @@ -93,6 +98,16 @@ SHARED_OK static Scheme_Object *num_limits[3]; void scheme_init_numstr(Scheme_Env *env) { + REGISTER_SO(decimal_as_inexact_symbol); + REGISTER_SO(decimal_as_exact_symbol); + REGISTER_SO(read_symbol); + REGISTER_SO(number_or_false_symbol); + + decimal_as_inexact_symbol = scheme_intern_symbol("decimal-as-inexact"); + decimal_as_exact_symbol = scheme_intern_symbol("decimal-as-exact"); + read_symbol = scheme_intern_symbol("read"); + number_or_false_symbol = scheme_intern_symbol("number-or-false"); + scheme_add_global_constant("number->string", scheme_make_immed_prim(number_to_string, "number->string", @@ -101,7 +116,7 @@ void scheme_init_numstr(Scheme_Env *env) scheme_add_global_constant("string->number", scheme_make_folding_prim(string_to_number, "string->number", - 1, 2, 1), + 1, 4, 1), env); scheme_add_global_constant("integer-bytes->integer", @@ -505,10 +520,10 @@ static Scheme_Object *do_CHECK_SINGLE(Scheme_Object *v, int s, int long_dbl, #define DISALLOW_EXTFLONUM(special, other) \ if ((special && SCHEME_LONG_DBLP(special)) || (other && SCHEME_LONG_DBLP(other))) { \ if (report) \ - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, \ - "read: cannot combine extflonum into complex number: %u", \ - str, len); \ - return scheme_false; \ + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, \ + "cannot combine extflonum into complex number: %u", \ + str, len); \ + return scheme_false; \ } Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, @@ -542,9 +557,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (str[delta+1] != 'E' && str[delta+1] != 'e' && str[delta+1] != 'I' && str[delta+1] != 'i') { if (radix_set) { if (complain) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: bad radix specification: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "bad radix specification: %u", + str, len); else return scheme_false; } @@ -552,9 +567,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else { if (is_float || is_not_float) { if (complain) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: bad exactness specification: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "bad exactness specification: %u", + str, len); else return scheme_false; } @@ -587,9 +602,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, break; default: if (complain) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: bad `#' indicator `%c': %u", - str[delta+1], str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "bad `#' indicator `%c': %u", + str[delta+1], str, len); return scheme_false; } delta += 2; @@ -602,8 +617,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (!(len - delta)) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: no digits"); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "no digits"); return scheme_false; } @@ -615,9 +630,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (!is_not_float) return special; if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: no exact representation for %V", - special); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "no exact representation for %V", + special); return scheme_false; } } @@ -660,9 +675,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (is_not_float) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: no exact representation for %V", - special); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "no exact representation for %V", + special); return scheme_false; } @@ -673,15 +688,18 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, stxsrc, line, col, pos, span, indentation); + if (SCHEME_CHAR_STRINGP(other)) + return other; + DISALLOW_EXTFLONUM(special, other); if (dbz) { if (div_by_zero) *div_by_zero = 1; if (complain) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: division by zero: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "division by zero: %u", + str, len); return scheme_false; } @@ -700,9 +718,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (is_not_float) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: no exact representation for %V", - special); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "no exact representation for %V", + special); return scheme_false; } @@ -753,13 +771,16 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (s2[i]) other = scheme_false; - else + else { other = scheme_read_number(s2, len - delta - 7, is_float, is_not_float, 1, radix, 1, 0, &dbz, test_only, stxsrc, line, col, pos, span, indentation); + if (SCHEME_CHAR_STRINGP(other)) + return other; + } DISALLOW_EXTFLONUM(special, other); @@ -767,9 +788,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (div_by_zero) *div_by_zero = 1; if (complain) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: division by zero: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "division by zero: %u", + str, len); return scheme_false; } @@ -814,9 +835,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, mzchar ch = str[i]; if (!ch) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: embedded null character: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "embedded null character: %u", + str, len); return scheme_false; } else if (isinexactmark(ch) && ((radix <= 10) || !isbaseNdigit(radix, ch))) { /* If a sign follows, don't count it */ @@ -825,41 +846,41 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else if ((ch == '+') || (ch == '-')) { if ((has_sign > delta) || ((has_sign == delta) && (i == delta+1))) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: too many signs: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "too many signs: %u", + str, len); return scheme_false; } has_sign = i; } else if (((ch == 'I') || (ch == 'i')) && (has_sign >= delta)) { if (has_at) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: cannot mix `@' and `i': %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "cannot mix `@' and `i': %u", + str, len); return scheme_false; } if (i + 1 < len) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: `i' must be at the end: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "`i' must be at the end: %u", + str, len); return scheme_false; } has_i = i; } else if (ch == '@') { if (has_at) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: too many `@'s: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "too many `@'s: %u", + str, len); return scheme_false; } if (i == delta) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: `@' cannot be at start: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "`@' cannot be at start: %u", + str, len); return scheme_false; } has_at = i; @@ -887,14 +908,16 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else second = NULL; - if (first) + if (first) { n1 = scheme_read_number(first, has_sign - delta, is_float, is_not_float, decimal_means_float, radix, 1, next_complain, &fdbz, test_only, stxsrc, line, col, pos, span, indentation); - else + if (SCHEME_CHAR_STRINGP(n1)) + return n1; + } else n1 = zeroi; if (SAME_OBJ(n1, scheme_false) && !fdbz) @@ -906,14 +929,16 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, return scheme_false; } - if (second) + if (second) { n2 = scheme_read_number(second, has_i - has_sign, is_float, is_not_float, decimal_means_float, radix, 1, next_complain, &sdbz, test_only, stxsrc, line, col, pos, span, indentation); - else if (str[has_sign] == '-') + if (SCHEME_CHAR_STRINGP(n2)) + return n2; + } else if (str[has_sign] == '-') n2 = scheme_make_integer(-1); else n2 = scheme_make_integer(1); @@ -933,9 +958,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (div_by_zero) *div_by_zero = 1; if (complain) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: division by zero: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "division by zero: %u", + str, len); return scheme_false; } @@ -980,6 +1005,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, &fdbz, test_only, stxsrc, line, col, pos, span, indentation); + if (SCHEME_CHAR_STRINGP(n2)) + return n2; if (!fdbz) { if (SCHEME_FALSEP(n2)) @@ -1014,6 +1041,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, stxsrc, line, col, pos, span, indentation); + if (SCHEME_CHAR_STRINGP(n1)) + return n1; + /* Special case: magnitude is zero => zero */ if (n1 == zeroi) return zeroi; @@ -1031,9 +1061,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (div_by_zero) *div_by_zero = 1; if (complain) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: division by zero in %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "division by zero in %u", + str, len); return scheme_false; } @@ -1071,17 +1101,17 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (ch == '.') { if (has_decimal) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: multiple decimal points: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "multiple decimal points: %u", + str, len); return scheme_false; } if (has_slash) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: decimal points and fractions " - "cannot be mixed: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "decimal points and fractions " + "cannot be mixed: %u", + str, len); return scheme_false; } has_decimal = 1; @@ -1089,9 +1119,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, && ((radix <= 10) || !isbaseNdigit(radix, ch))) { if (i == delta) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: cannot begin with `%c' in %u", - ch, str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "cannot begin with `%c' in %u", + ch, str, len); return scheme_false; } has_expt = i; @@ -1099,24 +1129,24 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else if (ch == '/') { if (i == delta) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: cannot have slash at start: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "cannot have slash at start: %u", + str, len); return scheme_false; } if (has_slash) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: multiple slashes: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "multiple slashes: %u", + str, len); return scheme_false; } if (has_decimal) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: decimal points and fractions " - "cannot be mixed: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "decimal points and fractions " + "cannot be mixed: %u", + str, len); return scheme_false; } has_slash = i; @@ -1125,17 +1155,17 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else if ((ch == '-') || (ch == '+')) { if (has_slash || has_decimal || has_hash) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: misplaced sign: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "misplaced sign: %u", + str, len); return scheme_false; } } else if (ch == '#') { if (!saw_digit_since_slash) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: misplaced hash: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "misplaced hash: %u", + str, len); return scheme_false; } has_hash = 1; @@ -1143,16 +1173,16 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else if (!isAdigit(ch) && !((radix > 10) && isbaseNdigit(radix, ch))) { if (has_decimal) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: bad decimal number: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "bad decimal number: %u", + str, len); return scheme_false; } if (has_hash) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: misplaced hash: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "misplaced hash: %u", + str, len); return scheme_false; } break; @@ -1162,9 +1192,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, saw_nonzero_digit = 1; if (has_hash_since_slash) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: misplaced hash: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "misplaced hash: %u", + str, len); return scheme_false; } } @@ -1213,9 +1243,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (has_expt && !(str[has_expt + 1])) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: no digits after \"%c\": %u", - str[has_expt], str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "no digits after \"%c\": %u", + str[has_expt], str, len); return scheme_false; } @@ -1252,18 +1282,18 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if ((ptr XFORM_OK_MINUS ffl_buf) < (len - delta)) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: bad decimal number %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "bad decimal number %u", + str, len); return scheme_false; } } if (is_long_double && is_float) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: cannot convert extflonum to inexact: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "cannot convert extflonum to inexact: %u", + str, len); return scheme_false; } @@ -1322,9 +1352,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (!str[has_expt + 1]) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: no digits after \"%c\": %u", - str[has_expt], str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "no digits after \"%c\": %u", + str[has_expt], str, len); return scheme_false; } @@ -1342,9 +1372,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, exponent = scheme_read_bignum(substr, 0, radix); if (SCHEME_FALSEP(exponent)) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: bad exponent: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "bad exponent: %u", + str, len); return scheme_false; } } else @@ -1370,19 +1400,22 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, stxsrc, line, col, pos, span, indentation); + if (SCHEME_CHAR_STRINGP(mantissa)) + return mantissa; + if (SCHEME_FALSEP(mantissa)) { if (dbz) { if (div_by_zero) *div_by_zero = 1; if (complain) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: division by zero: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "division by zero: %u", + str, len); } if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: bad number: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "bad number: %u", + str, len); return scheme_false; } } else { @@ -1434,17 +1467,17 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, || !dcp || (dcp == 1 && !(isAdigit(digits[0]) || ((radix > 10) && isbaseNdigit(radix, digits[0]))))) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: bad decimal number %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "bad decimal number %u", + str, len); return scheme_false; } if (is_long_double && is_float) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: cannot convert extflonum to inexact: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "cannot convert extflonum to inexact: %u", + str, len); return scheme_false; } @@ -1529,9 +1562,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else { if (is_long_double) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: cannot convert extflonum to exact: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "cannot convert extflonum to exact: %u", + str, len); return scheme_false; } n = CHECK_SINGLE(n, sgl, 0, NULL, NULL, 0, 0); @@ -1570,6 +1603,10 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, test_only, stxsrc, line, col, pos, span, indentation); + + if (SCHEME_CHAR_STRINGP(n1)) + return n1; + if (SAME_OBJ(n1, scheme_false)) return scheme_false; @@ -1597,14 +1634,17 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, indentation); } + if (SCHEME_CHAR_STRINGP(n2)) + return n2; + if (SAME_OBJ(n2, scheme_false)) return scheme_false; if (SCHEME_EXACT_REALP(n2) && scheme_is_zero(n2)) { if (complain) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: division by zero: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "division by zero: %u", + str, len); if (div_by_zero) *div_by_zero = 1; return scheme_false; @@ -1621,9 +1661,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (SCHEME_FLOATP(n1)) { if (!scheme_check_double(NULL, SCHEME_FLOAT_VAL(n1), NULL)) { if (complain) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: no exact representation for %V", - n1); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "no exact representation for %V", + n1); return scheme_false; } } @@ -1637,9 +1677,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, o = scheme_read_bignum(str, delta, radix); if (SAME_OBJ(o, scheme_false)) { if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: bad number: %u", - str, len); + return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + "bad number: %u", + str, len); } else if (is_float) { /* Special case: "#i-0" => -0. */ if ((o == zeroi) && str[delta] == '-') { @@ -1722,7 +1762,7 @@ string_to_number (int argc, Scheme_Object *argv[]) intptr_t len; mzchar *mzstr; int decimal_inexact, div_by_zero = 0; - Scheme_Object *v; + Scheme_Object *v, *reader_mode; if (!SCHEME_CHAR_STRINGP(argv[0])) scheme_wrong_contract("string->number", "string?", 0, argc, argv); @@ -1740,19 +1780,42 @@ string_to_number (int argc, Scheme_Object *argv[]) } else radix = 10; - decimal_inexact = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), - MZCONFIG_READ_DECIMAL_INEXACT)); + if (argc > 2) { + if (SAME_OBJ(argv[2], read_symbol)) + reader_mode = scheme_false; /* false in place of port triggers a string return from scheme_read_number() */ + else if (SAME_OBJ(argv[2], number_or_false_symbol)) + reader_mode = NULL; + else { + scheme_wrong_contract("string->number", "(or/c 'read 'number-or-false)", 2, argc, argv); + ESCAPED_BEFORE_HERE; + } + } else + reader_mode = NULL; + + if (argc > 3) { + if (SAME_OBJ(argv[3], decimal_as_inexact_symbol)) + decimal_inexact = 1; + else if (SAME_OBJ(argv[3], decimal_as_exact_symbol)) + decimal_inexact = 0; + else { + scheme_wrong_contract("string->number", "(or/c 'decimal-as-inexact 'decimal-as-exact)", 3, argc, argv); + ESCAPED_BEFORE_HERE; + } + } else { + decimal_inexact = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), + MZCONFIG_READ_DECIMAL_INEXACT)); + } mzstr = SCHEME_CHAR_STR_VAL(argv[0]); len = SCHEME_CHAR_STRTAG_VAL(argv[0]); v = scheme_read_number(mzstr, len, 0, 0, decimal_inexact, - radix, 0, NULL, &div_by_zero, + radix, 0, reader_mode, &div_by_zero, 0, NULL, 0, 0, 0, 0, NULL); - if (SCHEME_LONG_DBLP(v)) + if (!reader_mode && SCHEME_LONG_DBLP(v)) return scheme_false; return v; diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 54db1ee4c3..88425aa9f2 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -4054,6 +4054,11 @@ void scheme_read_err(Scheme_Object *port, intptr_t line, intptr_t column, intptr_t pos, intptr_t span, int is_eof, Scheme_Object *indentation, const char *detail, ...); +Scheme_Object *scheme_numr_err(Scheme_Object *complain, + Scheme_Object *stxsrc, + intptr_t line, intptr_t column, intptr_t pos, intptr_t span, + Scheme_Object *indentation, + const char *detail, ...); char *scheme_extract_indentation_suggestions(Scheme_Object *indentation); void scheme_wrong_syntax(const char *where,