In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/eb254f2672a985ec3c34810f624f36c18fc35fc7?hp=c9a671b17a9c588469bcef958038daaaaf9cc88b>
- Log ----------------------------------------------------------------- commit eb254f2672a985ec3c34810f624f36c18fc35fc7 Author: Jarkko Hietaniemi <[email protected]> Date: Tue Feb 10 19:37:54 2015 -0500 infnan: separate the nan payload overflow and invalid messages Also: display the payload, and the number of bits ----------------------------------------------------------------------- Summary of changes: numeric.c | 49 ++++++++++++++++++++++++++++++++++--------------- pod/perldiag.pod | 28 ++++++++++++++++++++-------- t/op/infnan.t | 6 +++--- 3 files changed, 57 insertions(+), 26 deletions(-) diff --git a/numeric.c b/numeric.c index bc5913e..a1e8aea 100644 --- a/numeric.c +++ b/numeric.c @@ -692,8 +692,6 @@ Perl_nan_is_signaling(NV nv) * precision of 128 bits. */ #define MAX_NV_BYTES (128/8) -static const char invalid_nan_payload[] = "Invalid NaN payload"; - /* =for apidoc nan_payload_set @@ -730,7 +728,7 @@ Perl_nan_payload_set(pTHX_ NV *nvp, const void *bytes, STRLEN byten, bool signal U8 hibit; STRLEN i, nvi; - bool error = FALSE; + bool overflow = FALSE; /* XXX None of this works for doubledouble platforms, or for mixendians. */ @@ -749,7 +747,7 @@ Perl_nan_payload_set(pTHX_ NV *nvp, const void *bytes, STRLEN byten, bool signal if (byten > MAX_NV_BYTES) { byten = MAX_NV_BYTES; - error = TRUE; + overflow = TRUE; } for (i = 0; bits > 0; i++) { U8 b = i < byten ? ((U8*) bytes)[i] : 0; @@ -774,9 +772,9 @@ Perl_nan_payload_set(pTHX_ NV *nvp, const void *bytes, STRLEN byten, bool signal } else { *hibyte &= ~mask; } - if (error) { + if (overflow) { Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), - invalid_nan_payload); + "NaN payload overflowed %d bits", NV_NAN_BITS); } nan_signaling_set(nvp, signaling); } @@ -798,7 +796,9 @@ Perl_grok_nan_payload(pTHX_ const char* s, const char* send, bool signaling, int U8 bytes[MAX_NV_BYTES]; STRLEN byten = 0; const char *t = send - 1; /* minus one for ')' */ - bool error = FALSE; + bool overflow = FALSE; + bool bogus = FALSE; + const char *orig = s; PERL_ARGS_ASSERT_GROK_NAN_PAYLOAD; @@ -810,6 +810,8 @@ Perl_grok_nan_payload(pTHX_ const char* s, const char* send, bool signaling, int if (*t != ')') { U8 bytes[1] = { 0 }; nan_payload_set(nvp, bytes, 1, signaling); + Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), + "NaN payload \"%s\" invalid", orig); return t; } @@ -864,7 +866,7 @@ Perl_grok_nan_payload(pTHX_ const char* s, const char* send, bool signaling, int STRLEN i; if ((n > MAX_NV_BYTES - byten) || (n * 8 > NV_MANT_REAL_DIG)) { - error = TRUE; + overflow = TRUE; break; } /* Copy the bytes in reverse so that \x41\x42 ('AB') @@ -875,7 +877,7 @@ Perl_grok_nan_payload(pTHX_ const char* s, const char* send, bool signaling, int } byten += n; break; - } else if (s < t && isDIGIT(*s)) { + } else if (s < t && (isDIGIT(*s) || *s == '-' || *s == '+')) { const char *u; nantype = grok_number_flags(s, (STRLEN)(t - s), &uv, @@ -885,40 +887,57 @@ Perl_grok_nan_payload(pTHX_ const char* s, const char* send, bool signaling, int * tell how far we got and the ')' will always * be "trailing", so we need to double-check * whether we had something dubious. */ - for (u = s; u < send - 1; u++) { + u = s; + if ((*u == '-' || *u == '+')) { + u++; + } + for (; u < t; u++) { if (!isDIGIT(*u)) { *flags |= IS_NUMBER_TRAILING; break; } } + if ((nantype & IS_NUMBER_NEG)) { + uv = (UV) (-uv); + } s = u; } else { - error = TRUE; + bogus = TRUE; break; } /* XXX Doesn't do octal: nan("0123"). * Probably not a big loss. */ if (!(nantype & IS_NUMBER_IN_UV)) { - error = TRUE; + overflow = TRUE; break; } if (uv) { - while (uv && byten < MAX_NV_BYTES) { + int bits = NV_NAN_BITS; + while (uv && byten < MAX_NV_BYTES && bits > 0) { bytes[byten++] = (U8) (uv & 0xFF); uv >>= 8; + bits -= 8; } } + if (uv) { + overflow = TRUE; + } } if (byten == 0) { bytes[byten++] = 0; } - if (error) { + if (overflow) { Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), - invalid_nan_payload); + "NaN payload \"%s\" overflowed %d bits", + orig, NV_NAN_BITS); + } + if (bogus) { + Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), + "NaN payload \"%s\" invalid", orig); } if (s == send) { diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 54c4d85..c331a24 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -2790,14 +2790,6 @@ where C<foo> is not a valid method resolution order (MRO). Currently, the only valid ones supported are C<dfs> and C<c3>, unless you have loaded a module that is a MRO plugin. See L<mro> and L<perlmroapi>. -=item Invalid NaN payload - -(W overflow) C<Nan> (not-a-number) floating point values can carry -payload information in addition to just being NaN. The amount of -information is limited, and dependent on the platform. -Either the payload overflowed, or simply could not be parsed. -See L<perldata/Special floating point>. - =item Invalid negative number (%s) in chr (W utf8) You passed a negative number to C<chr>. Negative numbers are @@ -3539,6 +3531,26 @@ but also uses any of the others it will not trigger this warning. Symbols beginning with an underscore and symbols using special identifiers (q.v. L<perldata>) are exempt from this warning. +=item NaN payload overflowed %d bits + +(W overflow) C<Nan> (not-a-number) floating point values can carry +payload information in addition to just being NaN. The amount of +information is limited, and dependent on the platform. +See L<perldata/Special floating point>. + +=item NaN payload "%s" overflowed %d bits + +(W overflow) C<Nan> (not-a-number) floating point values can carry +payload information in addition to just being NaN. The amount of +information is limited, and dependent on the platform. +See L<perldata/Special floating point>. + +=item NaN payload "%s" invalid + +(W digit) C<Nan> (not-a-number) floating point values can carry +payload information in addition to just being NaN. The payload +could not be parsed. See L<perldata/Special floating point>. + =item Need exactly 3 octal digits in regex; marked by S<<-- HERE> in m/%s/ (F) Within S<C<(?[ ])>>, all constants interpreted as octal need to be diff --git a/t/op/infnan.t b/t/op/infnan.t index 4670398..1b78701 100644 --- a/t/op/infnan.t +++ b/t/op/infnan.t @@ -516,7 +516,7 @@ cmp_ok('-1e-9999', '==', 0, "underflow to 0 (runtime) from neg"); [ " nan", 0, $NaN ], [ "nan ", 0, $NaN ], [ " nan ", 0, $NaN ], - [ " nan(123) ", 1, $NaN ], + [ " nan(123) ", 0, $NaN ], ]; for my $t (@$T) { @@ -527,7 +527,7 @@ cmp_ok('-1e-9999', '==', 0, "underflow to 0 (runtime) from neg"); is("$a", "$t->[2]", "$t->[0] plus one is $t->[2]"); if ($t->[1]) { like($w, qr/^Argument \Q"$t->[0]"\E isn't numeric/, - "$t->[2] numify warn"); + "'$t->[2]' numify warn"); } else { is($w, "", "no warning expected"); } @@ -539,7 +539,7 @@ cmp_ok('-1e-9999', '==', 0, "underflow to 0 (runtime) from neg"); is("$b", "$t->[2]", "$n plus one is $t->[2]"); if ($t->[1]) { like($w, qr/^Argument \Q"$n"\E isn't numeric/, - "$n numify warn"); + "'$n' numify warn"); } else { is($w, "", "no warning expected"); } -- Perl5 Master Repository
