#define SPACE_OR_TAB(c) isBLANK_A(c)
+#define HEXFP_PEEK(s) \
+ (((s[0] == '.') && \
+ (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
+ isALPHA_FOLD_EQ(s[0], 'p'))
+
/* LEX_* are values for PL_lex_state, the state of the lexer.
* They are arranged oddly so that the guard on the switch statement
* can get by with a single comparison (if the compiler is smart enough).
* PWop : power operator
* PMop : pattern-matching operator
* Aop : addition-level operator
+ * AopNOASSIGN : addition-level operator that is never part of .=
* Mop : multiplication-level operator
* Eop : equality-testing operator
* Rop : relational operator <= != gt
#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
#define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
#define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
-#define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
+#define LOOPX(f) return (PL_expect = XOPERATOR, \
+ PL_bufptr = force_word(s,WORD,TRUE,FALSE), \
+ pl_yylval.ival=f, \
+ (void)(PL_nexttoke || (PL_expect = XTERM)), \
+ REPORT((int)LOOPEX))
#define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
#define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
#define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
#define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
#define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
#define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
+#define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
#define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
#define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
#define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
STATIC int
S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
{
- dVAR;
-
PERL_ARGS_ASSERT_TOKEREPORT;
if (DEBUG_T_TEST) {
/*
* S_ao
*
- * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
- * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
+ * This subroutine looks for an '=' next to the operator that has just been
+ * parsed and turns it into an ASSIGNOP if it finds one.
*/
STATIC int
S_ao(pTHX_ int toketype)
{
- dVAR;
if (*PL_bufptr == '=') {
PL_bufptr++;
if (toketype == ANDAND)
STATIC void
S_no_op(pTHX_ const char *const what, char *s)
{
- dVAR;
char * const oldbp = PL_bufptr;
const bool is_first = (PL_oldbufptr == PL_linestart);
STATIC void
S_missingterm(pTHX_ char *s)
{
- dVAR;
char tmpbuf[3];
char q;
if (s) {
bool
Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
{
- dVAR;
char he_name[8 + MAX_FEATURE_LEN] = "feature_";
PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
void
Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
{
- dVAR;
const char *s = NULL;
yy_parser *parser, *oparser;
if (flags && flags & ~LEX_START_FLAGS)
STATIC void
S_incline(pTHX_ const char *s)
{
- dVAR;
const char *t;
const char *n;
const char *e;
if (*e != '\n' && *e != '\0')
return; /* false alarm */
- line_num = atoi(n)-1;
+ line_num = grok_atou(n, &e) - 1;
if (t - s > 0) {
const STRLEN len = t - s;
STATIC void
S_check_uni(pTHX)
{
- dVAR;
const char *s;
const char *t;
/*
* S_lop
* Build a list operator (or something that might be one). The rules:
- * - if we have a next token, then it's a list operator [why?]
+ * - if we have a next token, then it's a list operator (no parens) for
+ * which the next token has already been parsed; e.g.,
+ * sort foo @args
+ * sort foo (@args)
* - if the next thing is an opening paren, then it's a function
* - else it's a list operator
*/
STATIC I32
S_lop(pTHX_ I32 f, int x, char *s)
{
- dVAR;
-
PERL_ARGS_ASSERT_LOP;
pl_yylval.ival = f;
CLINE;
- PL_expect = x;
PL_bufptr = s;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = (OPCODE)f;
if (PL_nexttoke)
goto lstop;
+ PL_expect = x;
if (*s == '(')
return REPORT(FUNC);
s = PEEKSPACE(s);
STATIC void
S_force_next(pTHX_ I32 type)
{
- dVAR;
#ifdef DEBUGGING
if (DEBUG_T_TEST) {
PerlIO_printf(Perl_debug_log, "### forced token:\n");
static int
S_postderef(pTHX_ int const funny, char const next)
{
- dVAR;
assert(funny == DOLSHARP || strchr("$@%&*", funny));
assert(strchr("*[{", next));
if (next == '*') {
STATIC SV *
S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
{
- dVAR;
SV * const sv = newSVpvn_utf8(start, len,
!IN_BYTES
&& UTF
STATIC char *
S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
{
- dVAR;
char *s;
STRLEN len;
STATIC void
S_force_ident(pTHX_ const char *s, int kind)
{
- dVAR;
-
PERL_ARGS_ASSERT_FORCE_IDENT;
if (s[0]) {
STATIC char *
S_force_version(pTHX_ char *s, int guessing)
{
- dVAR;
OP *version = NULL;
char *d;
STATIC char *
S_force_strict_version(pTHX_ char *s)
{
- dVAR;
OP *version = NULL;
const char *errstr = NULL;
STATIC SV *
S_tokeq(pTHX_ SV *sv)
{
- dVAR;
char *s;
char *send;
char *d;
STATIC I32
S_sublex_start(pTHX)
{
- dVAR;
const I32 op_type = pl_yylval.ival;
if (op_type == OP_NULL) {
STATIC I32
S_sublex_push(pTHX)
{
- dVAR;
LEXSHARED *shared;
const bool is_heredoc = PL_multi_close == '<';
ENTER;
STATIC I32
S_sublex_done(pTHX)
{
- dVAR;
if (!PL_lex_starts++) {
SV * const sv = newSVpvs("");
if (SvUTF8(PL_linestr))
STATIC char *
S_scan_const(pTHX_ char *start)
{
- dVAR;
char *send = PL_bufend; /* end of the constant */
- SV *sv = newSV(send - start); /* sv for the constant. See
- note below on sizing. */
+ SV *sv = newSV(send - start); /* sv for the constant. See note below
+ on sizing. */
char *s = start; /* start of the constant */
char *d = SvPVX(sv); /* destination for copies */
- bool dorange = FALSE; /* are we in a translit range? */
- bool didrange = FALSE; /* did we just finish a range? */
- bool in_charclass = FALSE; /* within /[...]/ */
- bool has_utf8 = FALSE; /* Output constant is UTF8 */
- bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
- to be UTF8? But, this can
- show as true when the source
- isn't utf8, as for example
- when it is entirely composed
- of hex constants */
+ bool dorange = FALSE; /* are we in a translit range? */
+ bool didrange = FALSE; /* did we just finish a range? */
+ bool in_charclass = FALSE; /* within /[...]/ */
+ bool has_utf8 = FALSE; /* Output constant is UTF8 */
+ bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
+ UTF8? But, this can show as true
+ when the source isn't utf8, as for
+ example when it is entirely composed
+ of hex constants */
SV *res; /* result from charnames */
/* Note on sizing: The scanned constant is placed into sv, which is
i = d - SvPVX_const(sv); /* remember current offset */
#ifdef EBCDIC
SvGROW(sv,
- SvLEN(sv) + (has_utf8 ?
- (512 - UTF_CONTINUATION_MARK +
- UNISKIP(0x100))
+ SvLEN(sv) + ((has_utf8)
+ ? (512 - UTF_CONTINUATION_MARK
+ + UNISKIP(0x100))
: 256));
/* How many two-byte within 0..255: 128 in UTF-8,
* 96 in UTF-8-mod. */
}
#ifdef EBCDIC
+ /* Because of the discontinuities in EBCDIC A-Z and a-z, expand
+ * any subsets of these ranges into individual characters */
if (literal_endpoint == 2 &&
((isLOWER_A(min) && isLOWER_A(max)) ||
(isUPPER_A(min) && isUPPER_A(max))))
d += 5;
while (str < str_end) {
char hex_string[4];
- my_snprintf(hex_string, sizeof(hex_string),
- "%02X.", (U8) *str);
+ int len =
+ my_snprintf(hex_string,
+ sizeof(hex_string),
+ "%02X.", (U8) *str);
+ PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(hex_string));
Copy(hex_string, d, 3, char);
d += 3;
str++;
*d++ = '\t';
break;
case 'e':
- *d++ = ASCII_TO_NATIVE('\033');
+ *d++ = ESC_NATIVE;
break;
case 'a':
*d++ = '\a';
STATIC int
S_intuit_more(pTHX_ char *s)
{
- dVAR;
-
PERL_ARGS_ASSERT_INTUIT_MORE;
if (PL_lex_brackets)
STATIC int
S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
{
- dVAR;
char *s = start + (*start == '$');
char tmpbuf[sizeof PL_tokenbuf];
STRLEN len;
SV *
Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
{
- dVAR;
if (!funcp)
return NULL;
void
Perl_filter_del(pTHX_ filter_t funcp)
{
- dVAR;
SV *datasv;
PERL_ARGS_ASSERT_FILTER_DEL;
I32
Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
{
- dVAR;
filter_t funcp;
SV *datasv = NULL;
/* This API is bad. It should have been using unsigned int for maxlen.
STATIC char *
S_filter_gets(pTHX_ SV *sv, STRLEN append)
{
- dVAR;
-
PERL_ARGS_ASSERT_FILTER_GETS;
#ifdef PERL_CR_FILTER
STATIC HV *
S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
{
- dVAR;
GV *gv;
PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
STATIC char *
S_tokenize_use(pTHX_ int is_use, char *s) {
- dVAR;
-
PERL_ARGS_ASSERT_TOKENIZE_USE;
if (PL_expect != XSTATE)
#ifdef DEBUGGING
static const char* const exp_name[] =
{ "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
- "ATTRTERM", "TERMBLOCK", "POSTDEREF", "TERMORDORDOR"
+ "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
+ "TERMORDORDOR"
};
#endif
PL_lex_starts = 0;
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (PL_lex_casemods == 1 && PL_lex_inpat)
- OPERATOR(',');
+ TOKEN(',');
else
- Aop(OP_CONCAT);
+ AopNOASSIGN(OP_CONCAT);
}
else
return yylex();
s = PL_bufptr;
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (!PL_lex_casemods && PL_lex_inpat)
- OPERATOR(',');
+ TOKEN(',');
else
- Aop(OP_CONCAT);
+ AopNOASSIGN(OP_CONCAT);
}
return yylex();
if (PL_lex_starts++) {
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (!PL_lex_casemods && PL_lex_inpat)
- OPERATOR(',');
+ TOKEN(',');
else
- Aop(OP_CONCAT);
+ AopNOASSIGN(OP_CONCAT);
}
else {
PL_bufptr = s;
: Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
if (len > UNRECOGNIZED_PRECEDE_COUNT) {
- d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
+ d = UTF ? (char *) utf8_hop((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
} else {
d = PL_linestart;
}
* at least, set argv[0] to the basename of the Perl
* interpreter. So, having found "#!", we'll set it right.
*/
- SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
- SVt_PV)); /* $^X */
- assert(SvPOK(x) || SvGMAGICAL(x));
- if (sv_eq(x, CopFILESV(PL_curcop))) {
- sv_setpvn(x, ipath, ipathend - ipath);
- SvSETMAGIC(x);
- }
- else {
- STRLEN blen;
- STRLEN llen;
- const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
- const char * const lstart = SvPV_const(x,llen);
- if (llen < blen) {
- bstart += blen - llen;
- if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
- sv_setpvn(x, ipath, ipathend - ipath);
- SvSETMAGIC(x);
- }
+ SV* copfilesv = CopFILESV(PL_curcop);
+ if (copfilesv) {
+ SV * const x =
+ GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
+ SVt_PV)); /* $^X */
+ assert(SvPOK(x) || SvGMAGICAL(x));
+ if (sv_eq(x, copfilesv)) {
+ sv_setpvn(x, ipath, ipathend - ipath);
+ SvSETMAGIC(x);
+ }
+ else {
+ STRLEN blen;
+ STRLEN llen;
+ const char *bstart = SvPV_const(copfilesv, blen);
+ const char * const lstart = SvPV_const(x, llen);
+ if (llen < blen) {
+ bstart += blen - llen;
+ if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
+ sv_setpvn(x, ipath, ipathend - ipath);
+ SvSETMAGIC(x);
+ }
+ }
}
+ }
+ else {
+ /* Anything to do if no copfilesv? */
}
TAINT_NOT; /* $^X is always tainted, but that's OK */
}
* line contains "Perl" rather than "perl" */
if (!d) {
for (d = ipathend-4; d >= ipath; --d) {
- if ((*d == 'p' || *d == 'P')
+ if (isALPHA_FOLD_EQ(*d, 'p')
&& !ibcmp(d, "perl", 4))
{
break;
!= PL_unicode)
baduni = TRUE;
}
- if (baduni || *d1 == 'M' || *d1 == 'm') {
+ if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
const char * const m = d1;
while (*d1 && !isSPACE(*d1))
d1++;
goto just_a_word_zero_gv;
}
s++;
+ {
+ OP *attrs;
+
switch (PL_expect) {
- OP *attrs;
case XOPERATOR:
if (!PL_in_my || PL_lex_state != LEX_NORMAL)
break;
}
TOKEN(COLONATTR);
}
+ }
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
s--;
TOKEN(0);
TOKEN(0);
CLINE;
s++;
- OPERATOR(';');
+ PL_expect = XSTATE;
+ TOKEN(';');
case ')':
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
TOKEN(0);
PL_lex_allbrackets++;
PL_expect = XSTATE;
break;
+ case XBLOCKTERM:
+ PL_lex_brackstack[PL_lex_brackets++] = XTERM;
+ PL_lex_allbrackets++;
+ PL_expect = XSTATE;
+ break;
default: {
const char *t;
if (PL_oldoldbufptr == PL_last_lop)
TERM('@');
case '/': /* may be division, defined-or, or pattern */
- if (PL_expect == XTERMORDORDOR && s[1] == '/') {
+ if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
if (!PL_lex_allbrackets && PL_lex_fakeeof >=
(s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
TOKEN(0);
s += 2;
AOPERATOR(DORDOR);
}
- /* FALLTHROUGH */
- case '?': /* may either be conditional or pattern */
- if (PL_expect == XOPERATOR) {
- char tmp = *s++;
- if(tmp == '?') {
- if (!PL_lex_allbrackets &&
- PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
- s--;
- TOKEN(0);
- }
- PL_lex_allbrackets++;
- OPERATOR('?');
- }
- else {
- tmp = *s++;
- if(tmp == '/') {
- /* A // operator. */
- if (!PL_lex_allbrackets && PL_lex_fakeeof >=
- (*s == '=' ? LEX_FAKEEOF_ASSIGN :
- LEX_FAKEEOF_LOGIC)) {
- s -= 2;
- TOKEN(0);
- }
- AOPERATOR(DORDOR);
- }
- else {
- s--;
- if (*s == '=' && !PL_lex_allbrackets &&
- PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
- s--;
- TOKEN(0);
- }
- Mop(OP_DIVIDE);
- }
- }
- }
- else {
- /* Disable warning on "study /blah/" */
- if (PL_oldoldbufptr == PL_last_uni
- && (*PL_last_uni != 's' || s - PL_last_uni < 5
- || memNE(PL_last_uni, "study", 5)
- || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
- ))
- check_uni();
- if (*s == '?')
- deprecate("?PATTERN? without explicit operator");
- s = scan_pat(s,OP_MATCH);
- TERM(sublex_start());
- }
+ else if (PL_expect == XOPERATOR) {
+ s++;
+ if (*s == '=' && !PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s--;
+ TOKEN(0);
+ }
+ Mop(OP_DIVIDE);
+ }
+ else {
+ /* Disable warning on "study /blah/" */
+ if (PL_oldoldbufptr == PL_last_uni
+ && (*PL_last_uni != 's' || s - PL_last_uni < 5
+ || memNE(PL_last_uni, "study", 5)
+ || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
+ ))
+ check_uni();
+ s = scan_pat(s,OP_MATCH);
+ TERM(sublex_start());
+ }
+
+ case '?': /* conditional */
+ s++;
+ if (!PL_lex_allbrackets &&
+ PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
+ s--;
+ TOKEN(0);
+ }
+ PL_lex_allbrackets++;
+ OPERATOR('?');
case '.':
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
if (!PL_lex_allbrackets &&
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
- PREBLOCK(METHOD);
+ PL_expect = XBLOCKTERM;
+ PL_bufptr = s;
+ return REPORT(METHOD);
}
/* If followed by a bareword, see if it looks like indir obj. */
UNI(OP_DBMCLOSE);
case KEY_dump:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_DUMP);
case KEY_else:
LOP(OP_GREPSTART, XREF);
case KEY_goto:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_GOTO);
case KEY_gmtime:
LOP(OP_KILL,XTERM);
case KEY_last:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_LAST);
case KEY_lc:
PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
if (!PL_in_my_stash) {
char tmpbuf[1024];
+ int len;
PL_bufptr = s;
- my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
+ len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
+ PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
}
}
OPERATOR(MY);
case KEY_next:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_NEXT);
case KEY_ne:
case KEY_no:
s = tokenize_use(0, s);
- TERM(USE);
+ TOKEN(USE);
case KEY_not:
if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
}
else
pl_yylval.ival = 0;
- PL_expect = XTERM;
+ if (!PL_nexttoke) PL_expect = XTERM;
PL_bufptr = s;
PL_last_uni = PL_oldbufptr;
PL_last_lop_op = OP_REQUIRE;
UNI(OP_RESET);
case KEY_redo:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_REDO);
case KEY_rename:
case KEY_use:
s = tokenize_use(1, s);
- OPERATOR(USE);
+ TOKEN(USE);
case KEY_values:
UNI(OP_VALUES);
static int
S_pending_ident(pTHX)
{
- dVAR;
PADOFFSET tmp = 0;
const char pit = (char)pl_yylval.ival;
const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
STATIC void
S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
{
- dVAR;
-
PERL_ARGS_ASSERT_CHECKCOMMA;
if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
SV *sv, SV *pv, const char *type, STRLEN typelen)
{
- dVAR; dSP;
+ dSP;
HV * table = GvHV(PL_hintgv); /* ^H */
SV *res;
SV *errsv = NULL;
PERL_STATIC_INLINE void
S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
- dVAR;
PERL_ARGS_ASSERT_PARSE_IDENT;
for (;;) {
STATIC char *
S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
- dVAR;
char *d = dest;
char * const e = d + destlen - 3; /* two-character token, ending NUL */
bool is_utf8 = cBOOL(UTF);
STATIC char *
S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
{
- dVAR;
I32 herelines = PL_parser->herelines;
SSize_t bracket = -1;
char funny = *s++;
STATIC char *
S_scan_pat(pTHX_ char *start, I32 type)
{
- dVAR;
PMOP *pm;
char *s;
const char * const valid_flags =
PERL_ARGS_ASSERT_SCAN_PAT;
s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
- if (!s) {
- const char * const delimiter = skipspace(start);
- Perl_croak(aTHX_
- (const char *)
- (*delimiter == '?'
- ? "Search pattern not terminated or ternary operator parsed as search pattern"
- : "Search pattern not terminated" ));
- }
+ if (!s)
+ Perl_croak(aTHX_ "Search pattern not terminated");
pm = (PMOP*)newPMOP(type, 0);
if (PL_multi_open == '?') {
STATIC char *
S_scan_subst(pTHX_ char *start)
{
- dVAR;
char *s;
PMOP *pm;
I32 first_start;
STATIC char *
S_scan_trans(pTHX_ char *start)
{
- dVAR;
char* s;
OP *o;
U8 squash;
STATIC char *
S_scan_heredoc(pTHX_ char *s)
{
- dVAR;
I32 op_type = OP_SCALAR;
I32 len;
SV *tmpstr;
STATIC char *
S_scan_inputsymbol(pTHX_ char *start)
{
- dVAR;
char *s = start; /* current position in buffer */
char *end;
I32 len;
newUNOP(OP_RV2SV, 0,
newGVOP(OP_GV, 0, gv)));
}
- if (!readline_overriden)
- PL_lex_op->op_flags |= OPf_SPECIAL;
/* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
pl_yylval.ival = OP_NULL;
}
char **delimp
)
{
- dVAR;
SV *sv; /* scalar value: string */
const char *tmps; /* temp string, used for delimiter matching */
char *s = start; /* current position in the buffer */
\d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
\.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
- 0b[01](_?[01])*
- 0[0-7](_?[0-7])*
- 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
+ 0b[01](_?[01])* binary integers
+ 0[0-7](_?[0-7])* octal integers
+ 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
+ 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
thing it reads.
char *
Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
{
- dVAR;
const char *s = start; /* current position in buffer */
char *d; /* destination in temp buffer */
char *e; /* end of temp buffer */
bool floatit; /* boolean: int or float? */
const char *lastub = NULL; /* position of last underbar */
static const char* const number_too_long = "Number too long";
+ /* Hexadecimal floating point.
+ *
+ * In many places (where we have quads and NV is IEEE 754 double)
+ * we can fit the mantissa bits of a NV into an unsigned quad.
+ * (Note that UVs might not be quads even when we have quads.)
+ * This will not work everywhere, though (either no quads, or
+ * using long doubles), in which case we have to resort to NV,
+ * which will probably mean horrible loss of precision due to
+ * multiple fp operations. */
+ bool hexfp = FALSE;
+ int total_bits = 0;
+#if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
+# define HEXFP_UQUAD
+ Uquad_t hexfp_uquad = 0;
+ int hexfp_frac_bits = 0;
+#else
+# define HEXFP_NV
+ NV hexfp_nv = 0.0;
+#endif
+ NV hexfp_mult = 1.0;
+ UV high_non_zero = 0; /* highest digit */
PERL_ARGS_ASSERT_SCAN_NUM;
const char *base, *Base, *max;
/* check for hex */
- if (s[1] == 'x' || s[1] == 'X') {
+ if (isALPHA_FOLD_EQ(s[1], 'x')) {
shift = 4;
s += 2;
just_zero = FALSE;
- } else if (s[1] == 'b' || s[1] == 'B') {
+ } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
shift = 1;
s += 2;
just_zero = FALSE;
}
/* check for a decimal in disguise */
- else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
+ else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
goto decimal;
/* so it must be octal */
else {
if (!overflowed) {
x = u << shift; /* make room for the digit */
+ total_bits += shift;
+
if ((x >> shift) != u
&& !(PL_hints & HINT_NEW_BINARY)) {
overflowed = TRUE;
* amount. */
n += (NV) b;
}
+
+ if (high_non_zero == 0 && b > 0)
+ high_non_zero = b;
+
+ /* this could be hexfp, but peek ahead
+ * to avoid matching ".." */
+ if (UNLIKELY(HEXFP_PEEK(s))) {
+ goto out;
+ }
+
break;
}
}
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
}
+ if (UNLIKELY(HEXFP_PEEK(s))) {
+ /* Do sloppy (on the underbars) but quick detection
+ * (and value construction) for hexfp, the decimal
+ * detection will shortly be more thorough with the
+ * underbar checks. */
+ const char* h = s;
+#ifdef HEXFP_UQUAD
+ hexfp_uquad = u;
+#else /* HEXFP_NV */
+ hexfp_nv = u;
+#endif
+ if (*h == '.') {
+#ifdef HEXFP_NV
+ NV mult = 1 / 16.0;
+#endif
+ h++;
+ while (isXDIGIT(*h) || *h == '_') {
+ if (isXDIGIT(*h)) {
+ U8 b = XDIGIT_VALUE(*h);
+ total_bits += shift;
+#ifdef HEXFP_UQUAD
+ hexfp_uquad <<= shift;
+ hexfp_uquad |= b;
+ hexfp_frac_bits += shift;
+#else /* HEXFP_NV */
+ hexfp_nv += b * mult;
+ mult /= 16.0;
+#endif
+ }
+ h++;
+ }
+ }
+
+ if (total_bits >= 4) {
+ if (high_non_zero < 0x8)
+ total_bits--;
+ if (high_non_zero < 0x4)
+ total_bits--;
+ if (high_non_zero < 0x2)
+ total_bits--;
+ }
+
+ if (total_bits > 0 && (isALPHA_FOLD_EQ(*h, 'p'))) {
+ bool negexp = FALSE;
+ h++;
+ if (*h == '+')
+ h++;
+ else if (*h == '-') {
+ negexp = TRUE;
+ h++;
+ }
+ if (isDIGIT(*h)) {
+ I32 hexfp_exp = 0;
+ while (isDIGIT(*h) || *h == '_') {
+ if (isDIGIT(*h)) {
+ hexfp_exp *= 10;
+ hexfp_exp += *h - '0';
+#ifdef NV_MIN_EXP
+ if (negexp &&
+ -hexfp_exp < NV_MIN_EXP - 1) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Hexadecimal float: exponent underflow");
+#endif
+ break;
+ }
+ else {
+#ifdef NV_MAX_EXP
+ if (!negexp &&
+ hexfp_exp > NV_MAX_EXP - 1) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Hexadecimal float: exponent overflow");
+ break;
+ }
+#endif
+ }
+ }
+ h++;
+ }
+ if (negexp)
+ hexfp_exp = -hexfp_exp;
+#ifdef HEXFP_UQUAD
+ hexfp_exp -= hexfp_frac_bits;
+#endif
+ hexfp_mult = pow(2.0, hexfp_exp);
+ hexfp = TRUE;
+ goto decimal;
+ }
+ }
+ }
+
if (overflowed) {
if (n > 4294967295.0)
Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
decimal:
d = PL_tokenbuf;
e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
- floatit = FALSE;
+ floatit = FALSE;
+ if (hexfp) {
+ floatit = TRUE;
+ *d++ = '0';
+ *d++ = 'x';
+ s = start + 2;
+ }
/* read next group of digits and _ and copy into d */
- while (isDIGIT(*s) || *s == '_') {
+ while (isDIGIT(*s) || *s == '_' ||
+ UNLIKELY(hexfp && isXDIGIT(*s))) {
/* skip underscores, checking for misplaced ones
if -w is on
*/
/* copy, ignoring underbars, until we run out of digits.
*/
- for (; isDIGIT(*s) || *s == '_'; s++) {
+ for (; isDIGIT(*s) || *s == '_' ||
+ UNLIKELY(hexfp && isXDIGIT(*s));
+ s++) {
/* fixed length buffer check */
if (d >= e)
Perl_croak(aTHX_ "%s", number_too_long);
}
/* read exponent part, if present */
- if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
- floatit = TRUE;
+ if ((isALPHA_FOLD_EQ(*s, 'e')
+ || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
+ && strchr("+-0123456789_", s[1]))
+ {
+ floatit = TRUE;
+
+ /* regardless of whether user said 3E5 or 3e5, use lower 'e',
+ ditto for p (hexfloats) */
+ if ((isALPHA_FOLD_EQ(*s, 'e'))) {
+ /* At least some Mach atof()s don't grok 'E' */
+ *d++ = 'e';
+ }
+ else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
+ *d++ = 'p';
+ }
+
s++;
- /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
- *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
/* stray preinitial _ */
if (*s == '_') {
STORE_NUMERIC_LOCAL_SET_STANDARD();
/* terminate the string */
*d = '\0';
- nv = Atof(PL_tokenbuf);
+ if (UNLIKELY(hexfp)) {
+# ifdef NV_MANT_DIG
+ if (total_bits > NV_MANT_DIG)
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Hexadecimal float: mantissa overflow");
+# endif
+#ifdef HEXFP_UQUAD
+ nv = hexfp_uquad * hexfp_mult;
+#else /* HEXFP_NV */
+ nv = hexfp_nv * hexfp_mult;
+#endif
+ } else {
+ nv = Atof(PL_tokenbuf);
+ }
RESTORE_NUMERIC_LOCAL();
- sv = newSVnv(nv);
+ sv = newSVnv(nv);
}
if ( floatit
STATIC char *
S_scan_formline(pTHX_ char *s)
{
- dVAR;
char *eol;
char *t;
SV * const stuff = newSVpvs("");
I32
Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
{
- dVAR;
const I32 oldsavestack_ix = PL_savestack_ix;
CV* const outsidecv = PL_compcv;
static int
S_yywarn(pTHX_ const char *const s, U32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_YYWARN;
PL_in_eval |= EVAL_WARNONLY;
int
Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
{
- dVAR;
const char *context = NULL;
int contlen = -1;
SV *msg;
STATIC char*
S_swallow_bom(pTHX_ U8 *s)
{
- dVAR;
const STRLEN slen = SvCUR(PL_linestr);
PERL_ARGS_ASSERT_SWALLOW_BOM;
static I32
S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
{
- dVAR;
SV *const filter = FILTER_DATA(idx);
/* We re-use this each time round, throwing the contents away before we
return. */
char *
Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
{
- dVAR;
const char *pos = s;
const char *start = s;