From 59fa498a5677d73da07c843802c53d7204536fdc Mon Sep 17 00:00:00 2001
From: Stefan O'Rear <stefanor@cox.net>
Date: Wed, 15 Sep 2010 13:17:43 -0700
Subject: [PATCH] Generate control exception data for return

---
 src/Body.pm           |  6 ++++++
 src/CgOp.pm           |  2 +-
 src/Niecza/Actions.pm |  1 +
 test.pl               | 49 ++++++++++++++++++++++++++++++++++++++++++-
 test2.pl              | 47 -----------------------------------------
 5 files changed, 56 insertions(+), 49 deletions(-)

diff --git a/src/Body.pm b/src/Body.pm
index b1befc3d..2aa3be31 100644
--- 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
index 6aff7d92..6af8995b 100644
--- 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
index 70b1e957..75a736d5 100644
--- 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
index b01a2a09..901f2e21 100644
--- 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
index 23d850bc..a82920e2 100644
--- 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;