This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Collapse grok_bin, _oct, _hex into one function
authorKarl Williamson <khw@cpan.org>
Tue, 7 Jan 2020 00:32:35 +0000 (17:32 -0700)
committerKarl Williamson <khw@cpan.org>
Tue, 14 Jan 2020 03:58:56 +0000 (20:58 -0700)
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.

embed.fnc
embed.h
numeric.c
perl.h
pod/perldiag.pod
proto.h

index 296f791..e383fff 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1135,7 +1135,6 @@ Ap        |void   |vload_module|U32 flags|NN SV* name|NULLOK SV* ver|NULLOK va_list* args
 : Used in perly.y
 p      |OP*    |localize       |NN OP *o|I32 lex
 ApdR   |I32    |looks_like_number|NN SV *const sv
-Apd    |UV     |grok_bin       |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result
 #if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_DQUOTE_C)
 EpRX   |bool   |grok_bslash_x  |NN char** s             \
                                |NN const char* const send       \
@@ -1158,12 +1157,18 @@ EiR     |char*|form_short_octal_warning|NN const char * const s  \
                                |const STRLEN len
 EiRT   |I32    |regcurly       |NN const char *s
 #endif
-Apd    |UV     |grok_hex       |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result
+AMpd   |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_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
 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
+ApMd   |UV     |grok_oct       |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result
+ApMd   |UV     |grok_bin       |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result
+Cpd    |UV     |grok_bin_oct_hex|NN const char* start                      \
+                                |NN STRLEN* len_p                          \
+                                |NN I32* flags                             \
+                                |NULLOK NV *result                         \
+                                |const unsigned shift
 EXpdT  |bool   |grok_atoUV     |NN const char* pv|NN UV* valptr|NULLOK const char** endptr
 : These are all indirectly referenced by globals.c. This is somewhat annoying.
 p      |int    |magic_clearenv |NN SV* sv|NN MAGIC* mg
diff --git a/embed.h b/embed.h
index 9ee8b75..0c0a75b 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define getcwd_sv(a)           Perl_getcwd_sv(aTHX_ a)
 #define gp_free(a)             Perl_gp_free(aTHX_ a)
 #define gp_ref(a)              Perl_gp_ref(aTHX_ a)
-#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_bin_oct_hex(a,b,c,d,e)    Perl_grok_bin_oct_hex(aTHX_ a,b,c,d,e)
 #define grok_infnan(a,b)       Perl_grok_infnan(aTHX_ a,b)
 #define grok_number(a,b,c)     Perl_grok_number(aTHX_ a,b,c)
 #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)
 #define gv_add_by_type(a,b)    Perl_gv_add_by_type(aTHX_ a,b)
 #define gv_autoload_pv(a,b,c)  Perl_gv_autoload_pv(aTHX_ a,b,c)
 #define gv_autoload_pvn(a,b,c,d)       Perl_gv_autoload_pvn(aTHX_ a,b,c,d)
index 3349e33..d9e7b35 100644 (file)
--- 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);
 }
 
 /*
diff --git a/perl.h b/perl.h
index 8e77d0c..969dfc9 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -6890,6 +6890,10 @@ C<strtoul>.
 #   define Atoul(s)    Strtoul(s, NULL, 10)
 #endif
 
+#define grok_bin(s,lp,f,r) grok_bin_oct_hex(s, lp, f, r, 1)
+#define grok_oct(s,lp,f,r) grok_bin_oct_hex(s, lp, f, r, 3)
+#define grok_hex(s,lp,f,r) grok_bin_oct_hex(s, lp, f, r, 4)
+
 #ifndef PERL_SCRIPT_MODE
 #define PERL_SCRIPT_MODE "r"
 #endif
index 1e1af5c..d50f6d8 100644 (file)
@@ -2665,15 +2665,19 @@ zero-length sequence.  When such an escape is used in a character
 class its behavior is not well defined.  Check that the correct
 escape has been used, and the correct charname handler is in scope.
 
-=item Illegal binary digit '%c'
+=item Illegal %s digit '%c' ignored
 
-(F) You used a digit other than 0 or 1 in a binary number.
+(W digit) Here C<%s> is one of "binary", "octal", or "hex".
+You may have tried to use a digit other than one that is legal for the
+given type, such as only 0 and 1 for binary.  For octals, this is raised
+only if the illegal character is an '8' or '9'.  For hex, 'A' - 'F' and
+'a' - 'f' are legal.
+Interpretation of the number stopped just before the offending digit or
+character.
 
-=item Illegal binary digit %s ignored
+=item Illegal binary digit '%c'
 
-(W digit) You may have tried to use a digit other than 0 or 1 in a
-binary number.  Interpretation of the binary number stopped before the
-offending digit.
+(F) You used a digit other than 0 or 1 in a binary number.
 
 =item Illegal character after '_' in prototype for %s : %s
 
@@ -2729,12 +2733,6 @@ you must always specify a block of code.  See L<perlsub>.
 your logic, or you need to put a conditional in to guard against
 meaningless input.
 
-=item Illegal hexadecimal digit %s ignored
-
-(W digit) You may have tried to use a character other than 0 - 9 or
-A - F, a - f in a hexadecimal number.  Interpretation of the hexadecimal
-number stopped before the illegal character.
-
 =item Illegal modulus zero
 
 (F) You tried to divide a number by 0 to get the remainder.  Most
@@ -2749,11 +2747,6 @@ two from 1 to 32 (or 64, if your platform supports that).
 
 (F) You used an 8 or 9 in an octal number.
 
-=item Illegal octal digit %s ignored
-
-(W digit) You may have tried to use an 8 or 9 in an octal number.
-Interpretation of the octal number stopped before the 8 or 9.
-
 =item Illegal operator following parameter in a subroutine signature
 
 (F) A parameter in a subroutine signature, was followed by something
diff --git a/proto.h b/proto.h
index a0abbdd..7c719b5 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1148,6 +1148,9 @@ PERL_CALLCONV bool        Perl_grok_atoUV(const char* pv, UV* valptr, const char** endp
 PERL_CALLCONV UV       Perl_grok_bin(pTHX_ const char* start, STRLEN* len_p, I32* flags, NV *result);
 #define PERL_ARGS_ASSERT_GROK_BIN      \
        assert(start); assert(len_p); assert(flags)
+PERL_CALLCONV UV       Perl_grok_bin_oct_hex(pTHX_ const char* start, STRLEN* len_p, I32* flags, NV *result, const unsigned shift);
+#define PERL_ARGS_ASSERT_GROK_BIN_OCT_HEX      \
+       assert(start); assert(len_p); assert(flags)
 PERL_CALLCONV UV       Perl_grok_hex(pTHX_ const char* start, STRLEN* len_p, I32* flags, NV *result);
 #define PERL_ARGS_ASSERT_GROK_HEX      \
        assert(start); assert(len_p); assert(flags)