Upgrade to Module-Build-0.2803

[perl5.git] / perly.c

diff --git a/perly.c b/perly.c
index 18f8606..888c6ea 100644 (file)
--- a/perly.c
+++ b/perly.c
@@ -140,14 +140,23 @@ yy_stack_print (pTHX_ const short *yyss, const short *yyssp, const YYSTYPE *yyvs
     for (i=0; i < count; i++)
        PerlIO_printf(Perl_debug_log, " %8d", start+i);
     PerlIO_printf(Perl_debug_log, "\nstate:");
-    for (i=0, yyss += start; i < count; i++, yyss++)
-       PerlIO_printf(Perl_debug_log, " %8d", *yyss);
+    for (i=0; i < count; i++)
+       PerlIO_printf(Perl_debug_log, " %8d", yyss[start+i]);
     PerlIO_printf(Perl_debug_log, "\ntoken:");
-    for (i=0, yyns += start; i < count; i++, yyns++)
-       PerlIO_printf(Perl_debug_log, " %8.8s", *yyns);
+    for (i=0; i < count; i++)
+       PerlIO_printf(Perl_debug_log, " %8.8s", yyns[start+i]);
     PerlIO_printf(Perl_debug_log, "\nvalue:");
-    for (i=0, yyvs += start; i < count; i++, yyvs++)
-       PerlIO_printf(Perl_debug_log, " %8"UVxf, (UV)yyvs->ival);
+    for (i=0; i < count; i++) {
+       if (yy_is_opval[yystos[yyss[start+i]]]) {
+           PerlIO_printf(Perl_debug_log, " %8.8s",
+                 yyvs[start+i].opval
+                   ? PL_op_name[yyvs[start+i].opval->op_type]
+                   : "NULL"
+           );
+       }
+       else
+           PerlIO_printf(Perl_debug_log, " %8"UVxf, (UV)yyvs[start+i].ival);
+    }
     PerlIO_printf(Perl_debug_log, "\n\n");
 }
 
@@ -236,6 +245,38 @@ yystpcpy (pTHX_ char *yydest, const char *yysrc)
 
 #endif /* !YYERROR_VERBOSE */
 
+
+/* a snapshot of the current stack position variables for use by
+ * S_clear_yystack */
+
+typedef struct {
+    short *yyss;
+    short *yyssp;
+    YYSTYPE *yyvsp;
+    int yylen;
+} yystack_positions;
+
+/* called during cleanup (via SAVEDESTRUCTOR_X) to free any items on the
+ * parse stack, thus avoiding leaks if we die  */
+
+static void
+S_clear_yystack(pTHX_ const void *p)
+{
+    yystack_positions *y = (yystack_positions*) p;
+
+    if (!y->yyss)
+       return;
+    YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n"));
+    y->yyvsp -= y->yylen; /* ignore the tokens that have just been reduced */
+    y->yyssp -= y->yylen;
+    while (y->yyssp > y->yyss) {
+       if (yy_is_opval[yystos[*y->yyssp]])
+           op_free(y->yyvsp->opval);
+       y->yyvsp--;
+       y->yyssp--;
+    }
+}
+
 /*----------.
 | yyparse.  |
 `----------*/
@@ -274,6 +315,8 @@ Perl_yyparse (pTHX)
     /* for ease of re-allocation and automatic freeing, have two SVs whose
       * SvPVX points to the stacks */
     SV *yyss_sv, *yyvs_sv;
+    SV *ss_save_sv;
+    yystack_positions *ss_save;
 
 #ifdef DEBUGGING
     /* maintain also a stack of token/rule names for debugging with -Dpv */
@@ -311,10 +354,18 @@ Perl_yyparse (pTHX)
 
     yyss_sv = newSV(YYINITDEPTH * sizeof(short));
     yyvs_sv = newSV(YYINITDEPTH * sizeof(YYSTYPE));
+    ss_save_sv = newSV(sizeof(yystack_positions));
     SAVEFREESV(yyss_sv);
     SAVEFREESV(yyvs_sv);
+    SAVEFREESV(ss_save_sv);
     yyss = (short *) SvPVX(yyss_sv);
     yyvs = (YYSTYPE *) SvPVX(yyvs_sv);
+    ss_save = (yystack_positions *) SvPVX(ss_save_sv);
+
+    ss_save->yyss = NULL; /* disarm stack cleanup */
+    /* cleanup the parse stack on premature exit */
+    SAVEDESTRUCTOR_X(S_clear_yystack, (void*) ss_save);
+
     /* note that elements zero of yyvs and yyns are not used */
     yyssp = yyss;
     yyvsp = yyvs;
@@ -331,8 +382,6 @@ Perl_yyparse (pTHX)
     yynerrs = 0;
     yychar = YYEMPTY;          /* Cause a token to be read.  */
 
-
-
     YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
 
     goto yysetstate;
@@ -498,6 +547,15 @@ Perl_yyparse (pTHX)
 
 
     YY_REDUCE_PRINT (yyn);
+
+    /* running external code may trigger a die (eg 'use nosuchmodule'):
+     * record the current stack state so that an unwind will
+     * free all the pesky OPs lounging around on the parse stack */
+    ss_save->yyss = yyss;
+    ss_save->yyssp = yyssp;
+    ss_save->yyvsp = yyvsp;
+    ss_save->yylen = yylen;
+
     switch (yyn) {
 
 /* contains all the rule actions; auto-generated from perly.y */
@@ -613,6 +671,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 +712,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--;
@@ -699,7 +765,8 @@ Perl_yyparse (pTHX)
 
   yyreturn:
 
-    LEAVE;                     /* force stack free before we return */
+    ss_save->yyss = NULL;      /* disarm parse stack cleanup */
+    LEAVE;             /* force stack free before we return */
 
     return yyresult;
 }