X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/76d1013142ea50e7328ee8ae3fd351a40aacaff5..31705cdacf6f9aab26c6d405eaaaa3e1cf3d9b72:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 5c57580..142dec7 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -190,7 +190,7 @@ PP(pp_regcomp) PP(pp_substcont) { dSP; - PERL_CONTEXT *cx = &cxstack[cxstack_ix]; + PERL_CONTEXT *cx = CX_CUR(); PMOP * const pm = (PMOP*) cLOGOP->op_other; SV * const dstr = cx->sb_dstr; char *s = cx->sb_s; @@ -285,8 +285,11 @@ PP(pp_substcont) /* PL_tainted must be correctly set for this mg_set */ SvSETMAGIC(TARG); TAINT_NOT; + CX_LEAVE_SCOPE(cx); POPSUBST(cx); + CX_POP(cx); + PERL_ASYNC_CHECK(); RETURNOP(pm->op_next); NOT_REACHED; /* NOTREACHED */ @@ -1263,10 +1266,11 @@ static const char * const context_name[] = { NULL, /* CXt_WHEN never actually needs "block" */ NULL, /* CXt_BLOCK never actually needs "block" */ NULL, /* CXt_GIVEN never actually needs "block" */ - NULL, /* CXt_LOOP_FOR never actually needs "loop" */ NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */ - NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */ NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */ + NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */ + NULL, /* CXt_LOOP_LIST never actually needs "loop" */ + NULL, /* CXt_LOOP_ARY never actually needs "loop" */ "subroutine", "format", "eval", @@ -1294,10 +1298,11 @@ S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags) if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */ return -1; break; + case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: - case CXt_LOOP_FOR: - case CXt_LOOP_PLAIN: + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: { STRLEN cx_label_len = 0; U32 cx_label_flags = 0; @@ -1441,10 +1446,11 @@ S_dopoptoloop(pTHX_ I32 startingblock) if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */ return -1; break; + case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: - case CXt_LOOP_FOR: - case CXt_LOOP_PLAIN: + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i)); return i; } @@ -1452,7 +1458,7 @@ S_dopoptoloop(pTHX_ I32 startingblock) return i; } -/* find the next GIVEN or FOR loop context block */ +/* find the next GIVEN or FOR (with implicit $_) loop context block */ STATIC I32 S_dopoptogivenfor(pTHX_ I32 startingblock) @@ -1467,12 +1473,13 @@ S_dopoptogivenfor(pTHX_ I32 startingblock) DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i)); return i; case CXt_LOOP_PLAIN: - assert(!CxFOREACHDEF(cx)); + assert(!(cx->cx_type & CXp_FOR_DEF)); break; case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: - case CXt_LOOP_FOR: - if (CxFOREACHDEF(cx)) { + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: + if (cx->cx_type & CXp_FOR_DEF) { DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i)); return i; } @@ -1498,17 +1505,23 @@ S_dopoptowhen(pTHX_ I32 startingblock) return i; } +/* dounwind(): pop all contexts above (but not including) cxix. + * Note that it clears the savestack frame associated with each popped + * context entry, but doesn't free any temps. + * It does a POPBLOCK of the last frame that it pops, and leaves + * cxstack_ix equal to cxix. + */ + void Perl_dounwind(pTHX_ I32 cxix) { - I32 optype; - if (!PL_curstackinfo) /* can happen if die during thread cloning */ return; while (cxstack_ix > cxix) { - PERL_CONTEXT *cx = &cxstack[cxstack_ix]; - DEBUG_CX("UNWIND"); \ + PERL_CONTEXT *cx = CX_CUR(); + + CX_DEBUG(cx, "UNWIND"); /* Note: we don't need to restore the base context info till the end. */ CX_LEAVE_SCOPE(cx); @@ -1516,7 +1529,7 @@ Perl_dounwind(pTHX_ I32 cxix) switch (CxTYPE(cx)) { case CXt_SUBST: POPSUBST(cx); - continue; /* not break */ + break; case CXt_SUB: POPSUB(cx); break; @@ -1526,10 +1539,11 @@ Perl_dounwind(pTHX_ I32 cxix) case CXt_BLOCK: POPBASICBLK(cx); break; + case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: - case CXt_LOOP_FOR: - case CXt_LOOP_PLAIN: + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: POPLOOP(cx); break; case CXt_WHEN: @@ -1545,9 +1559,12 @@ Perl_dounwind(pTHX_ I32 cxix) POPFORMAT(cx); break; } + if (cxstack_ix == cxix + 1) { + POPBLOCK(cx); + } cxstack_ix--; } - PERL_UNUSED_VAR(optype); + } void @@ -1571,6 +1588,34 @@ Perl_qerror(pTHX_ SV *err) ++PL_parser->error_count; } + + +/* undef or delete the $INC{namesv} entry, then croak. + * require0 indicates that the require didn't return a true value */ + +static void +S_undo_inc_then_croak(pTHX_ SV *namesv, SV *err, bool require0) +{ + const char *fmt; + HV *inc_hv = GvHVn(PL_incgv); + I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv); + const char *key = SvPVX_const(namesv); + + if (require0) { + (void)hv_delete(inc_hv, key, klen, G_DISCARD); + fmt = "%"SVf" did not return a true value"; + err = namesv; + } + else { + (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0); + fmt = "%"SVf"Compilation failed in require"; + err = err ? err : newSVpvs_flags("Unknown error\n", SVs_TEMP); + } + + Perl_croak(aTHX_ fmt, SVfARG(err)); +} + + void Perl_die_unwind(pTHX_ SV *msv) { @@ -1628,63 +1673,44 @@ Perl_die_unwind(pTHX_ SV *msv) } if (cxix >= 0) { - I32 optype; - SV *namesv; + SV *namesv = NULL; PERL_CONTEXT *cx; - SV **newsp; + SV **oldsp; I32 gimme; -#ifdef DEBUGGING - COP *oldcop; -#endif JMPENV *restartjmpenv; OP *restartop; if (cxix < cxstack_ix) dounwind(cxix); - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_EVAL); - newsp = PL_stack_base + cx->blk_oldsp; - gimme = cx->blk_gimme; + /* return false to the caller of eval */ + oldsp = PL_stack_base + cx->blk_oldsp; + gimme = cx->blk_gimme; if (gimme == G_SCALAR) - *++newsp = &PL_sv_undef; - PL_stack_sp = newsp; - - - if (CxTYPE(cx) != CXt_EVAL) { - STRLEN msglen; - const char* message = SvPVx_const(exceptsv, msglen); - PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11); - PerlIO_write(Perl_error_log, message, msglen); - my_exit(1); - } + *++oldsp = &PL_sv_undef; + PL_stack_sp = oldsp; CX_LEAVE_SCOPE(cx); POPEVAL(cx); POPBLOCK(cx); - cxstack_ix--; - namesv = cx->blk_eval.old_namesv; -#ifdef DEBUGGING - oldcop = cx->blk_oldcop; -#endif restartjmpenv = cx->blk_eval.cur_top_env; restartop = cx->blk_eval.retop; + if (CxOLD_OP_TYPE(cx) == OP_REQUIRE) + namesv = cx->blk_eval.old_namesv; + CX_POP(cx); + + if (namesv) { + /* note that unlike pp_entereval, pp_require isn't + * supposed to trap errors. So now that we've popped the + * EVAL that pp_require pushed, process the error message + * and rethrow the error */ + S_undo_inc_then_croak(aTHX_ namesv, exceptsv, FALSE); + NOT_REACHED; /* NOTREACHED */ + } - if (optype == OP_REQUIRE) { - assert (PL_curcop == oldcop); - (void)hv_store(GvHVn(PL_incgv), - SvPVX_const(namesv), - SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), - &PL_sv_undef, 0); - /* note that unlike pp_entereval, pp_require isn't - * supposed to trap errors. So now that we've popped the - * EVAL that pp_require pushed, and processed the error - * message, rethrow the error */ - Perl_croak(aTHX_ "%"SVf"Compilation failed in require", - SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n", - SVs_TEMP))); - } if (!(in_eval & EVAL_KEEPERR)) sv_setsv(ERRSV, exceptsv); PL_restartjmpenv = restartjmpenv; @@ -1797,7 +1823,7 @@ PP(pp_caller) RETURN; } - DEBUG_CX("CALLER"); + CX_DEBUG(cx, "CALLER"); assert(CopSTASH(cx->blk_oldcop)); stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop)) @@ -1950,7 +1976,7 @@ PP(pp_dbstate) { PL_curcop = (COP*)PL_op; TAINT_NOT; /* Each statement is presumed innocent */ - PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; + PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp; FREETMPS; PERL_ASYNC_CHECK(); @@ -1991,7 +2017,7 @@ PP(pp_dbstate) PUSHBLOCK(cx, CXt_SUB, SP); PUSHSUB_DB(cx); cx->blk_sub.retop = PL_op->op_next; - cx->cx_old_savestack_ix = PL_savestack_ix; + cx->blk_oldsaveix = PL_savestack_ix; SAVEI32(PL_debug); PL_debug = 0; @@ -2009,59 +2035,6 @@ PP(pp_dbstate) return NORMAL; } -/* S_leave_common: Common code that many functions in this file use on - scope exit. - - Process the return args on the stack in the range (mark+1..PL_stack_sp) - based on context, with any final args starting at newsp+1. - Args are mortal copied (or mortalied if lvalue) unless its safe to use - as-is, based on whether it has the specified flags. Note that most - callers specify flags as (SVs_PADTMP|SVs_TEMP), while leaveeval skips - SVs_PADTMP since its optree gets immediately freed, freeing its padtmps - at the same time. - - Also, taintedness is cleared. -*/ - -STATIC void -S_leave_common(pTHX_ SV **newsp, SV **mark, I32 gimme, - U32 flags, bool lvalue) -{ - dSP; - PERL_ARGS_ASSERT_LEAVE_COMMON; - - TAINT_NOT; - if (gimme == G_SCALAR) { - if (MARK < SP) - *++newsp = (SvFLAGS(*SP) & flags) - ? *SP - : lvalue - ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP)) - : sv_mortalcopy(*SP); - else { - EXTEND(newsp, 1); - *++newsp = &PL_sv_undef; - } - } - else if (gimme == G_ARRAY) { - /* in case LEAVE wipes old return values */ - while (++MARK <= SP) { - if (SvFLAGS(*MARK) & flags) - *++newsp = *MARK; - else { - *++newsp = lvalue - ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)) - : sv_mortalcopy(*MARK); - TAINT_NOT; /* Each item is independent */ - } - } - /* When this function was called with MARK == newsp, we reach this - * point with SP == newsp. */ - } - - PL_stack_sp = newsp; -} - PP(pp_enter) { @@ -2078,28 +2051,28 @@ PP(pp_enter) PP(pp_leave) { PERL_CONTEXT *cx; - SV **newsp; + SV **oldsp; I32 gimme; - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_BLOCK); if (PL_op->op_flags & OPf_SPECIAL) cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ - newsp = PL_stack_base + cx->blk_oldsp; + oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; if (gimme == G_VOID) - PL_stack_sp = newsp; + PL_stack_sp = oldsp; else - leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, - PL_op->op_private & OPpLVALUE); + leave_adjust_stacks(oldsp, oldsp, gimme, + PL_op->op_private & OPpLVALUE ? 3 : 1); CX_LEAVE_SCOPE(cx); POPBASICBLK(cx); POPBLOCK(cx); - cxstack_ix--; + CX_POP(cx); return NORMAL; } @@ -2133,7 +2106,7 @@ PP(pp_enteriter) const I32 gimme = GIMME_V; void *itervarp; /* GV or pad slot of the iteration variable */ SV *itersave; /* the old var in the iterator var slot */ - U8 cxtype = CXt_LOOP_FOR; + U8 cxflags = 0; if (PL_op->op_targ) { /* "my" variable */ itervarp = &PAD_SVl(PL_op->op_targ); @@ -2146,68 +2119,58 @@ PP(pp_enteriter) SvPADSTALE_on(itersave); } SvREFCNT_inc_simple_void_NN(itersave); - cxtype |= CXp_FOR_PAD; + cxflags = CXp_FOR_PAD; } else { SV * const sv = POPs; itervarp = (void *)sv; if (LIKELY(isGV(sv))) { /* symbol table variable */ - SV** svp = &GvSV(sv); - itersave = *svp; - if (LIKELY(itersave)) - SvREFCNT_inc_simple_void_NN(itersave); - else - *svp = newSV(0); - cxtype |= CXp_FOR_GV; + itersave = GvSV(sv); + SvREFCNT_inc_simple_void(itersave); + cxflags = CXp_FOR_GV; + if (PL_op->op_private & OPpITER_DEF) + cxflags |= CXp_FOR_DEF; } else { /* LV ref: for \$foo (...) */ assert(SvTYPE(sv) == SVt_PVMG); assert(SvMAGIC(sv)); assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref); itersave = NULL; - cxtype |= CXp_FOR_LVREF; + cxflags = CXp_FOR_LVREF; } } + /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */ + assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF)); - if (PL_op->op_private & OPpITER_DEF) - cxtype |= CXp_FOR_DEF; + PUSHBLOCK(cx, cxflags, MARK); + PUSHLOOP_FOR(cx, itervarp, itersave); - PUSHBLOCK(cx, cxtype, SP); - PUSHLOOP_FOR(cx, itervarp, itersave, MARK); if (PL_op->op_flags & OPf_STACKED) { + /* OPf_STACKED implies either a single array: for(@), with a + * single AV on the stack, or a range: for (1..5), with 1 and 5 on + * the stack */ SV *maybe_ary = POPs; if (SvTYPE(maybe_ary) != SVt_PVAV) { + /* range */ dPOPss; SV * const right = maybe_ary; - if (UNLIKELY(cxtype & CXp_FOR_LVREF)) + if (UNLIKELY(cxflags & CXp_FOR_LVREF)) DIE(aTHX_ "Assigned value is not a reference"); SvGETMAGIC(sv); SvGETMAGIC(right); if (RANGE_IS_NUMERIC(sv,right)) { - cx->cx_type &= ~CXTYPEMASK; cx->cx_type |= CXt_LOOP_LAZYIV; - /* Make sure that no-one re-orders cop.h and breaks our - assumptions */ - assert(CxTYPE(cx) == CXt_LOOP_LAZYIV); if (S_outside_integer(aTHX_ sv) || S_outside_integer(aTHX_ right)) DIE(aTHX_ "Range iterator outside integer range"); cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv); cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right); -#ifdef DEBUGGING - /* for correct -Dstv display */ - cx->blk_oldsp = sp - PL_stack_base; -#endif } else { - cx->cx_type &= ~CXTYPEMASK; cx->cx_type |= CXt_LOOP_LAZYSV; - /* Make sure that no-one re-orders cop.h and breaks our - assumptions */ - assert(CxTYPE(cx) == CXt_LOOP_LAZYSV); cx->blk_loop.state_u.lazysv.cur = newSVsv(sv); cx->blk_loop.state_u.lazysv.end = right; - SvREFCNT_inc(right); + SvREFCNT_inc_simple_void_NN(right); (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur); /* This will do the upgrade to SVt_PV, and warn if the value is uninitialised. */ @@ -2221,22 +2184,28 @@ PP(pp_enteriter) } } else /* SvTYPE(maybe_ary) == SVt_PVAV */ { + /* for (@array) {} */ + cx->cx_type |= CXt_LOOP_ARY; cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary); - SvREFCNT_inc(maybe_ary); + SvREFCNT_inc_simple_void_NN(maybe_ary); cx->blk_loop.state_u.ary.ix = (PL_op->op_private & OPpITER_REVERSED) ? AvFILL(cx->blk_loop.state_u.ary.ary) + 1 : -1; } + /* EXTEND(SP, 1) not needed in this branch because we just did POPs */ } else { /* iterating over items on the stack */ - cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */ - if (PL_op->op_private & OPpITER_REVERSED) { - cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1; - } - else { - cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base; - } + cx->cx_type |= CXt_LOOP_LIST; + cx->blk_oldsp = SP - PL_stack_base; + cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base; + cx->blk_loop.state_u.stack.ix = + (PL_op->op_private & OPpITER_REVERSED) + ? cx->blk_oldsp + 1 + : cx->blk_loop.state_u.stack.basesp; + /* pre-extend stack so pp_iter doesn't have to check every time + * it pushes yes/no */ + EXTEND(SP, 1); } RETURN; @@ -2249,7 +2218,7 @@ PP(pp_enterloop) const I32 gimme = GIMME_V; PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); - PUSHLOOP_PLAIN(cx, SP); + PUSHLOOP_PLAIN(cx); RETURN; } @@ -2258,25 +2227,27 @@ PP(pp_leaveloop) { PERL_CONTEXT *cx; I32 gimme; - SV **newsp; + SV **oldsp; SV **mark; - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE_is_LOOP(cx)); mark = PL_stack_base + cx->blk_oldsp; - newsp = PL_stack_base + cx->blk_loop.resetsp; + oldsp = CxTYPE(cx) == CXt_LOOP_LIST + ? PL_stack_base + cx->blk_loop.state_u.stack.basesp + : mark; gimme = cx->blk_gimme; if (gimme == G_VOID) - PL_stack_sp = newsp; + PL_stack_sp = oldsp; else - leave_common(newsp, MARK, gimme, SVs_PADTMP|SVs_TEMP, - PL_op->op_private & OPpLVALUE); + leave_adjust_stacks(MARK, oldsp, gimme, + PL_op->op_private & OPpLVALUE ? 3 : 1); CX_LEAVE_SCOPE(cx); POPLOOP(cx); /* Stack values are safe: release loop vars ... */ POPBLOCK(cx); - cxstack_ix--; + CX_POP(cx); return NORMAL; } @@ -2292,15 +2263,12 @@ PP(pp_leaveloop) PP(pp_leavesublv) { - dSP; - SV **newsp; - SV **mark; I32 gimme; PERL_CONTEXT *cx; - bool ref; - const char *what = NULL; + SV **oldsp; + OP *retop; - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_SUB); if (CxMULTICALL(cx)) { @@ -2310,105 +2278,86 @@ PP(pp_leavesublv) return 0; } - newsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; - TAINT_NOT; + oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */ - mark = newsp + 1; - - ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS); - if (gimme == G_SCALAR) { - if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */ - if (MARK <= SP) { - if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) && - !SvSMAGICAL(TOPs)) { - what = - SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef" - : "a readonly value" : "a temporary"; - } - else goto copy_sv; - } - else { - /* sub:lvalue{} will take us here. */ - what = "undef"; - } - croak: - CX_LEAVE_SCOPE(cx); - POPSUB(cx); - cxstack_ix--; - PL_curpm = cx->blk_oldpm; - Perl_croak(aTHX_ - "Can't return %s from lvalue subroutine", what - ); - } - if (MARK <= SP) { - copy_sv: - if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { - if (!SvPADTMP(*SP)) { - *MARK = SvREFCNT_inc(*SP); - FREETMPS; - sv_2mortal(*MARK); - } - else { - /* FREETMPS could clobber it */ - SV *sv = SvREFCNT_inc(*SP); - FREETMPS; - *MARK = sv_mortalcopy(sv); - SvREFCNT_dec(sv); - } - } - else - *MARK = - SvPADTMP(*SP) - ? sv_mortalcopy(*SP) - : !SvTEMP(*SP) - ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP)) - : *SP; - } - else { - MEXTEND(MARK, 0); - *MARK = &PL_sv_undef; - } - SP = MARK; + if (gimme == G_VOID) + PL_stack_sp = oldsp; + else { + U8 lval = CxLVAL(cx); + bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS)); + const char *what = NULL; + + if (gimme == G_SCALAR) { + if (is_lval) { + /* check for bad return arg */ + if (oldsp < PL_stack_sp) { + SV *sv = *PL_stack_sp; + if ((SvPADTMP(sv) || SvREADONLY(sv))) { + what = + SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef" + : "a readonly value" : "a temporary"; + } + else goto ok; + } + else { + /* sub:lvalue{} will take us here. */ + what = "undef"; + } + croak: + Perl_croak(aTHX_ + "Can't return %s from lvalue subroutine", what); + } - if (CxLVAL(cx) & OPpDEREF) { - SvGETMAGIC(TOPs); - if (!SvOK(TOPs)) { - TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF); - } - } - } - else if (gimme == G_ARRAY) { - assert (!(CxLVAL(cx) & OPpDEREF)); - if (ref || !CxLVAL(cx)) - for (; MARK <= SP; MARK++) - *MARK = - SvFLAGS(*MARK) & SVs_PADTMP - ? sv_mortalcopy(*MARK) - : SvTEMP(*MARK) - ? *MARK - : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); - else for (; MARK <= SP; MARK++) { - if (*MARK != &PL_sv_undef - && (SvPADTMP(*MARK) || SvREADONLY(*MARK)) - ) { - /* Might be flattened array after $#array = */ - what = SvREADONLY(*MARK) - ? "a readonly value" : "a temporary"; - goto croak; - } - else if (!SvTEMP(*MARK)) - *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); - } + ok: + leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2); + + if (lval & OPpDEREF) { + /* lval_sub()->{...} and similar */ + dSP; + SvGETMAGIC(TOPs); + if (!SvOK(TOPs)) { + TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF); + } + PUTBACK; + } + } + else { + assert(gimme == G_ARRAY); + assert (!(lval & OPpDEREF)); + + if (is_lval) { + /* scan for bad return args */ + SV **p; + for (p = PL_stack_sp; p > oldsp; p--) { + SV *sv = *p; + /* the PL_sv_undef exception is to allow things like + * this to work, where PL_sv_undef acts as 'skip' + * placeholder on the LHS of list assigns: + * sub foo :lvalue { undef } + * ($a, undef, foo(), $b) = 1..4; + */ + if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv))) + { + /* Might be flattened array after $#array = */ + what = SvREADONLY(sv) + ? "a readonly value" : "a temporary"; + goto croak; + } + } + } + + leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2); + } } - PUTBACK; CX_LEAVE_SCOPE(cx); POPSUB(cx); /* Stack values are safe: release CV and @_ ... */ POPBLOCK(cx); - cxstack_ix--; + retop = cx->blk_sub.retop; + CX_POP(cx); - return cx->blk_sub.retop; + return retop; } @@ -2457,21 +2406,25 @@ PP(pp_return) * We may also need to shift the args down; for example, * for (1,2) { return 3,4 } * leaves 1,2,3,4 on the stack. Both these actions can be done by - * leave_common(). By calling it with lvalue=TRUE, we just bump - * the ref count and mortalise the args that need it. The "scan - * the args and maybe copy them" process will be repeated by - * whoever we tail-call (e.g. pp_leaveeval), where any copying etc - * will be done. That is to say, in this code path two scans of - * the args will be done; the first just shifts and preserves; the - * second is the "real" arg processing, based on the type of - * return. + * leave_adjust_stacks(). By calling it with and lvalue "pass + * all" action, we just bump the ref count and mortalise the args + * that need it, do a FREETMPS. The "scan the args and maybe copy + * them" process will be repeated by whoever we tail-call (e.g. + * pp_leaveeval), where any copying etc will be done. That is to + * say, in this code path two scans of the args will be done; the + * first just shifts and preserves; the second is the "real" arg + * processing, based on the type of return. */ cx = &cxstack[cxix]; PUTBACK; - leave_common(PL_stack_base + cx->blk_oldsp, MARK, - cx->blk_gimme, SVs_TEMP|SVs_PADTMP, TRUE); + if (cx->blk_gimme != G_VOID) + leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp, + cx->blk_gimme, + CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv) + ? 3 : 0); SPAGAIN; dounwind(cxix); + cx = &cxstack[cxix]; /* CX stack may have been realloced */ } else { /* Like in the branch above, we need to handle any extra junk on @@ -2520,16 +2473,18 @@ PP(pp_return) } } +/* find the enclosing loop or labelled loop and dounwind() back to it. */ -static I32 -S_unwind_loop(pTHX_ const char * const opname) +static PERL_CONTEXT * +S_unwind_loop(pTHX) { I32 cxix; if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) /* diag_listed_as: Can't "last" outside a loop block */ - Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname); + Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", + OP_NAME(PL_op)); } else { dSP; @@ -2547,7 +2502,7 @@ S_unwind_loop(pTHX_ const char * const opname) if (cxix < 0) /* diag_listed_as: Label not found for "last %s" */ Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"", - opname, + OP_NAME(PL_op), SVfARG(PL_op->op_flags & OPf_STACKED && !SvGMAGICAL(TOPp1s) ? TOPp1s @@ -2557,24 +2512,23 @@ S_unwind_loop(pTHX_ const char * const opname) } if (cxix < cxstack_ix) dounwind(cxix); - return cxix; + return &cxstack[cxix]; } + PP(pp_last) { PERL_CONTEXT *cx; + OP* nextop; - S_unwind_loop(aTHX_ "last"); - - cx = &cxstack[cxstack_ix]; + cx = S_unwind_loop(aTHX); - assert( - CxTYPE(cx) == CXt_LOOP_LAZYIV - || CxTYPE(cx) == CXt_LOOP_LAZYSV - || CxTYPE(cx) == CXt_LOOP_FOR - || CxTYPE(cx) == CXt_LOOP_PLAIN - ); - PL_stack_sp = PL_stack_base + cx->blk_loop.resetsp; + assert(CxTYPE_is_LOOP(cx)); + PL_stack_sp = PL_stack_base + + (CxTYPE(cx) == CXt_LOOP_LIST + ? cx->blk_loop.state_u.stack.basesp + : cx->blk_oldsp + ); TAINT_NOT; @@ -2582,16 +2536,17 @@ PP(pp_last) CX_LEAVE_SCOPE(cx); POPLOOP(cx); /* release loop vars ... */ POPBLOCK(cx); - cxstack_ix--; + nextop = cx->blk_loop.my_op->op_lastop->op_next; + CX_POP(cx); - return cx->blk_loop.my_op->op_lastop->op_next; + return nextop; } PP(pp_next) { PERL_CONTEXT *cx; - S_unwind_loop(aTHX_ "next"); + cx = S_unwind_loop(aTHX); TOPBLOCK(cx); PL_curcop = cx->blk_oldcop; @@ -2601,14 +2556,14 @@ PP(pp_next) PP(pp_redo) { - const I32 cxix = S_unwind_loop(aTHX_ "redo"); - PERL_CONTEXT *cx; - OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop; + PERL_CONTEXT *cx = S_unwind_loop(aTHX); + OP* redo_op = cx->blk_loop.my_op->op_redoop; if (redo_op->op_type == OP_ENTER) { /* pop one less context to avoid $x being freed in while (my $x..) */ cxstack_ix++; - assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK); + cx = CX_CUR(); + assert(CxTYPE(cx) == CXt_BLOCK); redo_op = redo_op->op_next; } @@ -2758,6 +2713,7 @@ PP(pp_goto) if (cxix < cxstack_ix) { dounwind(cxix); } + cx = CX_CUR(); TOPBLOCK(cx); SPAGAIN; @@ -2768,9 +2724,8 @@ PP(pp_goto) assert(PL_scopestack_ix == cx->blk_oldscopesp); CX_LEAVE_SCOPE(cx); - /* partial unrolled POPSUB(): */ - if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { + /* this is part of POPSUB_ARGS() */ AV* av = MUTABLE_AV(PAD_SVl(0)); assert(AvARRAY(MUTABLE_AV( PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[ @@ -2845,7 +2800,7 @@ PP(pp_goto) SP += items; if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { /* Restore old @_ */ - POP_SAVEARRAY(); + POP_SAVEARRAY(cx); } retop = cx->blk_sub.retop; @@ -2856,7 +2811,7 @@ PP(pp_goto) * this is a POPBLOCK(), less all the stuff we already did * for TOPBLOCK() earlier */ PL_curcop = cx->blk_oldcop; - cxstack_ix--; + CX_POP(cx); /* Push a mark for the start of arglist */ PUSHMARK(mark); @@ -2960,10 +2915,11 @@ PP(pp_goto) break; } /* else fall through */ - case CXt_LOOP_LAZYIV: - case CXt_LOOP_LAZYSV: - case CXt_LOOP_FOR: - case CXt_LOOP_PLAIN: + case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: case CXt_GIVEN: case CXt_WHEN: gotoprobe = OpSIBLING(cx->blk_oldcop); @@ -3040,6 +2996,7 @@ PP(pp_goto) if (ix < 0) DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix); dounwind(ix); + cx = CX_CUR(); TOPBLOCK(cx); } @@ -3163,8 +3120,8 @@ S_docatch(pTHX_ OP *o) switch (ret) { case 0: assert(cxstack_ix >= 0); - assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); - cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env; + assert(CxTYPE(CX_CUR()) == CXt_EVAL); + CX_CUR()->blk_eval.cur_top_env = PL_top_env; redo_body: CALLRUNOPS(aTHX); break; @@ -3268,7 +3225,7 @@ S_try_yyparse(pTHX_ int gramtype) int ret; dJMPENV; - assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); + assert(CxTYPE(CX_CUR()) == CXt_EVAL); JMPENV_PUSH(ret); switch (ret) { case 0: @@ -3301,7 +3258,7 @@ S_try_yyparse(pTHX_ int gramtype) */ STATIC bool -S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) +S_doeval_compile(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) { dSP; OP * const saveop = PL_op; @@ -3321,9 +3278,9 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) evalcv = MUTABLE_CV(newSV_type(SVt_PVCV)); CvEVAL_on(evalcv); - assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); - cxstack[cxstack_ix].blk_eval.cv = evalcv; - cxstack[cxstack_ix].blk_gimme = gimme; + assert(CxTYPE(CX_CUR()) == CXt_EVAL); + CX_CUR()->blk_eval.cv = evalcv; + CX_CUR()->blk_gimme = gimme; CvOUTSIDE_SEQ(evalcv) = seq; CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); @@ -3420,64 +3377,56 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) /* note that yyparse() may raise an exception, e.g. C, * so honour CATCH_GET and trap it here if necessary */ + + /* compile the code */ yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG); if (yystatus || PL_parser->error_count || !PL_eval_root) { + SV *namesv = NULL; /* initialise to avoid compiler warning */ PERL_CONTEXT *cx; - I32 optype; /* Used by POPEVAL. */ - SV *namesv; - SV *errsv = NULL; + SV *errsv; - cx = NULL; - namesv = NULL; - PERL_UNUSED_VAR(optype); - - /* note that if yystatus == 3, then the EVAL CX block has already - * been popped, and various vars restored */ PL_op = saveop; + /* note that if yystatus == 3, then the require/eval died during + * compilation, so the EVAL CX block has already been popped, and + * various vars restored */ if (yystatus != 3) { if (PL_eval_root) { op_free(PL_eval_root); PL_eval_root = NULL; } SP = PL_stack_base + POPMARK; /* pop original mark */ - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); CX_LEAVE_SCOPE(cx); POPEVAL(cx); POPBLOCK(cx); - cxstack_ix--; - namesv = cx->blk_eval.old_namesv; + if (in_require) + namesv = cx->blk_eval.old_namesv; + CX_POP(cx); } errsv = ERRSV; if (in_require) { - if (!cx) { - /* If cx is still NULL, it means that we didn't go in the - * POPEVAL branch. */ - cx = &cxstack[cxstack_ix]; - assert(CxTYPE(cx) == CXt_EVAL); - namesv = cx->blk_eval.old_namesv; - } - (void)hv_store(GvHVn(PL_incgv), - SvPVX_const(namesv), - SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), - &PL_sv_undef, 0); - Perl_croak(aTHX_ "%"SVf"Compilation failed in require", - SVfARG(errsv - ? errsv - : newSVpvs_flags("Unknown error\n", SVs_TEMP))); - } - else { - if (!*(SvPV_nolen_const(errsv))) { - sv_setpvs(errsv, "Compilation error"); - } + if (yystatus == 3) { + cx = CX_CUR(); + assert(CxTYPE(cx) == CXt_EVAL); + namesv = cx->blk_eval.old_namesv; + } + S_undo_inc_then_croak(aTHX_ namesv, errsv, FALSE); + NOT_REACHED; /* NOTREACHED */ } + + if (!*(SvPV_nolen_const(errsv))) + sv_setpvs(errsv, "Compilation error"); + if (gimme != G_ARRAY) PUSHs(&PL_sv_undef); PUTBACK; return FALSE; } - else - LEAVE_with_name("evalcomp"); + + /* Compilation successful. Now clean up */ + + LEAVE_with_name("evalcomp"); CopLINE_set(&PL_compiling, 0); SAVEFREEOP(PL_eval_root); @@ -3503,8 +3452,6 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) PL_eval_start = es; } - /* compiled okay, so do it */ - CvDEPTH(evalcv) = 1; SP = PL_stack_base + POPMARK; /* pop original mark */ PL_op = saveop; /* The caller may need it. */ @@ -3514,6 +3461,7 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) return TRUE; } + STATIC PerlIO * S_check_type_and_open(pTHX_ SV *name) { @@ -4097,7 +4045,7 @@ PP(pp_require) /* switch to eval mode */ PUSHBLOCK(cx, CXt_EVAL, SP); PUSHEVAL(cx, name); - cx->cx_old_savestack_ix = old_savestack_ix; + cx->blk_oldsaveix = old_savestack_ix; cx->blk_eval.retop = PL_op->op_next; SAVECOPLINE(&PL_compiling); @@ -4105,7 +4053,7 @@ PP(pp_require) PUTBACK; - if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL)) + if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL)) op = DOCATCH(PL_eval_start); else op = PL_op->op_next; @@ -4213,7 +4161,7 @@ PP(pp_entereval) PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); PUSHEVAL(cx, 0); - cx->cx_old_savestack_ix = old_savestack_ix; + cx->blk_oldsaveix = old_savestack_ix; cx->blk_eval.retop = PL_op->op_next; /* prepare to compile string */ @@ -4233,7 +4181,7 @@ PP(pp_entereval) PUTBACK; - if (doeval(gimme, runcv, seq, saved_hh)) { + if (doeval_compile(gimme, runcv, seq, saved_hh)) { if (was != PL_breakable_sub_gen /* Some subs defined here. */ ? PERLDB_LINE_OR_SAVESRC : PERLDB_SAVESRC_NOSUBS) { @@ -4245,7 +4193,7 @@ PP(pp_entereval) return DOCATCH(PL_eval_start); } else { /* We have already left the scope set up earlier thanks to the LEAVE - in doeval(). */ + in doeval_compile(). */ if (was != PL_breakable_sub_gen /* Some subs defined here. */ ? PERLDB_LINE_OR_SAVESRC : PERLDB_SAVESRC_INVALID) { @@ -4259,29 +4207,36 @@ PP(pp_entereval) PP(pp_leaveeval) { - dSP; - SV **newsp; + SV **oldsp; I32 gimme; PERL_CONTEXT *cx; OP *retop; - I32 optype; - SV *namesv; + SV *namesv = NULL; CV *evalcv; /* grab this value before POPEVAL restores old PL_in_eval */ bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR); PERL_ASYNC_CHECK(); - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_EVAL); - newsp = PL_stack_base + cx->blk_oldsp; + + oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; - if (gimme != G_VOID) { - PUTBACK; - leave_common(newsp, newsp, gimme, SVs_TEMP, FALSE); - SPAGAIN; - } + /* did require return a false value? */ + if ( CxOLD_OP_TYPE(cx) == OP_REQUIRE + && !(gimme == G_SCALAR + ? SvTRUE(*PL_stack_sp) + : PL_stack_sp > oldsp) + ) + namesv = cx->blk_eval.old_namesv; + + if (gimme == G_VOID) + PL_stack_sp = oldsp; + else + leave_adjust_stacks(oldsp, oldsp, gimme, 0); + /* the POPEVAL does a leavescope, which frees the optree associated * with eval, which if it frees the nextstate associated with * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a @@ -4289,38 +4244,29 @@ PP(pp_leaveeval) * to get the current hints. So restore it early. */ PL_curcop = cx->blk_oldcop; + CX_LEAVE_SCOPE(cx); POPEVAL(cx); POPBLOCK(cx); - cxstack_ix--; - namesv = cx->blk_eval.old_namesv; retop = cx->blk_eval.retop; evalcv = cx->blk_eval.cv; - + CX_POP(cx); #ifdef DEBUGGING assert(CvDEPTH(evalcv) == 1); #endif CvDEPTH(evalcv) = 0; - if (optype == OP_REQUIRE && - !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) - { + if (namesv) { /* require returned false */ /* Unassume the success we assumed earlier. */ - (void)hv_delete(GvHVn(PL_incgv), - SvPVX_const(namesv), - SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), - G_DISCARD); - Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv)); + S_undo_inc_then_croak(aTHX_ namesv, NULL, TRUE); NOT_REACHED; /* NOTREACHED */ - /* die_unwind() did LEAVE, or we won't be here */ - } - else { - if (!keep) - CLEAR_ERRSV(); } - RETURNOP(retop); + if (!keep) + CLEAR_ERRSV(); + + return retop; } /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it @@ -4329,14 +4275,12 @@ void Perl_delete_eval_scope(pTHX) { PERL_CONTEXT *cx; - I32 optype; - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); CX_LEAVE_SCOPE(cx); POPEVAL(cx); POPBLOCK(cx); - cxstack_ix--; - PERL_UNUSED_VAR(optype); + CX_POP(cx); } /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was @@ -4349,7 +4293,7 @@ Perl_create_eval_scope(pTHX_ U32 flags) PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); PUSHEVAL(cx, 0); - cx->cx_old_savestack_ix = PL_savestack_ix; + cx->blk_oldsaveix = PL_savestack_ix; PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) @@ -4371,29 +4315,27 @@ PP(pp_entertry) PP(pp_leavetry) { - SV **newsp; + SV **oldsp; I32 gimme; PERL_CONTEXT *cx; - I32 optype; OP *retop; PERL_ASYNC_CHECK(); - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_EVAL); - newsp = PL_stack_base + cx->blk_oldsp; + oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; if (gimme == G_VOID) - PL_stack_sp = newsp; + PL_stack_sp = oldsp; else - leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE); + leave_adjust_stacks(oldsp, oldsp, gimme, 1); CX_LEAVE_SCOPE(cx); POPEVAL(cx); POPBLOCK(cx); - cxstack_ix--; retop = cx->blk_eval.retop; - PERL_UNUSED_VAR(optype); + CX_POP(cx); CLEAR_ERRSV(); return retop; @@ -4420,23 +4362,23 @@ PP(pp_leavegiven) { PERL_CONTEXT *cx; I32 gimme; - SV **newsp; + SV **oldsp; PERL_UNUSED_CONTEXT; - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_GIVEN); - newsp = PL_stack_base + cx->blk_oldsp; + oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; if (gimme == G_VOID) - PL_stack_sp = newsp; + PL_stack_sp = oldsp; else - leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE); + leave_adjust_stacks(oldsp, oldsp, gimme, 1); CX_LEAVE_SCOPE(cx); POPGIVEN(cx); POPBLOCK(cx); - cxstack_ix--; + CX_POP(cx); return NORMAL; } @@ -5001,9 +4943,9 @@ PP(pp_leavewhen) I32 cxix; PERL_CONTEXT *cx; I32 gimme; - SV **newsp; + SV **oldsp; - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_WHEN); gimme = cx->blk_gimme; @@ -5013,11 +4955,12 @@ PP(pp_leavewhen) DIE(aTHX_ "Can't \"%s\" outside a topicalizer", PL_op->op_flags & OPf_SPECIAL ? "default" : "when"); - newsp = PL_stack_base + cx->blk_oldsp; + oldsp = PL_stack_base + cx->blk_oldsp; if (gimme == G_VOID) - PL_stack_sp = newsp; + PL_stack_sp = oldsp; else - leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE); + leave_adjust_stacks(oldsp, oldsp, gimme, 1); + /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */ assert(cxix < cxstack_ix); dounwind(cxix); @@ -5027,6 +4970,7 @@ PP(pp_leavewhen) if (CxFOREACH(cx)) { /* emulate pp_next. Note that any stack(s) cleanup will be * done by the pp_unstack which op_nextop should point to */ + cx = CX_CUR(); TOPBLOCK(cx); PL_curcop = cx->blk_oldcop; return cx->blk_loop.my_op->op_nextop; @@ -5042,6 +4986,7 @@ PP(pp_continue) { I32 cxix; PERL_CONTEXT *cx; + OP *nextop; cxix = dopoptowhen(cxstack_ix); if (cxix < 0) @@ -5050,15 +4995,16 @@ PP(pp_continue) if (cxix < cxstack_ix) dounwind(cxix); - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_WHEN); PL_stack_sp = PL_stack_base + cx->blk_oldsp; CX_LEAVE_SCOPE(cx); POPWHEN(cx); POPBLOCK(cx); - cxstack_ix--; + nextop = cx->blk_givwhen.leave_op->op_next; + CX_POP(cx); - return cx->blk_givwhen.leave_op->op_next; + return nextop; } PP(pp_break) @@ -5078,7 +5024,8 @@ PP(pp_break) dounwind(cxix); /* Restore the sp at the time we entered the given block */ - TOPBLOCK(cx); + cx = CX_CUR(); + PL_stack_sp = PL_stack_base + cx->blk_oldsp; return cx->blk_givwhen.leave_op; }