stop OPs leaking in eval "syntax error"

When bison pops states during error recovery, any states holding
an OP would leak the OP. Create an extra YY table that tells us
which states are of type opval, and when popping one of those,
free the op.

p4raw-id: //depot/perl@28315

4 files changed, 104 insertions, 0 deletions

diff --git a/madly.tab b/madly.tab
index 2718be6dc5..f89e7a36e9 100644
--- a/madly.tab
+++ b/madly.tab
@@ -876,3 +876,30 @@ static const unsigned char yystos[] =
       60,    96,    96,   105,   105,    99,    96,    88,    96,   108,
      105,     4,   112,   105,   113,    87,    87,    96,    96,   102
 };
+/* which symbols are of type opval */
+static const int yy_is_opval[] =
+{
+  0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  1, 0, 0, 0, 1, 0,
+  0, 1, 1, 1, 1, 1, 1, 1,
+  1, 1, 0, 1, 1, 1, 1, 1,
+  1, 0, 1, 1, 1, 1, 1,
+  1, 0, 0, 0, 1,
+  1, 1, 1, 1, 1, 1, 0,
+  1, 1, 1, 0, 1, 1, 1,
+  1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1, 1,
+  1, 1, 1, 0
+
+};
diff --git a/perly.c b/perly.c
index 18f8606bff..adf36063f1 100644
--- a/perly.c
+++ b/perly.c
@@ -613,6 +613,10 @@ Perl_yyparse (pTHX)
 	    /* Pop the rest of the stack.  */
 	    while (yyss < yyssp) {
 		YYDSYMPRINTF ("Error: popping", yystos[*yyssp], yyvsp);
+		if (yy_is_opval[yystos[*yyssp]]) {
+		    YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
+		    op_free(yyvsp->opval);
+		}
 		YYPOPSTACK;
 	    }
 	    YYABORT;
@@ -650,6 +654,10 @@ Perl_yyparse (pTHX)
 	    YYABORT;
 
 	YYDSYMPRINTF ("Error: popping", yystos[*yyssp], yyvsp);
+	if (yy_is_opval[yystos[*yyssp]]) {
+	    YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
+	    op_free(yyvsp->opval);
+	}
 	yyvsp--;
 #ifdef DEBUGGING
 	yynsp--;
diff --git a/perly.tab b/perly.tab
index 18c162424f..d1807d76f8 100644
--- a/perly.tab
+++ b/perly.tab
@@ -884,3 +884,30 @@ static const unsigned char yystos[] =
       96,   105,   105,    99,    96,    78,    96,   108,   105,    81,
      112,   105,   113,    77,    77,    96,    96,   102
 };
+/* which symbols are of type opval */
+static const int yy_is_opval[] =
+{
+  0, 0, 0, 0, 1, 1, 1,
+  1, 1, 1, 1, 1, 1,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 1, 0, 0, 0, 1,
+  0, 0, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 0, 1, 1, 1,
+  1, 1, 1, 0, 0, 0, 1,
+  1, 0, 0, 0, 0,
+  1, 1, 1, 1, 1, 0,
+  0, 0, 1, 1, 1, 0, 1, 1,
+  1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 1,
+  1, 1, 1, 1, 1, 0
+
+};
diff --git a/regen_perly.pl b/regen_perly.pl
index af92aa890c..95e209bc6c 100644
--- a/regen_perly.pl
+++ b/regen_perly.pl
@@ -11,6 +11,7 @@
 #		#line directives plus adding a #ifdef PERL_CORE
 #
 # perly.tab	the parser table C definitions extracted from the bison output
+#		plus an extra table generated by this script.
 #
 # perly.act	the action case statements extracted from the bison output
 #
@@ -87,6 +88,8 @@ close CTMPFILE;
 
 my ($actlines, $tablines) = extract($clines);
 
+$tablines .= make_opval_tab($y_file, $tablines);
+
 chmod 0644, $act_file;
 open ACTFILE, ">$act_file" or die "can't open $act_file: $!\n";
 print ACTFILE $actlines;
@@ -169,6 +172,45 @@ sub extract {
     return $actlines. "\n", $tablines. "\n";
 }
 
+# read a .y file and extract a list of all the token names and
+# non-terminal names that are declared to be of type opval
+# then scan the string $tablines for the table yytname which gives
+# the token index of each token/non-terminal, then use this to
+# create a new table, indexed by token number, which indicates
+# whether that token is of type opval.
+#
+# ie given
+# %token <opval> A B
+# %type  <opval> C D
+#
+# and yytname[] = { "A" "B", "C", "D", "E", "F" };
+#
+# then return
+# static const int yy_is_opval[] = { 1, 1, 1, 1, 0, 0 }
+
+sub make_opval_tab {
+    my ($y_file, $tablines) = @_;
+    my %tokens;
+    open my $fh, '<', $y_file or die "Can't open $y_file: $!\n";
+    while (<$fh>) {
+	next unless s/^%(token|type)\s+<opval>\s+//;
+	$tokens{$_} =1 for (split ' ', $_);
+    }
+
+    $tablines =~ /^\Qstatic const char *const yytname[] =\E\n
+	    {\n
+	    (.*?)
+	    ^};
+	    /xsm
+	or die "Can't extract yytname[] from table string\n";
+    my $fields = $1;
+    $fields =~ s/"([^"]+)"/$tokens{$1}||0/ge;
+    return 
+	"/* which symbols are of type opval */\n" .
+	"static const int yy_is_opval[] =\n{\n" . $fields . "\n};\n";
+}
+
+
 sub my_system {
     system(@_);
     if ($? == -1) {