implement labeled loops and throwing of labels as payload

Labels are lexcially installed as instances of type Label, and are glued to the exception handlers of e.g. 'while', 'until' and 'for' loops. When an exception with a label as payload is thrown, the handler that holds the identical label will be in charge. Introspecting the labels of a block is NYI, since we do not have &?BLOCK to yet, see S06:3047.
rakudo · May 21, 2014 · 196b4ff · 196b4ff
1 parent d96ad15
commit 196b4ff
Show file tree

Hide file tree

Showing 11 changed files with 215 additions and 24 deletions.
diff --git a/src/Perl6/Actions.nqp b/src/Perl6/Actions.nqp
@@ -1139,6 +1139,9 @@ class Perl6::Actions is HLL::Actions does STDActions {
                         QAST::Op.new(:name('&infix:<,>'), :op('call'), $xblock[0]),
                         block_closure($xblock[1])
         );
+        if $*LABEL {
+            $past.push(QAST::WVal.new( :value($*W.find_symbol([$*LABEL])), :named('label') ));
+        }
         $past := QAST::Want.new(
             QAST::Op.new( :op<callmethod>, :name<eager>, $past ),
             'v', QAST::Op.new( :op<callmethod>, :name<sink>, $past ));
@@ -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
@@ -1106,19 +1106,30 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
     }
 
     token label {
-        :my $label;
         <identifier> ':' <?[\s]> <.ws>
+        {
+            $*LABEL       := ~$<identifier>;
+            my $total     := nqp::chars(self.orig());
+            my $from      := self.MATCH.from();
+            my $to        := self.MATCH.to() + nqp::chars($*LABEL);
+            my $line      := HLL::Compiler.lineof(self.orig(), self.from());
+            my $prematch  := nqp::substr(self.orig(), $from > 20 ?? $from - 20 !! 0, $from);
+            my $postmatch := nqp::substr(self.orig(), $to, $total > $to + 20 ?? $to + 20 !! $total);
+            my $label     := $*W.find_symbol(['Label']).new( :name($*LABEL), :$line, :$prematch, :$postmatch );
+            $*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/Any.pm b/src/core/Any.pm
@@ -92,8 +92,8 @@ my class Any { # declared in BOOTSTRAP
     }
     proto method map (|) { * }
     multi method map(Whatever) is rw { self }
-    multi method map($block) is rw {
-        MapIter.new(self, $block, Bool::True).list
+    multi method map($block, :$label) is rw {
+        MapIter.new(self, $block, Bool::True, :$label).list
     }
     method flatmap($block) is rw { flatmap($block, self) }
     method duckmap($block) is rw { duckmap($block, self) }

diff --git a/src/core/Label.pm b/src/core/Label.pm
@@ -0,0 +1,69 @@
+my class Label {
+    has Str $!name;
+    has Str $!file;
+    has Int $!line;
+    has Str $!prematch;
+    has Str $!postmatch;
+    method new(:$name, :$line, :$prematch, :$postmatch) {
+        # XXX Register in &?BLOCK.labels when we have &?BLOCK.
+        my $obj := nqp::create(self);
+        nqp::bindattr($obj, Label, '$!name',      $name);
+        nqp::bindattr($obj, Label, '$!file',      nqp::p6box_s(nqp::getlexdyn('$?FILES')));
+        nqp::bindattr($obj, Label, '$!line',      $line);
+        nqp::bindattr($obj, Label, '$!prematch',  nqp::p6box_s($prematch));
+        nqp::bindattr($obj, Label, '$!postmatch', nqp::p6box_s($postmatch));
+        $obj
+    }
+    method name() {
+        $!name
+    }
+
+    # XXX method leave(@args)
+
+    method gist() {
+        my $color = %*ENV<RAKUDO_ERROR_COLOR> // $*OS ne 'MSWin32';
+        my ($red, $green, $yellow, $clear) = $color
+            ?? ("\e[31m", "\e[32m", "\e[33m", "\e[0m")
+            !! ("", "", "", "");
+        my $eject = $*OS eq 'MSWin32' ?? "<HERE>" !! "\x[23CF]";
+
+        "Label<$!name>(at $!file:$!line, '$green$!prematch$yellow$eject$red$!name$green$!postmatch$clear')"
+    }
+
+    method Int() { nqp::where(nqp::decont(self)) }
+
+    # XXX method goto
+    method next() {
+        my Mu $ex := nqp::newexception();
+        nqp::setpayload($ex, nqp::decont(self));
+#?if parrot
+        nqp::setextype($ex, 512); # XXX create nqp::const::CONTROL_LOOP_NEXT_LABELED?
+#?endif
+#?if !parrot
+        nqp::setextype($ex, nqp::const::CONTROL_NEXT + nqp::const::CONTROL_LABELED);
+#?endif
+        nqp::throw($ex);
+    }
+    method redo() {
+        my Mu $ex := nqp::newexception();
+        nqp::setpayload($ex, nqp::decont(self));
+#?if parrot
+        nqp::setextype($ex, 513); # XXX create nqp::const::CONTROL_LOOP_REDO_LABELED?
+#?endif
+#?if !parrot
+        nqp::setextype($ex, nqp::const::CONTROL_REDO + nqp::const::CONTROL_LABELED);
+#?endif
+        nqp::throw($ex);
+    }
+    method last() {
+        my Mu $ex := nqp::newexception();
+        nqp::setpayload($ex, nqp::decont(self));
+#?if parrot
+        nqp::setextype($ex, 514); # XXX create nqp::const::CONTROL_LOOP_LAST_LABELED?
+#?endif
+#?if !parrot
+        nqp::setextype($ex, nqp::const::CONTROL_LAST + nqp::const::CONTROL_LABELED);
+#?endif
+        nqp::throw($ex);
+    }
+}
diff --git a/src/core/MapIter.pm b/src/core/MapIter.pm
@@ -5,20 +5,22 @@ my class MapIter is Iterator {
     has $!block;               # the block we're applying
     has $!first;               # Is this the first iterator in the sequence?
     has Mu $!items;            # reified items we haven't consumed yet
+    has Mu $!label;            # The label that might be attached to us
 
-    method new($list, $block, Mu $flattens = Bool::True) { 
+    method new($list, $block, Mu $flattens = Bool::True, :$label) { 
         my $new := nqp::create(self);
         $new.BUILD(nqp::p6listiter(nqp::list(nqp::decont($list)), $new), 
-                   $block, $flattens, True);
+                   $block, $flattens, True, :$label);
         $new;
     }
 
-    method BUILD(Mu \listiter, \block, Mu \flattens, $first = False) { 
+    method BUILD(Mu \listiter, \block, Mu \flattens, $first = False, :$label) { 
         nqp::bindattr(listiter, ListIter, '$!list', self) if nqp::isconcrete(listiter);
         $!listiter := listiter; 
         $!block = block; 
         $!first = $first;
         $!flattens = flattens;
+        $!label := $label;
         self 
     }
 
@@ -49,6 +51,7 @@ my class MapIter is Iterator {
             my int $NEXT = nqp::can($block, 'fire_phasers') 
                              && +$block.phasers('NEXT');
             my int $is_sink = $sink ?? 1 !! 0;
+            my Mu $label := $!label;
 
 #?if parrot
             Q:PIR {
@@ -69,7 +72,16 @@ my class MapIter is Iterator {
                 is_sink  = find_lex '$is_sink'
 
                 set_addr handler, catch
-                handler.'handle_types'(.CONTROL_LOOP_LAST, .CONTROL_LOOP_NEXT, .CONTROL_LOOP_REDO)
+            };
+            if $!label {
+                Q:PIR { handler.'handle_types'(.CONTROL_LOOP_LAST, .CONTROL_LOOP_NEXT, .CONTROL_LOOP_REDO, 512, 513, 514) };
+                1
+            }
+            else {
+                Q:PIR { handler.'handle_types'(.CONTROL_LOOP_LAST, .CONTROL_LOOP_NEXT, .CONTROL_LOOP_REDO) };
+                1
+            }
+            Q:PIR {
                 push_eh handler
 
               iter_loop:
@@ -109,6 +121,24 @@ my class MapIter is Iterator {
                 type = getattribute exception, 'type'
                 if type == .CONTROL_LOOP_REDO goto redo
                 if type == .CONTROL_LOOP_LAST goto last
+            };
+            if $!label {
+                Q:PIR {
+                    .local int id1_reg, id2_reg
+                    .local pmc label
+                    label = find_lex '$label'
+                    id1_reg = get_id result
+                    id2_reg = label
+                    if id1_reg != id2_reg goto rethrow
+                    if type == 512 goto next
+                    if type == 513 goto redo
+                    if type == 514 goto last
+                  rethrow:
+                    rethrow exception # XXX Should that be perl6_based_rethrow?
+                };
+                1
+            }
+            Q:PIR {
               next:
                 unless NEXT goto iter_loop
                 block.'fire_phasers'('NEXT')
@@ -135,6 +165,31 @@ my class MapIter is Iterator {
 
             if $argc == 1 && !$NEXT {
                 # Fast path case: only 1 argument for each block, no NEXT phaser.
+                $!label ??
+                nqp::while(($state && nqp::islt_i(nqp::elems($rpa), $count)), nqp::handle(
+                    nqp::stmts(
+                        nqp::if(nqp::iseq_i($state, 1), nqp::stmts(
+                            nqp::unless(nqp::elems($items), nqp::stmts(
+                                nqp::if($!listiter, $!listiter.reify(1))
+                            )),
+                            nqp::if($items, 
+                                nqp::stmts(($arg := nqp::shift($items)), $state = 2),
+                                $state = 0)
+                        )),
+                        nqp::if(nqp::iseq_i($state, 2), nqp::stmts(
+                            ($sink ?? $block($arg) !! nqp::push($rpa, $block($arg))),
+                            $state = 1
+                        ))
+                    ),
+                    'LABELED', nqp::decont($label),
+                    'LAST', nqp::stmts(
+                        ($!items := Any),
+                        ($!listiter := Any),
+                        ($state = 0)
+                    ),
+                    'REDO', $state = 2,
+                    'NEXT', $state = 1
+                )) !!
                 nqp::while(($state && nqp::islt_i(nqp::elems($rpa), $count)), nqp::handle(
                     nqp::stmts(
                         nqp::if(nqp::iseq_i($state, 1), nqp::stmts(
@@ -160,6 +215,39 @@ my class MapIter is Iterator {
                 ));
             }
             else {
+                $!label ??
+                nqp::while(($state && nqp::islt_i(nqp::elems($rpa), $count)), nqp::handle(
+                    nqp::stmts(
+                        nqp::if(nqp::iseq_i($state, 1), nqp::stmts(
+                            ($itmp = nqp::elems($items)),
+                            nqp::unless($itmp >= $argc, nqp::stmts(
+                                ($itmp = $argc - $itmp),
+                                nqp::if($!listiter, $!listiter.reify($itmp))
+                            )),
+                            nqp::setelems($args, 0),
+                            nqp::p6shiftpush($args, $items, $argc),
+                            nqp::if($args, $state = 2, $state = 0)
+                        )),
+                        nqp::if(nqp::iseq_i($state, 2), nqp::stmts(
+                            ($sink
+                                ?? nqp::p6invokeflat($block, $args)
+                                !! nqp::push($rpa, nqp::p6invokeflat($block, $args))),
+                            $state = 3
+                        )),
+                        nqp::if(nqp::iseq_i($state, 3), nqp::stmts(
+                            nqp::if($NEXT, $block.fire_phasers('NEXT')),
+                            ($state = 1)
+                        ))
+                    ),
+                    'LABELED', nqp::decont($label),
+                    'LAST', nqp::stmts(
+                        ($!items := Any),
+                        ($!listiter := Any),
+                        ($state = 0)
+                    ),
+                    'REDO', $state = 2,
+                    'NEXT', $state = 3
+                )) !!
                 nqp::while(($state && nqp::islt_i(nqp::elems($rpa), $count)), nqp::handle(
                     nqp::stmts(
                         nqp::if(nqp::iseq_i($state, 1), nqp::stmts(
@@ -195,7 +283,7 @@ my class MapIter is Iterator {
 #?endif
 
             if $!items || $!listiter {
-                my $nextiter := nqp::create(self).BUILD($!listiter, $!block, $!flattens);
+                my $nextiter := nqp::create(self).BUILD($!listiter, $!block, $!flattens, :$!label);
                 nqp::bindattr($nextiter, MapIter, '$!items', $!items);
                 nqp::push($rpa, $nextiter);
             }

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,25 +50,37 @@ 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::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 := -> | { 
-    my $parcel := 
-        &RETURN-PARCEL(nqp::p6parcel(nqp::p6argvmarray(), Nil));
-    THROW(nqp::decont($parcel), 
-          nqp::const::CONTROL_NEXT) 
+    my Mu $args := nqp::p6argvmarray();
+    if nqp::islist($args) && nqp::istype(nqp::atpos($args, 0), Label) {
+        nqp::atpos($args, 0).next()
+    }
+    else {
+        my $parcel := nqp::decont(&RETURN-PARCEL(nqp::p6parcel($args, Nil)));
+        THROW($parcel, nqp::const::CONTROL_NEXT)
+    }
 };
 
 my &redo := -> | { 
-    my $parcel := 
-        &RETURN-PARCEL(nqp::p6parcel(nqp::p6argvmarray(), Nil));
-    THROW(nqp::decont($parcel), 
-          nqp::const::CONTROL_REDO) 
+    my Mu $args := nqp::p6argvmarray();
+    if nqp::islist($args) && nqp::istype(nqp::atpos($args, 0), Label) {
+        nqp::atpos($args, 0).redo()
+    }
+    else {
+        my $parcel := nqp::decont(&RETURN-PARCEL(nqp::p6parcel($args, Nil)));
+        THROW($parcel, nqp::const::CONTROL_REDO)
+    }
 };
 
 my &succeed := -> | { 

diff --git a/t/spectest.data b/t/spectest.data
@@ -273,6 +273,7 @@ S04-statements/for_with_only_one_item.t
 S04-statements/gather.t
 S04-statements/given.t
 S04-statements/if.t
+S04-statements/label.t
 S04-statements/last.t
 S04-statements/loop.t
 S04-statements/map-and-sort-in-for.t

diff --git a/tools/build/Makefile-JVM.in b/tools/build/Makefile-JVM.in
@@ -105,6 +105,7 @@ J_CORE_SOURCES = \
   src/core/EnumMap.pm \
   src/core/Hash.pm \
   src/core/Stash.pm \
+  src/core/Label.pm \
   src/core/PseudoStash.pm \
   src/core/Parameter.pm \
   src/core/Signature.pm \

diff --git a/tools/build/Makefile-Moar.in b/tools/build/Makefile-Moar.in
@@ -107,6 +107,7 @@ M_CORE_SOURCES = \
   src/core/EnumMap.pm \
   src/core/Hash.pm \
   src/core/Stash.pm \
+  src/core/Label.pm \
   src/core/PseudoStash.pm \
   src/core/Parameter.pm \
   src/core/Signature.pm \

diff --git a/tools/build/Makefile-Parrot.in b/tools/build/Makefile-Parrot.in
@@ -187,6 +187,7 @@ P_CORE_SOURCES = \
   src/core/EnumMap.pm \
   src/core/Hash.pm \
   src/core/Stash.pm \
+  src/core/Label.pm \
   src/core/PseudoStash.pm \
   src/core/Parameter.pm \
   src/core/Signature.pm \

diff --git a/tools/build/NQP_REVISION b/tools/build/NQP_REVISION
@@ -1 +1 @@
-2014.04-61-gf0ea1c3
+2014.04-63-g1783628