Move context propagation and finalize_optree from do_eval to newPROG

Aborting after errors found by finalize_optree in do_eval wasn't done
properly and would cause memory problems.
This patch moves the context propagation and finalize_optree to
newPROG such that the normal error handling is done.
The eval context blk_gimme is used to communicate the context.

diff --git a/op.c b/op.c
index a144385..fabffe1 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2704,11 +2704,23 @@ Perl_newPROG(pTHX_ OP *o)
     PERL_ARGS_ASSERT_NEWPROG;
 
     if (PL_in_eval) {
+       PERL_CONTEXT *cx;
        if (PL_eval_root)
                return;
        PL_eval_root = newUNOP(OP_LEAVEEVAL,
                               ((PL_in_eval & EVAL_KEEPERR)
                                ? OPf_SPECIAL : 0), o);
+
+       cx = &cxstack[cxstack_ix];
+       assert(CxTYPE(cx) == CXt_EVAL);
+
+       if ((cx->blk_gimme & G_WANT) == G_VOID)
+           scalarvoid(PL_eval_root);
+       else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
+           list(PL_eval_root);
+       else
+           scalar(PL_eval_root);
+
        /* don't use LINKLIST, since PL_eval_root might indirect through
         * a rather expensive function call and LINKLIST evaluates its
         * argument more than once */
@@ -2717,6 +2729,8 @@ Perl_newPROG(pTHX_ OP *o)
        OpREFCNT_set(PL_eval_root, 1);
        PL_eval_root->op_next = 0;
        CALL_PEEP(PL_eval_start);
+       finalize_optree(PL_eval_root);
+
     }
     else {
        if (o->op_type == OP_STUB) {

diff --git a/pp_ctl.c b/pp_ctl.c
index f226e0d..c0a16e4 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3471,6 +3471,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     CvEVAL_on(PL_compcv);
     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
+    cxstack[cxstack_ix].blk_gimme = gimme;
 
     CvOUTSIDE_SEQ(PL_compcv) = seq;
     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
@@ -3527,7 +3528,6 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
        SV *namesv;
        const char *msg;
 
-      parse_error:
        cx = NULL;
        namesv = NULL;
        PERL_UNUSED_VAR(newsp);
@@ -3589,20 +3589,6 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     } else
        SAVEFREEOP(PL_eval_root);
 
-    /* Set the context for this new optree.
-     * Propagate the context from the eval(). */
-    if ((gimme & G_WANT) == G_VOID)
-       scalarvoid(PL_eval_root);
-    else if ((gimme & G_WANT) == G_ARRAY)
-       list(PL_eval_root);
-    else
-       scalar(PL_eval_root);
-
-    finalize_optree(PL_eval_root);
-
-    if (PL_parser->error_count) /* finalize_optree might have generated new error */
-       goto parse_error;
-
     DEBUG_x(dump_eval());
 
     /* Register with debugger: */