infnan: grok_number* setting the infnan NV directly

diff --git a/embed.fnc b/embed.fnc
index 7f8b9d4..f3deba1 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -813,11 +813,12 @@ EMsPR     |char*|form_short_octal_warning|NN const char * const s  \
                                |const STRLEN len
 #endif
 Apd    |UV     |grok_hex       |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result
-Apd    |int    |grok_infnan    |NN const char** sp|NN const char *send
+Apd    |int    |grok_infnan    |NN const char** sp|NN const char *send|NULLOK NV *nvp
 Apd    |const char *|grok_nan  |NN const char* s|NN const char *send|NN int *flags|NULLOK NV *nvp
 Apd    |const char *|grok_nan_payload|NN const char* s|NN const char *send|bool signaling|NN int *flags|NULLOK NV *nvp
 Apd    |int    |grok_number    |NN const char *pv|STRLEN len|NULLOK UV *valuep
 Apd    |int    |grok_number_flags|NN const char *pv|STRLEN len|NULLOK UV *valuep|U32 flags
+Apd    |int    |grok_number2_flags|NN const char *pv|STRLEN len|NULLOK UV *valuep|NULLOK NV* nvp|U32 flags
 ApdR   |bool   |grok_numeric_radix|NN const char **sp|NN const char *send
 Apd    |UV     |grok_oct       |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result
 Apdn   |UV     |grok_atou      |NN const char* pv|NULLOK const char** endptr

diff --git a/embed.h b/embed.h
index 5f289fc..0475243 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -182,10 +182,11 @@
 #define grok_atou              Perl_grok_atou
 #define grok_bin(a,b,c,d)      Perl_grok_bin(aTHX_ a,b,c,d)
 #define grok_hex(a,b,c,d)      Perl_grok_hex(aTHX_ a,b,c,d)
-#define grok_infnan(a,b)       Perl_grok_infnan(aTHX_ a,b)
+#define grok_infnan(a,b,c)     Perl_grok_infnan(aTHX_ a,b,c)
 #define grok_nan(a,b,c,d)      Perl_grok_nan(aTHX_ a,b,c,d)
 #define grok_nan_payload(a,b,c,d,e)    Perl_grok_nan_payload(aTHX_ a,b,c,d,e)
 #define grok_number(a,b,c)     Perl_grok_number(aTHX_ a,b,c)
+#define grok_number2_flags(a,b,c,d,e)  Perl_grok_number2_flags(aTHX_ a,b,c,d,e)
 #define grok_number_flags(a,b,c,d)     Perl_grok_number_flags(aTHX_ a,b,c,d)
 #define grok_numeric_radix(a,b)        Perl_grok_numeric_radix(aTHX_ a,b)
 #define grok_oct(a,b,c,d)      Perl_grok_oct(aTHX_ a,b,c,d)

diff --git a/numeric.c b/numeric.c
index 876c67d..bf92e32 100644 (file)
--- a/numeric.c
+++ b/numeric.c
@@ -999,7 +999,7 @@ zero is returned, and the *sp will not move.
 */
 
 int
-Perl_grok_infnan(pTHX_ const char** sp, const char* send)
+Perl_grok_infnan(pTHX_ const char** sp, const char* send, NV* nvp)
 {
     const char* s = *sp;
     int flags = 0;
@@ -1007,6 +1007,12 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send)
 
     PERL_ARGS_ASSERT_GROK_INFNAN;
 
+    /* XXX there are further legacy formats like HP-UX "++" for Inf
+     * and "--" for -Inf.  While we might be able to grok those in
+     * string numification, having those in source code might open
+     * up too much golfing: ++++;
+     */
+
     if (*s == '+') {
         s++; if (s == send) return 0;
     }
@@ -1055,10 +1061,16 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send)
                 flags |= IS_NUMBER_TRAILING;
             }
             flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
+            if (nvp) {
+                *nvp = (flags & IS_NUMBER_NEG) ? -NV_INF: NV_INF;
+            }
         }
         else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */
             s++;
             flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
+            if (nvp) {
+                *nvp = NV_NAN;
+            }
             while (*s == '0') { /* 1.#IND00 */
                 s++;
             }
@@ -1070,158 +1082,9 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send)
     }
     else {
         /* Maybe NAN of some sort */
-
-        if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) {
-            /* snan, qNaN */
-            /* XXX do something with the snan/qnan difference */
-            s++; if (s == send) return 0;
-        }
-
-        if (isALPHA_FOLD_EQ(*s, 'N')) {
-            s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return 0;
-            s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
-            s++;
-
-            flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
-
-            /* NaN can be followed by various stuff (NaNQ, NaNS), but
-             * there are also multiple different NaN values, and some
-             * implementations output the "payload" values,
-             * e.g. NaN123, NAN(abc), while some legacy implementations
-             * have weird stuff like NaN%. */
-            if (isALPHA_FOLD_EQ(*s, 'q') ||
-                isALPHA_FOLD_EQ(*s, 's')) {
-                /* "nanq" or "nans" are ok, though generating
-                 * these portably is tricky. */
-                s++;
-            }
-            if (*s == '(') {
-                /* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */
-                const char *t;
-                s++;
-                if (s == send) {
-                    return flags | IS_NUMBER_TRAILING;
-                }
-                t = s + 1;
-                while (t < send && *t && *t != ')') {
-                    t++;
-                }
-                if (t == send) {
-                    return flags | IS_NUMBER_TRAILING;
-                }
-                if (*t == ')') {
-                    int nantype;
-                    UV nanval;
-                    if (s[0] == '0' && s + 2 < t &&
-                        isALPHA_FOLD_EQ(s[1], 'x') &&
-                        isXDIGIT(s[2])) {
-                        STRLEN len = t - s;
-                        I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
-                        nanval = grok_hex(s, &len, &flags, NULL);
-                        if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
-                            nantype = 0;
-                        } else {
-                            nantype = IS_NUMBER_IN_UV;
-                        }
-                        s += len;
-                    } else if (s[0] == '0' && s + 2 < t &&
-                               isALPHA_FOLD_EQ(s[1], 'b') &&
-                               (s[2] == '0' || s[2] == '1')) {
-                        STRLEN len = t - s;
-                        I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
-                        nanval = grok_bin(s, &len, &flags, NULL);
-                        if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) {
-                            nantype = 0;
-                        } else {
-                            nantype = IS_NUMBER_IN_UV;
-                        }
-                        s += len;
-                    } else {
-                        const char *u;
-                        nantype =
-                            grok_number_flags(s, t - s, &nanval,
-                                              PERL_SCAN_TRAILING |
-                                              PERL_SCAN_ALLOW_UNDERSCORES);
-                        /* Unfortunately grok_number_flags() doesn't
-                         * 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 < t; u++) {
-                            if (!isDIGIT(*u)) {
-                                flags |= IS_NUMBER_TRAILING;
-                                break;
-                            }
-                        }
-                        s = u;
-                    }
-
-                    /* XXX Doesn't do octal: nan("0123").
-                     * Probably not a big loss. */
-
-                    if ((nantype & IS_NUMBER_NOT_INT) ||
-                        !(nantype && IS_NUMBER_IN_UV)) {
-                        /* XXX the nanval is currently unused, that is,
-                         * not inserted as the NaN payload of the NV.
-                         * But the above code already parses the C99
-                         * nan(...)  format.  See below, and see also
-                         * the nan() in POSIX.xs.
-                         *
-                         * Certain configuration combinations where
-                         * NVSIZE is greater than UVSIZE mean that
-                         * a single UV cannot contain all the possible
-                         * NaN payload bits.  There would need to be
-                         * some more generic syntax than "nan($uv)".
-                         *
-                         * Issues to keep in mind:
-                         *
-                         * (1) In most common cases there would
-                         * not be an integral number of bytes that
-                         * could be set, only a certain number of bits.
-                         * For example for the common case of
-                         * NVSIZE == UVSIZE == 8 there is room for 52
-                         * bits in the payload, but the most significant
-                         * bit is commonly reserved for the
-                         * signaling/quiet bit, leaving 51 bits.
-                         * Furthermore, the C99 nan() is supposed
-                         * to generate quiet NaNs, so it is doubtful
-                         * whether it should be able to generate
-                         * signaling NaNs.  For the x86 80-bit doubles
-                         * (if building a long double Perl) there would
-                         * be 62 bits (s/q bit being the 63rd).
-                         *
-                         * (2) Endianness of the payload bits. If the
-                         * payload is specified as an UV, the low-order
-                         * bits of the UV are naturally little-endianed
-                         * (rightmost) bits of the payload.  The endianness
-                         * of UVs and NVs can be different. */
-                        return 0;
-                    }
-                    if (s < t) {
-                        flags |= IS_NUMBER_TRAILING;
-                    }
-                } else {
-                    /* Looked like nan(...), but no close paren. */
-                    flags |= IS_NUMBER_TRAILING;
-                }
-            } else {
-                while (s < send && isSPACE(*s))
-                    s++;
-                if (s < send && *s) {
-                    /* Note that we here implicitly accept (parse as
-                     * "nan", but with warnings) also any other weird
-                     * trailing stuff for "nan".  In the above we just
-                     * check that if we got the C99-style "nan(...)",
-                     * the "..."  looks sane.
-                     * If in future we accept more ways of specifying
-                     * the nan payload, the accepting would happen around
-                     * here. */
-                    flags |= IS_NUMBER_TRAILING;
-                }
-            }
-            s = send;
-        }
-        else
-            return 0;
+        const char *n = grok_nan(s, send, &flags, nvp);
+        if (n == NULL) return 0;
+        s = n;
     }
 
     while (s < send && isSPACE(*s))
@@ -1232,7 +1095,7 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send)
 }
 
 /*
-=for apidoc grok_number_flags
+=for apidoc grok_number2_flags
 
 Recognise (or not) a number.  The type of the number is returned
 (0 if unrecognised), otherwise it is a bit-ORed combination of
@@ -1246,6 +1109,9 @@ to during processing even though IS_NUMBER_IN_UV is not set on return.
 If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
 valuep is non-NULL, but no actual assignment (or SEGV) will occur.
 
+The nvp is used to directly set the value for infinities (Inf) and
+not-a-numbers (NaN).
+
 IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
 seen (in which case *valuep gives the true value truncated to an integer), and
 IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
@@ -1256,6 +1122,10 @@ C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing
 non-numeric text on an otherwise successful I<grok>, setting
 C<IS_NUMBER_TRAILING> on the result.
 
+=for apidoc grok_number_flags
+
+Identical to grok_number2_flags() with nvp and flags set to zero.
+
 =for apidoc grok_number
 
 Identical to grok_number_flags() with flags set to zero.
@@ -1270,18 +1140,26 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
     return grok_number_flags(pv, len, valuep, 0);
 }
 
+int
+Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
+{
+    PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS;
+
+    return grok_number2_flags(pv, len, valuep, NULL, flags);
+}
+
 static const UV uv_max_div_10 = UV_MAX / 10;
 static const U8 uv_max_mod_10 = UV_MAX % 10;
 
 int
-Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
+Perl_grok_number2_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, NV *nvp, U32 flags)
 {
   const char *s = pv;
   const char * const send = pv + len;
   const char *d;
   int numtype = 0;
 
-  PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS;
+  PERL_ARGS_ASSERT_GROK_NUMBER2_FLAGS;
 
   while (s < send && isSPACE(*s))
     s++;
@@ -1447,11 +1325,18 @@ Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
   if ((s + 2 < send) && strchr("inqs#", toFOLD(*s))) {
       /* Really detect inf/nan. Start at d, not s, since the above
        * code might have already consumed the "1." or "1". */
-      int infnan = Perl_grok_infnan(aTHX_ &d, send);
+      NV nanv;
+      int infnan = Perl_grok_infnan(aTHX_ &d, send, &nanv);
       if ((infnan & IS_NUMBER_INFINITY)) {
+          if (nvp) {
+              *nvp = (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF;
+          }
           return (numtype | infnan); /* Keep sign for infinity. */
       }
       else if ((infnan & IS_NUMBER_NAN)) {
+          if (nvp) {
+              *nvp = nanv;
+          }
           return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */
       }
   }
@@ -1699,18 +1584,18 @@ S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value
 {
     const char *p0 = negative ? s - 1 : s;
     const char *p = p0;
-    int infnan = grok_infnan(&p, send);
+    int infnan = grok_infnan(&p, send, value);
     if (infnan && p != p0) {
         /* If we can generate inf/nan directly, let's do so. */
 #ifdef NV_INF
         if ((infnan & IS_NUMBER_INFINITY)) {
-            *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF;
+            /* grok_infnan() already set the value. */
             return (char*)p;
         }
 #endif
 #ifdef NV_NAN
         if ((infnan & IS_NUMBER_NAN)) {
-            *value = NV_NAN;
+            /* grok_infnan() already set the value. */
             return (char*)p;
         }
 #endif
@@ -2012,7 +1897,7 @@ Perl_isinfnansv(pTHX_ SV *sv)
     {
         STRLEN len;
         const char *s = SvPV_nomg_const(sv, len);
-        return cBOOL(grok_infnan(&s, s+len));
+        return cBOOL(grok_infnan(&s, s+len, NULL));
     }
 }
 

diff --git a/proto.h b/proto.h
index c93ac80..62585a4 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1359,7 +1359,7 @@ PERL_CALLCONV UV  Perl_grok_hex(pTHX_ const char* start, STRLEN* len_p, I32* flag
 #define PERL_ARGS_ASSERT_GROK_HEX      \
        assert(start); assert(len_p); assert(flags)
 
-PERL_CALLCONV int      Perl_grok_infnan(pTHX_ const char** sp, const char *send)
+PERL_CALLCONV int      Perl_grok_infnan(pTHX_ const char** sp, const char *send, NV *nvp)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
 #define PERL_ARGS_ASSERT_GROK_INFNAN   \
@@ -1384,6 +1384,11 @@ PERL_CALLCONV int        Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
 #define PERL_ARGS_ASSERT_GROK_NUMBER   \
        assert(pv)
 
+PERL_CALLCONV int      Perl_grok_number2_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, NV* nvp, U32 flags)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GROK_NUMBER2_FLAGS    \
+       assert(pv)
+
 PERL_CALLCONV int      Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS     \

diff --git a/sv.c b/sv.c
index 602d9dc..d430049 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2112,7 +2112,7 @@ S_sv_2iuv_non_preserve(pTHX_ SV *const sv
 #  pragma warning(disable:4756;disable:4056)
 #endif
 static void
-S_sv_setnv(pTHX_ SV* sv, int numtype)
+S_sv_setnv(pTHX_ SV* sv, int numtype, NV nanv)
 {
     bool pok = cBOOL(SvPOK(sv));
     bool nok = FALSE;
@@ -2121,7 +2121,7 @@ S_sv_setnv(pTHX_ SV* sv, int numtype)
         nok = TRUE;
     }
     else if ((numtype & IS_NUMBER_NAN)) {
-        SvNV_set(sv, NV_NAN);
+        SvNV_set(sv, nanv);
         nok = TRUE;
     }
     else if (pok) {
@@ -2234,7 +2234,8 @@ S_sv_2iuv_common(pTHX_ SV *const sv)
     }
     else if (SvPOKp(sv)) {
        UV value;
-       const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+        NV nanv;
+       const int numtype = grok_number2_flags(SvPVX_const(sv), SvCUR(sv), &value, &nanv, 0);
        /* We want to avoid a possible problem when we cache an IV/ a UV which
           may be later translated to an NV, and the resulting NV is not
           the same as the direct translation of the initial string
@@ -2260,7 +2261,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv)
         if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
             if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
                not_a_number(sv);
-            S_sv_setnv(aTHX_ sv, numtype);
+            S_sv_setnv(aTHX_ sv, numtype, nanv);
             return FALSE;
         }
 
@@ -2310,7 +2311,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv)
        if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
            != IS_NUMBER_IN_UV) {
            /* It wasn't an (integer that doesn't overflow the UV). */
-            S_sv_setnv(aTHX_ sv, numtype);
+            S_sv_setnv(aTHX_ sv, numtype, nanv);
 
            if (! numtype && ckWARN(WARN_NUMERIC))
                not_a_number(sv);
@@ -2716,7 +2717,8 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
     }
     else if (SvPOKp(sv)) {
        UV value;
-       const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+        NV nanv;
+       const int numtype = grok_number2_flags(SvPVX_const(sv), SvCUR(sv), &value, &nanv, 0);
        if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
            not_a_number(sv);
 #ifdef NV_PRESERVES_UV
@@ -2725,7 +2727,7 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
            /* It's definitely an integer */
            SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
        } else {
-            S_sv_setnv(aTHX_ sv, numtype);
+            S_sv_setnv(aTHX_ sv, numtype, nanv);
         }
        if (numtype)
            SvNOK_on(sv);