infnan: separate the nan payload overflow and invalid messages

Also: display the payload, and the number of bits

diff --git a/numeric.c b/numeric.c
index bc5913e..a1e8aea 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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");
         }