Avoid vivifying stuff when looking up barewords

[perl5.git] / toke.c

diff --git a/toke.c b/toke.c
index 68cf152..4e7ae3b 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -54,7 +54,6 @@ Individual members of C<PL_parser> 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)
@@ -196,6 +195,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
@@ -217,10 +217,9 @@ 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_expect = XOPERATOR, \
-                        PL_bufptr = force_word(s,WORD,TRUE,FALSE), \
+#define LOOPX(f) return (PL_bufptr = force_word(s,WORD,TRUE,FALSE), \
                         pl_yylval.ival=f, \
-                        (void)(PL_nexttoke || (PL_expect = XTERM)), \
+                        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))
@@ -232,6 +231,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))
@@ -1908,7 +1908,6 @@ S_force_next(pTHX_ I32 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;
     }
 }
@@ -4280,7 +4279,6 @@ Perl_yylex(pTHX)
        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;
        }
        {
@@ -4388,9 +4386,9 @@ Perl_yylex(pTHX)
                PL_lex_starts = 0;
                /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
                if (PL_lex_casemods == 1 && PL_lex_inpat)
-                   OPERATOR(',');
+                   TOKEN(',');
                else
-                   Aop(OP_CONCAT);
+                   AopNOASSIGN(OP_CONCAT);
            }
            else
                return yylex();
@@ -4435,9 +4433,9 @@ Perl_yylex(pTHX)
            s = PL_bufptr;
            /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
            if (!PL_lex_casemods && PL_lex_inpat)
-               OPERATOR(',');
+               TOKEN(',');
            else
-               Aop(OP_CONCAT);
+               AopNOASSIGN(OP_CONCAT);
        }
        return yylex();
 
@@ -4525,9 +4523,9 @@ Perl_yylex(pTHX)
            if (PL_lex_starts++) {
                /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
                if (!PL_lex_casemods && PL_lex_inpat)
-                   OPERATOR(',');
+                   TOKEN(',');
                else
-                   Aop(OP_CONCAT);
+                   AopNOASSIGN(OP_CONCAT);
            }
            else {
                PL_bufptr = s;
@@ -5451,18 +5449,18 @@ Perl_yylex(pTHX)
                }
            }
            /* FALLTHROUGH */
-       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;
            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 XBLOCKTERM:
            PL_lex_brackstack[PL_lex_brackets++] = XTERM;
            PL_lex_allbrackets++;
@@ -5486,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
@@ -5505,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++;
                }
@@ -6316,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'",
@@ -6557,8 +6560,11 @@ Perl_yylex(pTHX)
                {
                    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
+                       ? GvCV(gv)
+                       : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
                }
 
                /* See if it's the indirect object for a list operator. */
@@ -6636,7 +6642,6 @@ Perl_yylex(pTHX)
                    }
                    NEXTVAL_NEXTTOKE.opval =
                        off ? rv2cv_op : pl_yylval.opval;
-                   PL_expect = XOPERATOR;
                    if (off)
                         op_free(pl_yylval.opval), force_next(PRIVATEREF);
                    else op_free(rv2cv_op),        force_next(WORD);
@@ -6673,6 +6678,7 @@ Perl_yylex(pTHX)
                /* Not a method, so call it a subroutine (if defined) */
 
                if (cv) {
+                   OP *gvop;
                    if (lastchar == '-' && penultchar != '-') {
                        const STRLEN l = len ? len : strlen(PL_tokenbuf);
                        Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
@@ -6697,6 +6703,20 @@ Perl_yylex(pTHX)
                        TOKEN(WORD);
                    }
 
+                   /* Resolve to GV now if this is a placeholder. */
+                   if ((gvop = cUNOPx(rv2cv_op)->op_first)
+                    && gvop->op_type == OP_GV) {
+                       GV *gv2 = cGVOPx_gv(gvop);
+                       if (gv2 && !isGV(gv2)) {
+                           gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
+                           assert (SvTYPE(gv) == SVt_PVGV);
+                           /* cv must have been some sort of placeholder,
+                              so now needs replacing with a real code
+                              reference.  */
+                           cv = GvCV(gv);
+                       }
+                   }
+
                    op_free(pl_yylval.opval);
                    pl_yylval.opval =
                        off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
@@ -7517,8 +7537,7 @@ Perl_yylex(pTHX)
            s = force_word(s,WORD,FALSE,TRUE);
            s = SKIPSPACE1(s);
            s = force_strict_version(s);
-           PL_lex_expect = XBLOCK;
-           OPERATOR(PACKAGE);
+           PREBLOCK(PACKAGE);
 
        case KEY_pipe:
            LOP(OP_PIPE_OP,XTERM);
@@ -7611,7 +7630,6 @@ Perl_yylex(pTHX)
 
        case KEY_require:
            s = SKIPSPACE1(s);
-           PL_expect = XOPERATOR;
            if (isDIGIT(*s)) {
                s = force_version(s, FALSE);
            }
@@ -7632,7 +7650,7 @@ Perl_yylex(pTHX)
            }
            else 
                pl_yylval.ival = 0;
-           if (!PL_nexttoke) PL_expect = XTERM;
+           PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
            PL_bufptr = s;
            PL_last_uni = PL_oldbufptr;
            PL_last_lop_op = OP_REQUIRE;