Implement gather/take

Body.pm

@@ -51,29 +51,48 @@ use CgOp ();
 
     sub lift_decls {
         my ($self) = @_;
-        my (@x, @y);
-        unshift @{ $self->transparent ? \@y : \@x },
-            $self->do->lift_decls;
-        unshift @x, $self->signature->local_decls if $self->signature;
-        @x = map { (map { $_->lift_decls } $_->bodies), $_ } @x;
-        unshift @x, Decl::Hint->new(name => '$?CURPKG',
-            value => CgOp::letvar('pkg')) if $self->type =~ /mainline|class|
+        my (@self_q, @outer_q);
+
+        # it is the caller's responsibility to process returned decls
+        local $::process = sub {
+            my (@decls) = @_;
+            for my $decl (@decls) {
+                push @outer_q, $decl->outer_decls;
+                for my $b ($decl->bodies) {
+                    my @o = $b->lift_decls;
+                    if ($self->transparent) {
+                        push @outer_q, @o;
+                    } else {
+                        for (@o) { $::process->($_); }
+                    }
+                }
+                push @self_q, $decl;
+            }
+        };
+
+        $::process->(Decl::Hint->new(name => '$?CURPKG',
+            value => CgOp::letvar('pkg'))) if $self->type =~ /mainline|class|
             package|grammar|module|role|slang|knowhow/x;
 
         if ($self->type eq 'mainline') {
-            @x = map { $_->outer_decls, $_ } @x;
-            unshift @x, Decl::Hint->new(name => '$?GLOBAL',
-                value => CgOp::letvar('pkg'));
-            unshift @x, Decl::Hint->new(name => '$?FILE',
-                value => CgOp::string_var($self->file));
-            unshift @x, Decl::Hint->new(name => '$?ORIG',
-                value => CgOp::string_var($self->text));
+            $::process->(
+                Decl::Hint->new(name => '$?GLOBAL',
+                    value => CgOp::letvar('pkg')),
+                Decl::Hint->new(name => '$?FILE',
+                    value => CgOp::string_var($self->file)),
+                Decl::Hint->new(name => '$?ORIG',
+                    value => CgOp::string_var($self->text)));
+        }
+        $::process->($self->signature->local_decls) if $self->signature;
+        if ($self->transparent) {
+            push @outer_q, $self->do->lift_decls;
         } else {
-            push @y, map { $_->outer_decls } @x;
+            $::process->($self->do->lift_decls);
         }
-        $self->decls(\@x);
 
-        @y;
+        $self->decls(\@self_q);
+
+        @outer_q;
     }
 
     sub to_cgop {
@@ -82,8 +101,15 @@ use CgOp ();
         push @enter, map { $_->enter_code($self) } @{ $self->decls };
         push @enter, $self->signature->binder($self->name) if $self->signature;
         # TODO: Bind a return value here to catch non-ro sub use
-        $self->cgoptree(CgOp::prog(@enter,
-                CgOp::return($self->do->cgop($self))));
+        if ($self->type eq 'gather') {
+            $self->cgoptree(CgOp::prog(@enter,
+                    CgOp::sink($self->do->cgop($self)),
+                    CgOp::rawsccall('Kernel.Take',
+                        CgOp::scopedlex('EMPTY'))));
+        } else {
+            $self->cgoptree(CgOp::prog(@enter,
+                    CgOp::return($self->do->cgop($self))));
+        }
         map { $_->preinit_code($self) } @{ $self->decls };
     }
 

CgOp.pm

@@ -540,6 +540,12 @@ use warnings;
             zyg => [ $inv, @args ], is_cps_call => 1);
     }
 
+    sub fgoto {
+        my ($tgt) = @_;
+        CgOp::Primitive->new(op => [ 'goto', $_[0] ], zyg => [ $_[1] ],
+            is_cps_call => 1);
+    }
+
     sub rawsget {
         CgOp::Primitive->new(op => [ 'clr_sfield_get', $_[0] ]);
     }

CodeGen.pm

@@ -65,6 +65,9 @@ use 5.010;
 
         'System.IO.File.ReadAllText' => [m => 'System.String'],
 
+        'Kernel.CoTake'        => [c => 'Variable'],
+        'Kernel.Take'          => [c => 'Variable'],
+        'Kernel.GatherHelper'  => [c => 'Frame'],
         'Kernel.ContextHelper' => [m => 'Variable'],
         'Kernel.StrP'          => [f => 'IP6'],
         'Kernel.CallFrameMO'   => [f => 'DynMetaObject'],
@@ -499,6 +502,11 @@ use 5.010;
         $self->_push($type, "(($type)" . ($self->_popn(1))[0] . ")");
     }
 
+    sub fgoto {
+        my ($nv, $self) = @_;
+        $self->_cpscall(($nv ? 'Variable' : 'Void'), ($self->_popn(1))[0]);
+    }
+
     sub clr_call_direct {
         my ($self, $name, $nargs) = @_;
         my ($cl, $rt) = $self->_typedata('cm', $name);

Kernel.cs

@@ -424,6 +424,32 @@ public class Kernel {
             }
         }
 
+        public static Frame TakeReturnFrame;
+
+        public static Frame Take(Frame th, Variable payload) {
+            Frame r = TakeReturnFrame;
+            TakeReturnFrame = null;
+            r.lex["$nextframe"] = NewROScalar(th);
+            r.resultSlot = payload;
+            th.resultSlot = payload;
+            return r;
+        }
+
+        public static Frame CoTake(Frame th, Frame from) {
+            TakeReturnFrame = th;
+            return from;
+        }
+
+        public static Frame GatherHelper(Frame th, IP6 sub) {
+            DynObject dyo = (DynObject) sub;
+            Frame n = new Frame(th,
+                                (Frame) dyo.slots["outer"],
+                                (DynBlockDelegate) dyo.slots["code"]);
+            n.proto = (Frame) dyo.slots["proto"];
+            th.resultSlot = n;
+            return th;
+        }
+
         private static Frame SubInvoke(DynObject th, Frame caller,
                 Variable[] pos, Dictionary<string,Variable> named) {
             Frame proto = (Frame) th.slots["proto"];

Niecza/Actions.pm

@@ -1783,6 +1783,11 @@ sub statement_prefix {}
 sub statement_prefix__S_do { my ($cl, $M) = @_;
     $M->{_ast} = $cl->block_to_immediate($M, 'do', $M->{blast}{_ast});
 }
+sub statement_prefix__S_gather { my ($cl, $M) = @_;
+    $M->{blast}{_ast}->type('gather');
+    $M->{_ast} = Op::Gather->new(node($M), var => $cl->gensym,
+        body => $M->{blast}{_ast});
+}
 sub statement_prefix__S_PREMinusINIT { my ($cl, $M) = @_;
     my $var = $cl->gensym;
 

Op.pm

@@ -853,4 +853,51 @@ use CgOp;
     no Moose;
 }
 
+{
+    package Op::Take;
+    use Moose;
+    extends 'Op';
+
+    has value => (isa => 'Op', is => 'ro', required => 1);
+    sub zyg { $_[0]->value }
+
+    sub code {
+        my ($self, $body) = @_;
+        CgOp::rawsccall('Kernel.Take', $self->value->cgop($body));
+    }
+
+    __PACKAGE__->meta->make_immutable;
+    no Moose;
+}
+
+{
+    package Op::Gather;
+    use Moose;
+    extends 'Op';
+
+    has body => (isa => 'Body', is => 'ro', required => 1);
+    has var  => (isa => 'Str',  is => 'ro', required => 1);
+
+    sub lift_decls {
+        my ($self) = @_;
+        Decl::Sub->new(var => $self->var, code => $self->body);
+    }
+
+    sub code {
+        my ($self, $body) = @_;
+
+        # construct a frame for our sub ip=0
+        # construct a GatherIterator with said frame
+        # construct a List from the iterator
+
+        CgOp::subcall(CgOp::fetch(CgOp::scopedlex('&_gather')),
+            CgOp::newscalar(CgOp::rawsccall('Kernel.GatherHelper',
+                    CgOp::fetch(CgOp::scopedlex($self->var)))));
+    }
+
+    __PACKAGE__->meta->make_immutable;
+    no Moose;
+}
+
+
 1;

SAFE.setting

@@ -849,6 +849,32 @@ sub postcircumfix:<{ }> is rawcall {
         });
 }
 
+my class GatherIterator is Iterator {
+    has $!frame;
+
+    method validate() {
+        my $nextframe;
+        $!value = Q:CgOp {
+            (rawsccall Kernel.CoTake (cast Frame (getattr frame (@ (l self)))))
+        };
+        $!valid = True;
+        $!frame = Any;
+        $!next  = GatherIterator.RAWCREATE("frame", $nextframe, "valid", False,
+            "value", Any, "next", Any);
+    }
+}
+
+sub _gather($fr) {
+    my @l := List.RAWCREATE("flat", True, "items", LLArray.new, "rest",
+        LLArray.new(GatherIterator.RAWCREATE("frame", $fr, "valid", False,
+            "value", Any, "next", Any)));
+    @l;
+}
+
+sub take($p) { # should be \|$p
+    Q:CgOp { (rawsccall Kernel.Take (l $p)) }
+}
+
 # these are immutable, though we may wind up reusing them in some cases by
 # uniqueness rules (TBD)
 my class Cursor {

test.pl

@@ -2,7 +2,7 @@
 
 use Test;
 
-plan 225;
+plan 231;
 
 ok 1, "one is true";
 ok 2, "two is also true";
@@ -598,3 +598,15 @@
     ok !Bob.parse("xac"), "grammars anchor (1)";
     ok !Bob.parse("acx"), "grammars anchor (2)";
 }
+
+{
+    my $x = False;
+    my $y = False;
+    my @l1 := gather do { $x = True; take 1; $y = True };
+    ok !$x, "gather does not run block immediately";
+    ok @l1.shift == 1, "first value pulled";
+    ok $x, "pull started block";
+    ok !$y, "but did not finish it";
+    ok !@l1, "no more values";
+    ok $y, "querying that fact finished the block";
+}