lex_read_unichar(0);
}
-#define CXt_MOO 12
-#define CXt_KOOH 13
-
static OP *
-pp_entertake (pTHX)
-{
- dSP;
- register PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
-
- if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
- RETURNOP(cLOGOP->op_other->op_next);
-
- ENTER;
-
- PUSHBLOCK(cx, CXt_KOOH, SP);
- cx->blk_givwhen.leave_op = cLOGOP->op_other;
-
- RETURN;
-}
-
-STATIC I32
-S_dopoptogather(pTHX_ I32 startingblock)
+pp_stub_marker (pTHX)
{
- dVAR;
- I32 i;
- for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT *cx = &cxstack[i];
- switch (CxTYPE(cx)) {
- default:
- continue;
- case CXt_MOO:
- DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
- return i;
-
- case CXt_LOOP_PLAIN:
- assert(!CxFOREACHDEF(cx));
- break;
- case CXt_LOOP_LAZYIV:
- case CXt_LOOP_LAZYSV:
- case CXt_LOOP_FOR:/* FIXME */
- if (CxFOREACHDEF(cx)) {
- DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
- return i;
- }
- }
- }
- return i;
-}
-
-static OP *
-pp_leavetake (pTHX)
-{
- dSP;
- I32 cxix;
- register PERL_CONTEXT *cx;
- I32 gimme;
- SV **newsp;
- PMOP *newpm;
-
- cxix = S_dopoptogather(aTHX_ cxstack_ix);
- if (cxix < 0)
- /* diag_listed_as: Can't "when" outside a topicalizer */
- DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
- PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
-
- POPBLOCK(cx,newpm);
- assert(CxTYPE(cx) == CXt_KOOH);
-
- LEAVE;
-
- if (cxix < cxstack_ix)
- dounwind(cxix);
-
- cx = &cxstack[cxix];
-
- RETURNOP(cx->blk_givwhen.leave_op);
+ croak("FAIL");
}
static OP *
blkop = parse_block(0);
blkop = Perl_block_end(aTHX_ blk_floor, blkop);
- NewOp(1101, enterop, 1, LOGOP);
- enterop->op_type = OP_ENTERWHEN;
- enterop->op_ppaddr = pp_entertake;
- enterop->op_flags = OPf_KIDS;
- enterop->op_targ = -1;
- enterop->op_private = 0;
-
- leaveop = newUNOP(OP_LEAVEWHEN, 0, (OP *)enterop);
- leaveop->op_ppaddr = pp_leavetake;
-
topicalise = SvTRUE(*av_fetch((AV *)SvRV(args), 0, 0));
if (topicalise) {
OP *pvarop;
pvarop = newOP(OP_PADSV, 0);
- pvarop->op_targ = pad_findmy("$Gather::Once::current_topic",
- sizeof("$Gather::Once::current_topic")-1, 0);
+ pvarop->op_targ = pad_findmy_pvs("$Gather::Once::current_topic", 0);
if (pvarop->op_targ == NOT_IN_PAD)
croak("outside topicaliser"); /* FIXME */
condop = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, condop,
newCVREF(0, newSVOP(OP_CONST, 0,
- predicate_cv_ref))));
-
- enterop->op_first = condop;
- enterop->op_first->op_sibling = op_scope(blkop);
- leaveop->op_next = LINKLIST(enterop->op_first);
- enterop->op_first->op_next = (OP *)enterop;
+ SvREFCNT_inc(predicate_cv_ref)))));
- enterop->op_next = LINKLIST(enterop->op_first->op_sibling);
- enterop->op_first->op_sibling->op_next = enterop->op_other = leaveop;
+ OP *stub = newSTATEOP(0, NULL, newOP(OP_NULL, 0));
+ condop = newCONDOP(0, condop, blkop, stub);
+ condop->op_ppaddr = pp_stub_marker;
- return leaveop;
+ return condop;
}
static OP *
-pp_entergather (pTHX)
+is_take_stmt (pTHX_ OP *stmt)
{
- dSP; dTARGET;
- register PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
-
- ENTER;
- if (PL_op->op_targ != NOT_IN_PAD)
- sv_setsv(TARG, POPs);
-
- PUSHBLOCK(cx, CXt_MOO, SP);
- cx->blk_givwhen.leave_op = cLOGOP->op_other;
-
- RETURN;
-}
-
-static OP *
-pp_leavegather (pTHX)
-{
- dSP;
- register PERL_CONTEXT *cx;
- I32 gimme;
- SV **newsp;
- PMOP *newpm;
-
- POPBLOCK(cx,newpm);
- assert(CxTYPE(cx) == CXt_MOO);
-
- //SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
- //PL_curpm = newpm; /* Don't pop $1 et al till now */
-
- LEAVE;
- RETURN;
+ if (stmt->op_type != OP_LINESEQ
+ || !cLISTOPx(stmt)->op_last
+ || cLISTOPx(stmt)->op_last->op_type == OP_COND_EXPR)
+ return NULL;
+
+ OP *nullop = cLISTOPx(stmt)->op_last;
+ if (nullop->op_type != OP_NULL
+ || !(nullop->op_flags & OPf_KIDS)
+ || !cLISTOPx(nullop)->op_first
+ || nullop->op_ppaddr != pp_stub_marker)
+ return NULL;
+
+ OP *condop = cLISTOPx(nullop)->op_first;
+ if (condop->op_type != OP_COND_EXPR || !(condop->op_flags & OPf_KIDS))
+ return NULL;
+
+ return condop;
+ OP *stub = condop->op_next; /* falseop */
+
+ return stub;
}
static OP *
myparse_args_gather (pTHX_ GV *namegv, SV *topicalise, U32 *flagsp)
{
- OP *topicaliser, *blkop, *initop = NULL;
+ OP *topicaliser, *topblkop, *curblkop, *initop;
int blk_floor;
PERL_UNUSED_ARG(namegv);
demand_unichar(')', 0);
}
- demand_unichar('{', DEMAND_NOCONSUME);
+ demand_unichar('{', 0);
blk_floor = Perl_block_start(aTHX_ 1);
- if (SvTRUE(topicalise)) {
- initop = newOP(OP_PADSV, (OPpLVAL_INTRO<<8));
- initop->op_targ = pad_add_my_scalar_pvn("$Gather::Once::current_topic",
- sizeof("$Gather::Once::current_topic")-1);
+
+ initop = newOP(OP_PADSV, (OPpLVAL_INTRO<<8));
+ initop->op_targ = pad_add_my_scalar_pvn("$Gather::Once::current_topic",
+ sizeof("$Gather::Once::current_topic")-1);
+
+ topblkop = curblkop = parse_fullstmt(0);
+ lex_read_space(0);
+ while (lex_peek_unichar(0) != '}') {
+ OP *stub, *stmt = parse_fullstmt(0);
+
+ curblkop = op_append_elem(OP_LINESEQ, curblkop, stmt);
+
+ if ((stub = is_take_stmt(aTHX_ stmt))) {
+ curblkop = stub->op_next;
+ }
+
+ //op_dump(curblkop);
+ lex_read_space(0);
}
- blkop = parse_block(0);
- if (initop)
- blkop = op_prepend_elem(OP_LINESEQ, initop, blkop);
+ demand_unichar('}', DEMAND_IMMEDIATE);
- blkop = Perl_block_end(aTHX_ blk_floor, blkop);
+ topblkop = op_prepend_elem(OP_LINESEQ, initop, topblkop);
+ topblkop = op_scope(Perl_block_end(aTHX_ blk_floor, topblkop));
- LOGOP *enterop;
- NewOp(1101, enterop, 1, LOGOP);
- enterop->op_type = OP_ENTERGIVEN;
- enterop->op_ppaddr = pp_entergather;
- enterop->op_flags = OPf_KIDS;
- enterop->op_targ = SvTRUE(topicalise) ? initop->op_targ : NOT_IN_PAD;
- enterop->op_private = 0;
-
- OP *leaveop;
- leaveop = newUNOP(OP_LEAVEGIVEN, 0, (OP *)enterop);
- leaveop->op_ppaddr = pp_leavegather;
-
- enterop->op_first = SvTRUE(topicalise) ? topicaliser : newOP(OP_NULL, 0);
- enterop->op_first->op_sibling = op_scope(blkop);
- leaveop->op_next = LINKLIST(enterop->op_first);
- enterop->op_first->op_next = (OP *)enterop;
-
- enterop->op_next = LINKLIST(enterop->op_first->op_sibling);
- enterop->op_first->op_sibling->op_next = enterop->op_other = leaveop;
-
- return leaveop;
+ //return newGIVENOP(SvTRUE(topicalise) ? topicaliser : newOP(OP_NULL, 0),
+ //blkop, initop->op_targ);
+
+ return topblkop;
}
static OP *
projects / p5sagit/Gather-Once.git / commitdiff