X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/61bac25cda61b4427e5f2b2a645379733dac20a6..5d288d736c2758c27a5943647f4a524f0e93a642:/toke.c diff --git a/toke.c b/toke.c index 72d2649..8585b7a 100644 --- a/toke.c +++ b/toke.c @@ -23,7 +23,6 @@ /* =head1 Lexer interface - This is the lower layer of the Perl parser, managing characters and tokens. =for apidoc AmU|yy_parser *|PL_parser @@ -55,7 +54,6 @@ Individual members of C have their own documentation. #define PL_lex_casestack (PL_parser->lex_casestack) #define PL_lex_defer (PL_parser->lex_defer) #define PL_lex_dojoin (PL_parser->lex_dojoin) -#define PL_lex_expect (PL_parser->lex_expect) #define PL_lex_formbrack (PL_parser->lex_formbrack) #define PL_lex_inpat (PL_parser->lex_inpat) #define PL_lex_inwhat (PL_parser->lex_inwhat) @@ -88,37 +86,13 @@ Individual members of C have their own documentation. #define PL_multi_end (PL_parser->multi_end) #define PL_error_count (PL_parser->error_count) -#ifdef PERL_MAD -# define PL_endwhite (PL_parser->endwhite) -# define PL_faketokens (PL_parser->faketokens) -# define PL_lasttoke (PL_parser->lasttoke) -# define PL_nextwhite (PL_parser->nextwhite) -# define PL_realtokenstart (PL_parser->realtokenstart) -# define PL_skipwhite (PL_parser->skipwhite) -# define PL_thisclose (PL_parser->thisclose) -# define PL_thismad (PL_parser->thismad) -# define PL_thisopen (PL_parser->thisopen) -# define PL_thisstuff (PL_parser->thisstuff) -# define PL_thistoken (PL_parser->thistoken) -# define PL_thiswhite (PL_parser->thiswhite) -# define PL_thiswhite (PL_parser->thiswhite) -# define PL_nexttoke (PL_parser->nexttoke) -# define PL_curforce (PL_parser->curforce) -#else # define PL_nexttoke (PL_parser->nexttoke) # define PL_nexttype (PL_parser->nexttype) # define PL_nextval (PL_parser->nextval) -#endif static const char* const ident_too_long = "Identifier too long"; -#ifdef PERL_MAD -# define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; } -# define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val -#else -# define CURMAD(slot,sv) # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke] -#endif #define XENUMMASK 0x3f #define XFAKEEOF 0x40 @@ -139,6 +113,11 @@ static const char* const ident_too_long = "Identifier too long"; #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). @@ -188,18 +167,6 @@ static const char* const lex_state_names[] = { #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline)) -#ifdef PERL_MAD -# define SKIPSPACE0(s) skipspace0(s) -# define SKIPSPACE1(s) skipspace1(s) -# define SKIPSPACE2(s,tsv) skipspace2(s,&tsv) -# define PEEKSPACE(s) skipspace2(s,0) -#else -# define SKIPSPACE0(s) skipspace(s) -# define SKIPSPACE1(s) skipspace(s) -# define SKIPSPACE2(s,tsv) skipspace(s) -# define PEEKSPACE(s) skipspace(s) -#endif - /* * Convenience functions to return different tokens and prime the * lexer for the next token. They all take an argument. @@ -223,6 +190,7 @@ static const char* const lex_state_names[] = { * 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 @@ -244,7 +212,10 @@ static const char* const lex_state_names[] = { #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_bufptr = force_word(s,WORD,TRUE,FALSE), \ + pl_yylval.ival=f, \ + PL_expect = PL_nexttoke ? XOPERATOR : 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)) @@ -255,6 +226,7 @@ static const char* const lex_state_names[] = { #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)) @@ -272,7 +244,7 @@ static const char* const lex_state_names[] = { PL_last_lop_op = f; \ if (*s == '(') \ return REPORT( (int)FUNC1 ); \ - s = PEEKSPACE(s); \ + s = skipspace(s); \ return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \ } #define UNI(f) UNI3(f,XTERM,1) @@ -375,7 +347,6 @@ static struct debug_tokens { { OROP, TOKENTYPE_IVAL, "OROP" }, { OROR, TOKENTYPE_NONE, "OROR" }, { PACKAGE, TOKENTYPE_NONE, "PACKAGE" }, - { PEG, TOKENTYPE_NONE, "PEG" }, { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" }, { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" }, { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" }, @@ -411,8 +382,6 @@ static struct debug_tokens { STATIC int S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp) { - dVAR; - PERL_ARGS_ASSERT_TOKEREPORT; if (DEBUG_T_TEST) { @@ -482,7 +451,9 @@ S_printbuf(pTHX_ const char *const fmt, const char *const s) PERL_ARGS_ASSERT_PRINTBUF; + GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */ PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60)); + GCC_DIAG_RESTORE; SvREFCNT_dec(tmp); } @@ -498,14 +469,13 @@ S_deprecate_commaless_var_list(pTHX) { /* * 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) @@ -535,7 +505,6 @@ S_ao(pTHX_ int toketype) 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); @@ -582,7 +551,6 @@ S_no_op(pTHX_ const char *const what, char *s) STATIC void S_missingterm(pTHX_ char *s) { - dVAR; char tmpbuf[3]; char q; if (s) { @@ -613,7 +581,6 @@ S_missingterm(pTHX_ char *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; @@ -705,7 +672,6 @@ used by perl internally, so extensions should always pass zero. 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) @@ -727,11 +693,7 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags) /* initialise lexer state */ -#ifdef PERL_MAD - parser->curforce = -1; -#else parser->nexttoke = 0; -#endif parser->error_count = oparser ? oparser->error_count : 0; parser->copline = parser->preambling = NOLINE; parser->lex_state = LEX_NORMAL; @@ -806,23 +768,9 @@ Perl_parser_free(pTHX_ const yy_parser *parser) void Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab) { -#ifdef PERL_MAD - I32 nexttoke = parser->lasttoke; -#else I32 nexttoke = parser->nexttoke; -#endif PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS; while (nexttoke--) { -#ifdef PERL_MAD - if (S_is_opval_token(parser->nexttoke[nexttoke].next_type - & 0xffff) - && parser->nexttoke[nexttoke].next_val.opval - && parser->nexttoke[nexttoke].next_val.opval->op_slabbed - && OpSLAB(parser->nexttoke[nexttoke].next_val.opval) == slab) { - op_free(parser->nexttoke[nexttoke].next_val.opval); - parser->nexttoke[nexttoke].next_val.opval = NULL; - } -#else if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff) && parser->nextval[nexttoke].opval && parser->nextval[nexttoke].opval->op_slabbed @@ -830,7 +778,6 @@ Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab) op_free(parser->nextval[nexttoke].opval); parser->nextval[nexttoke].opval = NULL; } -#endif } } @@ -867,7 +814,7 @@ through normal scalar means. Direct pointer to the end of the chunk of text currently being lexed, the end of the lexer buffer. This is equal to Clinestr) -+ SvCUR(PL_parser-Elinestr)>. A NUL character (zero octet) is ++ SvCUR(PL_parser-Elinestr)>. A C character (zero octet) is always located at the end of the buffer, and does not count as part of the buffer's contents. @@ -934,7 +881,7 @@ Perl_lex_bufutf8(pTHX) =for apidoc Amx|char *|lex_grow_linestr|STRLEN len Reallocates the lexer buffer (Llinestr>) to accommodate -at least I octets (including terminating NUL). Returns a +at least I octets (including terminating C). Returns a pointer to the reallocated buffer. This is necessary before making any direct modification of the buffer that would increase its length. L provides a more convenient way to insert text into @@ -1357,10 +1304,6 @@ Perl_lex_next_chunk(pTHX_ U32 flags) (void)PerlIO_close(PL_parser->rsfp); PL_parser->rsfp = NULL; PL_parser->in_pod = PL_parser->filtered = 0; -#ifdef PERL_MAD - if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n)) - PL_faketokens = 1; -#endif if (!PL_in_eval && PL_minus_p) { sv_catpvs(linestr, /*{*/";}continue{print or die qq(-p destination: $!\\n);}"); @@ -1534,14 +1477,6 @@ Perl_lex_read_space(pTHX_ U32 flags) bool need_incline = 0; if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE)) Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space"); -#ifdef PERL_MAD - if (PL_skipwhite) { - sv_free(PL_skipwhite); - PL_skipwhite = NULL; - } - if (PL_madskills) - PL_skipwhite = newSVpvs(""); -#endif /* PERL_MAD */ s = PL_parser->bufptr; bufend = PL_parser->bufend; while (1) { @@ -1564,10 +1499,6 @@ Perl_lex_read_space(pTHX_ U32 flags) } else if (c == 0 && s == bufend) { bool got_more; line_t l; -#ifdef PERL_MAD - if (PL_madskills) - sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr); -#endif /* PERL_MAD */ if (flags & LEX_NO_NEXT_CHUNK) break; PL_parser->bufptr = s; @@ -1587,10 +1518,6 @@ Perl_lex_read_space(pTHX_ U32 flags) break; } } -#ifdef PERL_MAD - if (PL_madskills) - sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr); -#endif /* PERL_MAD */ PL_parser->bufptr = s; } @@ -1708,7 +1635,6 @@ Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn) STATIC void S_incline(pTHX_ const char *s) { - dVAR; const char *t; const char *n; const char *e; @@ -1762,7 +1688,7 @@ S_incline(pTHX_ const char *s) 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; @@ -1827,85 +1753,6 @@ S_incline(pTHX_ const char *s) #define skipspace(s) skipspace_flags(s, 0) -#ifdef PERL_MAD -/* skip space before PL_thistoken */ - -STATIC char * -S_skipspace0(pTHX_ char *s) -{ - PERL_ARGS_ASSERT_SKIPSPACE0; - - s = skipspace(s); - if (!PL_madskills) - return s; - if (PL_skipwhite) { - if (!PL_thiswhite) - PL_thiswhite = newSVpvs(""); - sv_catsv(PL_thiswhite, PL_skipwhite); - sv_free(PL_skipwhite); - PL_skipwhite = 0; - } - PL_realtokenstart = s - SvPVX(PL_linestr); - return s; -} - -/* skip space after PL_thistoken */ - -STATIC char * -S_skipspace1(pTHX_ char *s) -{ - const char *start = s; - I32 startoff = start - SvPVX(PL_linestr); - - PERL_ARGS_ASSERT_SKIPSPACE1; - - s = skipspace(s); - if (!PL_madskills) - return s; - start = SvPVX(PL_linestr) + startoff; - if (!PL_thistoken && PL_realtokenstart >= 0) { - const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart; - PL_thistoken = newSVpvn(tstart, start - tstart); - } - PL_realtokenstart = -1; - if (PL_skipwhite) { - if (!PL_nextwhite) - PL_nextwhite = newSVpvs(""); - sv_catsv(PL_nextwhite, PL_skipwhite); - sv_free(PL_skipwhite); - PL_skipwhite = 0; - } - return s; -} - -STATIC char * -S_skipspace2(pTHX_ char *s, SV **svp) -{ - char *start; - const I32 startoff = s - SvPVX(PL_linestr); - - PERL_ARGS_ASSERT_SKIPSPACE2; - - s = skipspace(s); - if (!PL_madskills || !svp) - return s; - start = SvPVX(PL_linestr) + startoff; - if (!PL_thistoken && PL_realtokenstart >= 0) { - char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart; - PL_thistoken = newSVpvn(tstart, start - tstart); - PL_realtokenstart = -1; - } - if (PL_skipwhite) { - if (!*svp) - *svp = newSVpvs(""); - sv_setsv(*svp, PL_skipwhite); - sv_free(PL_skipwhite); - PL_skipwhite = 0; - } - - return s; -} -#endif STATIC void S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len) @@ -1941,16 +1788,7 @@ S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len) STATIC char * S_skipspace_flags(pTHX_ char *s, U32 flags) { -#ifdef PERL_MAD - char *start = s; -#endif /* PERL_MAD */ PERL_ARGS_ASSERT_SKIPSPACE_FLAGS; -#ifdef PERL_MAD - if (PL_skipwhite) { - sv_free(PL_skipwhite); - PL_skipwhite = NULL; - } -#endif /* PERL_MAD */ if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; @@ -1966,10 +1804,6 @@ S_skipspace_flags(pTHX_ char *s, U32 flags) PL_bufptr = PL_linestart; return s; } -#ifdef PERL_MAD - if (PL_madskills) - PL_skipwhite = newSVpvn(start, s-start); -#endif /* PERL_MAD */ return s; } @@ -1985,7 +1819,6 @@ S_skipspace_flags(pTHX_ char *s, U32 flags) STATIC void S_check_uni(pTHX) { - dVAR; const char *s; const char *t; @@ -2014,7 +1847,10 @@ S_check_uni(pTHX) /* * 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 */ @@ -2022,26 +1858,19 @@ S_check_uni(pTHX) 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; -#ifdef PERL_MAD - if (PL_lasttoke) - goto lstop; -#else if (PL_nexttoke) goto lstop; -#endif + PL_expect = x; if (*s == '(') return REPORT(FUNC); - s = PEEKSPACE(s); + s = skipspace(s); if (*s == '(') return REPORT(FUNC); else { @@ -2052,113 +1881,30 @@ S_lop(pTHX_ I32 f, int x, char *s) } } -#ifdef PERL_MAD - /* - * S_start_force - * Sets up for an eventual force_next(). start_force(0) basically does - * an unshift, while start_force(-1) does a push. yylex removes items - * on the "pop" end. - */ - -STATIC void -S_start_force(pTHX_ int where) -{ - int i; - - if (where < 0) /* so people can duplicate start_force(PL_curforce) */ - where = PL_lasttoke; - assert(PL_curforce < 0 || PL_curforce == where); - if (PL_curforce != where) { - for (i = PL_lasttoke; i > where; --i) { - PL_nexttoke[i] = PL_nexttoke[i-1]; - } - PL_lasttoke++; - } - if (PL_curforce < 0) /* in case of duplicate start_force() */ - Zero(&PL_nexttoke[where], 1, NEXTTOKE); - PL_curforce = where; - if (PL_nextwhite) { - if (PL_madskills) - curmad('^', newSVpvs("")); - CURMAD('_', PL_nextwhite); - } -} - -STATIC void -S_curmad(pTHX_ char slot, SV *sv) -{ - MADPROP **where; - - if (!sv) - return; - if (PL_curforce < 0) - where = &PL_thismad; - else - where = &PL_nexttoke[PL_curforce].next_mad; - - if (PL_faketokens) - sv_setpvs(sv, ""); - else { - if (!IN_BYTES) { - if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv))) - SvUTF8_on(sv); - else if (PL_encoding) { - sv_recode_to_utf8(sv, PL_encoding); - } - } - } - - /* keep a slot open for the head of the list? */ - if (slot != '_' && *where && (*where)->mad_key == '^') { - (*where)->mad_key = slot; - sv_free(MUTABLE_SV(((*where)->mad_val))); - (*where)->mad_val = (void*)sv; - } - else - addmad(newMADsv(slot, sv), where, 0); -} -#else -# define start_force(where) NOOP -# define curmad(slot, sv) NOOP -#endif - /* * S_force_next * When the lexer realizes it knows the next token (for instance, * it is reordering tokens for the parser) then it can call S_force_next * to know what token to return the next time the lexer is called. Caller - * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD), - * and possibly PL_expect to ensure the lexer handles the token correctly. + * will need to set PL_nextval[] and possibly PL_expect to ensure + * the lexer handles the token correctly. */ STATIC void S_force_next(pTHX_ I32 type) { - dVAR; #ifdef DEBUGGING if (DEBUG_T_TEST) { PerlIO_printf(Perl_debug_log, "### forced token:\n"); tokereport(type, &NEXTVAL_NEXTTOKE); } #endif -#ifdef PERL_MAD - if (PL_curforce < 0) - start_force(PL_lasttoke); - PL_nexttoke[PL_curforce].next_type = type; - if (PL_lex_state != LEX_KNOWNEXT) - PL_lex_defer = PL_lex_state; - PL_lex_state = LEX_KNOWNEXT; - PL_lex_expect = PL_expect; - PL_curforce = -1; -#else PL_nexttype[PL_nexttoke] = type; PL_nexttoke++; if (PL_lex_state != LEX_KNOWNEXT) { PL_lex_defer = PL_lex_state; - PL_lex_expect = PL_expect; PL_lex_state = LEX_KNOWNEXT; } -#endif } /* @@ -2171,20 +1917,17 @@ S_force_next(pTHX_ I32 type) */ static int -S_postderef(pTHX_ char const funny, char const next) +S_postderef(pTHX_ int const funny, char const next) { - dVAR; - assert(strchr("$@%&*", funny)); + assert(funny == DOLSHARP || strchr("$@%&*", funny)); assert(strchr("*[{", next)); if (next == '*') { PL_expect = XOPERATOR; if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) { - assert('@' == funny || '$' == funny); + assert('@' == funny || '$' == funny || DOLSHARP == funny); PL_lex_state = LEX_INTERPEND; - start_force(PL_curforce); force_next(POSTJOIN); } - start_force(PL_curforce); force_next(next); PL_bufptr+=2; } @@ -2204,7 +1947,6 @@ Perl_yyunlex(pTHX) int yyc = PL_parser->yychar; if (yyc != YYEMPTY) { if (yyc) { - start_force(-1); NEXTVAL_NEXTTOKE = PL_parser->yylval; if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) { PL_lex_allbrackets--; @@ -2223,7 +1965,6 @@ Perl_yyunlex(pTHX) STATIC SV * S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len) { - dVAR; SV * const sv = newSVpvn_utf8(start, len, !IN_BYTES && UTF @@ -2246,19 +1987,17 @@ S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len) * a keyword (do this if the word is a label, e.g. goto FOO) * int allow_pack : if true, : characters will also be allowed (require, * use, etc. do this) - * int allow_initial_tick : used by the "sub" lexer only. */ STATIC char * S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack) { - dVAR; char *s; STRLEN len; PERL_ARGS_ASSERT_FORCE_WORD; - start = SKIPSPACE1(start); + start = skipspace(start); s = start; if (isIDFIRST_lazy_if(s,UTF) || (allow_pack && *s == ':') ) @@ -2271,19 +2010,14 @@ S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack) if (keyword(s2, len, 0)) return start; } - start_force(PL_curforce); - if (PL_madskills) - curmad('X', newSVpvn(start,s-start)); if (token == METHOD) { - s = SKIPSPACE1(s); + s = skipspace(s); if (*s == '(') PL_expect = XTERM; else { PL_expect = XOPERATOR; } } - if (PL_madskills) - curmad('g', newSVpvs( "forced" )); NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST,0, S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len)); @@ -2305,15 +2039,12 @@ S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack) STATIC void S_force_ident(pTHX_ const char *s, int kind) { - dVAR; - PERL_ARGS_ASSERT_FORCE_IDENT; if (s[0]) { const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */ OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0)); - start_force(PL_curforce); NEXTVAL_NEXTTOKE.opval = o; force_next(WORD); if (kind) { @@ -2322,7 +2053,7 @@ S_force_ident(pTHX_ const char *s, int kind) warnings if the symbol must be introduced in an eval. GSAR 96-10-12 */ gv_fetchpvn_flags(s, len, - (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) + (PL_in_eval ? GV_ADDMULTI : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ), kind == '$' ? SVt_PV : kind == '@' ? SVt_PVAV : @@ -2336,7 +2067,6 @@ S_force_ident(pTHX_ const char *s, int kind) static void S_force_ident_maybe_lex(pTHX_ char pit) { - start_force(PL_curforce); NEXTVAL_NEXTTOKE.ival = pit; force_next('p'); } @@ -2380,16 +2110,12 @@ Perl_str_to_version(pTHX_ SV *sv) STATIC char * S_force_version(pTHX_ char *s, int guessing) { - dVAR; OP *version = NULL; char *d; -#ifdef PERL_MAD - I32 startoff = s - SvPVX(PL_linestr); -#endif PERL_ARGS_ASSERT_FORCE_VERSION; - s = SKIPSPACE1(s); + s = skipspace(s); d = s; if (*d == 'v') @@ -2397,23 +2123,9 @@ S_force_version(pTHX_ char *s, int guessing) if (isDIGIT(*d)) { while (isDIGIT(*d) || *d == '_' || *d == '.') d++; -#ifdef PERL_MAD - if (PL_madskills) { - start_force(PL_curforce); - curmad('X', newSVpvn(s,d-s)); - } -#endif if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) { SV *ver; -#ifdef USE_LOCALE_NUMERIC - char *loc = savepv(setlocale(LC_NUMERIC, NULL)); - setlocale(LC_NUMERIC, "C"); -#endif s = scan_num(s, &pl_yylval); -#ifdef USE_LOCALE_NUMERIC - setlocale(LC_NUMERIC, loc); - Safefree(loc); -#endif version = pl_yylval.opval; ver = cSVOPx(version)->op_sv; if (SvPOK(ver) && !SvNIOK(ver)) { @@ -2423,26 +2135,11 @@ S_force_version(pTHX_ char *s, int guessing) } } else if (guessing) { -#ifdef PERL_MAD - if (PL_madskills) { - sv_free(PL_nextwhite); /* let next token collect whitespace */ - PL_nextwhite = 0; - s = SvPVX(PL_linestr) + startoff; - } -#endif return s; } } -#ifdef PERL_MAD - if (PL_madskills && !version) { - sv_free(PL_nextwhite); /* let next token collect whitespace */ - PL_nextwhite = 0; - s = SvPVX(PL_linestr) + startoff; - } -#endif /* NOTE: The parser sees the package name and the VERSION swapped */ - start_force(PL_curforce); NEXTVAL_NEXTTOKE.opval = version; force_next(WORD); @@ -2457,11 +2154,7 @@ S_force_version(pTHX_ char *s, int guessing) STATIC char * S_force_strict_version(pTHX_ char *s) { - dVAR; OP *version = NULL; -#ifdef PERL_MAD - I32 startoff = s - SvPVX(PL_linestr); -#endif const char *errstr = NULL; PERL_ARGS_ASSERT_FORCE_STRICT_VERSION; @@ -2475,7 +2168,7 @@ S_force_strict_version(pTHX_ char *s) version = newSVOP(OP_CONST, 0, ver); } else if ( (*s != ';' && *s != '{' && *s != '}' ) && - (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' ))) + (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' ))) { PL_bufptr = s; if (errstr) @@ -2483,15 +2176,7 @@ S_force_strict_version(pTHX_ char *s) return s; } -#ifdef PERL_MAD - if (PL_madskills && !version) { - sv_free(PL_nextwhite); /* let next token collect whitespace */ - PL_nextwhite = 0; - s = SvPVX(PL_linestr) + startoff; - } -#endif /* NOTE: The parser sees the package name and the VERSION swapped */ - start_force(PL_curforce); NEXTVAL_NEXTTOKE.opval = version; force_next(WORD); @@ -2509,7 +2194,6 @@ S_force_strict_version(pTHX_ char *s) STATIC SV * S_tokeq(pTHX_ SV *sv) { - dVAR; char *s; char *send; char *d; @@ -2580,7 +2264,6 @@ S_tokeq(pTHX_ SV *sv) STATIC I32 S_sublex_start(pTHX) { - dVAR; const I32 op_type = pl_yylval.ival; if (op_type == OP_NULL) { @@ -2630,7 +2313,6 @@ S_sublex_start(pTHX) STATIC I32 S_sublex_push(pTHX) { - dVAR; LEXSHARED *shared; const bool is_heredoc = PL_multi_close == '<'; ENTER; @@ -2727,7 +2409,6 @@ S_sublex_push(pTHX) STATIC I32 S_sublex_done(pTHX) { - dVAR; if (!PL_lex_starts++) { SV * const sv = newSVpvs(""); if (SvUTF8(PL_linestr)) @@ -2744,7 +2425,8 @@ S_sublex_done(pTHX) /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */ assert(PL_lex_inwhat != OP_TRANSR); - if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) { + if (PL_lex_repl) { + assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS); PL_linestr = PL_lex_repl; PL_lex_inpat = 0; PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); @@ -2779,20 +2461,6 @@ S_sublex_done(pTHX) } else { const line_t l = CopLINE(PL_curcop); -#ifdef PERL_MAD - if (PL_madskills) { - if (PL_thiswhite) { - if (!PL_endwhite) - PL_endwhite = newSVpvs(""); - sv_catsv(PL_endwhite, PL_thiswhite); - PL_thiswhite = 0; - } - if (PL_thistoken) - sv_setpvs(PL_thistoken,""); - else - PL_realtokenstart = -1; - } -#endif LEAVE; if (PL_multi_close == '<') PL_parser->herelines += l - PL_multi_end; @@ -2870,8 +2538,9 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) * look to see that the first character is legal. Then loop through the * rest checking that each is a continuation */ - /* This code needs to be sync'ed with a regex in _charnames.pm which does - * the same thing */ + /* This code makes the reasonable assumption that the only Latin1-range + * characters that begin a character name alias are alphabetic, otherwise + * would have to create a isCHARNAME_BEGIN macro */ if (! UTF) { if (! isALPHAU(*s)) { @@ -2882,18 +2551,16 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) if (! isCHARNAME_CONT(*s)) { goto bad_charname; } - if (*s == ' ' && *(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) { + if (*s == ' ' && *(s-1) == ' ') { + goto multi_spaces; + } + if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) { Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), - "A sequence of multiple spaces in a charnames " + "NO-BREAK SPACE in a charnames " "alias definition is deprecated"); } s++; } - if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) { - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), - "Trailing white-space in a charnames alias " - "definition is deprecated"); - } } else { /* Similarly for utf8. For invariants can check directly; for other @@ -2929,11 +2596,8 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) if (! isCHARNAME_CONT(*s)) { goto bad_charname; } - if (*s == ' ' && *(s-1) == ' ' - && ckWARN_d(WARN_DEPRECATED)) { - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), - "A sequence of multiple spaces in a charnam" - "es alias definition is deprecated"); + if (*s == ' ' && *(s-1) == ' ') { + goto multi_spaces; } s++; } @@ -2942,6 +2606,14 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) { goto bad_charname; } + if (*s == *NBSP_UTF8 + && *(s+1) == *(NBSP_UTF8+1) + && ckWARN_d(WARN_DEPRECATED)) + { + Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), + "NO-BREAK SPACE in a charnames " + "alias definition is deprecated"); + } s += 2; } else { @@ -2958,11 +2630,17 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) s += UTF8SKIP(s); } } - if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) { - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), - "Trailing white-space in a charnames alias " - "definition is deprecated"); - } + } + if (*(s-1) == ' ') { + yyerror_pv( + Perl_form(aTHX_ + "charnames alias definitions may not contain trailing " + "white-space; marked by <-- HERE in %.*s<-- HERE %.*s", + (int)(s - backslash_ptr + 1), backslash_ptr, + (int)(e - s + 1), s + 1 + ), + UTF ? SVf_UTF8 : 0); + return NULL; } if (SvUTF8(res)) { /* Don't accept malformed input */ @@ -2993,19 +2671,29 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) return res; bad_charname: { - int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1); /* The final %.*s makes sure that should the trailing NUL be missing * that this print won't run off the end of the string */ yyerror_pv( Perl_form(aTHX_ "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s", - (int)(s - backslash_ptr + bad_char_size), backslash_ptr, - (int)(e - s + bad_char_size), s + bad_char_size + (int)(s - backslash_ptr + 1), backslash_ptr, + (int)(e - s + 1), s + 1 ), UTF ? SVf_UTF8 : 0); return NULL; } + + multi_spaces: + yyerror_pv( + Perl_form(aTHX_ + "charnames alias definitions may not contain a sequence of " + "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s", + (int)(s - backslash_ptr + 1), backslash_ptr, + (int)(e - s + 1), s + 1 + ), + UTF ? SVf_UTF8 : 0); + return NULL; } /* @@ -3100,22 +2788,20 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) 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 @@ -3183,9 +2869,9 @@ S_scan_const(pTHX_ char *start) 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. */ @@ -3226,6 +2912,8 @@ S_scan_const(pTHX_ char *start) } #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)))) @@ -3406,7 +3094,7 @@ S_scan_const(pTHX_ char *start) else if (PL_lex_inpat && (*s != 'N' || s[1] != '{' - || regcurly(s + 1, FALSE))) + || regcurly(s + 1))) { *d++ = '\\'; goto default_action; @@ -3420,7 +3108,7 @@ S_scan_const(pTHX_ char *start) *d++ = *s++; continue; } - /* FALL THROUGH */ + /* FALLTHROUGH */ default: { if ((isALPHANUMERIC(*s))) @@ -3673,8 +3361,11 @@ S_scan_const(pTHX_ char *start) 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++; @@ -3764,6 +3455,10 @@ S_scan_const(pTHX_ char *start) const STRLEN off = d - SvPVX_const(sv); d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1); } + if (! SvUTF8(res)) { /* Make sure is \N{} return is UTF-8 */ + sv_utf8_upgrade(res); + str = SvPV_const(res, len); + } Copy(str, d, len, char); d += len; } @@ -3782,7 +3477,7 @@ S_scan_const(pTHX_ char *start) case 'c': s++; if (s < send) { - *d++ = grok_bslash_c(*s++, has_utf8, 1); + *d++ = grok_bslash_c(*s++, 1); } else { yyerror("Missing control char name in \\c"); @@ -3806,7 +3501,7 @@ S_scan_const(pTHX_ char *start) *d++ = '\t'; break; case 'e': - *d++ = ASCII_TO_NATIVE('\033'); + *d++ = ESC_NATIVE; break; case 'a': *d++ = '\a'; @@ -3941,7 +3636,7 @@ S_scan_const(pTHX_ char *start) * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/ * * ->[ and ->{ return TRUE - * ->$* ->@* ->@[ and ->@{ return TRUE if postfix_interpolate is enabled + * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled * { and [ outside a pattern are always subscripts, so return TRUE * if we're outside a pattern and it's not { or [, then return FALSE * if we're in a pattern and the first char is a { @@ -3959,8 +3654,6 @@ S_scan_const(pTHX_ char *start) STATIC int S_intuit_more(pTHX_ char *s) { - dVAR; - PERL_ARGS_ASSERT_INTUIT_MORE; if (PL_lex_brackets) @@ -3969,7 +3662,7 @@ S_intuit_more(pTHX_ char *s) return TRUE; if (*s == '-' && s[1] == '>' && FEATURE_POSTDEREF_QQ_IS_ENABLED - && ( (s[2] == '$' && s[3] == '*') + && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*'))) ||(s[2] == '@' && strchr("*[{",s[3])) )) return TRUE; if (*s != '{' && *s != '[') @@ -3979,7 +3672,7 @@ S_intuit_more(pTHX_ char *s) /* In a pattern, so maybe we have {n,m}. */ if (*s == '{') { - if (regcurly(s, FALSE)) { + if (regcurly(s)) { return FALSE; } return TRUE; @@ -4119,16 +3812,18 @@ S_intuit_more(pTHX_ char *s) */ STATIC int -S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) +S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv) { - dVAR; char *s = start + (*start == '$'); char tmpbuf[sizeof PL_tokenbuf]; STRLEN len; GV* indirgv; -#ifdef PERL_MAD - int soff; -#endif + /* Mustn't actually add anything to a symbol table. + But also don't want to "initialise" any placeholder + constants that might already be there into full + blown PVGVs with attached PVCV. */ + GV * const gv = + ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL; PERL_ARGS_ASSERT_INTUIT_METHOD; @@ -4148,13 +3843,7 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY || isUPPER(*PL_tokenbuf)) return 0; -#ifdef PERL_MAD - len = start - SvPVX(PL_linestr); -#endif - s = PEEKSPACE(s); -#ifdef PERL_MAD - start = SvPVX(PL_linestr) + len; -#endif + s = skipspace(s); PL_bufptr = start; PL_expect = XREF; return *s == '(' ? FUNCMETH : METHOD; @@ -4170,9 +3859,6 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') { len -= 2; tmpbuf[len] = '\0'; -#ifdef PERL_MAD - soff = s - SvPVX(PL_linestr); -#endif goto bare_package; } indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV); @@ -4180,26 +3866,16 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) return 0; /* filehandle or package name makes it a method */ if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) { -#ifdef PERL_MAD - soff = s - SvPVX(PL_linestr); -#endif - s = PEEKSPACE(s); + s = skipspace(s); if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>') return 0; /* no assumptions -- "=>" quotes bareword */ bare_package: - start_force(PL_curforce); NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, S_newSV_maybe_utf8(aTHX_ tmpbuf, len)); NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE; - if (PL_madskills) - curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start, - ( UTF ? SVf_UTF8 : 0 ))); PL_expect = XTERM; force_next(WORD); PL_bufptr = s; -#ifdef PERL_MAD - PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */ -#endif return *s == '(' ? FUNCMETH : METHOD; } } @@ -4226,7 +3902,6 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) SV * Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) { - dVAR; if (!funcp) return NULL; @@ -4295,7 +3970,6 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) void Perl_filter_del(pTHX_ filter_t funcp) { - dVAR; SV *datasv; PERL_ARGS_ASSERT_FILTER_DEL; @@ -4323,7 +3997,6 @@ Perl_filter_del(pTHX_ filter_t funcp) 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. @@ -4413,8 +4086,6 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) STATIC char * S_filter_gets(pTHX_ SV *sv, STRLEN append) { - dVAR; - PERL_ARGS_ASSERT_FILTER_GETS; #ifdef PERL_CR_FILTER @@ -4437,7 +4108,6 @@ S_filter_gets(pTHX_ SV *sv, STRLEN append) STATIC HV * S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len) { - dVAR; GV *gv; PERL_ARGS_ASSERT_FIND_IN_MY_STASH; @@ -4457,209 +4127,26 @@ S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len) if (gv && GvCV(gv)) { SV * const sv = cv_const_sv(GvCV(gv)); if (sv) - pkgname = SvPV_const(sv, len); + return gv_stashsv(sv, 0); } return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0); } -#ifdef PERL_MAD - /* - * Perl_madlex - * The intent of this yylex wrapper is to minimize the changes to the - * tokener when we aren't interested in collecting madprops. It remains - * to be seen how successful this strategy will be... - */ - -int -Perl_madlex(pTHX) -{ - int optype; - char *s = PL_bufptr; - - /* make sure PL_thiswhite is initialized */ - PL_thiswhite = 0; - PL_thismad = 0; - - /* previous token ate up our whitespace? */ - if (!PL_lasttoke && PL_nextwhite) { - PL_thiswhite = PL_nextwhite; - PL_nextwhite = 0; - } - - /* isolate the token, and figure out where it is without whitespace */ - PL_realtokenstart = -1; - PL_thistoken = 0; - optype = yylex(); - s = PL_bufptr; - assert(PL_curforce < 0); - - if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */ - if (!PL_thistoken) { - if (PL_realtokenstart < 0 || !CopLINE(PL_curcop)) - PL_thistoken = newSVpvs(""); - else { - char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart; - PL_thistoken = newSVpvn(tstart, s - tstart); - } - } - if (PL_thismad) /* install head */ - CURMAD('X', PL_thistoken); - } - - /* last whitespace of a sublex? */ - if (optype == ')' && PL_endwhite) { - CURMAD('X', PL_endwhite); - } - - if (!PL_thismad) { - - /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */ - if (!PL_thiswhite && !PL_endwhite && !optype) { - sv_free(PL_thistoken); - PL_thistoken = 0; - return 0; - } - - /* put off final whitespace till peg */ - if (optype == ';' && !PL_rsfp && !PL_parser->filtered) { - PL_nextwhite = PL_thiswhite; - PL_thiswhite = 0; - } - else if (PL_thisopen) { - CURMAD('q', PL_thisopen); - if (PL_thistoken) - sv_free(PL_thistoken); - PL_thistoken = 0; - } - else { - /* Store actual token text as madprop X */ - CURMAD('X', PL_thistoken); - } - - if (PL_thiswhite) { - /* add preceding whitespace as madprop _ */ - CURMAD('_', PL_thiswhite); - } - - if (PL_thisstuff) { - /* add quoted material as madprop = */ - CURMAD('=', PL_thisstuff); - } - - if (PL_thisclose) { - /* add terminating quote as madprop Q */ - CURMAD('Q', PL_thisclose); - } - } - - /* special processing based on optype */ - - switch (optype) { - - /* opval doesn't need a TOKEN since it can already store mp */ - case WORD: - case METHOD: - case FUNCMETH: - case THING: - case PMFUNC: - case PRIVATEREF: - case FUNC0SUB: - case UNIOPSUB: - case LSTOPSUB: - if (pl_yylval.opval) - append_madprops(PL_thismad, pl_yylval.opval, 0); - PL_thismad = 0; - return optype; - - /* fake EOF */ - case 0: - optype = PEG; - if (PL_endwhite) { - addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0); - PL_endwhite = 0; - } - break; - - /* pval */ - case LABEL: - break; - - case ']': - case '}': - if (PL_faketokens) - break; - /* remember any fake bracket that lexer is about to discard */ - if (PL_lex_brackets == 1 && - ((expectation)PL_lex_brackstack[0] & XFAKEBRACK)) - { - s = PL_bufptr; - while (s < PL_bufend && (*s == ' ' || *s == '\t')) - s++; - if (*s == '}') { - PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr); - addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0); - PL_thiswhite = 0; - PL_bufptr = s - 1; - break; /* don't bother looking for trailing comment */ - } - else - s = PL_bufptr; - } - if (optype == ']') - break; - /* FALLTHROUGH */ - - /* attach a trailing comment to its statement instead of next token */ - case ';': - if (PL_faketokens) - break; - if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) { - s = PL_bufptr; - while (s < PL_bufend && (*s == ' ' || *s == '\t')) - s++; - if (*s == '\n' || *s == '#') { - while (s < PL_bufend && *s != '\n') - s++; - if (s < PL_bufend) - s++; - PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr); - addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0); - PL_thiswhite = 0; - PL_bufptr = s; - } - } - break; - - /* ival */ - default: - break; - - } - - /* Create new token struct. Note: opvals return early above. */ - pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad); - PL_thismad = 0; - return optype; -} -#endif STATIC char * S_tokenize_use(pTHX_ int is_use, char *s) { - dVAR; - PERL_ARGS_ASSERT_TOKENIZE_USE; if (PL_expect != XSTATE) yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression", is_use ? "use" : "no")); PL_expect = XTERM; - s = SKIPSPACE1(s); + s = skipspace(s); if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { s = force_version(s, TRUE); if (*s == ';' || *s == '}' - || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) { - start_force(PL_curforce); + || (s = skipspace(s), (*s == ';' || *s == '}'))) { NEXTVAL_NEXTTOKE.opval = NULL; force_next(WORD); } @@ -4678,7 +4165,8 @@ S_tokenize_use(pTHX_ int is_use, char *s) { #ifdef DEBUGGING static const char* const exp_name[] = { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK", - "ATTRTERM", "TERMBLOCK", "POSTDEREF", "TERMORDORDOR" + "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF", + "TERMORDORDOR" }; #endif @@ -4787,42 +4275,15 @@ Perl_yylex(pTHX) /* when we've already built the next token, just pull it out of the queue */ case LEX_KNOWNEXT: -#ifdef PERL_MAD - PL_lasttoke--; - pl_yylval = PL_nexttoke[PL_lasttoke].next_val; - if (PL_madskills) { - PL_thismad = PL_nexttoke[PL_lasttoke].next_mad; - PL_nexttoke[PL_lasttoke].next_mad = 0; - if (PL_thismad && PL_thismad->mad_key == '_') { - PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val); - PL_thismad->mad_val = 0; - mad_free(PL_thismad); - PL_thismad = 0; - } - } - if (!PL_lasttoke) { - PL_lex_state = PL_lex_defer; - PL_expect = PL_lex_expect; - PL_lex_defer = LEX_NORMAL; - if (!PL_nexttoke[PL_lasttoke].next_type) - return yylex(); - } -#else PL_nexttoke--; pl_yylval = PL_nextval[PL_nexttoke]; if (!PL_nexttoke) { PL_lex_state = PL_lex_defer; - PL_expect = PL_lex_expect; PL_lex_defer = LEX_NORMAL; } -#endif { I32 next_type; -#ifdef PERL_MAD - next_type = PL_nexttoke[PL_lasttoke].next_type; -#else next_type = PL_nexttype[PL_nexttoke]; -#endif if (next_type & (7<<24)) { if (next_type & (1<<24)) { if (PL_lex_brackets > 100) @@ -4861,10 +4322,6 @@ Perl_yylex(pTHX) || oldmod == 'F')) { PL_bufptr += 2; PL_lex_state = LEX_INTERPCONCAT; -#ifdef PERL_MAD - if (PL_madskills) - PL_thistoken = newSVpvs("\\E"); -#endif } PL_lex_allbrackets--; return REPORT(')'); @@ -4874,20 +4331,8 @@ Perl_yylex(pTHX) Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of \\E"); } -#ifdef PERL_MAD - while (PL_bufptr != PL_bufend && - PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') { - if (PL_madskills) { - if (!PL_thiswhite) - PL_thiswhite = newSVpvs(""); - sv_catpvn(PL_thiswhite, PL_bufptr, 2); - } - PL_bufptr += 2; - } -#else if (PL_bufptr != PL_bufend) PL_bufptr += 2; -#endif PL_lex_state = LEX_INTERPCONCAT; return yylex(); } @@ -4896,22 +4341,14 @@ Perl_yylex(pTHX) "### Saw case modifier\n"); }); s = PL_bufptr + 1; if (s[1] == '\\' && s[2] == 'E') { -#ifdef PERL_MAD - if (PL_madskills) { - if (!PL_thiswhite) - PL_thiswhite = newSVpvs(""); - sv_catpvn(PL_thiswhite, PL_bufptr, 4); - } -#endif PL_bufptr = s + 3; PL_lex_state = LEX_INTERPCONCAT; return yylex(); } else { I32 tmp; - if (!PL_madskills) /* when just compiling don't need correct */ - if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) - tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */ + if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) + tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */ if ((*s == 'L' || *s == 'U' || *s == 'F') && (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U') @@ -4925,10 +4362,8 @@ Perl_yylex(pTHX) PL_lex_casestack[PL_lex_casemods++] = *s; PL_lex_casestack[PL_lex_casemods] = '\0'; PL_lex_state = LEX_INTERPCONCAT; - start_force(PL_curforce); NEXTVAL_NEXTTOKE.ival = 0; force_next((2<<24)|'('); - start_force(PL_curforce); if (*s == 'l') NEXTVAL_NEXTTOKE.ival = OP_LCFIRST; else if (*s == 'u') @@ -4943,31 +4378,17 @@ Perl_yylex(pTHX) NEXTVAL_NEXTTOKE.ival = OP_FC; else Perl_croak(aTHX_ "panic: yylex, *s=%u", *s); - if (PL_madskills) { - SV* const tmpsv = newSVpvs("\\ "); - /* replace the space with the character we want to escape - */ - SvPVX(tmpsv)[1] = *s; - curmad('_', tmpsv); - } PL_bufptr = s + 1; } force_next(FUNC); if (PL_lex_starts) { s = PL_bufptr; PL_lex_starts = 0; -#ifdef PERL_MAD - if (PL_madskills) { - if (PL_thistoken) - sv_free(PL_thistoken); - PL_thistoken = newSVpvs(""); - } -#endif /* 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(); @@ -4988,18 +4409,13 @@ Perl_yylex(pTHX) && (!PL_lex_inpat || PL_lex_casemods)); PL_lex_state = LEX_INTERPNORMAL; if (PL_lex_dojoin) { - start_force(PL_curforce); NEXTVAL_NEXTTOKE.ival = 0; force_next(','); - start_force(PL_curforce); force_ident("\"", '$'); - start_force(PL_curforce); NEXTVAL_NEXTTOKE.ival = 0; force_next('$'); - start_force(PL_curforce); NEXTVAL_NEXTTOKE.ival = 0; force_next((2<<24)|'('); - start_force(PL_curforce); NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */ force_next(FUNC); } @@ -5009,26 +4425,17 @@ Perl_yylex(pTHX) PL_bufptr += 2; if (*PL_bufptr != '{') PL_bufptr++; - start_force(PL_curforce); - /* XXX probably need a CURMAD(something) here */ PL_expect = XTERMBLOCK; force_next(DO); } if (PL_lex_starts++) { s = PL_bufptr; -#ifdef PERL_MAD - if (PL_madskills) { - if (PL_thistoken) - sv_free(PL_thistoken); - PL_thistoken = newSVpvs(""); - } -#endif /* 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(); @@ -5037,20 +4444,13 @@ Perl_yylex(pTHX) PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */ break; } - /* FALL THROUGH */ + /* FALLTHROUGH */ case LEX_INTERPEND: if (PL_lex_dojoin) { const U8 dojoin_was = PL_lex_dojoin; PL_lex_dojoin = FALSE; PL_lex_state = LEX_INTERPCONCAT; -#ifdef PERL_MAD - if (PL_madskills) { - if (PL_thistoken) - sv_free(PL_thistoken); - PL_thistoken = newSVpvs(""); - } -#endif PL_lex_allbrackets--; return REPORT(dojoin_was == 1 ? ')' : POSTJOIN); } @@ -5082,8 +4482,6 @@ Perl_yylex(pTHX) } else sv = newSVpvn(PL_parser->lex_shared->re_eval_start, PL_bufptr - PL_parser->lex_shared->re_eval_start); - start_force(PL_curforce); - /* XXX probably need a CURMAD(something) here */ NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, sv); @@ -5119,26 +4517,15 @@ Perl_yylex(pTHX) } if (s != PL_bufptr) { - start_force(PL_curforce); - if (PL_madskills) { - curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr)); - } NEXTVAL_NEXTTOKE = pl_yylval; PL_expect = XTERM; force_next(THING); if (PL_lex_starts++) { -#ifdef PERL_MAD - if (PL_madskills) { - if (PL_thistoken) - sv_free(PL_thistoken); - PL_thistoken = newSVpvs(""); - } -#endif /* 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; @@ -5166,13 +4553,6 @@ Perl_yylex(pTHX) PL_parser->saw_infix_sigil = 0; retry: -#ifdef PERL_MAD - if (PL_thistoken) { - sv_free(PL_thistoken); - PL_thistoken = 0; - } - PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */ -#endif switch (*s) { default: if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s)) @@ -5186,7 +4566,7 @@ Perl_yylex(pTHX) : 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; } @@ -5198,10 +4578,6 @@ Perl_yylex(pTHX) case 26: goto fake_eof; /* emulate EOF on ^D or ^Z */ case 0: -#ifdef PERL_MAD - if (PL_madskills) - PL_faketokens = 0; -#endif if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) { PL_last_uni = 0; PL_last_lop = 0; @@ -5223,10 +4599,6 @@ Perl_yylex(pTHX) PL_last_lop = 0; if (!PL_in_eval && !PL_preambled) { PL_preambled = TRUE; -#ifdef PERL_MAD - if (PL_madskills) - PL_faketokens = 1; -#endif if (PL_perldb) { /* Generate a string of Perl code to load the debugger. * If PERL5DB is set, it will return the contents of that, @@ -5312,10 +4684,6 @@ Perl_yylex(pTHX) TOKEN(';'); /* not infinite loop because rsfp is NULL now */ } CopLINE_dec(PL_curcop); -#ifdef PERL_MAD - if (!PL_rsfp) - PL_realtokenstart = -1; -#endif s = PL_bufptr; /* If it looks like the start of a BOM or raw UTF-16, * check if it in fact is. */ @@ -5338,10 +4706,6 @@ Perl_yylex(pTHX) } if (PL_parser->in_pod) { /* Incest with pod. */ -#ifdef PERL_MAD - if (PL_madskills) - sv_catsv(PL_thiswhite, PL_linestr); -#endif if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) { sv_setpvs(PL_linestr, ""); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); @@ -5361,10 +4725,6 @@ Perl_yylex(pTHX) s++; if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */ s++; -#ifdef PERL_MAD - if (PL_madskills) - PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart); -#endif d = NULL; if (!PL_in_eval) { if (*s == '#' && *(s+1) == '!') @@ -5396,25 +4756,32 @@ Perl_yylex(pTHX) * 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 */ } @@ -5431,7 +4798,7 @@ Perl_yylex(pTHX) * 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; @@ -5513,7 +4880,7 @@ Perl_yylex(pTHX) != 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++; @@ -5550,7 +4917,6 @@ Perl_yylex(pTHX) } if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { PL_lex_state = LEX_FORMLINE; - start_force(PL_curforce); NEXTVAL_NEXTTOKE.ival = 0; force_next(FORMRBRACK); TOKEN(';'); @@ -5563,100 +4929,54 @@ Perl_yylex(pTHX) "\t(Maybe you didn't strip carriage returns after a network transfer?)\n"); #endif case ' ': case '\t': case '\f': case 013: -#ifdef PERL_MAD - PL_realtokenstart = -1; - if (PL_madskills) { - if (!PL_thiswhite) - PL_thiswhite = newSVpvs(""); - sv_catpvn(PL_thiswhite, s, 1); - } -#endif s++; goto retry; case '#': case '\n': -#ifdef PERL_MAD - PL_realtokenstart = -1; - if (PL_madskills) - PL_faketokens = 0; -#endif if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) { + const bool in_comment = *s == '#'; if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp && !PL_parser->filtered) { /* handle eval qq[#line 1 "foo"\n ...] */ CopLINE_dec(PL_curcop); incline(s); } - if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) { - s = SKIPSPACE0(s); - if (!PL_in_eval || PL_rsfp || PL_parser->filtered) - incline(s); - } - else { - const bool in_comment = *s == '#'; - d = s; - while (d < PL_bufend && *d != '\n') - d++; - if (d < PL_bufend) - d++; - else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */ - Perl_croak(aTHX_ "panic: input overflow, %p > %p", - d, PL_bufend); -#ifdef PERL_MAD - if (PL_madskills) - PL_thiswhite = newSVpvn(s, d - s); -#endif - s = d; - if (in_comment && d == PL_bufend - && PL_lex_state == LEX_INTERPNORMAL - && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr - && SvEVALED(PL_lex_repl) && d[-1] == '}') s--; - else incline(s); - } + d = s; + while (d < PL_bufend && *d != '\n') + d++; + if (d < PL_bufend) + d++; + else if (d > PL_bufend) + /* Found by Ilya: feed random input to Perl. */ + Perl_croak(aTHX_ "panic: input overflow, %p > %p", + d, PL_bufend); + s = d; + if (in_comment && d == PL_bufend + && PL_lex_state == LEX_INTERPNORMAL + && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr + && SvEVALED(PL_lex_repl) && d[-1] == '}') s--; + else + incline(s); if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { PL_lex_state = LEX_FORMLINE; - start_force(PL_curforce); NEXTVAL_NEXTTOKE.ival = 0; force_next(FORMRBRACK); TOKEN(';'); } } else { -#ifdef PERL_MAD - if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) { - if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') { - PL_faketokens = 0; - s = SKIPSPACE0(s); - TOKEN(PEG); /* make sure any #! line is accessible */ - } - s = SKIPSPACE0(s); - } - else { -#endif - if (PL_madskills) d = s; - while (s < PL_bufend && *s != '\n') - s++; - if (s < PL_bufend) - { - s++; - if (s < PL_bufend) - incline(s); - } - else if (s > PL_bufend) /* Found by Ilya: feed random input to Perl. */ - Perl_croak(aTHX_ "panic: input overflow"); -#ifdef PERL_MAD - if (PL_madskills && CopLINE(PL_curcop) >= 1) { - if (!PL_thiswhite) - PL_thiswhite = newSVpvs(""); - if (CopLINE(PL_curcop) == 1) { - sv_setpvs(PL_thiswhite, ""); - PL_faketokens = 0; - } - sv_catpvn(PL_thiswhite, d, s - d); - } - } -#endif + while (s < PL_bufend && *s != '\n') + s++; + if (s < PL_bufend) + { + s++; + if (s < PL_bufend) + incline(s); + } + else if (s > PL_bufend) + /* Found by Ilya: feed random input to Perl. */ + Perl_croak(aTHX_ "panic: input overflow"); } goto retry; case '-': @@ -5742,9 +5062,10 @@ Perl_yylex(pTHX) } else if (*s == '>') { s++; - s = SKIPSPACE1(s); + s = skipspace(s); if (FEATURE_POSTDEREF_IS_ENABLED && ( ((*s == '$' || *s == '&') && s[1] == '*') + ||(*s == '$' && s[1] == '#' && s[2] == '*') ||((*s == '@' || *s == '%') && strchr("*[{", s[1])) ||(*s == '*' && (s[1] == '*' || s[1] == '{')) )) @@ -5899,11 +5220,10 @@ Perl_yylex(pTHX) goto just_a_word_zero_gv; } s++; + { + OP *attrs; + switch (PL_expect) { - OP *attrs; -#ifdef PERL_MAD - I32 stuffstart; -#endif case XOPERATOR: if (!PL_in_my || PL_lex_state != LEX_NORMAL) break; @@ -5919,10 +5239,7 @@ Perl_yylex(pTHX) case XATTRTERM: PL_expect = XTERMBLOCK; grabattrs: -#ifdef PERL_MAD - stuffstart = s - SvPVX(PL_linestr) - 1; -#endif - s = PEEKSPACE(s); + s = skipspace(s); attrs = NULL; while (isIDFIRST_lazy_if(s,UTF)) { I32 tmp; @@ -5946,7 +5263,7 @@ Perl_yylex(pTHX) } sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0); if (*d == '(') { - d = scan_str(d,TRUE,TRUE,FALSE,FALSE,NULL); + d = scan_str(d,TRUE,TRUE,FALSE,NULL); COPLINE_SET_FROM_MULTI_END; if (!d) { /* MUST advance bufptr here to avoid bogus @@ -6006,22 +5323,22 @@ Perl_yylex(pTHX) newSVOP(OP_CONST, 0, sv)); } - s = PEEKSPACE(d); + s = skipspace(d); if (*s == ':' && s[1] != ':') - s = PEEKSPACE(s+1); + s = skipspace(s+1); else if (s == d) break; /* require real whitespace or :'s */ /* XXX losing whitespace on sequential attributes here */ } { - const char tmp - = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */ - if (*s != ';' && *s != '}' && *s != tmp - && (tmp != '=' || *s != ')')) { + if (*s != ';' && *s != '}' && + !(PL_expect == XOPERATOR + ? (*s == '=' || *s == ')') + : (*s == '{' || *s == '('))) { const char q = ((*s == '\'') ? '"' : '\''); /* If here for an expression, and parsed no attrs, back off. */ - if (tmp == '=' && !attrs) { + if (PL_expect == XOPERATOR && !attrs) { s = PL_bufptr; break; } @@ -6041,19 +5358,12 @@ Perl_yylex(pTHX) } got_attrs: if (attrs) { - start_force(PL_curforce); NEXTVAL_NEXTTOKE.opval = attrs; - CURMAD('_', PL_nextwhite); force_next(THING); } -#ifdef PERL_MAD - if (PL_madskills) { - PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart, - (s - SvPVX(PL_linestr)) - stuffstart); - } -#endif TOKEN(COLONATTR); } + } if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) { s--; TOKEN(0); @@ -6066,7 +5376,7 @@ Perl_yylex(pTHX) PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */ else PL_expect = XTERM; - s = SKIPSPACE1(s); + s = skipspace(s); PL_lex_allbrackets++; TOKEN('('); case ';': @@ -6074,13 +5384,14 @@ Perl_yylex(pTHX) TOKEN(0); CLINE; s++; - OPERATOR(';'); + PL_expect = XSTATE; + TOKEN(';'); case ')': if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) TOKEN(0); s++; PL_lex_allbrackets--; - s = SKIPSPACE1(s); + s = skipspace(s); if (*s == '{') PREBLOCK(')'); TERM(')'); @@ -6137,16 +5448,21 @@ Perl_yylex(pTHX) force_next('-'); } } - /* FALL THROUGH */ + /* FALLTHROUGH */ + case XATTRTERM: + case XTERMBLOCK: + PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; + PL_lex_allbrackets++; + PL_expect = XSTATE; + break; case XATTRBLOCK: case XBLOCK: PL_lex_brackstack[PL_lex_brackets++] = XSTATE; PL_lex_allbrackets++; PL_expect = XSTATE; break; - case XATTRTERM: - case XTERMBLOCK: - PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; + case XBLOCKTERM: + PL_lex_brackstack[PL_lex_brackets++] = XTERM; PL_lex_allbrackets++; PL_expect = XSTATE; break; @@ -6157,7 +5473,7 @@ Perl_yylex(pTHX) else PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; PL_lex_allbrackets++; - s = SKIPSPACE1(s); + s = skipspace(s); if (*s == '}') { if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) { PL_expect = XTERM; @@ -6168,6 +5484,11 @@ Perl_yylex(pTHX) } OPERATOR(HASHBRACK); } + if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) { + /* ${...} or @{...} etc., but not print {...} */ + PL_expect = XTERM; + break; + } /* This hack serves to disambiguate a pair of curlies * as being a block or an anon hash. Normally, expectation * determines that, but in cases where we're not in a @@ -6187,7 +5508,7 @@ Perl_yylex(pTHX) if (*s == '\'' || *s == '"' || *s == '`') { /* common case: get past first string, handling escapes */ for (t++; t < PL_bufend && *t != *s;) - if (*t++ == '\\' && (*t == '\\' || *t == *s)) + if (*t++ == '\\') t++; t++; } @@ -6279,13 +5600,6 @@ Perl_yylex(pTHX) PL_expect &= XENUMMASK; PL_lex_state = LEX_INTERPEND; PL_bufptr = s; -#if 0 - if (PL_madskills) { - if (!PL_thiswhite) - PL_thiswhite = newSVpvs(""); - sv_catpvs(PL_thiswhite,"}"); - } -#endif return yylex(); /* ignore fake brackets */ } if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr @@ -6302,19 +5616,9 @@ Perl_yylex(pTHX) PL_bufptr = s; return yylex(); /* ignore fake brackets */ } - start_force(PL_curforce); - if (PL_madskills) { - curmad('X', newSVpvn(s-1,1)); - CURMAD('_', PL_thiswhite); - } force_next(formbrack ? '.' : '}'); if (formbrack) LEAVE; -#ifdef PERL_MAD - if (PL_madskills && !PL_thistoken) - PL_thistoken = newSVpvs(""); -#endif if (formbrack == 2) { /* means . where arguments were expected */ - start_force(PL_curforce); force_next(';'); TOKEN(FORMRBRACK); } @@ -6426,14 +5730,6 @@ Perl_yylex(pTHX) } goto retry; } -#ifdef PERL_MAD - if (PL_madskills) { - if (!PL_thiswhite) - PL_thiswhite = newSVpvs(""); - sv_catpvn(PL_thiswhite, PL_linestart, - PL_bufend - PL_linestart); - } -#endif s = PL_bufend; PL_parser->in_pod = 1; goto retry; @@ -6579,7 +5875,13 @@ Perl_yylex(pTHX) return deprecate_commaless_var_list(); } } - else if (PL_expect == XPOSTDEREF) POSTDEREF('$'); + else if (PL_expect == XPOSTDEREF) { + if (s[1] == '#') { + s++; + POSTDEREF(DOLSHARP); + } + POSTDEREF('$'); + } if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) { PL_tokenbuf[0] = '@'; @@ -6609,7 +5911,7 @@ Perl_yylex(pTHX) { const char tmp = *s; if (PL_lex_state == LEX_NORMAL || PL_lex_brackets) - s = SKIPSPACE1(s); + s = skipspace(s); if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { @@ -6621,7 +5923,7 @@ Perl_yylex(pTHX) while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$') t++; if (*t++ == ',') { - PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */ + PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */ while (t < PL_bufend && *t != ']') t++; Perl_warner(aTHX_ packWARN(WARN_SYNTAX), @@ -6721,7 +6023,7 @@ Perl_yylex(pTHX) PREREF('@'); } if (PL_lex_state == LEX_NORMAL) - s = SKIPSPACE1(s); + s = skipspace(s); if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { if (*s == '{') PL_tokenbuf[0] = '%'; @@ -6738,61 +6040,43 @@ Perl_yylex(pTHX) 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); } - 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 @@ -6835,7 +6119,7 @@ Perl_yylex(pTHX) } Aop(OP_CONCAT); } - /* FALL THROUGH */ + /* FALLTHROUGH */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': s = scan_num(s, &pl_yylval); @@ -6845,7 +6129,9 @@ Perl_yylex(pTHX) TERM(THING); case '\'': - s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); + s = scan_str(s,FALSE,FALSE,FALSE,NULL); + if (!s) + missingterm(NULL); COPLINE_SET_FROM_MULTI_END; DEBUG_T( { printbuf("### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { @@ -6855,13 +6141,11 @@ Perl_yylex(pTHX) else no_op("String",s); } - if (!s) - missingterm(NULL); pl_yylval.ival = OP_CONST; TERM(sublex_start()); case '"': - s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); + s = scan_str(s,FALSE,FALSE,FALSE,NULL); DEBUG_T( { if (s) printbuf("### Saw string before %s\n", s); @@ -6892,7 +6176,7 @@ Perl_yylex(pTHX) TERM(sublex_start()); case '`': - s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); + s = scan_str(s,FALSE,FALSE,FALSE,NULL); DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } ); if (PL_expect == XOPERATOR) no_op("Backticks",s); @@ -6930,7 +6214,7 @@ Perl_yylex(pTHX) } /* avoid v123abc() or $h{v1}, allow C */ if (!isALPHA(*start) && (PL_expect == XTERM - || PL_expect == XREF || PL_expect == XSTATE + || PL_expect == XSTATE || PL_expect == XTERMORDORDOR)) { GV *const gv = gv_fetchpvn_flags(s, start - s, UTF ? SVf_UTF8 : 0, SVt_PVCV); @@ -7035,12 +6319,12 @@ Perl_yylex(pTHX) } else if (result == KEYWORD_PLUGIN_STMT) { pl_yylval.opval = o; CLINE; - PL_expect = XSTATE; + if (!PL_nexttoke) PL_expect = XSTATE; return REPORT(PLUGSTMT); } else if (result == KEYWORD_PLUGIN_EXPR) { pl_yylval.opval = o; CLINE; - PL_expect = XOPERATOR; + if (!PL_nexttoke) PL_expect = XOPERATOR; return REPORT(PLUGEXPR); } else { Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'", @@ -7103,7 +6387,8 @@ Perl_yylex(pTHX) if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) { CV *cv; if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, - UTF ? SVf_UTF8 : 0, SVt_PVCV)) && + (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL, + SVt_PVCV)) && (cv = GvCVu(gv))) { if (GvIMPORTED_CV(gv)) @@ -7188,13 +6473,7 @@ Perl_yylex(pTHX) just_a_word: { int pkgname = 0; const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); - const char penultchar = - lastchar && PL_bufptr - 2 >= PL_linestart - ? PL_bufptr[-2] - : 0; -#ifdef PERL_MAD - SV *nextPL_nextwhite = 0; -#endif + bool safebw; /* Get the rest if it looks like a package qualifier */ @@ -7221,12 +6500,11 @@ Perl_yylex(pTHX) no_op("Bareword",s); } - /* Look for a subroutine with this name in current package, - unless this is a lexical sub, or name is "Foo::", + /* See if the name is "Foo::", in which case Foo is a bareword (and a package name). */ - if (len > 2 && !PL_madskills && + if (len > 2 && PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') { if (ckWARN(WARN_BAREWORD) @@ -7238,25 +6516,17 @@ Perl_yylex(pTHX) PL_tokenbuf[len] = '\0'; gv = NULL; gvp = 0; + safebw = TRUE; } else { - if (!lex && !gv) { - /* Mustn't actually add anything to a symbol table. - But also don't want to "initialise" any placeholder - constants that might already be there into full - blown PVGVs with attached PVCV. */ - gv = gv_fetchpvn_flags(PL_tokenbuf, len, - GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ), - SVt_PVCV); - } - len = 0; + safebw = FALSE; } /* if we saw a global override before, get the right name */ if (!sv) sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, - len ? len : strlen(PL_tokenbuf)); + len); if (gvp) { SV * const tmp_sv = sv; sv = newSVpvs("CORE::GLOBAL::"); @@ -7264,13 +6534,6 @@ Perl_yylex(pTHX) SvREFCNT_dec(tmp_sv); } -#ifdef PERL_MAD - if (PL_madskills && !PL_thistoken) { - char *start = SvPVX(PL_linestr) + PL_realtokenstart; - PL_thistoken = newSVpvn(start,s - start); - PL_realtokenstart = s - SvPVX(PL_linestr); - } -#endif /* Presume this is going to be a bareword of some sort. */ CLINE; @@ -7278,17 +6541,28 @@ Perl_yylex(pTHX) pl_yylval.opval->op_private = OPpCONST_BARE; /* And if "Foo::", then that's what it certainly is. */ - if (len) + if (safebw) goto safe_bareword; if (!off) { OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv)); const_op->op_private = OPpCONST_BARE; - rv2cv_op = newCVREF(0, const_op); - cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0); + rv2cv_op = + newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op); + cv = lex + ? isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? (CV *)SvRV(gv) + : (CV *)gv + : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB); } + /* Use this var to track whether intuit_method has been + called. intuit_method returns 0 or > 255. */ + tmp = 1; + /* See if it's the indirect object for a list operator. */ if (PL_oldoldbufptr && @@ -7302,20 +6576,13 @@ Perl_yylex(pTHX) bool immediate_paren = *s == '('; /* (Now we can afford to cross potential line boundary.) */ - s = SKIPSPACE2(s,nextPL_nextwhite); -#ifdef PERL_MAD - PL_nextwhite = nextPL_nextwhite; /* assume no & deception */ -#endif + s = skipspace(s); /* Two barewords in a row may indicate method call. */ if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && - (tmp = intuit_method(s, gv, cv))) { - op_free(rv2cv_op); - if (tmp == METHOD && !PL_lex_allbrackets && - PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) - PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; - return REPORT(tmp); + (tmp = intuit_method(s, lex ? NULL : sv, cv))) { + goto method; } /* If not a declared subroutine, it's an indirect object. */ @@ -7337,25 +6604,23 @@ Perl_yylex(pTHX) } PL_expect = XOPERATOR; -#ifdef PERL_MAD - if (isSPACE(*s)) - s = SKIPSPACE2(s,nextPL_nextwhite); - PL_nextwhite = nextPL_nextwhite; -#else s = skipspace(s); -#endif /* Is this a word before a => operator? */ if (*s == '=' && s[1] == '>' && !pkgname) { op_free(rv2cv_op); CLINE; - /* This is our own scalar, created a few lines above, - so this is safe. */ - SvREADONLY_off(cSVOPx(pl_yylval.opval)->op_sv); - sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf); - if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len)) - SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv); - SvREADONLY_on(cSVOPx(pl_yylval.opval)->op_sv); + if (gvp || (lex && !off)) { + assert (cSVOPx(pl_yylval.opval)->op_sv == sv); + /* This is our own scalar, created a few lines + above, so this is safe. */ + SvREADONLY_off(sv); + sv_setpv(sv, PL_tokenbuf); + if (UTF && !IN_BYTES + && is_utf8_string((U8*)PL_tokenbuf, len)) + SvUTF8_on(sv); + SvREADONLY_on(sv); + } TERM(WORD); } @@ -7371,23 +6636,8 @@ Perl_yylex(pTHX) goto its_constant; } } -#ifdef PERL_MAD - if (PL_madskills) { - PL_nextwhite = PL_thiswhite; - PL_thiswhite = 0; - } - start_force(PL_curforce); -#endif NEXTVAL_NEXTTOKE.opval = off ? rv2cv_op : pl_yylval.opval; - PL_expect = XOPERATOR; -#ifdef PERL_MAD - if (PL_madskills) { - PL_nextwhite = nextPL_nextwhite; - curmad('X', PL_thistoken); - PL_thistoken = newSVpvs(""); - } -#endif if (off) op_free(pl_yylval.opval), force_next(PRIVATEREF); else op_free(rv2cv_op), force_next(WORD); @@ -7404,14 +6654,26 @@ Perl_yylex(pTHX) 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. */ - if (!orig_keyword + if (tmp == 1 && !orig_keyword && (isIDFIRST_lazy_if(s,UTF) || *s == '$') - && (tmp = intuit_method(s, gv, cv))) { + && (tmp = intuit_method(s, lex ? NULL : sv, cv))) { + method: + if (lex && !off) { + assert(cSVOPx(pl_yylval.opval)->op_sv == sv); + SvREADONLY_off(sv); + sv_setpvn(sv, PL_tokenbuf, len); + if (UTF && !IN_BYTES + && is_utf8_string((U8*)PL_tokenbuf, len)) + SvUTF8_on (sv); + else SvUTF8_off(sv); + } op_free(rv2cv_op); if (tmp == METHOD && !PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) @@ -7422,13 +6684,6 @@ Perl_yylex(pTHX) /* Not a method, so call it a subroutine (if defined) */ if (cv) { - if (lastchar == '-' && penultchar != '-') { - const STRLEN l = len ? len : strlen(PL_tokenbuf); - Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS), - "Ambiguous use of -%"UTF8f" resolved as -&%"UTF8f"()", - UTF8fARG(UTF, l, PL_tokenbuf), - UTF8fARG(UTF, l, PL_tokenbuf)); - } /* Check for a constant sub */ if ((sv = cv_const_sv_or_av(cv))) { its_constant: @@ -7454,9 +6709,6 @@ Perl_yylex(pTHX) PL_last_lop_op = OP_ENTERSUB; /* Is there a prototype? */ if ( -#ifdef PERL_MAD - cv && -#endif SvPOK(cv)) { STRLEN protolen = CvPROTOLEN(cv); @@ -7500,71 +6752,6 @@ Perl_yylex(pTHX) PREBLOCK(LSTOPSUB); } } -#ifdef PERL_MAD - { - if (PL_madskills) { - PL_nextwhite = PL_thiswhite; - PL_thiswhite = 0; - } - start_force(PL_curforce); - NEXTVAL_NEXTTOKE.opval = pl_yylval.opval; - PL_expect = XTERM; - if (PL_madskills) { - PL_nextwhite = nextPL_nextwhite; - curmad('X', PL_thistoken); - PL_thistoken = newSVpvs(""); - } - force_next(off ? PRIVATEREF : WORD); - if (!PL_lex_allbrackets && - PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) - PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; - TOKEN(NOAMP); - } - } - - /* Guess harder when madskills require "best effort". */ - if (PL_madskills && (!gv || !GvCVu(gv))) { - int probable_sub = 0; - if (strchr("\"'`$@%0123456789!*+{[<", *s)) - probable_sub = 1; - else if (isALPHA(*s)) { - char tmpbuf[1024]; - STRLEN tmplen; - d = s; - d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen); - if (!keyword(tmpbuf, tmplen, 0)) - probable_sub = 1; - else { - while (d < PL_bufend && isSPACE(*d)) - d++; - if (*d == '=' && d[1] == '>') - probable_sub = 1; - } - } - if (probable_sub) { - gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), - SVt_PVCV); - op_free(pl_yylval.opval); - pl_yylval.opval = - off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op; - pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN; - PL_last_lop = PL_oldbufptr; - PL_last_lop_op = OP_ENTERSUB; - PL_nextwhite = PL_thiswhite; - PL_thiswhite = 0; - start_force(PL_curforce); - NEXTVAL_NEXTTOKE.opval = pl_yylval.opval; - PL_expect = XTERM; - PL_nextwhite = nextPL_nextwhite; - curmad('X', PL_thistoken); - PL_thistoken = newSVpvs(""); - force_next(off ? PRIVATEREF : WORD); - if (!PL_lex_allbrackets && - PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) - PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; - TOKEN(NOAMP); - } -#else NEXTVAL_NEXTTOKE.opval = pl_yylval.opval; PL_expect = XTERM; force_next(off ? PRIVATEREF : WORD); @@ -7572,7 +6759,6 @@ Perl_yylex(pTHX) PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; TOKEN(NOAMP); -#endif } /* Call it a bare word */ @@ -7599,8 +6785,13 @@ Perl_yylex(pTHX) while (isLOWER(*d)) d++; if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0)) + { + /* PL_warn_reserved is constant */ + GCC_DIAG_IGNORE(-Wformat-nonliteral); Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved, PL_tokenbuf); + GCC_DIAG_RESTORE; + } } } } @@ -7698,7 +6889,6 @@ Perl_yylex(pTHX) ENTER; SAVETMPS; PUSHMARK(sp); - EXTEND(SP, 1); XPUSHs(PL_encoding); PUTBACK; call_method("name", G_SCALAR); @@ -7713,21 +6903,6 @@ Perl_yylex(pTHX) } } #endif -#ifdef PERL_MAD - if (PL_madskills) { - if (PL_realtokenstart >= 0) { - char *tstart = SvPVX(PL_linestr) + PL_realtokenstart; - if (!PL_endwhite) - PL_endwhite = newSVpvs(""); - sv_catsv(PL_endwhite, PL_thiswhite); - PL_thiswhite = 0; - sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart); - PL_realtokenstart = -1; - } - while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite))) - != NULL) ; - } -#endif PL_rsfp = NULL; } goto fake_eof; @@ -7869,15 +7044,16 @@ Perl_yylex(pTHX) PREBLOCK(DEFAULT); case KEY_do: - s = SKIPSPACE1(s); + s = skipspace(s); if (*s == '{') PRETERMBLOCK(DO); if (*s != '\'') { *PL_tokenbuf = '&'; d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, 1, &len); - if (len && !keyword(PL_tokenbuf + 1, len, 0)) { - d = SKIPSPACE1(d); + if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE")) + && !keyword(PL_tokenbuf + 1, len, 0)) { + d = skipspace(d); if (*d == '(') { force_ident_maybe_lex('&'); s = d; @@ -7916,8 +7092,6 @@ Perl_yylex(pTHX) UNI(OP_DBMCLOSE); case KEY_dump: - PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_DUMP); case KEY_else: @@ -7936,12 +7110,10 @@ Perl_yylex(pTHX) UNI(OP_EXISTS); case KEY_exit: - if (PL_madskills) - UNI(OP_INT); UNI(OP_EXIT); case KEY_eval: - s = SKIPSPACE1(s); + s = skipspace(s); if (*s == '{') { /* block eval */ PL_expect = XTERMBLOCK; UNIBRACK(OP_ENTERTRY); @@ -7990,12 +7162,9 @@ Perl_yylex(pTHX) if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR) return REPORT(0); pl_yylval.ival = CopLINE(PL_curcop); - s = SKIPSPACE1(s); + s = skipspace(s); if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) { char *p = s; -#ifdef PERL_MAD - int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */ -#endif if ((PL_bufend - p) >= 3 && strnEQ(p, "my", 2) && isSPACE(*(p + 2))) @@ -8003,17 +7172,14 @@ Perl_yylex(pTHX) else if ((PL_bufend - p) >= 4 && strnEQ(p, "our", 3) && isSPACE(*(p + 3))) p += 3; - p = PEEKSPACE(p); + p = skipspace(p); /* skip optional package name, as in "for my abc $x (..)" */ if (isIDFIRST_lazy_if(p,UTF)) { p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); - p = PEEKSPACE(p); + p = skipspace(p); } if (*p != '$') Perl_croak(aTHX_ "Missing $ on loop variable"); -#ifdef PERL_MAD - s = SvPVX(PL_linestr) + soff; -#endif } OPERATOR(FOR); @@ -8049,8 +7215,6 @@ Perl_yylex(pTHX) LOP(OP_GREPSTART, XREF); case KEY_goto: - PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_GOTO); case KEY_gmtime: @@ -8175,8 +7339,6 @@ Perl_yylex(pTHX) LOP(OP_KILL,XTERM); case KEY_last: - PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_LAST); case KEY_lc: @@ -8246,11 +7408,8 @@ Perl_yylex(pTHX) case KEY_my: case KEY_state: PL_in_my = (U16)tmp; - s = SKIPSPACE1(s); + s = skipspace(s); if (isIDFIRST_lazy_if(s,UTF)) { -#ifdef PERL_MAD - char* start = s; -#endif s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3)) { @@ -8267,24 +7426,17 @@ Perl_yylex(pTHX) 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); } -#ifdef PERL_MAD - if (PL_madskills) { /* just add type to declarator token */ - sv_catsv(PL_thistoken, PL_nextwhite); - PL_nextwhite = 0; - sv_catpvn(PL_thistoken, start, s - start); - } -#endif } pl_yylval.ival = 1; OPERATOR(MY); case KEY_next: - PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_NEXT); case KEY_ne: @@ -8294,10 +7446,10 @@ Perl_yylex(pTHX) case KEY_no: s = tokenize_use(0, s); - TERM(USE); + TOKEN(USE); case KEY_not: - if (*s == '(' || (s = SKIPSPACE1(s), *s == '(')) + if (*s == '(' || (s = skipspace(s), *s == '(')) FUN1(OP_NOT); else { if (!PL_lex_allbrackets && @@ -8307,7 +7459,7 @@ Perl_yylex(pTHX) } case KEY_open: - s = SKIPSPACE1(s); + s = skipspace(s); if (isIDFIRST_lazy_if(s,UTF)) { const char *t; d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, @@ -8367,19 +7519,18 @@ Perl_yylex(pTHX) case KEY_package: s = force_word(s,WORD,FALSE,TRUE); - s = SKIPSPACE1(s); + s = skipspace(s); s = force_strict_version(s); - PL_lex_expect = XBLOCK; - OPERATOR(PACKAGE); + PREBLOCK(PACKAGE); case KEY_pipe: LOP(OP_PIPE_OP,XTERM); case KEY_q: - s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); - COPLINE_SET_FROM_MULTI_END; + s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) missingterm(NULL); + COPLINE_SET_FROM_MULTI_END; pl_yylval.ival = OP_CONST; TERM(sublex_start()); @@ -8388,10 +7539,10 @@ Perl_yylex(pTHX) case KEY_qw: { OP *words = NULL; - s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); - COPLINE_SET_FROM_MULTI_END; + s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) missingterm(NULL); + COPLINE_SET_FROM_MULTI_END; PL_expect = XOPERATOR; if (SvCUR(PL_lex_stuff)) { int warned_comma = !ckWARN(WARN_QW); @@ -8439,7 +7590,7 @@ Perl_yylex(pTHX) } case KEY_qq: - s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); + s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) missingterm(NULL); pl_yylval.ival = OP_STRINGIFY; @@ -8452,7 +7603,7 @@ Perl_yylex(pTHX) TERM(sublex_start()); case KEY_qx: - s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); + s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) missingterm(NULL); pl_yylval.ival = OP_BACKTICK; @@ -8462,8 +7613,7 @@ Perl_yylex(pTHX) OLDLOP(OP_RETURN); case KEY_require: - s = SKIPSPACE1(s); - PL_expect = XOPERATOR; + s = skipspace(s); if (isDIGIT(*s)) { s = force_version(s, FALSE); } @@ -8476,7 +7626,7 @@ Perl_yylex(pTHX) gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD | (UTF ? SVf_UTF8 : 0)); else if (*s == '<') - yyerror("<> should be quotes"); + yyerror("<> at require-statement should be quotes"); } if (orig_keyword == KEY_require) { orig_keyword = 0; @@ -8484,7 +7634,7 @@ Perl_yylex(pTHX) } else pl_yylval.ival = 0; - PL_expect = XTERM; + PL_expect = PL_nexttoke ? XOPERATOR : XTERM; PL_bufptr = s; PL_last_uni = PL_oldbufptr; PL_last_lop_op = OP_REQUIRE; @@ -8495,8 +7645,6 @@ Perl_yylex(pTHX) UNI(OP_RESET); case KEY_redo: - PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_REDO); case KEY_rename: @@ -8635,7 +7783,7 @@ Perl_yylex(pTHX) case KEY_sort: checkcomma(s,PL_tokenbuf,"subroutine name"); - s = SKIPSPACE1(s); + s = skipspace(s); PL_expect = XTERM; s = force_word(s,WORD,TRUE,TRUE); LOP(OP_SORT,XREF); @@ -8672,44 +7820,21 @@ Perl_yylex(pTHX) expectation attrful; bool have_name, have_proto; const int key = tmp; -#ifndef PERL_MAD SV *format_name = NULL; -#endif - -#ifdef PERL_MAD - SV *tmpwhite = 0; - char *tstart = SvPVX(PL_linestr) + PL_realtokenstart; - SV *subtoken = PL_madskills - ? newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr)) - : NULL; - PL_thistoken = 0; - - d = s; - s = SKIPSPACE2(s,tmpwhite); -#else d = s; s = skipspace(s); -#endif if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' || (*s == ':' && s[1] == ':')) { -#ifdef PERL_MAD - SV *nametoke = NULL; -#endif PL_expect = XBLOCK; attrful = XATTRBLOCK; d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE, &len); -#ifdef PERL_MAD - if (PL_madskills) - nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr)); -#else if (key == KEY_format) format_name = S_newSV_maybe_utf8(aTHX_ s, d - s); -#endif *PL_tokenbuf = '&'; if (memchr(tmpbuf, ':', len) || key != KEY_sub || pad_findmy_pvn( @@ -8726,16 +7851,7 @@ Perl_yylex(pTHX) have_name = TRUE; -#ifdef PERL_MAD - start_force(0); - CURMAD('X', nametoke); - CURMAD('_', tmpwhite); - force_ident_maybe_lex('&'); - - s = SKIPSPACE2(d,tmpwhite); -#else s = skipspace(d); -#endif } else { if (key == KEY_my || key == KEY_our || key==KEY_state) @@ -8752,77 +7868,44 @@ Perl_yylex(pTHX) } if (key == KEY_format) { -#ifdef PERL_MAD - PL_thistoken = subtoken; - s = d; -#else if (format_name) { - start_force(PL_curforce); NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST,0, format_name); NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE; force_next(WORD); } -#endif PREBLOCK(FORMAT); } /* Look for a prototype */ - if (*s == '(') { - s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); + if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) { + s = scan_str(s,FALSE,FALSE,FALSE,NULL); COPLINE_SET_FROM_MULTI_END; if (!s) Perl_croak(aTHX_ "Prototype not terminated"); (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO)); have_proto = TRUE; -#ifdef PERL_MAD - start_force(0); - CURMAD('q', PL_thisopen); - CURMAD('_', tmpwhite); - CURMAD('=', PL_thisstuff); - CURMAD('Q', PL_thisclose); - NEXTVAL_NEXTTOKE.opval = - (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff); - PL_lex_stuff = NULL; - force_next(THING); - - s = SKIPSPACE2(s,tmpwhite); -#else s = skipspace(s); -#endif } else have_proto = FALSE; if (*s == ':' && s[1] != ':') PL_expect = attrful; - else if (*s != '{' && key == KEY_sub) { + else if ((*s != '{' && *s != '(') && key == KEY_sub) { if (!have_name) Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine"); else if (*s != ';' && *s != '}') Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname)); } -#ifdef PERL_MAD - start_force(0); - if (tmpwhite) { - if (PL_madskills) - curmad('^', newSVpvs("")); - CURMAD('_', tmpwhite); - } - force_next(0); - - PL_thistoken = subtoken; - PERL_UNUSED_VAR(have_proto); -#else if (have_proto) { NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff); PL_lex_stuff = NULL; force_next(THING); } -#endif if (!have_name) { if (PL_curstash) sv_setpvs(PL_subname, "__ANON__"); @@ -8830,9 +7913,7 @@ Perl_yylex(pTHX) sv_setpvs(PL_subname, "__ANON__::__ANON__"); TOKEN(ANONSUB); } -#ifndef PERL_MAD force_ident_maybe_lex('&'); -#endif TOKEN(SUB); } @@ -8924,7 +8005,7 @@ Perl_yylex(pTHX) case KEY_use: s = tokenize_use(1, s); - OPERATOR(USE); + TOKEN(USE); case KEY_values: UNI(OP_VALUES); @@ -9008,7 +8089,6 @@ Perl_yylex(pTHX) static int S_pending_ident(pTHX) { - dVAR; PADOFFSET tmp = 0; const char pit = (char)pl_yylval.ival; const STRLEN tokenbuf_len = strlen(PL_tokenbuf); @@ -9033,10 +8113,14 @@ S_pending_ident(pTHX) tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0); } else { - if (has_colon) + if (has_colon) { + /* PL_no_myglob is constant */ + GCC_DIAG_IGNORE(-Wformat-nonliteral); yyerror_pv(Perl_form(aTHX_ PL_no_myglob, PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf), UTF ? SVf_UTF8 : 0); + GCC_DIAG_RESTORE; + } pl_yylval.opval = newOP(OP_PADANY, 0); pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len, @@ -9066,10 +8150,7 @@ S_pending_ident(pTHX) pl_yylval.opval->op_private = OPpCONST_ENTERED; if (pit != '&') gv_fetchsv(sym, - (PL_in_eval - ? (GV_ADDMULTI | GV_ADDINEVAL) - : GV_ADDMULTI - ), + GV_ADDMULTI, ((PL_tokenbuf[0] == '$') ? SVt_PV : (PL_tokenbuf[0] == '@') ? SVt_PVAV : SVt_PVHV)); @@ -9113,7 +8194,7 @@ S_pending_ident(pTHX) pl_yylval.opval->op_private = OPpCONST_ENTERED; if (pit != '&') gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1, - (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD) + (PL_in_eval ? GV_ADDMULTI : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ), ((PL_tokenbuf[0] == '$') ? SVt_PV : (PL_tokenbuf[0] == '@') ? SVt_PVAV @@ -9124,8 +8205,6 @@ S_pending_ident(pTHX) 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 */ @@ -9164,12 +8243,20 @@ S_checkcomma(pTHX_ const char *s, const char *name, const char *what) s++; if (*s == ',') { GV* gv; + PADOFFSET off; if (keyword(w, s - w, 0)) return; gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV); if (gv && GvCVu(gv)) return; + if (s - w <= 254) { + char tmpbuf[256]; + Copy(w, tmpbuf+1, s - w, char); + *tmpbuf = '&'; + off = pad_findmy_pvn(tmpbuf, s-w+1, UTF ? SVf_UTF8 : 0); + if (off != NOT_IN_PAD) return; + } Perl_croak(aTHX_ "No comma allowed after %s", what); } } @@ -9187,7 +8274,7 @@ STATIC SV * 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; @@ -9323,7 +8410,6 @@ now_ok: 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 (;;) { @@ -9375,7 +8461,6 @@ S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool 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); @@ -9391,7 +8476,6 @@ S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN 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++; @@ -9403,7 +8487,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) PERL_ARGS_ASSERT_SCAN_IDENT; if (isSPACE(*s)) - s = PEEKSPACE(s); + s = skipspace(s); if (isDIGIT(*s)) { while (isDIGIT(*s)) { if (d >= e) @@ -9441,7 +8525,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) s++; orig_copline = CopLINE(PL_curcop); if (s < PL_bufend && isSPACE(*s)) { - s = PEEKSPACE(s); + s = skipspace(s); } } @@ -9501,7 +8585,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) *d = '\0'; tmp_copline = CopLINE(PL_curcop); if (s < PL_bufend && isSPACE(*s)) { - s = PEEKSPACE(s); + s = skipspace(s); } if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { /* ${foo[0]} and ${foo{bar}} notation. */ @@ -9540,7 +8624,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) if ( !tmp_copline ) tmp_copline = CopLINE(PL_curcop); if (s < PL_bufend && isSPACE(*s)) { - s = PEEKSPACE(s); + s = skipspace(s); } /* Expect to find a closing } after consuming any trailing whitespace. @@ -9564,7 +8648,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) CopLINE_set(PL_curcop, tmp_copline); Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf, - funny, tmp, funny, tmp); + funny, SVfARG(tmp), funny, SVfARG(tmp)); CopLINE_set(PL_curcop, orig_copline); } } @@ -9683,29 +8767,17 @@ S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charse STATIC char * S_scan_pat(pTHX_ char *start, I32 type) { - dVAR; PMOP *pm; char *s; const char * const valid_flags = (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS); char charset = '\0'; /* character set modifier */ -#ifdef PERL_MAD - char *modstart; -#endif PERL_ARGS_ASSERT_SCAN_PAT; - s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING), - TRUE /* look for escaped bracketed metas */, 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" )); - } + s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL); + if (!s) + Perl_croak(aTHX_ "Search pattern not terminated"); pm = (PMOP*)newPMOP(type, 0); if (PL_multi_open == '?') { @@ -9730,9 +8802,6 @@ S_scan_pat(pTHX_ char *start, I32 type) PmopSTASH_set(pm,PL_curstash); } } -#ifdef PERL_MAD - modstart = s; -#endif /* if qr/...(?{..}).../, then need to parse the pattern within a new * anon CV. False positives like qr/[(?{]/ are harmless */ @@ -9753,12 +8822,6 @@ S_scan_pat(pTHX_ char *start, I32 type) } while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {}; -#ifdef PERL_MAD - if (PL_madskills && modstart != s) { - SV* tmptoken = newSVpvn(modstart, s - modstart); - append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0); - } -#endif /* issue a warning if /c is specified,but /g is not */ if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)) { @@ -9774,42 +8837,28 @@ S_scan_pat(pTHX_ char *start, I32 type) STATIC char * S_scan_subst(pTHX_ char *start) { - dVAR; char *s; PMOP *pm; I32 first_start; line_t first_line; I32 es = 0; char charset = '\0'; /* character set modifier */ -#ifdef PERL_MAD - char *modstart; -#endif char *t; PERL_ARGS_ASSERT_SCAN_SUBST; pl_yylval.ival = OP_NULL; - s = scan_str(start,!!PL_madskills,FALSE,FALSE, - TRUE /* look for escaped bracketed metas */, &t); + s = scan_str(start, TRUE, FALSE, FALSE, &t); if (!s) Perl_croak(aTHX_ "Substitution pattern not terminated"); s = t; -#ifdef PERL_MAD - if (PL_madskills) { - CURMAD('q', PL_thisopen); - CURMAD('_', PL_thiswhite); - CURMAD('E', PL_thisstuff); - CURMAD('Q', PL_thisclose); - PL_realtokenstart = s - SvPVX(PL_linestr); - } -#endif first_start = PL_multi_start; first_line = CopLINE(PL_curcop); - s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); + s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) { if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); @@ -9821,14 +8870,6 @@ S_scan_subst(pTHX_ char *start) pm = (PMOP*)newPMOP(OP_SUBST, 0); -#ifdef PERL_MAD - if (PL_madskills) { - CURMAD('z', PL_thisopen); - CURMAD('R', PL_thisstuff); - CURMAD('Z', PL_thisclose); - } - modstart = s; -#endif while (*s) { if (*s == EXEC_PAT_MOD) { @@ -9841,14 +8882,6 @@ S_scan_subst(pTHX_ char *start) } } -#ifdef PERL_MAD - if (PL_madskills) { - if (modstart != s) - curmad('m', newSVpvn(modstart, s - modstart)); - append_madprops(PL_thismad, (OP*)pm, 0); - PL_thismad = 0; - } -#endif if ((pm->op_pmflags & PMf_CONTINUE)) { Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" ); } @@ -9886,38 +8919,25 @@ S_scan_subst(pTHX_ char *start) STATIC char * S_scan_trans(pTHX_ char *start) { - dVAR; char* s; OP *o; U8 squash; U8 del; U8 complement; bool nondestruct = 0; -#ifdef PERL_MAD - char *modstart; -#endif char *t; PERL_ARGS_ASSERT_SCAN_TRANS; pl_yylval.ival = OP_NULL; - s = scan_str(start,!!PL_madskills,FALSE,FALSE,FALSE,&t); + s = scan_str(start,FALSE,FALSE,FALSE,&t); if (!s) Perl_croak(aTHX_ "Transliteration pattern not terminated"); s = t; -#ifdef PERL_MAD - if (PL_madskills) { - CURMAD('q', PL_thisopen); - CURMAD('_', PL_thiswhite); - CURMAD('E', PL_thisstuff); - CURMAD('Q', PL_thisclose); - PL_realtokenstart = s - SvPVX(PL_linestr); - } -#endif - s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL); + s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) { if (PL_lex_stuff) { SvREFCNT_dec(PL_lex_stuff); @@ -9925,16 +8945,8 @@ S_scan_trans(pTHX_ char *start) } Perl_croak(aTHX_ "Transliteration replacement not terminated"); } - if (PL_madskills) { - CURMAD('z', PL_thisopen); - CURMAD('R', PL_thisstuff); - CURMAD('Z', PL_thisclose); - } complement = del = squash = 0; -#ifdef PERL_MAD - modstart = s; -#endif while (1) { switch (*s) { case 'c': @@ -9965,14 +8977,6 @@ S_scan_trans(pTHX_ char *start) PL_lex_op = o; pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS; -#ifdef PERL_MAD - if (PL_madskills) { - if (modstart != s) - curmad('m', newSVpvn(modstart, s - modstart)); - append_madprops(PL_thismad, o, 0); - PL_thismad = 0; - } -#endif return s; } @@ -10004,7 +9008,6 @@ S_scan_trans(pTHX_ char *start) STATIC char * S_scan_heredoc(pTHX_ char *s) { - dVAR; I32 op_type = OP_SCALAR; I32 len; SV *tmpstr; @@ -10015,12 +9018,6 @@ S_scan_heredoc(pTHX_ char *s) const bool infile = PL_rsfp || PL_parser->filtered; const line_t origline = CopLINE(PL_curcop); LEXSHARED *shared = PL_parser->lex_shared; -#ifdef PERL_MAD - I32 stuffstart = s - SvPVX(PL_linestr); - char *tstart; - - PL_realtokenstart = -1; -#endif PERL_ARGS_ASSERT_SCAN_HEREDOC; @@ -10059,15 +9056,6 @@ S_scan_heredoc(pTHX_ char *s) *d = '\0'; len = d - PL_tokenbuf; -#ifdef PERL_MAD - if (PL_madskills) { - tstart = PL_tokenbuf + 1; - PL_thisclose = newSVpvn(tstart, len - 1); - tstart = SvPVX(PL_linestr) + stuffstart; - PL_thisopen = newSVpvn(tstart, s - tstart); - stuffstart = s - SvPVX(PL_linestr); - } -#endif #ifndef PERL_STRICT_CR d = strchr(s, '\r'); if (d) { @@ -10092,17 +9080,6 @@ S_scan_heredoc(pTHX_ char *s) s = olds; } #endif -#ifdef PERL_MAD - if (PL_madskills) { - tstart = SvPVX(PL_linestr) + stuffstart; - if (PL_thisstuff) - sv_catpvn(PL_thisstuff, tstart, s - tstart); - else - PL_thisstuff = newSVpvn(tstart, s - tstart); - } - - stuffstart = s - SvPVX(PL_linestr); -#endif tmpstr = newSV_type(SVt_PVIV); SvGROW(tmpstr, 80); @@ -10168,15 +9145,6 @@ S_scan_heredoc(pTHX_ char *s) goto interminable; } sv_setpvn(tmpstr,d+1,s-d); -#ifdef PERL_MAD - if (PL_madskills) { - if (PL_thisstuff) - sv_catpvn(PL_thisstuff, d + 1, s - d); - else - PL_thisstuff = newSVpvn(d + 1, s - d); - stuffstart = s - SvPVX(PL_linestr); - } -#endif s += len - 1; /* the preceding stmt passes a newline */ PL_parser->herelines++; @@ -10226,15 +9194,6 @@ S_scan_heredoc(pTHX_ char *s) PL_linestr = newSVpvs(""); PL_bufend = SvPVX(PL_linestr); while (1) { -#ifdef PERL_MAD - if (PL_madskills) { - tstart = SvPVX(PL_linestr) + stuffstart; - if (PL_thisstuff) - sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart); - else - PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart); - } -#endif PL_bufptr = PL_bufend; CopLINE_set(PL_curcop, origline + 1 + PL_parser->herelines); @@ -10252,9 +9211,6 @@ S_scan_heredoc(pTHX_ char *s) PL_bufend = SvEND(PL_linestr); } s = PL_bufptr; -#ifdef PERL_MAD - stuffstart = s - SvPVX(PL_linestr); -#endif PL_parser->herelines++; PL_last_lop = PL_last_uni = NULL; #ifndef PERL_STRICT_CR @@ -10272,7 +9228,8 @@ S_scan_heredoc(pTHX_ char *s) else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r') PL_bufend[-1] = '\n'; #endif - if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) { + if (*s == term && PL_bufend-s >= len + && memEQ(s,PL_tokenbuf + 1,len)) { SvREFCNT_dec(PL_linestr); PL_linestr = linestr_save; PL_linestart = SvPVX(linestr_save); @@ -10324,7 +9281,6 @@ S_scan_heredoc(pTHX_ char *s) STATIC char * S_scan_inputsymbol(pTHX_ char *start) { - dVAR; char *s = start; /* current position in buffer */ char *end; I32 len; @@ -10370,7 +9326,7 @@ S_scan_inputsymbol(pTHX_ char *start) if (d - PL_tokenbuf != len) { pl_yylval.ival = OP_GLOB; - s = scan_str(start,!!PL_madskills,FALSE,FALSE,FALSE,NULL); + s = scan_str(start,FALSE,FALSE,FALSE,NULL); if (!s) Perl_croak(aTHX_ "Glob not terminated"); return s; @@ -10386,7 +9342,6 @@ S_scan_inputsymbol(pTHX_ char *start) Copy("ARGV",d,5,char); /* Check whether readline() is overriden */ - gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV); if ((gv_readline = gv_override("readline",8))) readline_overriden = TRUE; @@ -10423,9 +9378,7 @@ S_scan_inputsymbol(pTHX_ char *start) ++d; intro_sym: gv = gv_fetchpv(d, - (PL_in_eval - ? (GV_ADDMULTI | GV_ADDINEVAL) - : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ), + GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ), SVt_PV); PL_lex_op = readline_overriden ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, @@ -10436,8 +9389,6 @@ intro_sym: 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; } @@ -10463,13 +9414,11 @@ intro_sym: /* scan_str takes: start position in buffer - keep_quoted preserve \ on the embedded delimiter(s) + keep_bracketed_quoted preserve \ quoting of embedded delimiters, but + only if they are of the open/close form keep_delims preserve the delimiters around the string re_reparse compiling a run-time /(?{})/: collapse // to /, and skip encoding src - deprecate_escaped_meta issue a deprecation warning for cer- - tain paired metacharacters that appear - escaped within it delimp if non-null, this is set to the position of the closing delimiter, or just after it if the closing and opening delimiters differ @@ -10515,11 +9464,10 @@ intro_sym: */ STATIC char * -S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, - bool deprecate_escaped_meta, char **delimp +S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse, + 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 */ @@ -10531,28 +9479,15 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, U8 termstr[UTF8_MAXBYTES]; /* terminating string */ STRLEN termlen; /* length of terminating string */ int last_off = 0; /* last position for nesting bracket */ - char *escaped_open = NULL; line_t herelines; -#ifdef PERL_MAD - int stuffstart; - char *tstart; -#endif PERL_ARGS_ASSERT_SCAN_STR; /* skip space before the delimiter */ if (isSPACE(*s)) { - s = PEEKSPACE(s); + s = skipspace(s); } -#ifdef PERL_MAD - if (PL_realtokenstart >= 0) { - stuffstart = PL_realtokenstart; - PL_realtokenstart = -1; - } - else - stuffstart = start - SvPVX(PL_linestr); -#endif /* mark where we are, in case we need to report errors */ CLINE; @@ -10580,16 +9515,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, PL_multi_close = term; - /* A warning is raised if the input parameter requires it for escaped (by a - * backslash) paired metacharacters {} [] and () when the delimiters are - * those same characters, and the backslash is ineffective. This doesn't - * happen for <>, as they aren't metas. */ - if (deprecate_escaped_meta - && (PL_multi_open == PL_multi_close - || PL_multi_open == '<' - || ! ckWARN_d(WARN_DEPRECATED))) - { - deprecate_escaped_meta = FALSE; + if (PL_multi_open == PL_multi_close) { + keep_bracketed_quoted = FALSE; } /* create a new SV to hold the contents. 79 is the SV's initial length. @@ -10603,13 +9530,6 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, if (keep_delims) sv_catpvn(sv, s, termlen); s += termlen; -#ifdef PERL_MAD - tstart = SvPVX(PL_linestr) + stuffstart; - if (PL_madskills && !PL_thisopen && !keep_delims) { - PL_thisopen = newSVpvn(tstart, s - tstart); - stuffstart = s - SvPVX(PL_linestr); - } -#endif for (;;) { if (PL_encoding && !UTF && !re_reparse) { bool cont = TRUE; @@ -10675,7 +9595,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';) t--; if ((svlast-1 - t) % 2) { - if (!keep_quoted) { + if (!keep_bracketed_quoted) { *(svlast-1) = term; *svlast = '\0'; SvCUR_set(sv, SvCUR(sv) - 1); @@ -10693,7 +9613,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, /* At here, all closes are "was quoted" one, so we don't check PL_multi_close. */ if (*t == '\\') { - if (!keep_quoted && *(t+1) == PL_multi_open) + if (!keep_bracketed_quoted && *(t+1) == PL_multi_open) t++; else *w++ = *t++; @@ -10734,13 +9654,12 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, COPLINE_INC_WITH_HERELINES; /* handle quoted delimiters */ if (*s == '\\' && s+1 < PL_bufend && term != '\\') { - if (!keep_quoted + if (!keep_bracketed_quoted && (s[1] == term || (re_reparse && s[1] == '\\')) ) s++; - /* any other quotes are simply copied straight through */ - else + else /* any other quotes are simply copied straight through */ *to++ = *s++; } /* terminate when run out of buffer (the for() condition), or @@ -10769,62 +9688,14 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, COPLINE_INC_WITH_HERELINES; /* backslashes can escape the open or closing characters */ if (*s == '\\' && s+1 < PL_bufend) { - if (!keep_quoted && + if (!keep_bracketed_quoted && ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))) { s++; - - /* Here, 'deprecate_escaped_meta' is true iff the - * delimiters are paired metacharacters, and 's' points - * to an occurrence of one of them within the string, - * which was preceded by a backslash. If this is a - * context where the delimiter is also a metacharacter, - * the backslash is useless, and deprecated. () and [] - * are meta in any context. {} are meta only when - * appearing in a quantifier or in things like '\p{' - * (but '\\p{' isn't meta). They also aren't meta - * unless there is a matching closed, escaped char - * later on within the string. If 's' points to an - * open, set a flag; if to a close, test that flag, and - * raise a warning if it was set */ - - if (deprecate_escaped_meta) { - if (*s == PL_multi_open) { - if (*s != '{') { - escaped_open = s; - } - /* Look for a closing '\}' */ - else if (regcurly(s, TRUE)) { - escaped_open = s; - } - /* Look for e.g. '\x{' */ - else if (s - start > 2 - && _generic_isCC(*(s-2), - _CC_BACKSLASH_FOO_LBRACE_IS_META)) - { /* Exclude '\\x', '\\\\x', etc. */ - char *lookbehind = s - 4; - bool is_meta = TRUE; - while (lookbehind >= start - && *lookbehind == '\\') - { - is_meta = ! is_meta; - lookbehind--; - } - if (is_meta) { - escaped_open = s; - } - } - } - else if (escaped_open) { - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), - "Useless use of '\\'; doesn't escape metacharacter '%c'", PL_multi_open); - escaped_open = NULL; - } - } } else *to++ = *s++; - } + } /* allow nested opens and closes */ else if (*s == PL_multi_close && --brackets <= 0) break; @@ -10866,15 +9737,6 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, /* if we're out of file, or a read fails, bail and reset the current line marker so we can report where the unterminated string began */ -#ifdef PERL_MAD - if (PL_madskills) { - char * const tstart = SvPVX(PL_linestr) + stuffstart; - if (PL_thisstuff) - sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart); - else - PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart); - } -#endif COPLINE_INC_WITH_HERELINES; PL_bufptr = PL_bufend; if (!lex_next_chunk(0)) { @@ -10883,45 +9745,16 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, return NULL; } s = PL_bufptr; -#ifdef PERL_MAD - stuffstart = 0; -#endif } /* at this point, we have successfully read the delimited string */ if (!PL_encoding || UTF || re_reparse) { -#ifdef PERL_MAD - if (PL_madskills) { - char * const tstart = SvPVX(PL_linestr) + stuffstart; - const int len = s - tstart; - if (PL_thisstuff) - sv_catpvn(PL_thisstuff, tstart, len); - else - PL_thisstuff = newSVpvn(tstart, len); - if (!PL_thisclose && !keep_delims) - PL_thisclose = newSVpvn(s,termlen); - } -#endif if (keep_delims) sv_catpvn(sv, s, termlen); s += termlen; } -#ifdef PERL_MAD - else { - if (PL_madskills) { - char * const tstart = SvPVX(PL_linestr) + stuffstart; - const int len = s - tstart - termlen; - if (PL_thisstuff) - sv_catpvn(PL_thisstuff, tstart, len); - else - PL_thisstuff = newSVpvn(tstart, len); - if (!PL_thisclose && !keep_delims) - PL_thisclose = newSVpvn(s - termlen,termlen); - } - } -#endif if (has_utf8 || (PL_encoding && !re_reparse)) SvUTF8_on(sv); @@ -10957,9 +9790,10 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, \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. @@ -10972,7 +9806,6 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, 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 */ @@ -10981,6 +9814,27 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) 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; @@ -11023,17 +9877,17 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) 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 { @@ -11075,14 +9929,14 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) case '8': case '9': if (shift == 3) yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s)); - /* FALL THROUGH */ + /* FALLTHROUGH */ /* octal digits */ case '2': case '3': case '4': case '5': case '6': case '7': if (shift == 1) yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s)); - /* FALL THROUGH */ + /* FALLTHROUGH */ case '0': case '1': b = *s++ & 15; /* ASCII digit -> value of digit */ @@ -11105,6 +9959,8 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) if (!overflowed) { x = u << shift; /* make room for the digit */ + total_bits += shift; + if ((x >> shift) != u && !(PL_hints & HINT_NEW_BINARY)) { overflowed = TRUE; @@ -11127,6 +9983,16 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) * 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; } } @@ -11141,6 +10007,96 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) 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), @@ -11174,10 +10130,17 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) 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 */ @@ -11217,7 +10180,9 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) /* 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); @@ -11243,12 +10208,24 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) } /* 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 == '_') { @@ -11309,10 +10286,25 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) floatit = TRUE; } if (floatit) { + STORE_NUMERIC_LOCAL_SET_STANDARD(); /* terminate the string */ *d = '\0'; - nv = Atof(PL_tokenbuf); - sv = newSVnv(nv); + 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); } if ( floatit @@ -11349,21 +10341,11 @@ vstring: STATIC char * S_scan_formline(pTHX_ char *s) { - dVAR; char *eol; char *t; SV * const stuff = newSVpvs(""); bool needargs = FALSE; bool eofmt = FALSE; -#ifdef PERL_MAD - char *tokenstart = s; - SV* savewhite = NULL; - - if (PL_madskills) { - savewhite = PL_thiswhite; - PL_thiswhite = 0; - } -#endif PERL_ARGS_ASSERT_SCAN_FORMLINE; @@ -11412,22 +10394,11 @@ S_scan_formline(pTHX_ char *s) if ((PL_rsfp || PL_parser->filtered) && PL_parser->form_lex_state == LEX_NORMAL) { bool got_some; -#ifdef PERL_MAD - if (PL_madskills) { - if (PL_thistoken) - sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart); - else - PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart); - } -#endif PL_bufptr = PL_bufend; COPLINE_INC_WITH_HERELINES; got_some = lex_next_chunk(0); CopLINE_dec(PL_curcop); s = PL_bufptr; -#ifdef PERL_MAD - tokenstart = PL_bufptr; -#endif if (!got_some) break; } @@ -11439,7 +10410,15 @@ S_scan_formline(pTHX_ char *s) if (SvCUR(stuff)) { PL_expect = XSTATE; if (needargs) { - start_force(PL_curforce); + const char *s2 = s; + while (*s2 == '\r' || *s2 == ' ' || *s2 == '\t' || *s2 == '\f' + || *s2 == 013) + s2++; + if (*s2 == '{') { + PL_expect = XTERMBLOCK; + NEXTVAL_NEXTTOKE.ival = 0; + force_next(DO); + } NEXTVAL_NEXTTOKE.ival = 0; force_next(FORMLBRACK); } @@ -11449,7 +10428,6 @@ S_scan_formline(pTHX_ char *s) else if (PL_encoding) sv_recode_to_utf8(stuff, PL_encoding); } - start_force(PL_curforce); NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff); force_next(THING); } @@ -11458,22 +10436,12 @@ S_scan_formline(pTHX_ char *s) if (eofmt) PL_lex_formbrack = 0; } -#ifdef PERL_MAD - if (PL_madskills) { - if (PL_thistoken) - sv_catpvn(PL_thistoken, tokenstart, s - tokenstart); - else - PL_thistoken = newSVpvn(tokenstart, s - tokenstart); - PL_thiswhite = savewhite; - } -#endif return s; } I32 Perl_start_subparse(pTHX_ I32 is_format, U32 flags) { - dVAR; const I32 oldsavestack_ix = PL_savestack_ix; CV* const outsidecv = PL_compcv; @@ -11498,8 +10466,6 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) static int S_yywarn(pTHX_ const char *const s, U32 flags) { - dVAR; - PERL_ARGS_ASSERT_YYWARN; PL_in_eval |= EVAL_WARNONLY; @@ -11525,7 +10491,6 @@ Perl_yyerror_pv(pTHX_ const char *const s, U32 flags) int Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags) { - dVAR; const char *context = NULL; int contlen = -1; SV *msg; @@ -11630,7 +10595,6 @@ Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags) STATIC char* S_swallow_bom(pTHX_ U8 *s) { - dVAR; const STRLEN slen = SvCUR(PL_linestr); PERL_ARGS_ASSERT_SWALLOW_BOM; @@ -11698,6 +10662,7 @@ S_swallow_bom(pTHX_ U8 *s) #endif } } + break; default: if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) { @@ -11721,7 +10686,6 @@ S_swallow_bom(pTHX_ U8 *s) 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. */ @@ -11889,7 +10853,6 @@ sv_2mortal. char * Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv) { - dVAR; const char *pos = s; const char *start = s; @@ -12369,6 +11332,206 @@ Perl_parse_stmtseq(pTHX_ U32 flags) return stmtseqop; } +#define lex_token_boundary() S_lex_token_boundary(aTHX) +static void +S_lex_token_boundary(pTHX) +{ + PL_oldoldbufptr = PL_oldbufptr; + PL_oldbufptr = PL_bufptr; +} + +#define parse_opt_lexvar() S_parse_opt_lexvar(aTHX) +static OP * +S_parse_opt_lexvar(pTHX) +{ + I32 sigil, c; + char *s, *d; + OP *var; + lex_token_boundary(); + sigil = lex_read_unichar(0); + if (lex_peek_unichar(0) == '#') { + qerror(Perl_mess(aTHX_ "Parse error")); + return NULL; + } + lex_read_space(0); + c = lex_peek_unichar(0); + if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c))) + return NULL; + s = PL_bufptr; + d = PL_tokenbuf + 1; + PL_tokenbuf[0] = (char)sigil; + parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0, cBOOL(UTF)); + PL_bufptr = s; + if (d == PL_tokenbuf+1) + return NULL; + *d = 0; + var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV, + OPf_MOD | (OPpLVAL_INTRO<<8)); + var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0); + return var; +} + +OP * +Perl_parse_subsignature(pTHX) +{ + I32 c; + int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0; + OP *initops = NULL; + lex_read_space(0); + c = lex_peek_unichar(0); + while (c != /*(*/')') { + switch (c) { + case '$': { + OP *var, *expr; + if (prev_type == 2) + qerror(Perl_mess(aTHX_ "Slurpy parameter not last")); + var = parse_opt_lexvar(); + expr = var ? + newBINOP(OP_AELEM, 0, + ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)), + OP_RV2AV), + newSVOP(OP_CONST, 0, newSViv(pos))) : + NULL; + lex_read_space(0); + c = lex_peek_unichar(0); + if (c == '=') { + lex_token_boundary(); + lex_read_unichar(0); + lex_read_space(0); + c = lex_peek_unichar(0); + if (c == ',' || c == /*(*/')') { + if (var) + qerror(Perl_mess(aTHX_ "Optional parameter " + "lacks default expression")); + } else { + OP *defexpr = parse_termexpr(0); + if (defexpr->op_type == OP_UNDEF && + !(defexpr->op_flags & OPf_KIDS)) { + op_free(defexpr); + } else { + OP *ifop = + newBINOP(OP_GE, 0, + scalar(newUNOP(OP_RV2AV, 0, + newGVOP(OP_GV, 0, PL_defgv))), + newSVOP(OP_CONST, 0, newSViv(pos+1))); + expr = var ? + newCONDOP(0, ifop, expr, defexpr) : + newLOGOP(OP_OR, 0, ifop, defexpr); + } + } + prev_type = 1; + } else { + if (prev_type == 1) + qerror(Perl_mess(aTHX_ "Mandatory parameter " + "follows optional parameter")); + prev_type = 0; + min_arity = pos + 1; + } + if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr); + if (expr) + initops = op_append_list(OP_LINESEQ, initops, + newSTATEOP(0, NULL, expr)); + max_arity = ++pos; + } break; + case '@': + case '%': { + OP *var; + if (prev_type == 2) + qerror(Perl_mess(aTHX_ "Slurpy parameter not last")); + var = parse_opt_lexvar(); + if (c == '%') { + OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0, + newBINOP(OP_BIT_AND, 0, + scalar(newUNOP(OP_RV2AV, 0, + newGVOP(OP_GV, 0, PL_defgv))), + newSVOP(OP_CONST, 0, newSViv(1))), + newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0), + newSVOP(OP_CONST, 0, + newSVpvs("Odd name/value argument " + "for subroutine")))); + if (pos != min_arity) + chkop = newLOGOP(OP_AND, 0, + newBINOP(OP_GT, 0, + scalar(newUNOP(OP_RV2AV, 0, + newGVOP(OP_GV, 0, PL_defgv))), + newSVOP(OP_CONST, 0, newSViv(pos))), + chkop); + initops = op_append_list(OP_LINESEQ, + newSTATEOP(0, NULL, chkop), + initops); + } + if (var) { + OP *slice = pos ? + op_prepend_elem(OP_ASLICE, + newOP(OP_PUSHMARK, 0), + newLISTOP(OP_ASLICE, 0, + list(newRANGE(0, + newSVOP(OP_CONST, 0, newSViv(pos)), + newUNOP(OP_AV2ARYLEN, 0, + ref(newUNOP(OP_RV2AV, 0, + newGVOP(OP_GV, 0, PL_defgv)), + OP_AV2ARYLEN)))), + ref(newUNOP(OP_RV2AV, 0, + newGVOP(OP_GV, 0, PL_defgv)), + OP_ASLICE))) : + newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)); + initops = op_append_list(OP_LINESEQ, initops, + newSTATEOP(0, NULL, + newASSIGNOP(OPf_STACKED, var, 0, slice))); + } + prev_type = 2; + max_arity = -1; + } break; + default: + parse_error: + qerror(Perl_mess(aTHX_ "Parse error")); + return NULL; + } + lex_read_space(0); + c = lex_peek_unichar(0); + switch (c) { + case /*(*/')': break; + case ',': + do { + lex_token_boundary(); + lex_read_unichar(0); + lex_read_space(0); + c = lex_peek_unichar(0); + } while (c == ','); + break; + default: + goto parse_error; + } + } + if (min_arity != 0) { + initops = op_append_list(OP_LINESEQ, + newSTATEOP(0, NULL, + newLOGOP(OP_OR, 0, + newBINOP(OP_GE, 0, + scalar(newUNOP(OP_RV2AV, 0, + newGVOP(OP_GV, 0, PL_defgv))), + newSVOP(OP_CONST, 0, newSViv(min_arity))), + newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0), + newSVOP(OP_CONST, 0, + newSVpvs("Too few arguments for subroutine"))))), + initops); + } + if (max_arity != -1) { + initops = op_append_list(OP_LINESEQ, + newSTATEOP(0, NULL, + newLOGOP(OP_OR, 0, + newBINOP(OP_LE, 0, + scalar(newUNOP(OP_RV2AV, 0, + newGVOP(OP_GV, 0, PL_defgv))), + newSVOP(OP_CONST, 0, newSViv(max_arity))), + newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0), + newSVOP(OP_CONST, 0, + newSVpvs("Too many arguments for subroutine"))))), + initops); + } + return initops; +} + /* * Local variables: * c-indentation-style: bsd