X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=numeric.c;h=f12e9ba2d3c7353c0516063fef8b8f83ad62c034;hb=0af80b6034aad516a126a9414dadccac4de7f9dc;hp=00d58bc4d6ecf51d7406216b3a3a8aeefab66472;hpb=51bd16da02fd2d9228605a3672c5bc91eaddf57b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/numeric.c b/numeric.c index 00d58bc..f12e9ba 100644 --- a/numeric.c +++ b/numeric.c @@ -350,7 +350,7 @@ Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) Recognise (or not) a number. The type of the number is returned (0 if unrecognised), otherwise it is a bit-ORed combination of IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT, -IS_NUMBER_NEG, IS_NUMBER_INFINITY (defined in perl.h). +IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h). If the value of the number can fit an in UV, it is returned in the *valuep IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV @@ -376,6 +376,7 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; + int sawnan = 0; while (s < send && isSPACE(*s)) s++; @@ -401,49 +402,49 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) With it gcc on arm is managing 6 instructions (6 cycles) per digit. In theory the optimiser could deduce how far to unroll the loop before checking for overflow. */ - if (s < send) { - int digit = *++s - '0'; + if (++s < send) { + int digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; - if (s < send) { - digit = *++s - '0'; + if (++s < send) { + digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; - if (s < send) { - digit = *++s - '0'; + if (++s < send) { + digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; - if (s < send) { - digit = *++s - '0'; + if (++s < send) { + digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; - if (s < send) { - digit = *++s - '0'; + if (++s < send) { + digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; - if (s < send) { - digit = *++s - '0'; + if (++s < send) { + digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; - if (s < send) { - digit = *++s - '0'; + if (++s < send) { + digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; - if (s < send) { - digit = *++s - '0'; + if (++s < send) { + digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; - if (s < send) { + if (++s < send) { /* Now got 9 digits, so need to check each time for overflow. */ - digit = *++s - '0'; + digit = *s - '0'; while (digit >= 0 && digit <= 9 && (value < max_div_10 || (value == max_div_10 && digit <= max_mod_10))) { value = value * 10 + digit; - if (s < send) - digit = *++s - '0'; + if (++s < send) + digit = *s - '0'; else break; } @@ -512,12 +513,21 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) s++; } sawinf = 1; - } else /* Add test for NaN here. */ + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else return 0; if (sawinf) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { @@ -539,7 +549,7 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) while (s < send && isSPACE(*s)) s++; if (s >= send) - return numtype; + return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; @@ -562,7 +572,19 @@ S_mulexp10(NV value, I32 exponent) negative = 1; exponent = -exponent; } -#ifdef __VAX /* avoid %SYSTEM-F-FLTOVF_F sans VAXC$ESTABLISH */ + + /* Avoid %SYSTEM-F-FLTOVF_F sans VAXC$ESTABLISH. + * In VAX VMS we by default use the D_FLOAT double format, + * and that format does not have *easy* capabilities [1] for + * overflowing doubles 'silently' as IEEE fp does. Therefore we + * need to detect early whether we would overflow (this is + * the behaviour of the native string-to-float conversion routines, + * and therefore the behaviour of native applications, too.) + * + * [1] VAXC$EXTABLISH is the capability but it is basically a signal + * handler setup routine, and one cannot return from a fp exception + * handler and except much anything useful. */ +#if defined(VMS) && !defined(__IEEE_FP) # if defined(__DECC_VER) && __DECC_VER <= 50390006 /* __F_FLT_MAX_10_EXP - 5 == 33 */ if (!negative && @@ -570,11 +592,26 @@ S_mulexp10(NV value, I32 exponent) return NV_MAX; # endif #endif + + /* In UNICOS and in certain Cray models (such as T90) there is no + * IEEE fp, and no way at all from C to catch fp overflows gracefully. + * There is something you can do if you are willing to use some + * inline assembler: the instruction is called DFI-- but that will + * disable *all* floating point interrupts, a little bit too large + * a hammer. Therefore we need to catch potential overflows before + * it's too late. */ +#if defined(_UNICOS) && defined(NV_MAX_10_EXP) + if (!negative && + (log10(value) + exponent) >= NV_MAX_10_EXP) + return NV_MAX; +#endif + for (bit = 1; exponent; bit <<= 1) { if (exponent & bit) { exponent ^= bit; result *= power; } + /* Floating point exceptions are supposed to be turned off. */ power *= power; } return negative ? value / result : value * result; @@ -629,6 +666,10 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) I32 ipart = 0; /* index into part[] */ I32 offcount; /* number of digits in least significant part */ + /* leading whitespace */ + while (isSPACE(*s)) + ++s; + /* sign */ switch (*s) { case '-':