From: Florian Ragwitz <rafl@debian.org>
Date: Wed, 1 Aug 2012 15:07:21 +0000 (-0400)
Subject: Get the optree almost right
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=83489a6bd9368d3684356330ebdecf53b6af4c2a;p=p5sagit%2FGather-Once.git

Get the optree almost right
---

diff --git a/Once.xs b/Once.xs
index 7d14c37..0ec8704 100644
--- a/Once.xs
+++ b/Once.xs
@@ -58,83 +58,10 @@ THX_demand_unichar (pTHX_ I32 c, U32 flags)
     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 *
@@ -158,23 +85,12 @@ myparse_args_take (pTHX_ GV *namegv, SV *args, U32 *flagsp)
   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 */
@@ -186,59 +102,44 @@ myparse_args_take (pTHX_ GV *namegv, SV *args, U32 *flagsp)
   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);
@@ -250,41 +151,37 @@ myparse_args_gather (pTHX_ GV *namegv, SV *topicalise, U32 *flagsp)
     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 *
diff --git a/t/basic.t b/t/basic.t
index ecaa468..c68402e 100644
--- a/t/basic.t
+++ b/t/basic.t
@@ -3,11 +3,11 @@ use warnings;
 use Test::More 0.89;
 
 use Gather::Once
-    block => 'with',
-    take  => 'iff',
+    block      => 'with',
+    take       => 'iff',
     topicalise => 1,
     predicate  => sub {
-        warn "$_[0] == $_[1]";
+        diag explain \@_;
         $_[0] == $_[1];
     };
 
@@ -15,6 +15,7 @@ my $n = 42;
 
 my @ret = with ($n) {
     warn 42;
+    iff (23) { 42 };
     iff (42) { 23 };
     warn 23;
     42;
@@ -22,6 +23,25 @@ my @ret = with ($n) {
 
 diag explain \@ret;
 
+done_testing;
+
+__END__
+
+my $pred = sub {};
+my @ret___ = do {
+    warn 42;
+    ($pred->($n, 23))
+        ? do { 42 }
+            : ($pred->($n, 42))
+                ? do { 23 }
+                    : do {
+                        warn 23;
+                        42;
+                    };
+};
+
+diag explain \@ret;
+
 use Gather::Once
     block => 'moo',
     take  => 'iff_',
@@ -39,6 +59,10 @@ my @ret_ = moo {
     iff_ (42) { 1, 2, 3 };
 };
 
+my @ret__ = do {
+    $pred->(42) ? do { 1, 2, 3 } : ()
+};
+
 diag explain \@ret_;
 
 done_testing;