test for supporting loop labels

rakudo · Apr 28, 2014 · ed78569 · ed78569
1 parent 270088d
commit ed78569
Show file tree

Hide file tree

Showing 4 changed files with 53 additions and 8 deletions.
diff --git a/src/Perl6/Actions.nqp b/src/Perl6/Actions.nqp
@@ -1134,6 +1134,9 @@ class Perl6::Actions is HLL::Actions does STDActions {
 
     method statement_control:sym<for>($/) {
         my $xblock := $<xblock>.ast;
+        #~ if $*LABEL {
+            #~ $loop.push(QAST::WVal.new( :value($*W.find_sym([$*LABEL])), :named('label') ));
+        #~ }
         my $past := QAST::Op.new(
                         :op<callmethod>, :name<map>, :node($/),
                         QAST::Op.new(:name('&infix:<,>'), :op('call'), $xblock[0]),
@@ -1163,6 +1166,9 @@ class Perl6::Actions is HLL::Actions does STDActions {
     }
 
     sub tweak_loop($loop) {
+        if $*LABEL {
+            $loop.push(QAST::WVal.new( :value($*W.find_symbol([$*LABEL])), :named('label') ));
+        }
         # Handle phasers.
         my $code := $loop[1]<code_object>;
         my $block_type := $*W.find_symbol(['Block']);

diff --git a/src/Perl6/Grammar.nqp b/src/Perl6/Grammar.nqp
@@ -1102,19 +1102,24 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
     }
 
     token label {
-        :my $label;
         <identifier> ':' <?[\s]> <.ws>
+        {
+            $*LABEL := ~$<identifier>;
+            my $label := $*W.find_symbol(['Label']).new($*LABEL);
+            $*W.add_object($label);
+            $*W.install_lexical_symbol($*W.cur_lexpad(), $*LABEL, $label);
+        }
     }
 
-    token statement {
+    token statement($*LABEL = '') {
         :my $*QSIGIL := '';
         :my $*SCOPE := '';
         :my $*ACTIONS := %*LANG<MAIN-actions>;
         <!before <[\])}]> | $ >
         <!stopper>
         <!!{ nqp::rebless($/.CURSOR, %*LANG<MAIN>) }>
         [
-        | <label> <statement>
+        | <label> <statement($*LABEL)> { $*LABEL := '' if $*LABEL }
         | <statement_control>
         | <EXPR> :dba('statement end')
             [

diff --git a/src/core/PseudoStash.pm b/src/core/PseudoStash.pm
@@ -1,6 +1,29 @@
 my class X::Bind { ... }
 my class X::Caller::NotDynamic { ... }
 
+my class Label {
+    has Str $!name;
+    method new($name) {
+        # XXX register in &?BLOCK.labels
+        my $obj := nqp::create(self);
+        nqp::bindattr($obj, Label, '$!name', $name);
+        $obj
+    }
+    method name() {
+        $!name
+    }
+    # XXX method leave(@args)
+    # XXX method goto
+    # XXX method next
+    method last() {
+        say $!name ~ '.last called';
+        my Mu $ex   := nqp::newexception();
+        nqp::setpayload($ex, self);
+        nqp::setextype($ex, nqp::const::CONTROL_LAST + nqp::const::CONTROL_LABELED);
+        nqp::throw($ex);
+    }
+}
+
 my class PseudoStash is EnumMap {
     has Mu $!ctx;
     has int $!mode;

diff --git a/src/core/control.pm b/src/core/control.pm
@@ -1,5 +1,6 @@
 my class X::Eval::NoSuchLang { ... }
 my class PseudoStash { ... }
+my class Label { ... }
 
 my &THROW :=
     -> | {
@@ -49,11 +50,21 @@ my &take := -> | {
     $parcel
 };
 
-my &last := -> | { 
-    my $parcel := 
-        &RETURN-PARCEL(nqp::p6parcel(nqp::p6argvmarray(), Nil));
-    THROW(nqp::decont($parcel), 
-          nqp::const::CONTROL_LAST) 
+my &last := -> | {
+    my Mu $args := nqp::p6argvmarray();
+
+    if nqp::istype($args, Label) {
+        say 'nqp::istype($args, Label)';
+        $args.last()
+    }
+    elsif nqp::islist($args) && nqp::istype(nqp::atpos($args, 0), Label) {
+        say 'nqp::islist($args) && nqp::istype(nqp::atpos($args, 0), Label)';
+        nqp::atpos($args, 0).last()
+    }
+    else {
+        my $parcel := nqp::decont(&RETURN-PARCEL(nqp::p6parcel($args, Nil)));
+        THROW($parcel, nqp::const::CONTROL_LAST)
+    }
 };
 
 my &next := -> | {