#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)
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);
}
/*
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;
}
}
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;
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);
}
/*
https://perl5.git.perl.org / perl5.git / commitdiff