Collapse grok_bin, _oct, _hex into one function

These functions are identical in logic in the main loop, the difference
being which digits they accept.  The rest of the code had slight
variations.  This commit unifies the functions.

I presume the reason they were kept separate was because of speed.
Future commits will make this unified function faster than blead, and
the reduced maintenance cost makes this worthwhile.

1 files changed, 92 insertions, 187 deletions

diff --git a/numeric.c b/numeric.c
index 3349e33fce..d9e7b3581c 100644
--- a/numeric.c
+++ b/numeric.c
@@ -243,93 +243,9 @@ on this platform.
 UV
 Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
 {
-    const char *s = start;
-    STRLEN len = *len_p;
-    UV value = 0;
-    NV value_nv = 0;
-
-    const UV max_div_2 = UV_MAX / 2;
-    const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
-    bool overflowed = FALSE;
-    char bit;
-
     PERL_ARGS_ASSERT_GROK_BIN;
 
-    if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
-        /* strip off leading b or 0b.
-           for compatibility silently suffer "b" and "0b" as valid binary
-           numbers. */
-        if (len >= 1) {
-            if (isALPHA_FOLD_EQ(s[0], 'b')) {
-                s++;
-                len--;
-            }
-            else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'b'))) {
-                s+=2;
-                len-=2;
-            }
-        }
-    }
-
-    for (; len-- && (bit = *s); s++) {
-        if (bit == '0' || bit == '1') {
-            /* Write it in this wonky order with a goto to attempt to get the
-               compiler to make the common case integer-only loop pretty tight.
-               With gcc seems to be much straighter code than old scan_bin.  */
-          redo:
-            if (!overflowed) {
-                if (value <= max_div_2) {
-                    value = (value << 1) | (bit - '0');
-                    continue;
-                }
-                /* Bah. We're just overflowed.  */
-		/* diag_listed_as: Integer overflow in %s number */
-		Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
-				 "Integer overflow in binary number");
-                overflowed = TRUE;
-                value_nv = (NV) value;
-            }
-            value_nv *= 2.0;
-	    /* If an NV has not enough bits in its mantissa to
-	     * represent a UV this summing of small low-order numbers
-	     * is a waste of time (because the NV cannot preserve
-	     * the low-order bits anyway): we could just remember when
-	     * did we overflow and in the end just multiply value_nv by the
-	     * right amount. */
-            value_nv += (NV)(bit - '0');
-            continue;
-        }
-        if (bit == '_' && len && allow_underscores && (bit = s[1])
-            && (bit == '0' || bit == '1'))
-	    {
-		--len;
-		++s;
-                goto redo;
-	    }
-        if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
-            Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
-			   "Illegal binary digit '%c' ignored", *s);
-        break;
-    }
-
-    if (   ( overflowed && value_nv > 4294967295.0)
-#if UVSIZE > 4
-	|| (!overflowed && value > 0xffffffff
-	    && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
-#endif
-	) {
-	Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
-		       "Binary number > 0b11111111111111111111111111111111 non-portable");
-    }
-    *len_p = s - start;
-    if (!overflowed) {
-        *flags = 0;
-        return value;
-    }
-    *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
-    if (result)
-        *result = value_nv;
-    return UV_MAX;
+    return grok_bin(start, len_p, flags, result);
 }
 
 /*
@@ -366,26 +282,49 @@ on this platform.
 UV
 Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
 {
+    PERL_ARGS_ASSERT_GROK_HEX;
+
+    return grok_hex(start, len_p, flags, result);
+}
+
+UV
+Perl_grok_bin_oct_hex(pTHX_ const char *start,
+                        STRLEN *len_p,
+                        I32 *flags,
+                        NV *result,
+                        const unsigned shift) /* 1 for binary; 3 for octal;
+                                                 4 for hex */
+{
     const char *s = start;
     STRLEN len = *len_p;
     UV value = 0;
     NV value_nv = 0;
-    const UV max_div_16 = UV_MAX / 16;
+    const PERL_UINT_FAST8_T base = 1 << shift;
+    const UV max_div= UV_MAX / base;
+    const PERL_UINT_FAST8_T class_bit = (base == 2)
+                                        ? _CC_BINDIGIT
+                                        : (base == 8)
+                                          ? _CC_OCTDIGIT
+                                          : _CC_XDIGIT;
     const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
     bool overflowed = FALSE;
 
-    PERL_ARGS_ASSERT_GROK_HEX;
+    PERL_ARGS_ASSERT_GROK_BIN_OCT_HEX;
 
-    if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
-        /* strip off leading x or 0x.
-           for compatibility silently suffer "x" and "0x" as valid hex numbers.
-        */
+    ASSUME(inRANGE(shift, 1, 4) && shift != 2);
+
+    if (base != 8 && !(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
+        const char prefix = base == 2 ? 'b' : 'x';
+
+        /* strip off leading b or 0b; x or 0x.
+           for compatibility silently suffer "b" and "0b" as valid binary; "x"
+           and "0x" as valid hex numbers. */
         if (len >= 1) {
-            if (isALPHA_FOLD_EQ(s[0], 'x')) {
+            if (isALPHA_FOLD_EQ(s[0], prefix)) {
                 s++;
                 len--;
             }
-            else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'x'))) {
+            else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], prefix))) {
                 s+=2;
                 len-=2;
             }
@@ -393,55 +332,91 @@ Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
     }
 
     for (; len-- && *s; s++) {
-        if (isXDIGIT(*s)) {
+        if (_generic_isCC(*s, class_bit)) {
             /* Write it in this wonky order with a goto to attempt to get the
                compiler to make the common case integer-only loop pretty tight.
                With gcc seems to be much straighter code than old scan_hex.  */
           redo:
             if (!overflowed) {
-                if (value <= max_div_16) {
-                    value = (value << 4) | XDIGIT_VALUE(*s);
+                if (value <= max_div) {
+                    value = (value << shift) | XDIGIT_VALUE(*s);
+                        /* Note XDIGIT_VALUE() is branchless, works on binary
+                         * and octal as well, so can be used here, without
+                         * slowing those down */
                     continue;
                 }
                 /* Bah. We're just overflowed.  */
-		/* diag_listed_as: Integer overflow in %s number */
-		Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
-				 "Integer overflow in hexadecimal number");
+                Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
+                                       "Integer overflow in %s number",
+                                       (base == 16) ? "hexadecimal"
+                                                    : (base == 2)
+                                                      ? "binary"
+                                                      : "octal");
                 overflowed = TRUE;
                 value_nv = (NV) value;
             }
-            value_nv *= 16.0;
+            value_nv *= base;
 	    /* If an NV has not enough bits in its mantissa to
 	     * represent a UV this summing of small low-order numbers
 	     * is a waste of time (because the NV cannot preserve
 	     * the low-order bits anyway): we could just remember when
 	     * did we overflow and in the end just multiply value_nv by the
-	     * right amount of 16-tuples. */
+	     * right amount of base-tuples. */
             value_nv += (NV) XDIGIT_VALUE(*s);
             continue;
         }
-        if (*s == '_' && len && allow_underscores && s[1]
-		&& isXDIGIT(s[1]))
-	    {
-		--len;
-		++s;
-                goto redo;
-	    }
-        if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
-            Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
-                        "Illegal hexadecimal digit '%c' ignored", *s);
+        if (   *s == '_'
+            && len
+            && allow_underscores
+            && _generic_isCC(s[1], class_bit))
+        {
+            --len;
+            ++s;
+            goto redo;
+        }
+        if ( ! (*flags & PERL_SCAN_SILENT_ILLDIGIT)
+            &&  ckWARN(WARN_DIGIT))
+        {
+            if (base != 8) {
+                Perl_warner(aTHX_ packWARN(WARN_DIGIT),
+                                   "Illegal %s digit '%c' ignored",
+                                      ((base == 2)
+                                      ? "binary"
+                                      : "hexadecimal"),
+                                    *s);
+            }
+            else if (isDIGIT(*s)) { /* octal base */
+
+                /* Allow \octal to work the DWIM way (that is, stop scanning as
+                 * soon as non-octal characters are seen, complain only if
+                 * someone seems to want to use the digits eight and nine.
+                 * Since we know it is not octal, then if isDIGIT, must be an 8
+                 * or 9). */
+                Perl_warner(aTHX_ packWARN(WARN_DIGIT),
+                                       "Illegal octal digit '%c' ignored", *s);
+            }
+        }
         break;
     }
 
     if (   ( overflowed && value_nv > 4294967295.0)
 #if UVSIZE > 4
-	|| (!overflowed && value > 0xffffffff
-	    && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
+        || (   !  overflowed && value > 0xffffffff
+            && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
 #endif
-	) {
-	Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
-		       "Hexadecimal number > 0xffffffff non-portable");
+    ) {
+        const char * which = (base == 2)
+                          ? "Binary number > 0b11111111111111111111111111111111"
+                          : (base == 8)
+                            ? "Octal number > 037777777777"
+                            : "Hexadecimal number > 0xffffffff";
+        /* Also there are listings for the other two.  Since they are the first
+         * word, it would be hard for a user to find them there starting with a
+         * %s. */
+        /* diag_listed_as: Hexadecimal number > 0xffffffff non-portable */
+        Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), "%s non-portable", which);
     }
+
     *len_p = s - start;
     if (!overflowed) {
         *flags = 0;
@@ -485,79 +460,9 @@ on this platform.
 UV
 Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
 {
-    const char *s = start;
-    STRLEN len = *len_p;
-    UV value = 0;
-    NV value_nv = 0;
-    const UV max_div_8 = UV_MAX / 8;
-    const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
-    bool overflowed = FALSE;
-
     PERL_ARGS_ASSERT_GROK_OCT;
 
-    for (; len-- && *s; s++) {
-        if (isOCTAL(*s)) {
-            /* Write it in this wonky order with a goto to attempt to get the
-               compiler to make the common case integer-only loop pretty tight.
-            */
-          redo:
-            if (!overflowed) {
-                if (value <= max_div_8) {
-                    value = (value << 3) | OCTAL_VALUE(*s);
-                    continue;
-                }
-                /* Bah. We're just overflowed.  */
-		/* diag_listed_as: Integer overflow in %s number */
-		Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
-			       "Integer overflow in octal number");
-                overflowed = TRUE;
-                value_nv = (NV) value;
-            }
-            value_nv *= 8.0;
-	    /* If an NV has not enough bits in its mantissa to
-	     * represent a UV this summing of small low-order numbers
-	     * is a waste of time (because the NV cannot preserve
-	     * the low-order bits anyway): we could just remember when
-	     * did we overflow and in the end just multiply value_nv by the
-	     * right amount of 8-tuples. */
-            value_nv += (NV) OCTAL_VALUE(*s);
-            continue;
-        }
-        if (*s == '_' && len && allow_underscores && isOCTAL(s[1])) {
-            --len;
-            ++s;
-            goto redo;
-        }
-        /* Allow \octal to work the DWIM way (that is, stop scanning
-         * as soon as non-octal characters are seen, complain only if
-         * someone seems to want to use the digits eight and nine.  Since we
-         * know it is not octal, then if isDIGIT, must be an 8 or 9). */
-        if (isDIGIT(*s)) {
-            if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
-                Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
-			       "Illegal octal digit '%c' ignored", *s);
-        }
-        break;
-    }
-
-    if (   ( overflowed && value_nv > 4294967295.0)
-#if UVSIZE > 4
-	|| (!overflowed && value > 0xffffffff
-	    && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
-#endif
-	) {
-	Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
-		       "Octal number > 037777777777 non-portable");
-    }
-    *len_p = s - start;
-    if (!overflowed) {
-        *flags = 0;
-        return value;
-    }
-    *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
-    if (result)
-        *result = value_nv;
-    return UV_MAX;
+    return grok_oct(start, len_p, flags, result);
 }
 
 /*