Test CORE::break’s prototype
authorFather Chrysostomos <sprout@cpan.org>
Thu, 25 Aug 2011 05:39:28 +0000 (22:39 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Thu, 25 Aug 2011 05:39:28 +0000 (22:39 -0700)
embed.fnc
embed.h
op.c
proto.h
t/op/cproto.t

index 2ed8f60..636361b 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -623,7 +623,7 @@ p   |OP*    |jmaybe         |NN OP *o
 pP     |I32    |keyword        |NN const char *name|I32 len|bool all_keywords
 #if defined(PERL_IN_OP_C)
 s      |OP*    |opt_scalarhv   |NN OP* rep_op
-s      |OP*    |is_inplace_av  |NN OP* o|NULLOK OP* oright
+s      |void   |inplace_aassign        |NN OP* o
 #endif
 Ap     |void   |leave_scope    |I32 base
 : Public lexer API
diff --git a/embed.h b/embed.h
index 26d1bdb..c20e2b4 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define force_list(a)          S_force_list(aTHX_ a)
 #define gen_constant_list(a)   S_gen_constant_list(aTHX_ a)
 #define gv_ename(a)            S_gv_ename(aTHX_ a)
+#define inplace_aassign(a)     S_inplace_aassign(aTHX_ a)
 #define is_handle_constructor  S_is_handle_constructor
-#define is_inplace_av(a,b)     S_is_inplace_av(aTHX_ a,b)
 #define is_list_assignment(a)  S_is_list_assignment(aTHX_ a)
 #define listkids(a)            S_listkids(aTHX_ a)
 #define looks_like_bool(a)     S_looks_like_bool(aTHX_ a)
diff --git a/op.c b/op.c
index 395b46b..d68389f 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1260,6 +1260,11 @@ Perl_scalarvoid(pTHX_ OP *o)
        break;
     }
 
+    case OP_AASSIGN: {
+       inplace_aassign(o);
+       break;
+    }
+
     case OP_OR:
     case OP_AND:
        kid = cLOGOPo->op_first;
@@ -9599,59 +9604,57 @@ S_opt_scalarhv(pTHX_ OP *rep_op) {
     return (OP*)unop;
 }                        
 
-/* Checks if o acts as an in-place operator on an array. oright points to the
- * beginning of the right-hand side. Returns the left-hand side of the
- * assignment if o acts in-place, or NULL otherwise. */
+/* Check for in place reverse and sort assignments like "@a = reverse @a"
+   and modify the optree to make them work inplace */
 
-STATIC OP *
-S_is_inplace_av(pTHX_ OP *o, OP *oright) {
-    OP *o2;
-    OP *oleft = NULL;
+STATIC void
+S_inplace_aassign(pTHX_ OP *o) {
 
-    PERL_ARGS_ASSERT_IS_INPLACE_AV;
+    OP *modop, *modop_pushmark;
+    OP *oright;
+    OP *oleft, *oleft_pushmark;
 
-    if (!oright ||
-       (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
-       || oright->op_next != o
-       || (oright->op_private & OPpLVAL_INTRO)
-    )
-       return NULL;
+    PERL_ARGS_ASSERT_INPLACE_AASSIGN;
 
-    /* o2 follows the chain of op_nexts through the LHS of the
-     * assign (if any) to the aassign op itself */
-    o2 = o->op_next;
-    if (!o2 || o2->op_type != OP_NULL)
-       return NULL;
-    o2 = o2->op_next;
-    if (!o2 || o2->op_type != OP_PUSHMARK)
-       return NULL;
-    o2 = o2->op_next;
-    if (o2 && o2->op_type == OP_GV)
-       o2 = o2->op_next;
-    if (!o2
-       || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
-       || (o2->op_private & OPpLVAL_INTRO)
-    )
-       return NULL;
-    oleft = o2;
-    o2 = o2->op_next;
-    if (!o2 || o2->op_type != OP_NULL)
-       return NULL;
-    o2 = o2->op_next;
-    if (!o2 || o2->op_type != OP_AASSIGN
-           || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
-       return NULL;
+    assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
 
-    /* check that the sort is the first arg on RHS of assign */
+    assert(cUNOPo->op_first->op_type == OP_NULL);
+    modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
+    assert(modop_pushmark->op_type == OP_PUSHMARK);
+    modop = modop_pushmark->op_sibling;
 
-    o2 = cUNOPx(o2)->op_first;
-    if (!o2 || o2->op_type != OP_NULL)
-       return NULL;
-    o2 = cUNOPx(o2)->op_first;
-    if (!o2 || o2->op_type != OP_PUSHMARK)
-       return NULL;
-    if (o2->op_sibling != o)
-       return NULL;
+    if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
+       return;
+
+    /* no other operation except sort/reverse */
+    if (modop->op_sibling)
+       return;
+
+    assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
+    oright = cUNOPx(modop)->op_first->op_sibling;
+
+    if (modop->op_flags & OPf_STACKED) {
+       /* skip sort subroutine/block */
+       assert(oright->op_type == OP_NULL);
+       oright = oright->op_sibling;
+    }
+
+    assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
+    oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
+    assert(oleft_pushmark->op_type == OP_PUSHMARK);
+    oleft = oleft_pushmark->op_sibling;
+
+    /* Check the lhs is an array */
+    if (!oleft ||
+       (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
+       || oleft->op_sibling
+       || (oleft->op_private & OPpLVAL_INTRO)
+    )
+       return;
+
+    /* Only one thing on the rhs */
+    if (oright->op_sibling)
+       return;
 
     /* check the array is the same on both sides */
     if (oleft->op_type == OP_RV2AV) {
@@ -9661,14 +9664,26 @@ S_is_inplace_av(pTHX_ OP *o, OP *oright) {
            || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
               cGVOPx_gv(cUNOPx(oright)->op_first)
        )
-           return NULL;
+           return;
     }
     else if (oright->op_type != OP_PADAV
        || oright->op_targ != oleft->op_targ
     )
-       return NULL;
+       return;
+
+    /* This actually is an inplace assignment */
 
-    return oleft;
+    modop->op_private |= OPpSORT_INPLACE;
+
+    /* transfer MODishness etc from LHS arg to RHS arg */
+    oright->op_flags = oleft->op_flags;
+
+    /* remove the aassign op and the lhs */
+    op_null(o);
+    op_null(oleft_pushmark);
+    if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
+       op_null(cUNOPx(oleft)->op_first);
+    op_null(oleft);
 }
 
 #define MAX_DEFERRED 4
@@ -9973,15 +9988,14 @@ Perl_rpeep(pTHX_ register OP *o)
            break;
 
        case OP_SORT: {
-           /* will point to RV2AV or PADAV op on LHS/RHS of assign */
-           OP *oleft;
-           OP *o2;
-
            /* check that RHS of sort is a single plain array */
            OP *oright = cUNOPo->op_first;
            if (!oright || oright->op_type != OP_PUSHMARK)
                break;
 
+           if (o->op_private & OPpSORT_INPLACE)
+               break;
+
            /* reverse sort ... can be optimised.  */
            if (!cUNOPo->op_sibling) {
                /* Nothing follows us on the list. */
@@ -10001,72 +10015,16 @@ Perl_rpeep(pTHX_ register OP *o)
                }
            }
 
-           /* make @a = sort @a act in-place */
-
-           oright = cUNOPx(oright)->op_sibling;
-           if (!oright)
-               break;
-           if (oright->op_type == OP_NULL) { /* skip sort block/sub */
-               oright = cUNOPx(oright)->op_sibling;
-           }
-
-           oleft = is_inplace_av(o, oright);
-           if (!oleft)
-               break;
-
-           /* transfer MODishness etc from LHS arg to RHS arg */
-           oright->op_flags = oleft->op_flags;
-           o->op_private |= OPpSORT_INPLACE;
-
-           /* excise push->gv->rv2av->null->aassign */
-           o2 = o->op_next->op_next;
-           op_null(o2); /* PUSHMARK */
-           o2 = o2->op_next;
-           if (o2->op_type == OP_GV) {
-               op_null(o2); /* GV */
-               o2 = o2->op_next;
-           }
-           op_null(o2); /* RV2AV or PADAV */
-           o2 = o2->op_next->op_next;
-           op_null(o2); /* AASSIGN */
-
-           o->op_next = o2->op_next;
-
            break;
        }
 
        case OP_REVERSE: {
            OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
            OP *gvop = NULL;
-           OP *oleft, *oright;
            LISTOP *enter, *exlist;
 
-           /* @a = reverse @a */
-           if ((oright = cLISTOPo->op_first)
-                   && (oright->op_type == OP_PUSHMARK)
-                   && (oright = oright->op_sibling)
-                   && (oleft = is_inplace_av(o, oright))) {
-               OP *o2;
-
-               /* transfer MODishness etc from LHS arg to RHS arg */
-               oright->op_flags = oleft->op_flags;
-               o->op_private |= OPpREVERSE_INPLACE;
-
-               /* excise push->gv->rv2av->null->aassign */
-               o2 = o->op_next->op_next;
-               op_null(o2); /* PUSHMARK */
-               o2 = o2->op_next;
-               if (o2->op_type == OP_GV) {
-                   op_null(o2); /* GV */
-                   o2 = o2->op_next;
-               }
-               op_null(o2); /* RV2AV or PADAV */
-               o2 = o2->op_next->op_next;
-               op_null(o2); /* AASSIGN */
-
-               o->op_next = o2->op_next;
+           if (o->op_private & OPpSORT_INPLACE)
                break;
-           }
 
            enter = (LISTOP *) o->op_next;
            if (!enter)
diff --git a/proto.h b/proto.h
index 7784a7a..73a322d 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5513,17 +5513,17 @@ STATIC const char*      S_gv_ename(pTHX_ GV *gv)
 #define PERL_ARGS_ASSERT_GV_ENAME      \
        assert(gv)
 
+STATIC void    S_inplace_aassign(pTHX_ OP* o)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_INPLACE_AASSIGN       \
+       assert(o)
+
 STATIC bool    S_is_handle_constructor(const OP *o, I32 numargs)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(1);
 #define PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR \
        assert(o)
 
-STATIC OP*     S_is_inplace_av(pTHX_ OP* o, OP* oright)
-                       __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_IS_INPLACE_AV \
-       assert(o)
-
 STATIC I32     S_is_list_assignment(pTHX_ const OP *o)
                        __attribute__warn_unused_result__;
 
index 2c54c0c..c9cfe46 100644 (file)
@@ -7,7 +7,7 @@ BEGIN {
 }
 
 BEGIN { require './test.pl'; }
-plan tests => 244;
+plan tests => 245;
 
 while (<DATA>) {
     chomp;
@@ -41,6 +41,7 @@ atan2 ($$)
 bind (*$)
 binmode (*;$)
 bless ($;$)
+break ()
 caller (;$)
 chdir (;$)
 chmod (@)