Generate control exception data for return

sorear · Sep 15, 2010 · 59fa498 · 59fa498
1 parent 2d649c9
commit 59fa498
Show file tree

Hide file tree

Showing 5 changed files with 56 additions and 49 deletions.
diff --git a/src/Body.pm b/src/Body.pm
@@ -18,6 +18,7 @@ use CgOp ();
             builder => 'is_mainline');
     # '' for incorrectly contextualized {p,x,}block, blast
     has type      => (isa => 'Str', is => 'rw');
+    has returnable=> (isa => 'Bool', is => 'rw');
 
     # Any => [ 'Variable', 'SAFE.F12_34' ] # a global
     # $x  => [ 'Variable', undef, 5 ] # slot 5 in pad
@@ -155,6 +156,11 @@ use CgOp ();
                     CgOp::sink($self->do->cgop($self)),
                     CgOp::rawsccall('Kernel.Take',
                         CgOp::scopedlex('EMPTY'))));
+        } elsif ($self->returnable) {
+            $self->cgoptree(CgOp::prog(@enter,
+                    CgOp::return(CgOp::span("rstart", "rend",
+                        $self->do->cgop($self))),
+                    CgOp::ehspan(4, undef, 0, "rstart", "rend", "rend")));
         } else {
             $self->cgoptree(CgOp::prog(@enter,
                     CgOp::return($self->do->cgop($self))));

diff --git a/src/CgOp.pm b/src/CgOp.pm
@@ -281,7 +281,7 @@ use warnings;
             $_->var_cg($cg);
         }
         my ($c, @o) = @{ $self->op };
-        if ($cg->unreach && $c ne 'labelhere') {
+        if ($cg->unreach && $c ne 'labelhere' && $c ne 'ehspan') {
             return;
         }
         $cg->$c(@o);

diff --git a/src/Niecza/Actions.pm b/src/Niecza/Actions.pm
@@ -2237,6 +2237,7 @@ sub sl_to_block { my ($cl, $type, $ast, %args) = @_;
     $cl->blockcheck;
     Body->new(
         name      => $subname,
+        returnable=> ($type eq 'sub'),
         ($type eq 'mainline' ? (
                 file => $::FILE->{name},
                 text => $::ORIG) : ()),

diff --git a/test.pl b/test.pl
@@ -2,7 +2,7 @@
 
 use Test;
 
-plan 454;
+plan 518;
 
 ok 1, "one is true";
 ok 2, "two is also true";
@@ -1029,3 +1029,50 @@
     is +$me<tok>[4]<sign>, 0, "fifth no sign";
     is $me<tok>[2], '-34', "3rd token '-34'";
 }
+
+{
+    rxtest / . << . /, ".<<.", (" x",), ("x ","  ","xx");
+    rxtest / . << /, ".<<", Nil, ("x", " ");
+    rxtest / << . /, "<<.", ("x",), (" ",);
+    rxtest / << /, "<<", Nil, ("",);
+
+    rxtest / . >> . /, ".>>.", ("x ",), (" x","  ","xx");
+    rxtest / . >> /, ".>>", ("x",), (" ",);
+    rxtest / >> . /, ">>.", Nil, ("x"," ");
+    rxtest / >> /, ">>", Nil, ("",);
+
+    rxtest / . « . /, ".«.", (" x",), ("x ","  ","xx");
+    rxtest / . « /, ".«", Nil, ("x", " ");
+    rxtest / « . /, "«.", ("x",), (" ",);
+    rxtest / « /, "«", Nil, ("",);
+
+    rxtest / . » . /, ".».", ("x ",), (" x","  ","xx");
+    rxtest / . » /, ".»", ("x",), (" ",);
+    rxtest / » . /, "».", Nil, ("x"," ");
+    rxtest / » /, "»", Nil, ("",);
+
+    rxtest / . ^ . /, ".^.", Nil, ("x",);
+    rxtest / . ^ /, ".^", Nil, ("x",);
+    rxtest / ^ . /, "^.", ("x",), Nil;
+    rxtest / ^ /, "^", ("",), Nil;
+
+    rxtest / . $ . /, '.$.', Nil, ("x",);
+    rxtest / . $ /, '.$', ("x",), Nil;
+    rxtest / $ . /, '$.', Nil, ("x",);
+    rxtest / $ /, '$', ("",), Nil;
+
+    rxtest / . ^^ . /, '.^^.', ("\nx","\n\n"), ("x\n","xx");
+    rxtest / . ^^ /, '.^^', Nil, ("x","\n");
+    rxtest / ^^ . /, '^^.', ("x","\n"), Nil;
+    rxtest / ^^ /, '^^', ("",), Nil;
+
+    rxtest / . $$ . /, '.$$.', ("x\n", "\n\n"), ("\nx","xx");
+    rxtest / . $$ /, '.$$', ("x",), ("\n",);
+    rxtest / $$ . /, '$$.', ("\n",), ("x",);
+    rxtest / $$ /, '$$', ("",), Nil;
+}
+
+{
+    ok "foo" ~~ / :my $gothere = 1; foo /, "can embed :my in regexes";
+    ok $gothere, ":my code is run";
+}
diff --git a/test2.pl b/test2.pl
@@ -1,51 +1,4 @@
 # vim: ft=perl6
 use Test;
 
-{
-    rxtest / . << . /, ".<<.", (" x",), ("x ","  ","xx");
-    rxtest / . << /, ".<<", Nil, ("x", " ");
-    rxtest / << . /, "<<.", ("x",), (" ",);
-    rxtest / << /, "<<", Nil, ("",);
-
-    rxtest / . >> . /, ".>>.", ("x ",), (" x","  ","xx");
-    rxtest / . >> /, ".>>", ("x",), (" ",);
-    rxtest / >> . /, ">>.", Nil, ("x"," ");
-    rxtest / >> /, ">>", Nil, ("",);
-
-    rxtest / . « . /, ".«.", (" x",), ("x ","  ","xx");
-    rxtest / . « /, ".«", Nil, ("x", " ");
-    rxtest / « . /, "«.", ("x",), (" ",);
-    rxtest / « /, "«", Nil, ("",);
-
-    rxtest / . » . /, ".».", ("x ",), (" x","  ","xx");
-    rxtest / . » /, ".»", ("x",), (" ",);
-    rxtest / » . /, "».", Nil, ("x"," ");
-    rxtest / » /, "»", Nil, ("",);
-
-    rxtest / . ^ . /, ".^.", Nil, ("x",);
-    rxtest / . ^ /, ".^", Nil, ("x",);
-    rxtest / ^ . /, "^.", ("x",), Nil;
-    rxtest / ^ /, "^", ("",), Nil;
-
-    rxtest / . $ . /, '.$.', Nil, ("x",);
-    rxtest / . $ /, '.$', ("x",), Nil;
-    rxtest / $ . /, '$.', Nil, ("x",);
-    rxtest / $ /, '$', ("",), Nil;
-
-    rxtest / . ^^ . /, '.^^.', ("\nx","\n\n"), ("x\n","xx");
-    rxtest / . ^^ /, '.^^', Nil, ("x","\n");
-    rxtest / ^^ . /, '^^.', ("x","\n"), Nil;
-    rxtest / ^^ /, '^^', ("",), Nil;
-
-    rxtest / . $$ . /, '.$$.', ("x\n", "\n\n"), ("\nx","xx");
-    rxtest / . $$ /, '.$$', ("x",), ("\n",);
-    rxtest / $$ . /, '$$.', ("\n",), ("x",);
-    rxtest / $$ /, '$$', ("",), Nil;
-}
-
-{
-    ok "foo" ~~ / :my $gothere = 1; foo /, "can embed :my in regexes";
-    ok $gothere, ":my code is run";
-}
-
 done-testing;