Look up state subs in the pad

This commit does just enough to get things compiling.  The padcv op
is still unimplemented (in fact, converting the padany to a padcv is
still not done), so you can’t actually run the code yet.

Bareword lookup in yylex now produces PRIVATEREF tokens for state
subs, so the grammar has been adjusted to accept a ‘subname’ in sub
calls (PRIVATEREF or WORD) where previously only a WORD was permitted.

1 files changed, 34 insertions, 17 deletions

diff --git a/toke.c b/toke.c
index f93d96e41c..cca84cc76e 100644
--- a/toke.c
+++ b/toke.c
@@ -6602,12 +6602,18 @@ Perl_yylex(pTHX)
 	bool lex;
 	I32 tmp;
 	SV *sv;
+	CV *cv;
+	PADOFFSET off;
+	OP *rv2cv_op;
 
 	lex = FALSE;
 	orig_keyword = 0;
+	off = 0;
 	sv = NULL;
+	cv = NULL;
 	gv = NULL;
 	gvp = NULL;
+	rv2cv_op = NULL;
 
 	PL_bufptr = s;
 	s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
@@ -6677,11 +6683,11 @@ Perl_yylex(pTHX)
 	/* Check for lexical sub */
 	if (PL_expect != XOPERATOR) {
 	    char tmpbuf[sizeof PL_tokenbuf + 1];
-	    PADOFFSET off;
 	    *tmpbuf = '&';
 	    Copy(PL_tokenbuf, tmpbuf+1, len, char);
 	    off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0);
 	    if (off != NOT_IN_PAD) {
+		assert(off); /* we assume this is boolean-true below */
 		if (PAD_COMPNAME_FLAGS_isOUR(off)) {
 		    HV *  const stash = PAD_COMPNAME_OURSTASH(off);
 		    HEK * const stashname = HvNAME_HEK(stash);
@@ -6691,12 +6697,18 @@ Perl_yylex(pTHX)
 				    (UTF ? SV_CATUTF8 : SV_CATBYTES));
 		    gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
 				    SVt_PVCV);
-		    lex = TRUE;
-		    goto just_a_word;
+		    off = 0;
+		}
+		else {
+		    rv2cv_op = newOP(OP_PADANY, 0);
+		    rv2cv_op->op_targ = off;
+		    rv2cv_op = (OP*)newCVREF(0, rv2cv_op);
+		    cv = (CV *)PAD_SV(off);
 		}
-		/* unreachable */
-		else Perl_croak(aTHX_ "\"my sub\" not yet implemented");
+		lex = TRUE;
+		goto just_a_word;
 	    }
+	    off = 0;
 	}
 
 	if (tmp < 0) {			/* second-class keyword? */
@@ -6758,8 +6770,11 @@ Perl_yylex(pTHX)
 	       earlier ':' case doesn't bypass the initialisation.  */
 	    if (0) {
 	    just_a_word_zero_gv:
+		sv = NULL;
+		cv = NULL;
 		gv = NULL;
 		gvp = NULL;
+		rv2cv_op = NULL;
 		orig_keyword = 0;
 		lex = 0;
 		off = 0;
@@ -6767,8 +6782,6 @@ Perl_yylex(pTHX)
 	  just_a_word: {
 		int pkgname = 0;
 		const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
-		OP *rv2cv_op;
-		CV *cv;
 #ifdef PERL_MAD
 		SV *nextPL_nextwhite = 0;
 #endif
@@ -6800,7 +6813,8 @@ Perl_yylex(pTHX)
 		}
 
 		/* Look for a subroutine with this name in current package,
-		   unless name is "Foo::", in which case Foo is a bareword
+		   unless this is a lexical sub, or name is "Foo::",
+		   in which case Foo is a bareword
 		   (and a package name). */
 
 		if (len > 2 && !PL_madskills &&
@@ -6818,7 +6832,7 @@ Perl_yylex(pTHX)
 		    gvp = 0;
 		}
 		else {
-		    if (!gv) {
+		    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
@@ -6832,7 +6846,7 @@ Perl_yylex(pTHX)
 
 		/* if we saw a global override before, get the right name */
 
-		if (!lex)
+		if (!sv)
 		  sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
 		    len ? len : strlen(PL_tokenbuf));
 		if (gvp) {
@@ -6859,12 +6873,13 @@ Perl_yylex(pTHX)
 		if (len)
 		    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);
 		}
-		cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0);
 
 		/* See if it's the indirect object for a list operator. */
 
@@ -6951,7 +6966,8 @@ Perl_yylex(pTHX)
 		    }
 		    start_force(PL_curforce);
 #endif
-		    NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
+		    NEXTVAL_NEXTTOKE.opval =
+			off ? rv2cv_op : pl_yylval.opval;
 		    PL_expect = XOPERATOR;
 #ifdef PERL_MAD
 		    if (PL_madskills) {
@@ -6960,8 +6976,9 @@ Perl_yylex(pTHX)
 			PL_thistoken = newSVpvs("");
 		    }
 #endif
-		    op_free(rv2cv_op);
-		    force_next(WORD);
+		    if (off)
+			 op_free(pl_yylval.opval), force_next(PRIVATEREF);
+		    else op_free(rv2cv_op),	   force_next(WORD);
 		    pl_yylval.ival = 0;
 		    TOKEN('&');
 		}
@@ -7076,7 +7093,7 @@ Perl_yylex(pTHX)
 			    curmad('X', PL_thistoken);
 			    PL_thistoken = newSVpvs("");
 			}
-			force_next(WORD);
+			force_next(off ? PRIVATEREF : WORD);
 			if (!PL_lex_allbrackets &&
 				PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
 			    PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
@@ -7119,7 +7136,7 @@ Perl_yylex(pTHX)
 			PL_nextwhite = nextPL_nextwhite;
 			curmad('X', PL_thistoken);
 			PL_thistoken = newSVpvs("");
-			force_next(WORD);
+			force_next(off ? PRIVATEREF : WORD);
 			if (!PL_lex_allbrackets &&
 				PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
 			    PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
@@ -7128,7 +7145,7 @@ Perl_yylex(pTHX)
 #else
 		    NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
 		    PL_expect = XTERM;
-		    force_next(WORD);
+		    force_next(off ? PRIVATEREF : WORD);
 		    if (!PL_lex_allbrackets &&
 			    PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
 			PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;