[nrx] Reimplement / { } /

sorear · Sep 6, 2010 · 91d975d · 91d975d
1 parent 773fb58
commit 91d975d
Show file tree

Hide file tree

Showing 4 changed files with 34 additions and 32 deletions.
diff --git a/src/Body.pm b/src/Body.pm
@@ -13,7 +13,7 @@ use CgOp ();
     has uid       => (isa => 'Int', is => 'ro', default => sub { ++(state $i) });
     has do        => (isa => 'Op', is => 'rw');
     has scopetree => (is => 'rw');
-    has signature => (isa => 'Maybe[Sig]', is => 'ro');
+    has signature => (isa => 'Maybe[Sig]', is => 'rw');
     has mainline  => (isa => 'Bool', is => 'ro', lazy => 1,
             builder => 'is_mainline');
     # '' for incorrectly contextualized {p,x,}block, blast
@@ -30,9 +30,6 @@ use CgOp ();
     has file => (isa => 'Str', is => 'ro');
     has text => (isa => 'Str', is => 'ro');
 
-    # wtf is this doing here
-    has cname => (isa => 'Str', is => 'rw');
-
     # metadata for runtime inspection
     has class => (isa => 'Str', is => 'rw', default => 'Sub');
     has ltm   => (is => 'rw');
@@ -116,12 +113,6 @@ use CgOp ();
             value => CgOp::letvar('pkg'))) if $self->type =~ /mainline|class|
             package|grammar|module|role|slang|knowhow/x;
 
-        if ($self->cname) {
-            $::process->(
-                Decl::VarAlias->new(oname => $self->cname, nname => '$/'),
-                Decl::VarAlias->new(oname => $self->cname, nname => '$¢'));
-        }
-
         if ($self->type eq 'mainline') {
             $::process->(
                 Decl::Hint->new(name => '$?GLOBAL',
@@ -132,6 +123,10 @@ use CgOp ();
                     value => CgOp::string_var($self->text)));
         }
         $::process->($self->signature->local_decls) if $self->signature;
+        if ($self->type eq 'rxembedded') {
+            $::process->(
+                Decl::VarAlias->new(oname => '$¢', nname => '$/'));
+        }
         if ($self->transparent) {
             push @outer_q, $self->do->lift_decls;
         } else {

diff --git a/src/Niecza/Actions.pm b/src/Niecza/Actions.pm
@@ -481,7 +481,10 @@ sub metachar__S_unsp { my ($cl, $M) = @_;
 }
 
 sub metachar__S_Cur_Ly { my ($cl, $M) = @_;
-    $M->{_ast} = RxOp::VoidBlock->new(block => $M->{embeddedblock}{_ast});
+    my $inv = $M->{embeddedblock}{_ast}->invocant;
+    $inv->body->type('rxembedded');
+    $inv->body->signature(Sig->simple('$¢'));
+    $M->{_ast} = RxOp::VoidBlock->new(block => $inv);
 }
 
 sub metachar__S_mod { my ($cl, $M) = @_;
@@ -684,7 +687,10 @@ sub assertion__S_Bang { my ($cl, $M) = @_;
 }
 
 sub assertion__S_Cur_Ly { my ($cl, $M) = @_;
-    $M->{_ast} = RxOp::CheckBlock->new(block => $M->{embeddedblock}{_ast});
+    my $inv = $M->{embeddedblock}{_ast}->invocant;
+    $inv->body->type('rxembedded');
+    $inv->body->signature(Sig->simple('$¢'));
+    $M->{_ast} = RxOp::CheckBlock->new(block => $inv);
 }
 
 *assertion__S_Bra   = \&do_cclass;

diff --git a/src/RxOp.pm b/src/RxOp.pm
@@ -353,11 +353,12 @@ use CgOp;
     extends 'RxOp';
 
     has block => (isa => 'Op', is => 'ro', required => 1);
+    sub opzyg { $_->block }
 
-    sub op {
-        my ($self, $cn, $cont) = @_;
-        $self->block->invocant->body->cname($cn); #XXX
-        $cn, Op::StatementList->new(children => [$self->block, $cont]);
+    sub code {
+        my ($self, $body) = @_;
+        CgOp::subcall(CgOp::fetch($self->block->cgop($body)),
+            CgOp::newscalar(CgOp::rawcall(CgOp::rxframe, "MakeCursor")));
     }
 
     sub lad {

diff --git a/test2.pl b/test2.pl
@@ -75,23 +75,23 @@
     ok !("abab" ~~ / ab <.ws> ab /), "ws does not match nothing";
     ok ("ab   ab" ~~ rule { ab ab }), "rule gives space";
 }
-# 
-# {
+
+{
 #     # doing a more reasonable test will probably require embedded blocks
 #     ok "foobarx" ~~ / [ foo | foobar ]: x /, "LTM picks longest even if second";
 #     ok "foobarx" ~~ / [ foobar | foo ]: x /, "LTM picks longest even if first";
-# }
-# 
-# {
-#     my $x = '';
-#     ok !("a" ~~ / a { $x = 1; } b /), '{} does not terminate regex';
-#     is $x, 1, '{} is run even if regex fails';
-#     $x = '';
-#     ok !("" ~~ / a { $x = 1; } b /), '{} does not affect regex that ends before it';
-#     is $x, '', '{} is only run if reached';
-#     $x = 0;
-#     ok ("aab" ~~ / a* { $x++ } ab /), '{} does not block backtracking';
-#     is $x, 2, '{} is run multiple times when backtracking';
+}
+
+{
+    my $x = '';
+    ok !("a" ~~ / a { $x = 1; } b /), '{} does not terminate regex';
+    is $x, 1, '{} is run even if regex fails';
+    $x = '';
+    ok !("" ~~ / a { $x = 1; } b /), '{} does not affect regex that ends before it';
+    is $x, '', '{} is only run if reached';
+    $x = 0;
+    ok ("aab" ~~ / a* { $x++ } ab /), '{} does not block backtracking';
+    is $x, 2, '{} is run multiple times when backtracking';
 # 
 #     $x = '';
 #     ok ("foo" ~~ / foo { $x = $x ~ 1 } | foo { $x = $x ~ 2 } /),
@@ -131,8 +131,8 @@
 #     }
 #     G6.parse("foo");
 #     is $x, 2, "prefix length testing works in subrules";
-# }
-# 
+}
+
 # {
 #     my grammar G7 {
 #         proto token tok  {*}