label.diff

diff --git a/src/NQP/Actions.nqp b/src/NQP/Actions.nqp
index f4993d0..ca07474 100644
--- a/src/NQP/Actions.nqp
+++ b/src/NQP/Actions.nqp
@@ -290,7 +290,10 @@ class NQP::Actions is HLL::Actions {
     method statement_control:sym<while>($/) {
         my $past := xblock_immediate( $<xblock>.ast );
         $past.op(~$<sym>);
-        unless $*CONTROL_USED {
+        if $*LABEL {
+            $past.push(QAST::WVal.new( :value($*W.find_sym([$*LABEL])), :named('label') ));
+        }
+        elsif !$*CONTROL_USED {
             $past.push(QAST::IVal.new( :value(1), :named('nohandler') ));
         }
         make $past;
@@ -1574,9 +1577,33 @@ class NQP::Actions is HLL::Actions {
         );
     }
     
-    method term:sym<next>($/) { make QAST::Op.new( :op('control'), :name('next') ) }
-    method term:sym<last>($/) { make QAST::Op.new( :op('control'), :name('last') ) }
-    method term:sym<redo>($/) { make QAST::Op.new( :op('control'), :name('redo') ) }
+    method term:sym<next>($/) {
+        my $ast := QAST::Op.new( :op('control'), :name('next') );
+        
+        if $<identifier> {
+            $ast.push(QAST::WVal.new( :value($*W.find_sym([$<identifier>])), :named('label') ));
+        }
+        
+        make $ast
+    }
+    method term:sym<last>($/) {
+        my $ast := QAST::Op.new( :op('control'), :name('last') );
+        
+        if $<identifier> {
+            $ast.push(QAST::WVal.new( :value($*W.find_sym([$<identifier>])), :named('label') ));
+        }
+        
+        make $ast
+    }
+    method term:sym<redo>($/) {
+        my $ast := QAST::Op.new( :op('control'), :name('redo') );
+        
+        if $<identifier> {
+            $ast.push(QAST::WVal.new( :value($*W.find_sym([$<identifier>])), :named('label') ));
+        }
+        
+        make $ast
+    }
 
     method infix:sym<~~>($/) {
         make QAST::Op.new( :op<callmethod>, :name<ACCEPTS>, :node($/) );
diff --git a/src/NQP/Grammar.nqp b/src/NQP/Grammar.nqp
index c59d542..47ce5d8 100644
--- a/src/NQP/Grammar.nqp
+++ b/src/NQP/Grammar.nqp
@@ -152,14 +152,19 @@ grammar NQP::Grammar is HLL::Grammar {
     }
 
     token label {
-        :my $label;
         <identifier> ':' <?[\s]> <.ws>
+        {
+            $*LABEL := ~$<identifier>;
+            my $label := $*W.find_sym(['NQPLabel']).new();
+            $*W.add_object($label);
+            $*W.install_lexical_symbol($*W.cur_lexpad(), $*LABEL, $label);
+        }
     }
 
-    token statement {
+    token statement($*LABEL = '') {
         <!before <[\])}]> | $ >
         [
-        | <label> <statement>
+        | <label> <statement($*LABEL)> { $*LABEL := '' if $*LABEL }
         | <statement_control>
         | <EXPR> <.ws>
             [
@@ -311,9 +316,9 @@ grammar NQP::Grammar is HLL::Grammar {
     token term:sym<regex_declarator>   { <regex_declarator> }
     token term:sym<statement_prefix>   { <statement_prefix> }
     token term:sym<lambda>             { <?lambda> <pblock> }
-    token term:sym<last>               { <sym> <!identifier> { $*CONTROL_USED := 1 } }
-    token term:sym<next>               { <sym> <!identifier> { $*CONTROL_USED := 1 } }
-    token term:sym<redo>               { <sym> <!identifier> { $*CONTROL_USED := 1 } }
+    token term:sym<last>               { <sym> [<.ws> <identifier> <?{ $*W.is_lexical(~$<identifier>) }>]? { $*CONTROL_USED := 1 } }
+    token term:sym<next>               { <sym> [<.ws> <identifier> <?{ $*W.is_lexical(~$<identifier>) }>]? { $*CONTROL_USED := 1 } }
+    token term:sym<redo>               { <sym> [<.ws> <identifier> <?{ $*W.is_lexical(~$<identifier>) }>]? { $*CONTROL_USED := 1 } }
 
     token fatarrow {
         <key=.identifier> \h* '=>' <.ws> <val=.EXPR('i=')>
diff --git a/src/core/NQPMu.nqp b/src/core/NQPMu.nqp
index 033fa9a..3fdde41 100644
--- a/src/core/NQPMu.nqp
+++ b/src/core/NQPMu.nqp
@@ -134,3 +134,5 @@ nqp::sethllconfig('nqp', nqp::hash(
     'hash_iter', NQPHashIter
 ));
 #?endif
+
+my class NQPLabel { }
diff --git a/src/vm/parrot/QAST/Operations.nqp b/src/vm/parrot/QAST/Operations.nqp
index c61391b..b41f144 100644
--- a/src/vm/parrot/QAST/Operations.nqp
+++ b/src/vm/parrot/QAST/Operations.nqp
@@ -566,8 +566,10 @@ for ('', 'repeat_') -> $repness {
             my @comp_types;
             my $handler := 1;
             my $*IMM_ARG;
+            my $label;
             for $op.list {
                 if $_.named eq 'nohandler' { $handler := 0; }
+                elsif $_.named eq 'label' { $label := $_ }
                 else {
                     my $*HAVE_IMM_ARG := nqp::istype($_, QAST::Block) && $_.arity > 0 && $_ =:= $op.list[1];
                     my $comp := $qastcomp.as_post($_);
@@ -578,6 +580,7 @@ for ('', 'repeat_') -> $repness {
                     }
                 }
             }
+
             my $res_type := @comp_types[0] eq @comp_types[1] ?? nqp::lc(@comp_types[0]) !! 'p';
             my $res_reg  := $*REGALLOC."fresh_$res_type"();
 
@@ -594,7 +597,9 @@ for ('', 'repeat_') -> $repness {
             if $handler {
                 $exc_reg := $*REGALLOC.fresh_p();
                 $ops.push_pirop('new', $exc_reg, "'ExceptionHandler'",
-                    '[.CONTROL_LOOP_NEXT;.CONTROL_LOOP_REDO;.CONTROL_LOOP_LAST]');
+                    $label  ?? '[.CONTROL_LOOP_NEXT;.CONTROL_LOOP_REDO;.CONTROL_LOOP_LAST;512;513;514]'
+                            !! '[.CONTROL_LOOP_NEXT;.CONTROL_LOOP_REDO;.CONTROL_LOOP_LAST]'
+                );
                 $ops.push_pirop('set_label', $exc_reg, $hand_lbl);
                 $ops.push_pirop('push_eh', $exc_reg);
             }
@@ -644,12 +649,32 @@ for ('', 'repeat_') -> $repness {
             # Emit postlude, with exception handlers.
             if $handler {
                 $ops.push($hand_lbl);
+                my $type_reg := $*REGALLOC.fresh_p();
                 $ops.push_pirop('.get_results', '(' ~ $exc_reg ~ ')');
                 $ops.push_pirop('pop_upto_eh', $exc_reg);
-                $ops.push_pirop('getattribute', $exc_reg, $exc_reg, "'type'");
-                $ops.push_pirop('eq', $exc_reg, '.CONTROL_LOOP_NEXT',
+                $ops.push_pirop('getattribute', $type_reg, $exc_reg, "'type'");
+                $ops.push_pirop('eq', $type_reg, '.CONTROL_LOOP_NEXT',
                     $operands == 3 ?? $next_lbl !! $test_lbl);
-                $ops.push_pirop('eq', $exc_reg, '.CONTROL_LOOP_REDO', $redo_lbl);
+                $ops.push_pirop('eq', $type_reg, '.CONTROL_LOOP_REDO', $redo_lbl);
+                
+                if $label {
+                    my $l := $qastcomp.coerce($qastcomp.as_post($label), 'P');
+                    my $pay_reg := $*REGALLOC.fresh_p();
+                    my $id1_reg := $*REGALLOC.fresh_i();
+                    my $id2_reg := $*REGALLOC.fresh_i();
+                    my $rethrow_lbl := PIRT::Label.new(:name($while_id ~ '_rethrow'));
+                    $ops.push($l);
+                    $ops.push_pirop('getattribute', $pay_reg, $exc_reg, "'payload'");
+                    $ops.push_pirop('get_id', $id1_reg, $pay_reg);
+                    $ops.push_pirop('get_id', $id2_reg, $l);
+                    $ops.push_pirop('ne', $id1_reg, $id2_reg, $rethrow_lbl);
+                    $ops.push_pirop('eq', $type_reg, 512, $operands == 3 ?? $next_lbl !! $test_lbl);
+                    $ops.push_pirop('eq', $type_reg, 513, $redo_lbl);
+                    $ops.push_pirop('eq', $type_reg, 514, $done_lbl);
+                    $ops.push($rethrow_lbl);
+                    $ops.push_pirop('rethrow', $exc_reg);
+                }
+
                 $ops.push($done_lbl);
                 $ops.push_pirop('pop_eh');
             }
@@ -1494,8 +1519,28 @@ my %control_map := nqp::hash(
 QAST::Operations.add_core_op('control', -> $qastcomp, $op {
     my $name := $op.name;
     if nqp::existskey(%control_map, $name) {
+        my $label;
+        for $op.list {
+            $label := $_ if $_.named eq 'label';
+        }
+        
         my $ops := PIRT::Ops.new(:result('0'));
-        $ops.push_pirop('die', '0', %control_map{$name});
+        
+        if $label {
+            #~ $label.value."$name"(1);
+            my $l  := $qastcomp.coerce($qastcomp.as_post($label), 'P');
+            my $ex := $*REGALLOC.fresh_p();
+            $ops.push($l);
+            $ops.push_pirop('new', $ex, "'Exception'");
+            $ops.push_pirop('set', "$ex\['type']", 512) if $name eq 'next';
+            $ops.push_pirop('set', "$ex\['type']", 513) if $name eq 'redo';
+            $ops.push_pirop('set', "$ex\['type']", 514) if $name eq 'last';
+            $ops.push_pirop('set', "$ex\['payload']", $l);
+            $ops.push_pirop('throw', $ex);
+        }
+        else {
+            $ops.push_pirop('die', '0', %control_map{$name});
+        }
         $ops
     }
     else {