Revert "switch removal: remove given/when/break/continue"

This reverts commit dff5181.

Author: tonycoz

MANIFEST

@@ -6131,6 +6131,7 @@ t/lib/feature/multidimensional		Tests for enabling/disabling $foo{$x, $y} => $fo
 t/lib/feature/nonesuch			Tests for enabling/disabling nonexistent feature
 t/lib/feature/removed			Tests for enabling/disabling removed feature
 t/lib/feature/say			Tests for enabling/disabling say feature
+t/lib/feature/switch			Tests for enabling/disabling switch feature
 t/lib/h2ph.h				Test header file for h2ph
 t/lib/h2ph.pht				Generated output from h2ph.h by h2ph, for comparison
 t/lib/locale/latin1			Part of locale.t in Latin 1
@@ -6456,6 +6457,7 @@ t/op/substr_thr.t			See if substr works in another thread
 t/op/svflags.t				See if POK is set as expected.
 t/op/svleak.pl				Test file for svleak.t
 t/op/svleak.t				See if stuff leaks SVs
+t/op/switch.t				See if switches (given/when) work
 t/op/symbolcache.t			See if undef/delete works on stashes with functions
 t/op/sysio.t				See if sysread and syswrite work
 t/op/taint.t				See if tainting works

cop.h

@@ -1127,21 +1127,27 @@ struct context {
    and a static array of context names in pp_ctl.c  */
 #define CXTYPEMASK	0xf
 #define CXt_NULL	0 /* currently only used for sort BLOCK */
-#define CXt_BLOCK	1
+#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,
  * CxFOREACH compare ranges */
-#define CXt_LOOP_ARY	2 /* for (@ary)     { ...; } */
-#define CXt_LOOP_LAZYSV	3 /* for ('a'..'z') { ...; } */
-#define CXt_LOOP_LAZYIV	4 /* for (1..9)     { ...; } */
-#define CXt_LOOP_LIST	5 /* for (1,2,3)    { ...; } */
-#define CXt_LOOP_PLAIN	6 /* while (...)    { ...; }
+#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_LIST	7 /* for (1,2,3)    { ...; } */
+#define CXt_LOOP_PLAIN	8 /* while (...)    { ...; }
                              or plain block { ...; } */
-#define CXt_SUB		7
-#define CXt_FORMAT      8
-#define CXt_EVAL        9 /* eval'', eval{}, try{} */
-#define CXt_SUBST      10
-#define CXt_DEFER      11
+#define CXt_SUB		9
+#define CXt_FORMAT     10
+#define CXt_EVAL       11 /* eval'', eval{}, try{} */
+#define CXt_SUBST      12
+#define CXt_DEFER      13
 /* SUBST doesn't feature in all switch statements.  */
 
 /* private flags for CXt_SUB and CXt_FORMAT */

dump.c

@@ -1448,6 +1448,8 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
     case OP_DORASSIGN:
     case OP_ANDASSIGN:
     case OP_ARGDEFELEM:
+    case OP_ENTERGIVEN:
+    case OP_ENTERWHEN:
     case OP_ENTERTRY:
     case OP_ONCE:
         S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");

embed.fnc

@@ -2213,6 +2213,9 @@ ARdp	|OP *	|newFOROP	|I32 flags				\
 				|NN OP *expr				\
 				|NULLOK OP *block			\
 				|NULLOK OP *cont
+ARdp	|OP *	|newGIVENOP	|NN OP *cond				\
+				|NN OP *block				\
+				|PADOFFSET defsv_off
 : Used in scope.c
 eopx	|GP *	|newGP		|NN GV * const gv
 Adm	|GV *	|newGVgen	|NN const char *pack
@@ -2357,6 +2360,8 @@ ERXopx	|char * |new_warnings_bitfield					\
 				|NULLOK char *buffer			\
 				|NN const char * const bits		\
 				|STRLEN size
+ARdp	|OP *	|newWHENOP	|NULLOK OP *cond			\
+				|NN OP *block
 ARdp	|OP *	|newWHILEOP	|I32 flags				\
 				|I32 debuggable 			\
 				|NULLOK LOOP *loop			\
@@ -4861,6 +4866,7 @@ RST	|bool	|is_handle_constructor					\
 Ti	|bool	|is_standard_filehandle_name				\
 				|NN const char *fhname
 S	|OP *	|listkids	|NULLOK OP *o
+S	|bool	|looks_like_bool|NN const OP *o
 S	|OP *	|modkids	|NULLOK OP *o				\
 				|I32 type
 S	|void	|move_proto_attr|NN OP **proto				\
@@ -4870,6 +4876,11 @@ S	|void	|move_proto_attr|NN OP **proto				\
 S	|OP *	|my_kid 	|NULLOK OP *o				\
 				|NULLOK OP *attrs			\
 				|NN OP **imopsp
+S	|OP *	|newGIVWHENOP	|NULLOK OP *cond			\
+				|NN OP *block				\
+				|I32 enter_opcode			\
+				|I32 leave_opcode			\
+				|PADOFFSET entertarg
 RS	|OP *	|new_logop	|I32 type				\
 				|I32 flags				\
 				|NN OP **firstp 			\
@@ -5087,12 +5098,14 @@ RS	|OP *	|dofindlabel	|NN OP *o				\
 				|NN OP **oplimit
 S	|MAGIC *|doparseform	|NN SV *sv
 RS	|I32	|dopoptoeval	|I32 startingblock
+RS	|I32	|dopoptogivenfor|I32 startingblock
 RS	|I32	|dopoptolabel	|NN const char *label			\
 				|STRLEN len				\
 				|U32 flags
 RS	|I32	|dopoptoloop	|I32 startingblock
 RS	|I32	|dopoptosub_at	|NN const PERL_CONTEXT *cxstk		\
 				|I32 startingblock
+RS	|I32	|dopoptowhen	|I32 startingblock
 S	|OP *	|do_smartmatch	|NULLOK HV *seen_this			\
 				|NULLOK HV *seen_other			\
 				|const bool copied
@@ -6204,11 +6217,13 @@ CTp	|Malloc_t|mem_log_realloc					\
 Cipx	|void	|cx_popblock	|NN PERL_CONTEXT *cx
 Cipx	|void	|cx_popeval	|NN PERL_CONTEXT *cx
 Cipx	|void	|cx_popformat	|NN PERL_CONTEXT *cx
+Cipx	|void	|cx_popgiven	|NN PERL_CONTEXT *cx
 Cipx	|void	|cx_poploop	|NN PERL_CONTEXT *cx
 Cipx	|void	|cx_popsub	|NN PERL_CONTEXT *cx
 Cipx	|void	|cx_popsub_args |NN PERL_CONTEXT *cx
 Cipx	|void	|cx_popsub_common					\
 				|NN PERL_CONTEXT *cx
+Cipx	|void	|cx_popwhen	|NN PERL_CONTEXT *cx
 Cipx	|PERL_CONTEXT *|cx_pushblock					\
 				|U8 type				\
 				|U8 gimme				\
@@ -6221,6 +6236,8 @@ Cipx	|void	|cx_pushformat	|NN PERL_CONTEXT *cx			\
 				|NN CV *cv				\
 				|NULLOK OP *retop			\
 				|NULLOK GV *gv
+Cipx	|void	|cx_pushgiven	|NN PERL_CONTEXT *cx			\
+				|NULLOK SV *orig_defsv
 Cipx	|void	|cx_pushloop_for|NN PERL_CONTEXT *cx			\
 				|NN void *itervarp			\
 				|NULLOK SV *itersave
@@ -6232,6 +6249,7 @@ Cipx	|void	|cx_pushsub	|NN PERL_CONTEXT *cx			\
 				|bool hasargs
 Cipx	|void	|cx_pushtry	|NN PERL_CONTEXT *cx			\
 				|NULLOK OP *retop
+Cipx	|void	|cx_pushwhen	|NN PERL_CONTEXT *cx
 Cipx	|void	|cx_topblock	|NN PERL_CONTEXT *cx
 Cipx	|U8	|gimme_V
 #endif /* !defined(PERL_NO_INLINE_FUNCTIONS) */

embed.h

@@ -425,6 +425,7 @@
 # define newDEFSVOP()                           Perl_newDEFSVOP(aTHX)
 # define newFORM(a,b,c)                         Perl_newFORM(aTHX_ a,b,c)
 # define newFOROP(a,b,c,d,e)                    Perl_newFOROP(aTHX_ a,b,c,d,e)
+# define newGIVENOP(a,b,c)                      Perl_newGIVENOP(aTHX_ a,b,c)
 # define newGVOP(a,b,c)                         Perl_newGVOP(aTHX_ a,b,c)
 # define newGVREF(a,b)                          Perl_newGVREF(aTHX_ a,b)
 # define newGVgen_flags(a,b)                    Perl_newGVgen_flags(aTHX_ a,b)
@@ -480,6 +481,7 @@
 # define newTRYCATCHOP(a,b,c,d)                 Perl_newTRYCATCHOP(aTHX_ a,b,c,d)
 # define newUNOP(a,b,c)                         Perl_newUNOP(aTHX_ a,b,c)
 # define newUNOP_AUX(a,b,c,d)                   Perl_newUNOP_AUX(aTHX_ a,b,c,d)
+# define newWHENOP(a,b)                         Perl_newWHENOP(aTHX_ a,b)
 # define newWHILEOP(a,b,c,d,e,f,g)              Perl_newWHILEOP(aTHX_ a,b,c,d,e,f,g)
 # define newXS(a,b,c)                           Perl_newXS(aTHX_ a,b,c)
 # define newXS_flags(a,b,c,d,e)                 Perl_newXS_flags(aTHX_ a,b,c,d,e)
@@ -1546,9 +1548,11 @@
 #     define is_handle_constructor              S_is_handle_constructor
 #     define is_standard_filehandle_name        S_is_standard_filehandle_name
 #     define listkids(a)                        S_listkids(aTHX_ a)
+#     define looks_like_bool(a)                 S_looks_like_bool(aTHX_ a)
 #     define modkids(a,b)                       S_modkids(aTHX_ a,b)
 #     define move_proto_attr(a,b,c,d)           S_move_proto_attr(aTHX_ a,b,c,d)
 #     define my_kid(a,b,c)                      S_my_kid(aTHX_ a,b,c)
+#     define newGIVWHENOP(a,b,c,d,e)            S_newGIVWHENOP(aTHX_ a,b,c,d,e)
 #     define newMETHOP_internal(a,b,c,d)        S_newMETHOP_internal(aTHX_ a,b,c,d)
 #     define new_logop(a,b,c,d)                 S_new_logop(aTHX_ a,b,c,d)
 #     define no_fh_allowed(a)                   S_no_fh_allowed(aTHX_ a)
@@ -1640,9 +1644,11 @@
 #     define dofindlabel(a,b,c,d,e,f)           S_dofindlabel(aTHX_ a,b,c,d,e,f)
 #     define doparseform(a)                     S_doparseform(aTHX_ a)
 #     define dopoptoeval(a)                     S_dopoptoeval(aTHX_ a)
+#     define dopoptogivenfor(a)                 S_dopoptogivenfor(aTHX_ a)
 #     define dopoptolabel(a,b,c)                S_dopoptolabel(aTHX_ a,b,c)
 #     define dopoptoloop(a)                     S_dopoptoloop(aTHX_ a)
 #     define dopoptosub_at(a,b)                 S_dopoptosub_at(aTHX_ a,b)
+#     define dopoptowhen(a)                     S_dopoptowhen(aTHX_ a)
 #     define make_matcher(a)                    S_make_matcher(aTHX_ a)
 #     define matcher_matches_sv(a,b)            S_matcher_matches_sv(aTHX_ a,b)
 #     define num_overflow                       S_num_overflow
@@ -2229,17 +2235,21 @@
 #   define cx_popblock(a)                       Perl_cx_popblock(aTHX_ a)
 #   define cx_popeval(a)                        Perl_cx_popeval(aTHX_ a)
 #   define cx_popformat(a)                      Perl_cx_popformat(aTHX_ a)
+#   define cx_popgiven(a)                       Perl_cx_popgiven(aTHX_ a)
 #   define cx_poploop(a)                        Perl_cx_poploop(aTHX_ a)
 #   define cx_popsub(a)                         Perl_cx_popsub(aTHX_ a)
 #   define cx_popsub_args(a)                    Perl_cx_popsub_args(aTHX_ a)
 #   define cx_popsub_common(a)                  Perl_cx_popsub_common(aTHX_ a)
+#   define cx_popwhen(a)                        Perl_cx_popwhen(aTHX_ a)
 #   define cx_pushblock(a,b,c,d)                Perl_cx_pushblock(aTHX_ a,b,c,d)
 #   define cx_pusheval(a,b,c)                   Perl_cx_pusheval(aTHX_ a,b,c)
 #   define cx_pushformat(a,b,c,d)               Perl_cx_pushformat(aTHX_ a,b,c,d)
+#   define cx_pushgiven(a,b)                    Perl_cx_pushgiven(aTHX_ a,b)
 #   define cx_pushloop_for(a,b,c)               Perl_cx_pushloop_for(aTHX_ a,b,c)
 #   define cx_pushloop_plain(a)                 Perl_cx_pushloop_plain(aTHX_ a)
 #   define cx_pushsub(a,b,c,d)                  Perl_cx_pushsub(aTHX_ a,b,c,d)
 #   define cx_pushtry(a,b)                      Perl_cx_pushtry(aTHX_ a,b)
+#   define cx_pushwhen(a)                       Perl_cx_pushwhen(aTHX_ a)
 #   define cx_topblock(a)                       Perl_cx_topblock(aTHX_ a)
 #   define gimme_V()                            Perl_gimme_V(aTHX)
 # endif /* !defined(PERL_NO_INLINE_FUNCTIONS) */

ext/Opcode/Opcode.pm

@@ -1,4 +1,4 @@
-package Opcode 1.68;
+package Opcode 1.69;
 
 use strict;
 
@@ -436,6 +436,9 @@ These are a hotchpotch of opcodes still waiting to be considered
     entertry leavetry -- can be used to 'hide' fatal errors
     entertrycatch poptry catch leavetrycatch -- similar
 
+    entergiven leavegiven
+    enterwhen leavewhen
+    break continue
     smartmatch
 
     pushdefer

gv.c

@@ -612,12 +612,12 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
     case KEY_DESTROY : case KEY_END     : case KEY_INIT  : case KEY_UNITCHECK:
     case KEY_all     : case KEY_and     : case KEY_any   :
     case KEY_catch   : case KEY_class   :
-    case KEY_continue: case KEY_cmp     : case KEY_defer :
+    case KEY_cmp     : case KEY_default : case KEY_defer :
     case KEY_do      : case KEY_dump   : case KEY_else  : case KEY_elsif  :
     case KEY_eq     : case KEY_eval  : case KEY_field  :
     case KEY_finally:
     case KEY_for     : case KEY_foreach: case KEY_format: case KEY_ge     :
-    case KEY_goto   : case KEY_grep  : case KEY_gt     :
+    case KEY_given   : case KEY_goto   : case KEY_grep  : case KEY_gt     :
     case KEY_if      : case KEY_isa    : 
     case KEY_last   :
     case KEY_le      : case KEY_local  : case KEY_lt    : case KEY_m      :
@@ -630,7 +630,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
     case KEY_state: case KEY_sub  :
     case KEY_tr   : case KEY_try  :
     case KEY_unless:
-    case KEY_until: case KEY_use  : case KEY_while :
+    case KEY_until: case KEY_use  : case KEY_when     : case KEY_while :
     case KEY_x    : case KEY_xor  : case KEY_y        :
         return NULL;
     case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:

inline.h

@@ -3791,6 +3791,52 @@ Perl_cx_poploop(pTHX_ PERL_CONTEXT *cx)
 }
 
 
+PERL_STATIC_INLINE void
+Perl_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
+{
+    PERL_ARGS_ASSERT_CX_PUSHWHEN;
+
+    cx->blk_givwhen.leave_op = cLOGOP->op_other;
+}
+
+
+PERL_STATIC_INLINE void
+Perl_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
+{
+    PERL_ARGS_ASSERT_CX_POPWHEN;
+    assert(CxTYPE(cx) == CXt_WHEN);
+
+    PERL_UNUSED_ARG(cx);
+    PERL_UNUSED_CONTEXT;
+    /* currently NOOP */
+}
+
+
+PERL_STATIC_INLINE void
+Perl_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
+{
+    PERL_ARGS_ASSERT_CX_PUSHGIVEN;
+
+    cx->blk_givwhen.leave_op = cLOGOP->op_other;
+    cx->blk_givwhen.defsv_save = orig_defsv;
+}
+
+
+PERL_STATIC_INLINE void
+Perl_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_givwhen.defsv_save;
+    cx->blk_givwhen.defsv_save = NULL;
+    SvREFCNT_dec(sv);
+}
+
+
 /* Make @_ empty in-place in simple cases: a cheap av_clear().
  * See Perl_clear_defarray() for non-simple cases */