handle bracket stack better in recdescent parsing

When recursing into the parser for recursive-descent parsing, put
a special entry on the bracket stack that generates a fake EOF if a
closing bracket belonging to an outer parser frame is seen.  This keeps
the bracket stack balanced across a parse_stmtseq() frame, fixing
[perl #78222].

If a recursive-descent parser frame ends by yyunlex()ing an opening
bracket, pop its entry off the bracket stack and stash it in the
forced-token queue, to be revived when the token is re-lexed.  This keeps
the bracket stack balanced across a parse_fullstmt() frame.

1 files changed, 54 insertions, 14 deletions

diff --git a/toke.c b/toke.c
index 878547e1b9..d0af57e1d6 100644
--- a/toke.c
+++ b/toke.c
@@ -124,8 +124,9 @@ static const char ident_too_long[] = "Identifier too long";
 #  define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
 #endif
 
-#define XFAKEBRACK 128
-#define XENUMMASK 127
+#define XENUMMASK  0x3f
+#define XFAKEEOF   0x40
+#define XFAKEBRACK 0x80
 
 #ifdef USE_UTF8_SCRIPTS
 #   define UTF (!IN_BYTES)
@@ -1947,10 +1948,17 @@ S_force_next(pTHX_ I32 type)
 void
 Perl_yyunlex(pTHX)
 {
-    if (PL_parser->yychar != YYEMPTY) {
-	start_force(-1);
-	NEXTVAL_NEXTTOKE = PL_parser->yylval;
-	force_next(PL_parser->yychar);
+    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_brackets--;
+		yyc |= (1<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
+	    }
+	    force_next(yyc);
+	}
 	PL_parser->yychar = YYEMPTY;
     }
 }
@@ -4272,12 +4280,26 @@ Perl_yylex(pTHX)
 	    PL_lex_defer = LEX_NORMAL;
 	}
 #endif
+	{
+	    I32 next_type;
 #ifdef PERL_MAD
-	/* FIXME - can these be merged?  */
-	return(PL_nexttoke[PL_lasttoke].next_type);
+	    next_type = PL_nexttoke[PL_lasttoke].next_type;
 #else
-	return REPORT(PL_nexttype[PL_nexttoke]);
+	    next_type = PL_nexttype[PL_nexttoke];
 #endif
+	    if (next_type & (1<<24)) {
+		if (PL_lex_brackets > 100)
+		    Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
+		PL_lex_brackstack[PL_lex_brackets++] = (next_type >> 16) & 0xff;
+		next_type &= 0xffff;
+	    }
+#ifdef PERL_MAD
+	    /* FIXME - can these be merged?  */
+	    return next_type;
+#else
+	    return REPORT(next_type);
+#endif
+	}
 
     /* interpolated case modifiers like \L \U, including \Q and \E.
        when we get here, PL_bufptr is at the \
@@ -4567,7 +4589,8 @@ Perl_yylex(pTHX)
 	if (!PL_rsfp) {
 	    PL_last_uni = 0;
 	    PL_last_lop = 0;
-	    if (PL_lex_brackets) {
+	    if (PL_lex_brackets &&
+		    PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
 		yyerror((const char *)
 			(PL_lex_formbrack
 			 ? "Format not terminated"
@@ -5156,7 +5179,9 @@ Perl_yylex(pTHX)
 	s++;
 	BOop(OP_BIT_XOR);
     case '[':
-	PL_lex_brackets++;
+	if (PL_lex_brackets > 100)
+	    Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
+	PL_lex_brackstack[PL_lex_brackets++] = 0;
 	{
 	    const char tmp = *s++;
 	    OPERATOR(tmp);
@@ -5356,6 +5381,8 @@ Perl_yylex(pTHX)
 	    TERM(tmp);
 	}
     case ']':
+	if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
+	    TOKEN(0);
 	s++;
 	if (PL_lex_brackets <= 0)
 	    yyerror("Unmatched right square bracket");
@@ -5533,6 +5560,8 @@ Perl_yylex(pTHX)
 	    PL_copline = NOLINE;   /* invalidate current command line number */
 	TOKEN('{');
     case '}':
+	if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
+	    TOKEN(0);
       rightbracket:
 	s++;
 	if (PL_lex_brackets <= 0)
@@ -13943,6 +13972,17 @@ Perl_keyword_plugin_standard(pTHX_
     return KEYWORD_PLUGIN_DECLINE;
 }
 
+#define parse_recdescent(g) S_parse_recdescent(aTHX_ g)
+static void S_parse_recdescent(pTHX_ int gramtype)
+{
+    SAVEI32(PL_lex_brackets);
+    if (PL_lex_brackets > 100)
+	Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
+    PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
+    if(yyparse(gramtype) && !PL_parser->error_count)
+	qerror(Perl_mess(aTHX_ "Parse error"));
+}
+
 /*
 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
 
@@ -13979,8 +14019,7 @@ Perl_parse_fullstmt(pTHX_ U32 flags)
     ENTER;
     SAVEVPTR(PL_eval_root);
     PL_eval_root = NULL;
-    if(yyparse(GRAMFULLSTMT) && !PL_parser->error_count)
-	qerror(Perl_mess(aTHX_ "Parse error"));
+    parse_recdescent(GRAMFULLSTMT);
     fullstmtop = PL_eval_root;
     LEAVE;
     return fullstmtop;
@@ -14025,7 +14064,8 @@ Perl_parse_stmtseq(pTHX_ U32 flags)
     ENTER;
     SAVEVPTR(PL_eval_root);
     PL_eval_root = NULL;
-    if(yyparse(GRAMSTMTSEQ) && !PL_parser->error_count)
+    parse_recdescent(GRAMSTMTSEQ);
+    if (!((PL_bufptr == PL_bufend && !PL_rsfp) || *PL_bufptr == /*{*/'}'))
 	qerror(Perl_mess(aTHX_ "Parse error"));
     stmtseqop = PL_eval_root;
     LEAVE;