{
dSP; dMARK;
PERL_CONTEXT *cx;
- bool clear_errsv = FALSE;
- I32 gimme;
- SV **newsp;
- PMOP *newpm;
- I32 optype = 0;
- SV *namesv;
- CV *evalcv;
- OP *retop = NULL;
-
+ SV **oldsp;
const I32 cxix = dopoptosub(cxstack_ix);
- if (cxix < 0) {
- if (CxMULTICALL(cxstack)) { /* In this case we must be in a
- * sort block, which is a CXt_NULL
- * not a CXt_SUB */
- dounwind(0);
- /* if we were in list context, we would have to splice out
- * any junk before the return args, like we do in the general
- * pp_return case, e.g.
- * sub f { for (junk1, junk2) { return arg1, arg2 }}
- */
- assert(cxstack[0].blk_gimme == G_SCALAR);
- return 0;
- }
- else
- DIE(aTHX_ "Can't return outside a subroutine");
- }
- if (cxix < cxstack_ix)
+ assert(cxstack_ix >= 0);
+ if (cxix < cxstack_ix) {
+ if (cxix < 0) {
+ if (CxMULTICALL(cxstack)) { /* In this case we must be in a
+ * sort block, which is a CXt_NULL
+ * not a CXt_SUB */
+ dounwind(0);
+ /* if we were in list context, we would have to splice out
+ * any junk before the return args, like we do in the general
+ * pp_return case, e.g.
+ * sub f { for (junk1, junk2) { return arg1, arg2 }}
+ */
+ assert(cxstack[0].blk_gimme == G_SCALAR);
+ return 0;
+ }
+ else
+ DIE(aTHX_ "Can't return outside a subroutine");
+ }
dounwind(cxix);
+ }
cx = &cxstack[cxix];
- if (CxTYPE(cx) == CXt_SUB
- || (CxTYPE(cx) == CXt_EVAL && CxTRYBLOCK(cx)))
- {
- SV **oldsp = PL_stack_base + cx->blk_oldsp;
- if (oldsp != MARK) {
- /* Handle extra junk on the stack. For example,
- * for (1,2) { return 3,4 }
- * leaves 1,2,3,4 on the stack. In list context we
- * have to splice out the 1,2; In scalar context for
- * for (1,2) { return }
- * we need to set sp = oldsp so that pp_leavesub knows
- * to push &PL_sv_undef onto the stack.
- * Note that in pp_return we only do the extra processing
- * required to handle junk; everything else we leave to
- * pp_leavesub.
- */
- SSize_t nargs = SP - MARK;
- if (nargs) {
- if (cx->blk_gimme == G_ARRAY) {
- /* shift return args to base of call stack frame */
- Move(MARK + 1, oldsp + 1, nargs, SV**);
- PL_stack_sp = oldsp + nargs;
- }
+ oldsp = PL_stack_base + cx->blk_oldsp;
+ if (oldsp != MARK) {
+ /* Handle extra junk on the stack. For example,
+ * for (1,2) { return 3,4 }
+ * leaves 1,2,3,4 on the stack. In list context we
+ * have to splice out the 1,2; In scalar context for
+ * for (1,2) { return }
+ * we need to set sp = oldsp so that pp_leavesub knows
+ * to push &PL_sv_undef onto the stack.
+ * Note that in pp_return we only do the extra processing
+ * required to handle junk; everything else we leave to
+ * pp_leavesub.
+ */
+ SSize_t nargs = SP - MARK;
+ if (nargs) {
+ if (cx->blk_gimme == G_ARRAY) {
+ /* shift return args to base of call stack frame */
+ Move(MARK + 1, oldsp + 1, nargs, SV**);
+ PL_stack_sp = oldsp + nargs;
}
- else
- PL_stack_sp = oldsp;
}
- if (CxTYPE(cx) == CXt_EVAL)
- return Perl_pp_leavetry(aTHX);
- /* fall through to a normal sub exit */
- return CvLVALUE(cx->blk_sub.cv)
- ? Perl_pp_leavesublv(aTHX)
- : Perl_pp_leavesub(aTHX);
+ else
+ PL_stack_sp = oldsp;
}
- POPBLOCK(cx,newpm);
+ /* fall through to a normal exit */
switch (CxTYPE(cx)) {
case CXt_EVAL:
- if (!(PL_in_eval & EVAL_KEEPERR))
- clear_errsv = TRUE;
- POPEVAL(cx);
- namesv = cx->blk_eval.old_namesv;
- retop = cx->blk_eval.retop;
- evalcv = cx->blk_eval.cv;
- break;
+ return CxTRYBLOCK(cx)
+ ? Perl_pp_leavetry(aTHX)
+ : Perl_pp_leaveeval(aTHX);
+ case CXt_SUB:
+ return CvLVALUE(cx->blk_sub.cv)
+ ? Perl_pp_leavesublv(aTHX)
+ : Perl_pp_leavesub(aTHX);
case CXt_FORMAT:
- retop = cx->blk_sub.retop;
- POPFORMAT(cx);
- break;
+ return Perl_pp_leavewrite(aTHX);
default:
DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
}
-
- TAINT_NOT;
- if (gimme == G_SCALAR)
- *++newsp = (MARK < SP) ? sv_mortalcopy(*SP) : &PL_sv_undef;
- else if (gimme == G_ARRAY) {
- while (++MARK <= SP) {
- *++newsp = sv_mortalcopy(*MARK);
- TAINT_NOT; /* Each item is independent */
- }
- }
- PL_stack_sp = newsp;
-
- if (CxTYPE(cx) == CXt_EVAL) {
-#ifdef DEBUGGING
- assert(CvDEPTH(evalcv) == 1);
-#endif
- CvDEPTH(evalcv) = 0;
-
- if (optype == OP_REQUIRE &&
- !(gimme == G_SCALAR ? SvTRUE(*PL_stack_sp) : PL_stack_sp > PL_stack_base + cx->blk_oldsp) )
- {
- /* 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);
- DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
- }
- }
-
- LEAVE;
-
- PL_curpm = newpm; /* ... and pop $1 et al */
-
- if (clear_errsv) {
- CLEAR_ERRSV();
- }
- return retop;
}
https://perl5.git.perl.org / perl5.git / blobdiff