Add $<foo> = { 2 + 2 } value capture extension

sorear · Oct 16, 2010 · 9d8f45c · 9d8f45c
1 parent 5a45932
commit 9d8f45c
Show file tree

Hide file tree

Showing 4 changed files with 70 additions and 13 deletions.
diff --git a/lib/Cursor.cs b/lib/Cursor.cs
@@ -31,9 +31,9 @@ public sealed class NState {
 public sealed class CapInfo {
     public CapInfo prev;
     public string[] names;
-    public Cursor cap;
+    public Variable cap;
 
-    public CapInfo(CapInfo prev, string[] names, Cursor cap) {
+    public CapInfo(CapInfo prev, string[] names, Variable cap) {
         this.prev = prev; this.names = names; this.cap = cap;
     }
 }
@@ -130,7 +130,7 @@ public sealed class RxFrame {
         bt = new Choice(bt, ip, st);
     }
 
-    public void PushCapture(string[] cn, Cursor cl) {
+    public void PushCapture(string[] cn, Variable cl) {
         st.captures = new CapInfo(st.captures, cn, cl);
     }
 
@@ -383,7 +383,7 @@ public Cursor(IP6 proto, string text)
         return new Cursor(global, mo, nstate, xact, npos);
     }
 
-    // TODO: keep variables around so { $<foo> = 1 } will work
+    // TODO: cache generated lists
     public Variable GetKey(string str) {
         CapInfo it = captures;
         VarDeque caps = new VarDeque();
@@ -399,7 +399,7 @@ public Cursor(IP6 proto, string text)
             if (it.cap == null) {
                 list = true;
             } else {
-                caps.Unshift(Kernel.NewRWScalar(Kernel.AnyMO, it.cap));
+                caps.Unshift(it.cap);
             }
 no:
             it = it.prev;
@@ -413,7 +413,7 @@ public Cursor(IP6 proto, string text)
             return Kernel.NewRWListVar(l);
         } else {
             return caps.Count() != 0 ? caps[0] :
-                Kernel.NewRWScalar(Kernel.AnyMO, Kernel.AnyP);
+                Kernel.NewROScalar(Kernel.AnyP);
         }
     }
 

diff --git a/src/Niecza/Actions.pm b/src/Niecza/Actions.pm
@@ -639,7 +639,22 @@ sub metachar__S_Double_Double { my ($cl, $M) = @_;
 }
 
 sub metachar__S_var { my ($cl, $M) = @_;
-    if ($M->{quantified_atom}) {
+    if ($M->{binding}) {
+        my $a = $M->{binding}{quantified_atom}{_ast}->uncut;
+        my $cid = $M->{variable}{_ast}{capid};
+
+        if (!defined $cid) {
+            $M->sorry("Non-Match bindings NYI");
+            $M->{_ast} = RxOp::Sequence->new;
+            return;
+        }
+
+        if ($a->isa('RxOp::VoidBlock')) {
+            $M->{_ast} = RxOp::SaveValue->new(capid => $cid,
+                block => $a->block);
+            return;
+        }
+
         $M->sorry("Explicit regex bindings NYI");
         $M->{_ast} = RxOp::Sequence->new;
         return;
@@ -1625,7 +1640,7 @@ sub variable { my ($cl, $M) = @_;
     } elsif ($M->{special_variable}) {
         $name = substr($M->{special_variable}->Str, 1);
     } elsif ($M->{index}) {
-        $M->{_ast} = { term =>
+        $M->{_ast} = { capid => $M->{index}{_ast}, term =>
             # maybe a little of a cheat
             $M->{_ast} = Op::CallMethod->new(node($M), name => 'at-pos',
                 receiver => Op::Lexical->new(name => '$/'),
@@ -1634,7 +1649,8 @@ sub variable { my ($cl, $M) = @_;
         return;
     } elsif ($M->{postcircumfix}[0]) {
         if ($M->{postcircumfix}[0]{sym} eq '< >') {
-            $M->{_ast} = { term =>
+            $M->{_ast} = { capid => $M->{postcircumfix}[0]{_ast}{args}[0]->text,
+                term =>
                 # maybe a little of a cheat
                 $M->{_ast} = Op::CallMethod->new(node($M), name => 'at-key',
                     receiver => Op::Lexical->new(name => '$/'),

diff --git a/src/RxOp.pm b/src/RxOp.pm
@@ -13,6 +13,7 @@ use CgOp;
 
     sub opzyg { map { $_->opzyg } @{ $_[0]->zyg } }
     sub oplift { map { $_->oplift } @{ $_[0]->zyg } }
+    sub uncut { $_[0] }
 
     # all that matters is 0-1-infty; $*in_quant valid here
     sub used_caps {
@@ -288,6 +289,8 @@ use CgOp;
     use Moose;
     extends 'RxOp';
 
+    sub uncut { $_[0]->zyg->[0] }
+
     sub code {
         my ($self, $body) = @_;
 
@@ -492,7 +495,7 @@ use CgOp;
         my $callf = CgOp::methodcall(CgOp::newscalar(
                 CgOp::rxcall("MakeCursor")), $self->name);
         my @pushcapf = (@{ $self->captures } == 0) ? () : (
-            CgOp::rxpushcapture(CgOp::cast('cursor', CgOp::letvar("k")),
+            CgOp::rxpushcapture(CgOp::letvar("kv"),
                 @{ $self->captures }));
         my $updatef = CgOp::prog(
             CgOp::ncgoto('backtrack', CgOp::obj_is_defined(CgOp::letvar("k"))),
@@ -504,7 +507,8 @@ use CgOp;
 
         if ($self->selfcut) {
             push @code, CgOp::letn(
-                "k", CgOp::fetch(CgOp::get_first(CgOp::fetch($callf))),
+                "kv", CgOp::get_first(CgOp::fetch($callf)),
+                "k", CgOp::fetch(CgOp::letvar("kv")),
                 $updatef);
         } else {
             push @code, CgOp::rxcall("SetCursorList", $callf);
@@ -514,8 +518,9 @@ use CgOp;
                         "GetCursorList"), "shift"));
             push @code, CgOp::label($sk);
             push @code, CgOp::letn(
-                "k", CgOp::fetch(CgOp::get_first(CgOp::fetch(
-                            CgOp::rxcall("GetCursorList")))),
+                "kv", CgOp::get_first(CgOp::fetch(
+                        CgOp::rxcall("GetCursorList"))),
+                "k", CgOp::fetch(CgOp::letvar("kv")),
                 $updatef);
             push @code, CgOp::rxpushb("SUBRULE", $bt);
             push @code, CgOp::rxcall("SetCursorList", CgOp::null("var"));
@@ -693,6 +698,36 @@ use CgOp;
     no Moose;
 }
 
+{
+    package RxOp::SaveValue;
+    use Moose;
+    extends 'RxOp';
+
+    has capid => (isa => 'Str', is => 'ro', required => 1);
+    has block => (isa => 'Op', is => 'ro', required => 1);
+    sub opzyg { $_[0]->block }
+
+    sub used_caps {
+        my ($self) = @_;
+        +{ $self->capid => ($::in_quant ? 2 : 1) };
+    }
+
+    sub code {
+        my ($self, $body) = @_;
+        CgOp::rxpushcapture(CgOp::subcall(
+                CgOp::fetch($self->block->cgop($body)),
+            CgOp::newscalar(CgOp::rxcall("MakeCursor"))), $self->capid);
+    }
+
+    sub lad {
+        my ($self) = @_;
+        [ 'Imp' ];
+    }
+
+    __PACKAGE__->meta->make_immutable;
+    no Moose;
+}
+
 {
     package RxOp::VoidBlock;
     use Moose;

diff --git a/test2.pl b/test2.pl
@@ -79,6 +79,12 @@
 
 rxtest / <alpha> / , '<alpha>', ('a', 'A', "\x4E00"), ("+", "1", " ");
 
+{
+    my $m = "" ~~ / $<foo> = { 2 + 2 } $<bar> = {"x"} $<bar> = {"y"} /;
+    is $m<foo>, 4, "value aliasing works (sing)";
+    is $m<bar>, "x y", "value aliasing works (plur)";
+}
+
 # {
 #     our role Stop4717[$a] {
 #         token foo { $a }