make loop control apply to "given"

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

diff --git a/cop.h b/cop.h
index c26fc18..37895e6 100644 (file)
--- 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
 #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 */
  * 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)     { ...; } */
 #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 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))         \
                            && 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 dc4e6fc..82e8370 100644 (file)
--- 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_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_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
 #endif
 
 #ifdef USE_DTRACE

diff --git a/embed.h b/embed.h
index e0362ef..5e82a0f 100644 (file)
--- 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_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)
 #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_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_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)
 #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 8c28d98..30d6955 100644 (file)
--- 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
 /* 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 ------------------------------------------- */
 
 /*
 /* ------------------ util.h ------------------------------------------- */
 
 /*

diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 0f88ba4..727a6cd 100644 (file)
--- 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.
 
 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.
 
 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.
 
 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.
 
 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.
 
 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.
 
 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 cb12a35..480b352 100644 (file)
--- 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
 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.
 
 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 *
 
 
 =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 *
 
 
 =item *
 

diff --git a/pp_ctl.c b/pp_ctl.c
index 1ab2eea..de7ac58 100644 (file)
--- 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" */
     "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" */
     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;
            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:
        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;
            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:
        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;
        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:
            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_EVAL:
            cx_popeval(cx);
            break;

+       case CXt_LOOP_GIVEN:

        case CXt_LOOP_PLAIN:
        case CXt_LOOP_LAZYIV:
        case CXt_LOOP_LAZYSV:
        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_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() */
        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_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;
            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);
 
     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;
 }
 
     RETURN;
 }


@@ -4613,7 +4613,7 @@ PP(pp_leavegiven)
     PERL_UNUSED_CONTEXT;
 
     cx = CX_CUR();
     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;
 
     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);
         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
 
     CX_LEAVE_SCOPE(cx);

-    cx_popgiven(cx);
+    cx_poploop(cx);

     cx_popblock(cx);
     CX_POP(cx);
 
     cx_popblock(cx);
     CX_POP(cx);
 

diff --git a/proto.h b/proto.h
index fd0f145..d87aaa7 100644 (file)
--- 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
        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)
 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
        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_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)
 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 3fef7a2..b09a25d 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -1530,6 +1530,7 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
                PTR2UV(cx->blk_eval.retop));
        break;
 
                PTR2UV(cx->blk_eval.retop));
        break;
 

+    case CXt_LOOP_GIVEN:

     case CXt_LOOP_PLAIN:
     case CXt_LOOP_LAZYIV:
     case CXt_LOOP_LAZYSV:
     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));
                     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",
             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 33387ee..c589757 100644 (file)
--- 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:
                 /* 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);
                 /* 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;
                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:
            case CXt_BLOCK:
            case CXt_NULL:
            case CXt_WHEN:

diff --git a/t/op/given.t b/t/op/given.t
index ff7ee75..1187171 100644 (file)
--- a/t/op/given.t
+++ b/t/op/given.t
@@ -10,7 +10,7 @@ use strict;
 use warnings;
 no warnings 'experimental::smartmatch';
 
 use warnings;
 no warnings 'experimental::smartmatch';
 

-plan tests => 39;
+plan tests => 55;

 
 CORE::given(3) {
     pass "CORE::given without feature flag";
 
 CORE::given(3) {
     pass "CORE::given without feature flag";


@@ -131,4 +131,108 @@ given(()) {
     is \$_, \undef, "stub topic identity";
 }
 
     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;
 1;

diff --git a/t/op/switch.t b/t/op/switch.t
index 11372df..5fdda90 100644 (file)
--- a/t/op/switch.t
+++ b/t/op/switch.t
@@ -10,7 +10,7 @@ use strict;
 use warnings;
 no warnings 'experimental::smartmatch';
 
 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
 
 # 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 = '';
 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 = $_;
 LETTER1: for ("a".."e") {
     given ($_) {
        $letter = $_;


@@ -757,16 +747,6 @@ LETTER1: for ("a".."e") {
 is($letter, "b", "last LABEL in when");
 
 $letter = '';
 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 }
 LETTER2: for ("a".."e") {
     given ($_) {
        when (/b|d/) { next LETTER2 }


@@ -910,11 +890,11 @@ GIVEN5:
 {
     # Switch control
     my @exp = ('6 7', '', '6 7');
 {
     # 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;
        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 [$_]");
            6, 7;
        } };
        is("@list", shift(@exp), "rvalue given - default list [$_]");