Improve trace output; non-working attempt at <foo>

sorear · Aug 9, 2010 · 83b026b · 83b026b
1 parent 2925456
commit 83b026b
Show file tree

Hide file tree

Showing 5 changed files with 63 additions and 3 deletions.
diff --git a/CodeGen.pm b/CodeGen.pm
@@ -604,7 +604,7 @@ use 5.010;
         my $name = $self->csname;
         my $vis  = ($self->entry ? 'public' : 'private');
         print ::NIECZA_OUT " " x 4, "$vis static Frame $name(Frame th) {\n";
-        print ::NIECZA_OUT " " x 8, "if (Kernel.TraceCont) { Console.WriteLine(\"Entering $::UNITNAME : $name @ \" + th.ip); }\n";
+        print ::NIECZA_OUT " " x 8, "if (Kernel.TraceCont) { Console.WriteLine(th.DepthMark() + \"$::UNITNAME : $name @ \" + th.ip); }\n";
         print ::NIECZA_OUT " " x 8, "switch (th.ip) {\n";
         print ::NIECZA_OUT " " x 12, "case 0:\n";
         print ::NIECZA_OUT " " x 12, $_ for @{ $self->buffer };

diff --git a/Kernel.cs b/Kernel.cs
@@ -167,6 +167,15 @@ public class Frame: IP6 {
             }
             return Kernel.NewROScalar(Kernel.AnyP);
         }
+
+        private static List<string> spacey = new List<string>();
+        public string DepthMark() {
+            Frame f = this;
+            int ix = 0;
+            while (f != null) { ix++; f = f.caller; }
+            while (spacey.Count <= ix) { spacey.Add(new String(' ', spacey.Count * 2)); }
+            return spacey[ix];
+        }
     }
 
     // NOT IP6; these things should only be exposed through a ClassHOW-like

diff --git a/Niecza/Actions.pm b/Niecza/Actions.pm
@@ -185,6 +185,7 @@ sub quote__S_Q { my ($cl, $M) = @_;
 sub quote__S_Slash_Slash { my ($cl, $M) = @_;
     my $slot = $cl->gensym;
     # TODO should be a real pass.
+    local $::parenid = 0;
     $M->{_ast} = RxOp::Export->new(zyg => [$M->{nibble}{_ast}])->closure;
 }
 
@@ -218,6 +219,7 @@ sub regex_def { my ($cl, $M) = @_;
     my $var = ($scope eq 'anon' || $scope eq 'has') ? $cl->gensym
         : '&' . $name;
 
+    local $::parenid = 0;
     $M->{_ast} = Op::SubDef->new(
         var => $var, class => 'Regex',
         method_too => ($scope eq 'has' ? $name : undef),

diff --git a/RxOp.pm b/RxOp.pm
@@ -128,6 +128,26 @@ use CgOp;
 
     has names => (isa => 'ArrayRef[Maybe[Str]]', is => 'ro', required => 1);
 
+    sub op {
+        my ($self) = @_;
+        my @n = @{ $self->names };
+        for (@n) {
+            $::parennum = $_ if defined($_) && $_ =~ /^[0-9]+$/;
+            $_ = $::parennum++ if !defined($_);
+        }
+        Op::CallSub->new(
+            invocant => Op::Lexical->new(name => '&_rxbind'),
+            positionals => [
+                Op::Lexical->new(name => '$¢'),
+                Op::CallSub->new(
+                    invocant => Op::Lexical->new(name => '&infix:<,>'),
+                    positionals => [
+                        map { Op::StringLiteral->new(text => $_) }
+                            @{ $self->names }
+                    ]),
+                $self->zyg->[0]->closure]);
+    }
+
     __PACKAGE__->meta->make_immutable;
     no Moose;
 }
@@ -139,6 +159,20 @@ use CgOp;
 
     has name => (isa => 'Str', is => 'ro', required => 1);
 
+    sub op {
+        my ($self) = @_;
+        Op::CallSub->new(
+            invocant => Op::Lexical->new(name => '&_rxcall'),
+            positionals => [
+                Op::Lexical->new(name => '$¢'),
+                Op::SubDef->new(var => Niecza::Actions->gensym, body =>
+                    Body->new(
+                        type        => 'sub',
+                        signature   => Sig->simple('$¢'),
+                        do          => Op::CallMethod->new(name => $self->name,
+                            receiver => Op::Lexical->new(name => '$¢'))))]);
+    }
+
     __PACKAGE__->meta->make_immutable;
     no Moose;
 }

diff --git a/test2.pl b/test2.pl
@@ -9,14 +9,21 @@ ($C, $fun)
 
 # A call to a subrule could return a cursor of a different type, or with
 # unwanted subcaptures that need to be cleared for <.foo>
-sub _rxunbind($C, $fun) {
+sub _rxbind($C, @names, $fun) {
     my $it = $fun($C);
     sub {
         if my $v = $it() { #OK
-            Q:CgOp {
+            my $nC = Q:CgOp {
                 (box (@ (l $C)) (rawcall (unbox Cursor (@ (l $v)))
                     SetCaps (getfield captures (unbox Cursor (@ (l $C))))))
+            };
+            for @names -> $n { #OK
+                $nC = Q:CgOp {
+                    (box (@ (l $nC)) (rawcall (unbox Cursor (@ (l $nC)))
+                        Bind (unbox String (@ (l $n))) (l $v)))
+                };
             }
+            $nC;
         } else {
             Any
         }
@@ -39,4 +46,12 @@ ($C, $fun)
 ok G2.parse("yxxy"), "subrule position tracking works";
 ok !G2.parse("yxy"), "subrule position tracking works (2)";
 
+my grammar G3 {
+    regex TOP { <moo> }
+    regex moo { x }
+}
+
+ok G3.parse("x"), "capturing subrules work (positive)";
+ok !G3.parse("y"), "capturing subrules work (negative)";
+
 done-testing;