Implement <O> and regex args

sorear · Oct 21, 2010 · 5c30728 · 5c30728
1 parent 6344d14
commit 5c30728
Show file tree

Hide file tree

Showing 6 changed files with 38 additions and 18 deletions.
diff --git a/lib/Cursor.cs b/lib/Cursor.cs
@@ -460,11 +460,19 @@ public Cursor(IP6 proto, string text)
         into.SetSlot("named", nam);
     }
 
-    public Cursor O(Dictionary<string,Variable> caps) {
+    public Variable O(Dictionary<string,Variable> caps) {
         Cursor nw = At(pos);
         foreach (KeyValuePair<string,Variable> kv in caps)
             nw.captures = new CapInfo(nw.captures, new string[] { kv.Key }, kv.Value);
-        return nw;
+        VarDeque ks = new VarDeque();
+
+        DynObject lst = new DynObject(RxFrame.ListMO);
+        lst.slots[0 /*items*/] = ks;
+        lst.slots[1 /*rest*/ ] = new VarDeque();
+        lst.slots[2 /*flat*/ ] = false;
+
+        ks.Push(Kernel.NewROScalar(nw));
+        return Kernel.NewRWListVar(lst);
     }
 
     public Variable SimpleWS() {

diff --git a/src/CgOp.pm b/src/CgOp.pm
@@ -211,7 +211,7 @@ use warnings;
     sub cursor_dows    { rawcall($_[0], 'SimpleWS') }
     sub cursor_item    { rawcall($_[0], 'GetKey', $_[1]) }
     sub cursor_unpackcaps { rawcall($_[0], 'UnpackCaps:m,Void', $_[1]) }
-    sub cursor_O       { rawcall($_[0], 'O:m,Cursor', $_[1]) }
+    sub cursor_O       { rawcall($_[0], 'O:m,Variable', $_[1]) }
     sub rxstripcaps    { rawcall($_[0], 'StripCaps:m,Cursor') }
 
     sub bget { getfield('v', $_[0]) }

diff --git a/src/Op.pm b/src/Op.pm
@@ -121,13 +121,10 @@ use CgOp;
         blessed($self)->new(args => [ $self->getargs, $adv ], %h);
     }
 
-    sub argblock {
-        my ($self, $body) = @_;
-        if (! $self->args) {
-            return map { $_->cgop($body) } @{ $self->positionals };
-        }
+    sub parsearglist {
+        my ($body, @args) = @_;
         my @out;
-        for my $a (@{ $self->args }) {
+        for my $a (@args) {
             if ($a->isa('Op::SimplePair')) {
                 push @out, ":" . $a->key, $a->value->cgop($body);
             } elsif ($a->isa('Op::CallSub') && $a->invocant->isa('Op::Lexical')
@@ -141,6 +138,14 @@ use CgOp;
         @out;
     }
 
+    sub argblock {
+        my ($self, $body) = @_;
+        if (! $self->args) {
+            return map { $_->cgop($body) } @{ $self->positionals };
+        }
+        parsearglist($body, @{ $self->args });
+    }
+
     __PACKAGE__->meta->make_immutable;
     no Moose;
 }

diff --git a/src/RxOp.pm b/src/RxOp.pm
@@ -521,11 +521,13 @@ use CgOp;
             return $true->code($body);
         }
 
+        my @args = Op::CallLike::parsearglist($body, @{ $self->arglist // [] });
+
         my $callf = $self->regex ?
             CgOp::subcall(CgOp::fetch($self->regex->cgop($body)),
-                CgOp::newscalar(CgOp::rxcall("MakeCursor"))) :
+                CgOp::newscalar(CgOp::rxcall("MakeCursor")), @args) :
             CgOp::methodcall(CgOp::newscalar(
-                CgOp::rxcall("MakeCursor")), $self->method);
+                CgOp::rxcall("MakeCursor")), $self->method, @args);
         my @pushcapf = (@{ $self->captures } == 0) ? () : ($self->passcap ?
             (CgOp::rxsetcapsfrom(CgOp::cast("cursor",
                     CgOp::letvar("k"))),

diff --git a/test2.pl b/test2.pl
@@ -16,8 +16,8 @@
 
 augment class Cursor {
     method O (*%hash) {
-        Q:CgOp { (newscalar (cursor_O (cast cursor (@ {self}))
-                                      (unbox varhash (@ {%hash})))) }
+        Q:CgOp { (cursor_O (cast cursor (@ {self}))
+                           (unbox varhash (@ {%hash}))) }
     }
     method list () { @( self.Capture ) }
     method flat () { @( self.Capture ) }

diff --git a/v6/STD.pm6 b/v6/STD.pm6
@@ -4528,7 +4528,12 @@ method EXPR ($preclvl?) {
         my $oldpos = $here.pos;
         $here = $here.cursor_fresh();
         $*LEFTSIGIL = @opstack[*-1]<O><prec> gt $item_assignment_prec ?? '@' !! '';     # XXX P6
-        my @t = $here.$termish;
+        my @t =
+            ($termish eq 'termish') ?? $here.termish !!
+            ($termish eq 'nulltermish') ?? $here.nulltermish !!
+            ($termish eq 'statement') ?? $here.statement !!
+            ($termish eq 'dottyopish') ?? $here.dottyopish !!
+            die "weird value of $termish";
 
         if not @t or not $here = @t[0] or ($here.pos == $oldpos and $termish eq 'termish') {
             $here.panic("Bogus term") if @opstack > 1;
@@ -4609,15 +4614,15 @@ method EXPR ($preclvl?) {
 
             # Does new infix (or terminator) force any reductions?
             while @opstack[*-1]<O><prec> gt $inprec {
-                &reduce();
+                reduce();
             }
 
             # Not much point in reducing the sentinels...
             last if $inprec lt $LOOSEST;
 
         if $infix<fake> {
             push @opstack, $infix;
-            &reduce();
+            reduce();
             next;  # not really an infix, so keep trying
         }
 
@@ -4626,7 +4631,7 @@ method EXPR ($preclvl?) {
                 my $assoc = 1;
                 my $atype = $inO<assoc>;
                 if $atype eq 'non'   { $assoc = 0; }
-                elsif $atype eq 'left'  { &reduce() }   # reduce immediately
+                elsif $atype eq 'left'  { reduce() }   # reduce immediately
                 elsif $atype eq 'right' { }            # just shift
                 elsif $atype eq 'chain' { }            # just shift
                 elsif $atype eq 'unary' { }            # just shift
@@ -4644,7 +4649,7 @@ method EXPR ($preclvl?) {
             last;
         }
     }
-    &reduce() while +@opstack > 1;
+    reduce() while +@opstack > 1;
     if @termstack {
         +@termstack == 1 or $here.panic("Internal operator parser error, termstack == " ~ (+@termstack));
         @termstack[0].from = self.pos;