make loop control apply to "given"

A "given" construct is now officially a one-iteration loop.

12 files changed, 156 insertions, 90 deletions

diff --git a/cop.h b/cop.h
index c26fc18fb3..37895e66fe 100644
--- a/cop.h
+++ b/cop.h
@@ -858,14 +858,9 @@ struct context {
 #define CXt_NULL	0 /* currently only used for sort BLOCK */
 #define CXt_WHEN	1
 #define CXt_BLOCK	2
-/* When micro-optimising :-) keep GIVEN next to the LOOPs, as these 5 share a
-   jump table in pp_ctl.c
-   The first 4 don't have a 'case' in at least one switch statement in pp_ctl.c
-*/
-#define CXt_GIVEN	3
-
-/* be careful of the ordering of these five. Macros like CxTYPE_is_LOOP,
+/* be careful of the ordering of these six. Macros like CxTYPE_is_LOOP,
  * CxFOREACH compare ranges */
+#define CXt_LOOP_GIVEN	3 /* given (...)    { ...; } */
 #define CXt_LOOP_ARY	4 /* for (@ary)     { ...; } */
 #define CXt_LOOP_LAZYSV	5 /* for ('a'..'z') { ...; } */
 #define CXt_LOOP_LAZYIV	6 /* for (1..9)     { ...; } */
@@ -904,7 +899,7 @@ struct context {
 #define CXp_ONCE	0x10	/* What was sbu_once in struct subst */
 
 #define CxTYPE(c)	((c)->cx_type & CXTYPEMASK)
-#define CxTYPE_is_LOOP(c) (   CxTYPE(cx) >= CXt_LOOP_ARY                \
+#define CxTYPE_is_LOOP(c) (   CxTYPE(cx) >= CXt_LOOP_GIVEN              \
                            && CxTYPE(cx) <= CXt_LOOP_PLAIN)
 #define CxMULTICALL(c)	((c)->cx_type & CXp_MULTICALL)
 #define CxREALEVAL(c)	(((c)->cx_type & (CXTYPEMASK|CXp_REAL))		\
diff --git a/embed.fnc b/embed.fnc
index dc4e6fc7ee..82e8370a1d 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -3155,11 +3155,10 @@ AiM	|void	|cx_popeval      |NN PERL_CONTEXT *cx
 AiM	|void	|cx_pushloop_plain|NN PERL_CONTEXT *cx
 AiM	|void	|cx_pushloop_for |NN PERL_CONTEXT *cx \
 				 |NN void *itervarp|NULLOK SV *itersave
+AiM	|void	|cx_pushloop_given    |NN PERL_CONTEXT *cx|NULLOK SV *orig_defsv
 AiM	|void	|cx_poploop      |NN PERL_CONTEXT *cx
 AiM	|void	|cx_pushwhen     |NN PERL_CONTEXT *cx
 AiM	|void	|cx_popwhen      |NN PERL_CONTEXT *cx
-AiM	|void	|cx_pushgiven    |NN PERL_CONTEXT *cx|NULLOK SV *orig_defsv
-AiM	|void	|cx_popgiven     |NN PERL_CONTEXT *cx
 #endif
 
 #ifdef USE_DTRACE
diff --git a/embed.h b/embed.h
index e0362efb93..5e82a0f832 100644
--- a/embed.h
+++ b/embed.h
@@ -788,7 +788,6 @@
 #define cx_popblock(a)		S_cx_popblock(aTHX_ a)
 #define cx_popeval(a)		S_cx_popeval(aTHX_ a)
 #define cx_popformat(a)		S_cx_popformat(aTHX_ a)
-#define cx_popgiven(a)		S_cx_popgiven(aTHX_ a)
 #define cx_poploop(a)		S_cx_poploop(aTHX_ a)
 #define cx_popsub(a)		S_cx_popsub(aTHX_ a)
 #define cx_popsub_args(a)	S_cx_popsub_args(aTHX_ a)
@@ -797,8 +796,8 @@
 #define cx_pushblock(a,b,c,d)	S_cx_pushblock(aTHX_ a,b,c,d)
 #define cx_pusheval(a,b,c)	S_cx_pusheval(aTHX_ a,b,c)
 #define cx_pushformat(a,b,c,d)	S_cx_pushformat(aTHX_ a,b,c,d)
-#define cx_pushgiven(a,b)	S_cx_pushgiven(aTHX_ a,b)
 #define cx_pushloop_for(a,b,c)	S_cx_pushloop_for(aTHX_ a,b,c)
+#define cx_pushloop_given(a,b)	S_cx_pushloop_given(aTHX_ a,b)
 #define cx_pushloop_plain(a)	S_cx_pushloop_plain(aTHX_ a)
 #define cx_pushsub(a,b,c,d)	S_cx_pushsub(aTHX_ a,b,c,d)
 #define cx_pushwhen(a)		S_cx_pushwhen(aTHX_ a)
diff --git a/inline.h b/inline.h
index 8c28d983ff..30d695543e 100644
--- a/inline.h
+++ b/inline.h
@@ -1596,6 +1596,17 @@ S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
 }
 
 
+PERL_STATIC_INLINE void
+S_cx_pushloop_given(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
+{
+    PERL_ARGS_ASSERT_CX_PUSHLOOP_GIVEN;
+
+    cx->blk_loop.my_op = cLOOP;
+    cx->blk_loop.itervar_u.gv = PL_defgv;
+    cx->blk_loop.itersave = orig_defsv;
+}
+
+
 /* pop all loop types, including plain */
 
 PERL_STATIC_INLINE void
@@ -1652,30 +1663,6 @@ S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
 }
 
 
-PERL_STATIC_INLINE void
-S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
-{
-    PERL_ARGS_ASSERT_CX_PUSHGIVEN;
-
-    cx->blk_loop.my_op = cLOOP;
-    cx->blk_loop.itersave = orig_defsv;
-}
-
-
-PERL_STATIC_INLINE void
-S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
-{
-    SV *sv;
-
-    PERL_ARGS_ASSERT_CX_POPGIVEN;
-    assert(CxTYPE(cx) == CXt_GIVEN);
-
-    sv = GvSV(PL_defgv);
-    GvSV(PL_defgv) = cx->blk_loop.itersave;
-    cx->blk_loop.itersave = NULL;
-    SvREFCNT_dec(sv);
-}
-
 /* ------------------ util.h ------------------------------------------- */
 
 /*
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 0f88ba4c55..727a6cdf89 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -3776,7 +3776,8 @@ value such as C<eval {}>, C<sub {}>, or C<do {}>, and should not be used
 to exit a L<C<grep>|/grep BLOCK LIST> or L<C<map>|/map BLOCK LIST>
 operation.
 
-Note that a block by itself is semantically identical to a loop
+Note that a block by itself or a C<given> construct
+is semantically identical to a loop
 that executes once.  Thus L<C<last>|/last LABEL> can be used to effect
 an early exit out of such a block.
 
@@ -4306,7 +4307,8 @@ value such as C<eval {}>, C<sub {}>, or C<do {}>, and should not be used
 to exit a L<C<grep>|/grep BLOCK LIST> or L<C<map>|/map BLOCK LIST>
 operation.
 
-Note that a block by itself is semantically identical to a loop
+Note that a block by itself or a C<given> construct
+is semantically identical to a loop
 that executes once.  Thus L<C<next>|/next LABEL> will exit such a block
 early.
 
@@ -6259,7 +6261,8 @@ value such as C<eval {}>, C<sub {}>, or C<do {}>, and should not be used
 to exit a L<C<grep>|/grep BLOCK LIST> or L<C<map>|/map BLOCK LIST>
 operation.
 
-Note that a block by itself is semantically identical to a loop
+Note that a block by itself or a C<given> construct
+is semantically identical to a loop
 that executes once.  Thus L<C<redo>|/redo LABEL> inside such a block
 will effectively turn it into a looping construct.
 
diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod
index cb12a3590f..480b352e7c 100644
--- a/pod/perlsyn.pod
+++ b/pod/perlsyn.pod
@@ -638,7 +638,11 @@ independently and mixed with other kinds of compound statement.
 C<given> evaluates its argument in scalar context, and executes its block
 with the C<$_> variable locally aliased to the result of evaluating the
 argument expression.  It is much like a C<foreach> loop that always has
-exactly one item to iterate over.  Either a C<given> or a C<foreach>
+exactly one item to iterate over.
+A C<given> construct even counts as a one-iteration loop for the purposes
+of loop control, so the C<redo> operator can be used to restart its block,
+and C<next> or C<last> can be used to exit the block early.
+Either a C<given> or a C<foreach>
 construct serves as a I<topicalizer>: C<when> can only
 be used in the dynamic scope of a topicalizer.
 
@@ -697,7 +701,8 @@ so providing the subroutine's return value, it evaluates to:
 
 =item *
 
-An empty list as soon as an explicit C<break> is encountered.
+An empty list as soon as an explicit C<break>, C<next>, or C<last>
+is encountered.
 
 =item *
 
diff --git a/pp_ctl.c b/pp_ctl.c
index 1ab2eeaad4..de7ac5865c 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1287,7 +1287,7 @@ static const char * const context_name[] = {
     "pseudo-block",
     NULL, /* CXt_WHEN never actually needs "block" */
     NULL, /* CXt_BLOCK never actually needs "block" */
-    NULL, /* CXt_GIVEN never actually needs "block" */
+    NULL, /* CXt_LOOP_GIVEN never actually needs "block" */
     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
@@ -1320,6 +1320,7 @@ S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
 	    if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
 		return -1;
 	    break;
+	case CXt_LOOP_GIVEN:
 	case CXt_LOOP_PLAIN:
 	case CXt_LOOP_LAZYIV:
 	case CXt_LOOP_LAZYSV:
@@ -1468,6 +1469,7 @@ S_dopoptoloop(pTHX_ I32 startingblock)
 	    if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
 		return -1;
 	    break;
+	case CXt_LOOP_GIVEN:
 	case CXt_LOOP_PLAIN:
 	case CXt_LOOP_LAZYIV:
 	case CXt_LOOP_LAZYSV:
@@ -1491,7 +1493,7 @@ S_dopoptogivenfor(pTHX_ I32 startingblock)
 	switch (CxTYPE(cx)) {
 	default:
 	    continue;
-	case CXt_GIVEN:
+	case CXt_LOOP_GIVEN:
 	    DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
 	    return i;
 	case CXt_LOOP_PLAIN:
@@ -1564,6 +1566,7 @@ Perl_dounwind(pTHX_ I32 cxix)
 	case CXt_EVAL:
 	    cx_popeval(cx);
 	    break;
+	case CXt_LOOP_GIVEN:
 	case CXt_LOOP_PLAIN:
 	case CXt_LOOP_LAZYIV:
 	case CXt_LOOP_LAZYSV:
@@ -1574,9 +1577,6 @@ Perl_dounwind(pTHX_ I32 cxix)
 	case CXt_WHEN:
 	    cx_popwhen(cx);
 	    break;
-	case CXt_GIVEN:
-	    cx_popgiven(cx);
-	    break;
 	case CXt_BLOCK:
 	case CXt_NULL:
             /* these two don't have a POPFOO() */
@@ -2990,7 +2990,7 @@ PP(pp_goto)
             case CXt_LOOP_LAZYSV:
             case CXt_LOOP_LIST:
             case CXt_LOOP_ARY:
-	    case CXt_GIVEN:
+	    case CXt_LOOP_GIVEN:
 	    case CXt_WHEN:
 		gotoprobe = OpSIBLING(cx->blk_oldcop);
 		break;
@@ -4599,8 +4599,8 @@ PP(pp_entergiven)
     assert(!PL_op->op_targ); /* used to be set for lexical $_ */
     GvSV(PL_defgv) = SvREFCNT_inc(newsv);
 
-    cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
-    cx_pushgiven(cx, origsv);
+    cx = cx_pushblock(CXt_LOOP_GIVEN|CXp_FOR_GV, gimme, SP, PL_savestack_ix);
+    cx_pushloop_given(cx, origsv);
 
     RETURN;
 }
@@ -4613,7 +4613,7 @@ PP(pp_leavegiven)
     PERL_UNUSED_CONTEXT;
 
     cx = CX_CUR();
-    assert(CxTYPE(cx) == CXt_GIVEN);
+    assert(CxTYPE(cx) == CXt_LOOP_GIVEN);
     oldsp = PL_stack_base + cx->blk_oldsp;
     gimme = cx->blk_gimme;
 
@@ -4623,7 +4623,7 @@ PP(pp_leavegiven)
         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
 
     CX_LEAVE_SCOPE(cx);
-    cx_popgiven(cx);
+    cx_poploop(cx);
     cx_popblock(cx);
     CX_POP(cx);
 
diff --git a/proto.h b/proto.h
index fd0f145a48..d87aaa77fc 100644
--- a/proto.h
+++ b/proto.h
@@ -3988,11 +3988,6 @@ PERL_STATIC_INLINE void	S_cx_popformat(pTHX_ PERL_CONTEXT *cx);
 	assert(cx)
 #endif
 #ifndef PERL_NO_INLINE_FUNCTIONS
-PERL_STATIC_INLINE void	S_cx_popgiven(pTHX_ PERL_CONTEXT *cx);
-#define PERL_ARGS_ASSERT_CX_POPGIVEN	\
-	assert(cx)
-#endif
-#ifndef PERL_NO_INLINE_FUNCTIONS
 PERL_STATIC_INLINE void	S_cx_poploop(pTHX_ PERL_CONTEXT *cx);
 #define PERL_ARGS_ASSERT_CX_POPLOOP	\
 	assert(cx)
@@ -4033,16 +4028,16 @@ PERL_STATIC_INLINE void	S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *reto
 	assert(cx); assert(cv)
 #endif
 #ifndef PERL_NO_INLINE_FUNCTIONS
-PERL_STATIC_INLINE void	S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv);
-#define PERL_ARGS_ASSERT_CX_PUSHGIVEN	\
-	assert(cx)
-#endif
-#ifndef PERL_NO_INLINE_FUNCTIONS
 PERL_STATIC_INLINE void	S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV *itersave);
 #define PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR	\
 	assert(cx); assert(itervarp)
 #endif
 #ifndef PERL_NO_INLINE_FUNCTIONS
+PERL_STATIC_INLINE void	S_cx_pushloop_given(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv);
+#define PERL_ARGS_ASSERT_CX_PUSHLOOP_GIVEN	\
+	assert(cx)
+#endif
+#ifndef PERL_NO_INLINE_FUNCTIONS
 PERL_STATIC_INLINE void	S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx);
 #define PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN	\
 	assert(cx)
diff --git a/scope.c b/scope.c
index 3fef7a2326..b09a25dbb3 100644
--- a/scope.c
+++ b/scope.c
@@ -1530,6 +1530,7 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
 		PTR2UV(cx->blk_eval.retop));
 	break;
 
+    case CXt_LOOP_GIVEN:
     case CXt_LOOP_PLAIN:
     case CXt_LOOP_LAZYIV:
     case CXt_LOOP_LAZYSV:
@@ -1543,7 +1544,8 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
                     PTR2UV(CxITERVAR(cx)));
             PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%" UVxf "\n",
                     PTR2UV(cx->blk_loop.itersave));
-            /* XXX: not accurate for LAZYSV/IV/LIST */
+	}
+	if (CxTYPE(cx) == CXt_LOOP_ARY) {
             PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%" UVxf "\n",
                     PTR2UV(cx->blk_loop.state_u.ary.ary));
             PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
diff --git a/sv.c b/sv.c
index 33387ee4f3..c589757d55 100644
--- a/sv.c
+++ b/sv.c
@@ -14606,6 +14606,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
                 /* FALLTHROUGH */
 	    case CXt_LOOP_LIST:
 	    case CXt_LOOP_LAZYIV:
+	    case CXt_LOOP_GIVEN:
                 /* code common to all 'for' CXt_LOOP_* types */
 		ncx->blk_loop.itersave =
                                     sv_dup_inc(ncx->blk_loop.itersave, param);
@@ -14638,10 +14639,6 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
 		ncx->blk_format.dfoutgv	= gv_dup_inc(ncx->blk_format.dfoutgv,
 						     param);
 		break;
-	    case CXt_GIVEN:
-		ncx->blk_loop.itersave =
-                                sv_dup_inc(ncx->blk_loop.itersave, param);
-		break;
 	    case CXt_BLOCK:
 	    case CXt_NULL:
 	    case CXt_WHEN:
diff --git a/t/op/given.t b/t/op/given.t
index ff7ee75363..1187171fc3 100644
--- a/t/op/given.t
+++ b/t/op/given.t
@@ -10,7 +10,7 @@ use strict;
 use warnings;
 no warnings 'experimental::smartmatch';
 
-plan tests => 39;
+plan tests => 55;
 
 CORE::given(3) {
     pass "CORE::given without feature flag";
@@ -131,4 +131,108 @@ given(()) {
     is \$_, \undef, "stub topic identity";
 }
 
+foreach my $test (
+    [ "no", "[aA][bB][cB][dA]" ],
+    [ "last", "[aA][bB][dA]" ],
+    [ "next", "[aA][bB][dA]" ],
+    [ "redo", "[aA][bB][bB][cB][dA]" ],
+) {
+    my($loopex, $expect_act) = @$test;
+    my $act = "";
+    my $i = 0;
+    {
+	local $_ = "A";
+	$act .= "[a$_]";
+	given("B") {
+	    $act .= "[b$_]";
+	    $i++;
+	    if($i < 2) {
+		if($loopex eq "last") {
+		    last;
+		} elsif($loopex eq "next") {
+		    next;
+		} elsif($loopex eq "redo") {
+		    redo;
+		}
+	    }
+	    $act .= "[c$_]";
+	}
+	$act .= "[d$_]";
+    }
+    is $act, $expect_act, "given unlabelled $loopex loop exit";
+    $act = "";
+    $i = 0;
+    {
+	local $_ = "A";
+	$act .= "[a$_]";
+	G: given("B") {
+	    $act .= "[b$_]";
+	    {
+		$i++;
+		if($i < 2) {
+		    if($loopex eq "last") {
+			last G;
+		    } elsif($loopex eq "next") {
+			next G;
+		    } elsif($loopex eq "redo") {
+			redo G;
+		    }
+		}
+	    }
+	    $act .= "[c$_]";
+	}
+	$act .= "[d$_]";
+    }
+    is $act, $expect_act, "given labelled $loopex loop exit";
+    $act = "";
+    $i = 0;
+    {
+	local $_ = "A";
+	$act .= "[a$_]";
+	given("B") {
+	    $act .= "[b$_]";
+	    {
+		$i++;
+		if($i < 2) {
+		    if($loopex eq "last") {
+			last;
+		    } elsif($loopex eq "next") {
+			next;
+		    } elsif($loopex eq "redo") {
+			redo;
+		    }
+		}
+	    }
+	    $act .= "[c$_]";
+	}
+	$act .= "[d$_]";
+    }
+    is $act, "[aA][bB][cB][dA]", "interior $loopex loop exit";
+    $act = "";
+    $i = 0;
+    {
+	local $_ = "A";
+	$act .= "[a$_]";
+	B: {
+	    local $_ = "B";
+	    $act .= "[b$_]";
+	    given("C") {
+		$i++;
+		if($i < 2) {
+		    if($loopex eq "last") {
+			last B;
+		    } elsif($loopex eq "next") {
+			next B;
+		    } elsif($loopex eq "redo") {
+			redo B;
+		    }
+		}
+	    }
+	    $act .= "[c$_]";
+	}
+	$act .= "[d$_]";
+    }
+    is $act, $expect_act, "exterior $loopex loop exit";
+}
+
 1;
diff --git a/t/op/switch.t b/t/op/switch.t
index 11372df4c6..5fdda90f42 100644
--- a/t/op/switch.t
+++ b/t/op/switch.t
@@ -10,7 +10,7 @@ use strict;
 use warnings;
 no warnings 'experimental::smartmatch';
 
-plan tests => 166;
+plan tests => 164;
 
 # The behaviour of the feature pragma should be tested by lib/feature.t
 # using the tests in t/lib/feature/*. This file tests the behaviour of
@@ -737,16 +737,6 @@ sub contains_x {
 my $letter;
 
 $letter = '';
-for ("a".."e") {
-    given ($_) {
-	$letter = $_;
-	when ($_ eq "b") { last }
-    }
-    $letter = "z";
-}
-is($letter, "b", "last in when");
-
-$letter = '';
 LETTER1: for ("a".."e") {
     given ($_) {
 	$letter = $_;
@@ -757,16 +747,6 @@ LETTER1: for ("a".."e") {
 is($letter, "b", "last LABEL in when");
 
 $letter = '';
-for ("a".."e") {
-    given ($_) {
-	when (/b|d/) { next }
-	$letter .= $_;
-    }
-    $letter .= ',';
-}
-is($letter, "a,c,e,", "next in when");
-
-$letter = '';
 LETTER2: for ("a".."e") {
     given ($_) {
 	when (/b|d/) { next LETTER2 }
@@ -910,11 +890,11 @@ GIVEN5:
 {
     # Switch control
     my @exp = ('6 7', '', '6 7');
-    for (0, 1, 2, 3) {
+    F: for (0, 1, 2, 3) {
 	my @list = do { given ($_) {
 	    continue when $_ <= 1;
 	    break    when $_ == 1;
-	    next     when $_ == 2;
+	    next F   when $_ == 2;
 	    6, 7;
 	} };
 	is("@list", shift(@exp), "rvalue given - default list [$_]");