This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Merge branch 'grok_bin_oct_hex' into blead
authorKarl Williamson <khw@cpan.org>
Tue, 14 Jan 2020 03:59:17 +0000 (20:59 -0700)
committerKarl Williamson <khw@cpan.org>
Tue, 14 Jan 2020 03:59:17 +0000 (20:59 -0700)
This branch collapses 3 very similar functions into one, for easier
maintenance.  The resulting function is then modified to improve
performance over blead, and documentation is clarified.

13 files changed:
charclass_invlists.h
embed.fnc
embed.h
handy.h
l1_char_class_tab.h
lib/unicore/uni_keywords.pl
numeric.c
perl.h
pod/perldiag.pod
pp.c
proto.h
regen/mk_PL_charclass.pl
uni_keywords.h

index bbee968..f4c7dbd 100644 (file)
@@ -395170,6 +395170,6 @@ static const U8 WB_table[23][23] = {
  * 498da0b9ef6a52bfd71bda5771005bbe4cfc37b456d9d350cd840991eb80c8b1 lib/unicore/mktables
  * a712c758275b460d18fa77a26ed3589689bb3f69dcc1ea99b913e32db92a5cd2 lib/unicore/version
  * 2680b9254eb236c5c090f11b149605043e8c8433661b96efc4a42fb4709342a5 regen/charset_translations.pl
- * e9283c761c5a95e3379384ca47c13a284f08d743c2be6e5091f1152b1b6b7a37 regen/mk_PL_charclass.pl
+ * 6bbad21de0848e0236b02f34f5fa0edd3cdae9ba8173cc9469a5513936b9e728 regen/mk_PL_charclass.pl
  * eb6b8e366260282e03108163fbf907367474c469310d716a4a5c7b244d88ce45 regen/mk_invlists.pl
  * ex: set ro: */
index 296f791..88c9993 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,23 @@ 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                      \
+                                |const U8 lookup_bit                       \
+                                |const char prefix
+#ifdef PERL_IN_NUMERIC_C
+S      |void   |output_non_portable|const U8 shift
+#endif
 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..a2c0dc1 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,f,g)        Perl_grok_bin_oct_hex(aTHX_ a,b,c,d,e,f,g)
 #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)
 #define mro_gather_and_rename(a,b,c,d,e)       S_mro_gather_and_rename(aTHX_ a,b,c,d,e)
 #define mro_get_linear_isa_dfs(a,b)    S_mro_get_linear_isa_dfs(aTHX_ a,b)
 #  endif
+#  if defined(PERL_IN_NUMERIC_C)
+#define output_non_portable(a) S_output_non_portable(aTHX_ a)
+#  endif
 #  if defined(PERL_IN_OP_C)
 #define apply_attrs(a,b,c)     S_apply_attrs(aTHX_ a,b,c)
 #define apply_attrs_my(a,b,c,d)        S_apply_attrs_my(aTHX_ a,b,c,d)
diff --git a/handy.h b/handy.h
index 08f832a..a7a75f1 100644 (file)
--- a/handy.h
+++ b/handy.h
@@ -1365,7 +1365,9 @@ or casts
 #  define _CC_QUOTEMETA                20
 #  define _CC_NON_FINAL_FOLD           21
 #  define _CC_IS_IN_SOME_FOLD          22
-#  define _CC_MNEMONIC_CNTRL           23
+#  define _CC_BINDIGIT                 23
+#  define _CC_OCTDIGIT                 24
+#  define _CC_MNEMONIC_CNTRL           25
 
 /* This next group is only used on EBCDIC platforms, so theoretically could be
  * shared with something entirely different that's only on ASCII platforms */
index a757596..83469a0 100644 (file)
 /* U+2D '-' */ (1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
 /* U+2E '.' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
 /* U+2F '/' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
-/* U+30 '0' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* U+31 '1' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* U+32 '2' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* U+33 '3' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* U+34 '4' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* U+35 '5' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* U+36 '6' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* U+37 '7' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+30 '0' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_BINDIGIT)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+31 '1' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_BINDIGIT)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+32 '2' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+33 '3' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+34 '4' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+35 '5' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+36 '6' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* U+37 '7' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
 /* U+38 '8' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
 /* U+39 '9' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
 /* U+3A ':' */ (1U<<_CC_ASCII)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_PUNCT)|(1U<<_CC_QUOTEMETA),
 /* 0xED U+D2 I8=F8 O with GRAVE */ (1U<<_CC_ALPHA)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_UTF8_START_BYTE_IS_FOR_AT_LEAST_SURROGATE),
 /* 0xEE U+D3 I8=F9 O with ACUTE */ (1U<<_CC_ALPHA)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_UTF8_START_BYTE_IS_FOR_AT_LEAST_SURROGATE),
 /* 0xEF U+D5 I8=FA O with '~' */ (1U<<_CC_ALPHA)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_UTF8_START_BYTE_IS_FOR_AT_LEAST_SURROGATE),
-/* 0xF0 U+30 '0' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* 0xF1 U+31 '1' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* 0xF2 U+32 '2' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* 0xF3 U+33 '3' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* 0xF4 U+34 '4' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* 0xF5 U+35 '5' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* 0xF6 U+36 '6' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* 0xF7 U+37 '7' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF0 U+30 '0' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_BINDIGIT)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF1 U+31 '1' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_BINDIGIT)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF2 U+32 '2' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF3 U+33 '3' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF4 U+34 '4' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF5 U+35 '5' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF6 U+36 '6' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF7 U+37 '7' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
 /* 0xF8 U+38 '8' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
 /* 0xF9 U+39 '9' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
 /* 0xFA U+B3 I8=FB SUPERSCRIPT 3 */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_UTF8_START_BYTE_IS_FOR_AT_LEAST_SURROGATE),
 /* 0xED U+D2 I8=F8 O with GRAVE */ (1U<<_CC_ALPHA)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_UTF8_START_BYTE_IS_FOR_AT_LEAST_SURROGATE),
 /* 0xEE U+D3 I8=F9 O with ACUTE */ (1U<<_CC_ALPHA)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_UTF8_START_BYTE_IS_FOR_AT_LEAST_SURROGATE),
 /* 0xEF U+D5 I8=FA O with '~' */ (1U<<_CC_ALPHA)|(1U<<_CC_ALPHANUMERIC)|(1U<<_CC_CASED)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_GRAPH)|(1U<<_CC_IDFIRST)|(1U<<_CC_IS_IN_SOME_FOLD)|(1U<<_CC_PRINT)|(1U<<_CC_UPPER)|(1U<<_CC_WORDCHAR)|(1U<<_CC_UTF8_START_BYTE_IS_FOR_AT_LEAST_SURROGATE),
-/* 0xF0 U+30 '0' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* 0xF1 U+31 '1' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* 0xF2 U+32 '2' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* 0xF3 U+33 '3' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* 0xF4 U+34 '4' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* 0xF5 U+35 '5' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* 0xF6 U+36 '6' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
-/* 0xF7 U+37 '7' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF0 U+30 '0' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_BINDIGIT)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF1 U+31 '1' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_BINDIGIT)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF2 U+32 '2' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF3 U+33 '3' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF4 U+34 '4' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF5 U+35 '5' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF6 U+36 '6' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
+/* 0xF7 U+37 '7' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_OCTDIGIT)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
 /* 0xF8 U+38 '8' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
 /* 0xF9 U+39 '9' */ (1U<<_CC_ALPHANUMERIC)|(1U<<_CC_ASCII)|(1U<<_CC_CHARNAME_CONT)|(1U<<_CC_DIGIT)|(1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_WORDCHAR)|(1U<<_CC_XDIGIT),
 /* 0xFA U+B3 I8=FB SUPERSCRIPT 3 */ (1U<<_CC_GRAPH)|(1U<<_CC_PRINT)|(1U<<_CC_UTF8_START_BYTE_IS_FOR_AT_LEAST_SURROGATE),
index 953bbe4..701e4c2 100644 (file)
 # 498da0b9ef6a52bfd71bda5771005bbe4cfc37b456d9d350cd840991eb80c8b1 lib/unicore/mktables
 # a712c758275b460d18fa77a26ed3589689bb3f69dcc1ea99b913e32db92a5cd2 lib/unicore/version
 # 2680b9254eb236c5c090f11b149605043e8c8433661b96efc4a42fb4709342a5 regen/charset_translations.pl
-# e9283c761c5a95e3379384ca47c13a284f08d743c2be6e5091f1152b1b6b7a37 regen/mk_PL_charclass.pl
+# 6bbad21de0848e0236b02f34f5fa0edd3cdae9ba8173cc9469a5513936b9e728 regen/mk_PL_charclass.pl
 # eb6b8e366260282e03108163fbf907367474c469310d716a4a5c7b244d88ce45 regen/mk_invlists.pl
 # ex: set ro:
index 3349e33..0c3c48e 100644 (file)
--- a/numeric.c
+++ b/numeric.c
@@ -208,30 +208,31 @@ Perl_cast_uv(NV f)
 
 converts a string representing a binary number to numeric form.
 
-On entry C<start> and C<*len> give the string to scan, C<*flags> gives
-conversion flags, and C<result> should be C<NULL> or a pointer to an NV.
-The scan stops at the end of the string, or the first invalid character.
-Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an
-invalid character will also trigger a warning.
-On return C<*len> is set to the length of the scanned string,
-and C<*flags> gives output flags.
+On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
+conversion flags, and C<result> should be C<NULL> or a pointer to an NV.  The
+scan stops at the end of the string, or at just before the first invalid
+character.  Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
+encountering an invalid character (except NUL) will also trigger a warning.  On
+return C<*len_p> is set to the length of the scanned string, and C<*flags>
+gives output flags.
 
 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
 and nothing is written to C<*result>.  If the value is > C<UV_MAX>, C<grok_bin>
 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
-and writes the value to C<*result> (or the value is discarded if C<result>
-is NULL).
+and writes an approximation of the correct value into C<*result> (which is an
+NV; or the approximation is discarded if C<result> is NULL).
 
 The binary number may optionally be prefixed with C<"0b"> or C<"b"> unless
-C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry.  If
-C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the binary
-number may use C<"_"> characters to separate digits.
+C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry.
+
+If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
+digits may be separated from each other by a single underscore; also a single
+leading underscore is accepted.
 
 =for apidoc Amnh||PERL_SCAN_ALLOW_UNDERSCORES
 =for apidoc Amnh||PERL_SCAN_DISALLOW_PREFIX
 =for apidoc Amnh||PERL_SCAN_GREATER_THAN_UV_MAX
 =for apidoc Amnh||PERL_SCAN_SILENT_ILLDIGIT
-=for apidoc Amnh||PERL_SCAN_TRAILING
 
 =cut
 
@@ -243,93 +244,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);
 }
 
 /*
@@ -338,27 +255,29 @@ Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
 converts a string representing a hex number to numeric form.
 
 On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
-conversion flags, and C<result> should be C<NULL> or a pointer to an NV.
-The scan stops at the end of the string, or the first invalid character.
-Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an
-invalid character will also trigger a warning.
-On return C<*len> is set to the length of the scanned string,
-and C<*flags> gives output flags.
+conversion flags, and C<result> should be C<NULL> or a pointer to an NV.  The
+scan stops at the end of the string, or at just before the first invalid
+character.  Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
+encountering an invalid character (except NUL) will also trigger a warning.  On
+return C<*len_p> is set to the length of the scanned string, and C<*flags>
+gives output flags.
 
 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
 and nothing is written to C<*result>.  If the value is > C<UV_MAX>, C<grok_hex>
 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
-and writes the value to C<*result> (or the value is discarded if C<result>
-is C<NULL>).
+and writes an approximation of the correct value into C<*result> (which is an
+NV; or the approximation is discarded if C<result> is NULL).
 
 The hex number may optionally be prefixed with C<"0x"> or C<"x"> unless
-C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry.  If
-C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the hex
-number may use C<"_"> characters to separate digits.
+C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry.
+
+If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
+digits may be separated from each other by a single underscore; also a single
+leading underscore is accepted.
 
 =cut
 
-Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
+Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE>
 which suppresses any message for non-portable numbers, but which are valid
 on this platform.
  */
@@ -366,91 +285,9 @@ on this platform.
 UV
 Perl_grok_hex(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_16 = UV_MAX / 16;
-    const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
-    bool overflowed = FALSE;
-
     PERL_ARGS_ASSERT_GROK_HEX;
 
-    if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
-        /* strip off leading x or 0x.
-           for compatibility silently suffer "x" and "0x" as valid hex numbers.
-        */
-        if (len >= 1) {
-            if (isALPHA_FOLD_EQ(s[0], 'x')) {
-                s++;
-                len--;
-            }
-            else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'x'))) {
-                s+=2;
-                len-=2;
-            }
-        }
-    }
-
-    for (; len-- && *s; s++) {
-        if (isXDIGIT(*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.
-               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);
-                    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");
-                overflowed = TRUE;
-                value_nv = (NV) value;
-            }
-            value_nv *= 16.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 16-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);
-        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),
-                      "Hexadecimal number > 0xffffffff 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_hex(start, len_p, flags, result);
 }
 
 /*
@@ -458,22 +295,26 @@ Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
 
 converts a string representing an octal number to numeric form.
 
-On entry C<start> and C<*len> give the string to scan, C<*flags> gives
-conversion flags, and C<result> should be C<NULL> or a pointer to an NV.
-The scan stops at the end of the string, or the first invalid character.
-Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an
-8 or 9 will also trigger a warning.
-On return C<*len> is set to the length of the scanned string,
-and C<*flags> gives output flags.
+On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives
+conversion flags, and C<result> should be C<NULL> or a pointer to an NV.  The
+scan stops at the end of the string, or at just before the first invalid
+character.  Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>,
+encountering an invalid character (except NUL) will also trigger a warning.  On
+return C<*len_p> is set to the length of the scanned string, and C<*flags>
+gives output flags.
 
 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear,
 and nothing is written to C<*result>.  If the value is > C<UV_MAX>, C<grok_oct>
 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
-and writes the value to C<*result> (or the value is discarded if C<result>
-is C<NULL>).
+and writes an approximation of the correct value into C<*result> (which is an
+NV; or the approximation is discarded if C<result> is NULL).
 
-If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the octal
-number may use C<"_"> characters to separate digits.
+If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then any or all pairs of
+digits may be separated from each other by a single underscore; also a single
+leading underscore is accepted.
+
+The the C<PERL_SCAN_DISALLOW_PREFIX> flag is always treated as being set for
+this function.
 
 =cut
 
@@ -485,75 +326,255 @@ on this platform.
 UV
 Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
 {
-    const char *s = start;
+    PERL_ARGS_ASSERT_GROK_OCT;
+
+    return grok_oct(start, len_p, flags, result);
+}
+
+STATIC void
+S_output_non_portable(pTHX_ const U8 base)
+{
+    /* Display the proper message for a number in the given input base not
+     * fitting in 32 bits */
+    const char * which = (base == 2)
+                      ? "Binary number > 0b11111111111111111111111111111111"
+                      : (base == 8)
+                        ? "Octal number > 037777777777"
+                        : "Hexadecimal number > 0xffffffff";
+
+    PERL_ARGS_ASSERT_OUTPUT_NON_PORTABLE;
+
+    /* Also there are listings for the other two.  That's because, 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);
+}
+
+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 U8 class_bit,
+                        const char prefix
+                     )
+
+{
+    const char *s0 = start;
+    const char *s;
     STRLEN len = *len_p;
+    STRLEN bytes_so_far;    /* How many real digits have been processed */
     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);
+    const PERL_UINT_FAST8_T base = 1 << shift;  /* 2, 8, or 16 */
+    const UV max_div= UV_MAX / base;    /* Value above which, the next digit
+                                           processed would overflow */
+    const I32 input_flags = *flags;
+    const bool allow_underscores =
+                                cBOOL(input_flags & PERL_SCAN_ALLOW_UNDERSCORES);
     bool overflowed = FALSE;
 
-    PERL_ARGS_ASSERT_GROK_OCT;
+    /* In overflows, this keeps track of how much to multiply the overflowed NV
+     * by as we continue to parse the remaining digits */
+    UV factor;
+
+    /* This function unifies the core of grok_bin, grok_oct, and grok_hex.  It
+     * is optimized for hex conversion.  For example, it uses XDIGIT_VALUE to
+     * find the numeric value of a digit.  That requires more instructions than
+     * OCTAL_VALUE would, but gives the same result for the narrowed range of
+     * octal digits; same for binary.  If it were ever critical to squeeze more
+     * performance from this, the function could become grok_hex, and a regen
+     * perl script could scan it and write out two edited copies for the other
+     * two functions.  That would improve the performance of all three
+     * somewhat.  Besides eliminating XDIGIT_VALUE for the other two, extra
+     * parameters are now passed to this to avoid conditionals.  Those could
+     * become declared consts, like:
+     *      const U8 base = 16;
+     *      const U8 base = 8;
+     *      ...
+     */
+
+    PERL_ARGS_ASSERT_GROK_BIN_OCT_HEX;
+
+    ASSUME(inRANGE(shift, 1, 4) && shift != 2);
+
+    /* Clear output flags; unlikely to find a problem that sets them */
+    *flags = 0;
+
+    if (!(input_flags & PERL_SCAN_DISALLOW_PREFIX)) {
+
+        /* 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(s0[0], prefix)) {
+                s0++;
+                len--;
+            }
+            else if (len >= 2 && s0[0] == '0' && (isALPHA_FOLD_EQ(s0[1], prefix))) {
+                s0+=2;
+                len-=2;
+            }
+        }
+    }
 
-    for (; len-- && *s; s++) {
-        if (isOCTAL(*s)) {
+    s = s0; /* s0 potentially advanced from 'start' */
+
+    /* Unroll the loop so that the first 7 digits are branchless except for the
+     * switch.  An eighth one could overflow a 32 bit word.  This should
+     * completely handle the common case without needing extra checks */
+    switch (len) {
+      case 0:
+          return 0;
+      default:
+          if (! _generic_isCC(*s, class_bit))  break;
+          value = (value << shift) | XDIGIT_VALUE(*s);
+          s++;
+          /* FALLTHROUGH */
+      case 6:
+          if (! _generic_isCC(*s, class_bit))  break;
+          value = (value << shift) | XDIGIT_VALUE(*s);
+          s++;
+          /* FALLTHROUGH */
+      case 5:
+          if (! _generic_isCC(*s, class_bit))  break;
+          value = (value << shift) | XDIGIT_VALUE(*s);
+          s++;
+          /* FALLTHROUGH */
+      case 4:
+          if (! _generic_isCC(*s, class_bit))  break;
+          value = (value << shift) | XDIGIT_VALUE(*s);
+          s++;
+          /* FALLTHROUGH */
+      case 3:
+          if (! _generic_isCC(*s, class_bit))  break;
+          value = (value << shift) | XDIGIT_VALUE(*s);
+          s++;
+          /* FALLTHROUGH */
+      case 2:
+          if (! _generic_isCC(*s, class_bit))  break;
+          value = (value << shift) | XDIGIT_VALUE(*s);
+          s++;
+          /* FALLTHROUGH */
+      case 1:
+          if (! _generic_isCC(*s, class_bit))  break;
+          value = (value << shift) | XDIGIT_VALUE(*s);
+
+          if (LIKELY(len <= 7)) {
+              return value;
+          }
+
+          s++;
+          break;
+    }
+
+    bytes_so_far = s - s0;
+    factor = shift << bytes_so_far;
+    len -= bytes_so_far;
+
+    for (; len--; 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.
+               (khw suspects that adding a LIKELY() just above would do the
+               same thing) */
           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");
+            if (LIKELY(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 */
+                factor <<= shift;
+                continue;
+            }
+
+            /* Bah. We are about to overflow.  Instead, add the unoverflowed
+             * value to an NV that contains an approximation to the correct
+             * value.  Each time through the loop we have increased 'factor' so
+             * that it gives how much the current approximation needs to
+             * effectively be shifted to make room for this new value */
+            value_nv *= (NV) factor;
+            value_nv += (NV) value;
+
+            /* Then we keep accumulating digits, until all are parsed.  We
+             * start over using the current input value.  This will be added to
+             * 'value_nv' eventually, either when all digits are gone, or we
+             * have overflowed this fresh start. */
+            value = XDIGIT_VALUE(*s);
+            factor = 1 << shift;
+
+            if (! overflowed) {
                 overflowed = TRUE;
-                value_nv = (NV) value;
+                Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
+                                       "Integer overflow in %s number",
+                                       (base == 16) ? "hexadecimal"
+                                                    : (base == 2)
+                                                      ? "binary"
+                                                      : "octal");
             }
-            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])) {
+
+        if (   *s == '_'
+            && len
+            && allow_underscores
+            && _generic_isCC(s[1], class_bit))
+        {
             --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);
+
+        if (      *s
+            && ! (input_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)
+    *len_p = s - start;
+
+    if (LIKELY(! overflowed)) {
 #if UVSIZE > 4
-       || (!overflowed && value > 0xffffffff
-           && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
+        if (      UNLIKELY(value > 0xffffffff)
+            && ! (input_flags & PERL_SCAN_SILENT_NON_PORTABLE))
+        {
+            output_non_portable(base);
+        }
 #endif
-       ) {
-       Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
-                      "Octal number > 037777777777 non-portable");
-    }
-    *len_p = s - start;
-    if (!overflowed) {
-        *flags = 0;
         return value;
     }
+
+    /* Overflowed: Calculate the final overflow approximation */
+    value_nv *= (NV) factor;
+    value_nv += (NV) value;
+
+    output_non_portable(base);
+
     *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
     if (result)
         *result = value_nv;
@@ -962,6 +983,8 @@ 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 Amnh||PERL_SCAN_TRAILING
+
 =for apidoc grok_number
 
 Identical to C<grok_number_flags()> with C<flags> set to zero.
diff --git a/perl.h b/perl.h
index 8e77d0c..6b33b9d 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -6890,6 +6890,14 @@ C<strtoul>.
 #   define Atoul(s)    Strtoul(s, NULL, 10)
 #endif
 
+#define grok_bin(s,lp,fp,rp)                                                \
+                    grok_bin_oct_hex(s, lp, fp, rp, 1, _CC_BINDIGIT, 'b')
+#define grok_oct(s,lp,fp,rp)                                                \
+                    (*(fp) |= PERL_SCAN_DISALLOW_PREFIX,                    \
+                    grok_bin_oct_hex(s, lp, fp, rp, 3, _CC_OCTDIGIT, '\0'))
+#define grok_hex(s,lp,fp,rp)                                                \
+                    grok_bin_oct_hex(s, lp, fp, rp, 4, _CC_XDIGIT, 'x')
+
 #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/pp.c b/pp.c
index 5cd32e1..b86593e 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -3084,11 +3084,16 @@ PP(pp_oct)
     if (*tmps == '0')
         tmps++, len--;
     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
+        tmps++, len--;
+        flags |= PERL_SCAN_DISALLOW_PREFIX;
     hex:
         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
     }
-    else if (isALPHA_FOLD_EQ(*tmps, 'b'))
+    else if (isALPHA_FOLD_EQ(*tmps, 'b')) {
+        tmps++, len--;
+        flags |= PERL_SCAN_DISALLOW_PREFIX;
         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
+    }
     else
         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
 
diff --git a/proto.h b/proto.h
index a0abbdd..deed243 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, const U8 lookup_bit, const char prefix);
+#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)
@@ -5095,6 +5098,10 @@ STATIC AV*       S_mro_get_linear_isa_dfs(pTHX_ HV* stash, U32 level);
 #define PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS        \
        assert(stash)
 #endif
+#if defined(PERL_IN_NUMERIC_C)
+STATIC void    S_output_non_portable(pTHX_ const U8 shift);
+#define PERL_ARGS_ASSERT_OUTPUT_NON_PORTABLE
+#endif
 #if defined(PERL_IN_OP_C)
 STATIC void    S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs);
 #define PERL_ARGS_ASSERT_APPLY_ATTRS   \
index d0c0ae8..10802d6 100644 (file)
@@ -49,6 +49,9 @@ my %bit_names = (
             XDIGIT                  => 0,
             VERTSPACE               => 0,
             IS_IN_SOME_FOLD         => '_Perl_Any_Folds',
+            BINDIGIT                => [ ord '0', ord '1' ],
+            OCTDIGIT                => [ ord '0', ord '1', ord '2', ord '3',
+                                         ord '4', ord '5', ord '6', ord '7' ],
 
             # These are the control characters that there are mnemonics for
             MNEMONIC_CNTRL          => [ ord "\a", ord "\b", ord "\e", ord "\f",
index 5024c89..485a05f 100644 (file)
@@ -7286,7 +7286,7 @@ MPH_VALt match_uniprop( const unsigned char * const key, const U16 key_len ) {
  * 498da0b9ef6a52bfd71bda5771005bbe4cfc37b456d9d350cd840991eb80c8b1 lib/unicore/mktables
  * a712c758275b460d18fa77a26ed3589689bb3f69dcc1ea99b913e32db92a5cd2 lib/unicore/version
  * 2680b9254eb236c5c090f11b149605043e8c8433661b96efc4a42fb4709342a5 regen/charset_translations.pl
- * e9283c761c5a95e3379384ca47c13a284f08d743c2be6e5091f1152b1b6b7a37 regen/mk_PL_charclass.pl
+ * 6bbad21de0848e0236b02f34f5fa0edd3cdae9ba8173cc9469a5513936b9e728 regen/mk_PL_charclass.pl
  * eb6b8e366260282e03108163fbf907367474c469310d716a4a5c7b244d88ce45 regen/mk_invlists.pl
  * cf1d68efb7d919d302c4005641eae8d36da6d7850816ad374b0c00b45e609f43 regen/mph.pl
  * ex: set ro: */