This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
sort(!) out CXt_NULL and CXp_MULTICALL
authorDavid Mitchell <davem@iabyn.com>
Thu, 15 Oct 2015 10:16:14 +0000 (11:16 +0100)
committerDavid Mitchell <davem@iabyn.com>
Wed, 3 Feb 2016 08:59:42 +0000 (08:59 +0000)
A sort BLOCK is done using a CXt_NULL context type. Currently it has
the CXp_MULTICALL flag set. Remove this flag so that CXp_MULTICALL is
only set on CXt_SUB contexts.

Also add code comments in various places explainging that CXt_NULL is
likely to a sort BLOCK, and fix the comments in pp_return which said
a particular code path was only taken by sort BLOCK; it's also taken
be (?{...}) too.

cop.h
pp_ctl.c
pp_sort.c
sv.c
t/re/re_tests

diff --git a/cop.h b/cop.h
index 806f72c..c3fad65 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -945,7 +945,7 @@ struct block {
         /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
          * and leaves a CX entry lying around for repeated use, so
          * skip for multicall */                  \
-        assert(CxMULTICALL(cx) ||                                       \
+        assert((CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx)) ||            \
             PL_savestack_ix == cx->cx_u.cx_blk.blku_old_savestack_ix);  \
        PL_curpm         = cx->blk_oldpm;
 
@@ -1028,7 +1028,7 @@ struct context {
 /* If you re-order these, there is also an array of uppercase names in perl.h
    and a static array of context names in pp_ctl.c  */
 #define CXTYPEMASK     0xf
-#define CXt_NULL       0
+#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
@@ -1047,14 +1047,9 @@ struct context {
 #define CXt_SUBST      11
 /* SUBST doesn't feature in all switch statements.  */
 
-/* private flags for CXt_SUB and CXt_NULL
-   However, this is checked in many places which do not check the type, so
-   this bit needs to be kept clear for most everything else. For reasons I
-   haven't investigated, it can coexist with CXp_FOR_DEF */
-#define CXp_MULTICALL  0x10    /* part of a multicall (so don't
-                                  tear down context on exit). */ 
-
 /* private flags for CXt_SUB and CXt_FORMAT */
+#define CXp_MULTICALL  0x10    /* part of a multicall (so don't tear down
+                                   context on exit). (not CXt_FORMAT) */
 #define CXp_HASARGS    0x20
 #define CXp_SUB_RE     0x40    /* code called within regex, i.e. (?{}) */
 #define CXp_SUB_RE_FAKE        0x80    /* fake sub CX for (?{}) in current scope */
@@ -1075,8 +1070,7 @@ struct context {
 
 #define CxTYPE(c)      ((c)->cx_type & CXTYPEMASK)
 #define CxTYPE_is_LOOP(c)      (((c)->cx_type & 0xC) == 0x4)
-#define CxMULTICALL(c) (((c)->cx_type & CXp_MULTICALL)                 \
-                        == CXp_MULTICALL)
+#define CxMULTICALL(c) ((c)->cx_type & CXp_MULTICALL)
 #define CxREALEVAL(c)  (((c)->cx_type & (CXTYPEMASK|CXp_REAL))         \
                         == (CXt_EVAL|CXp_REAL))
 #define CxTRYBLOCK(c)  (((c)->cx_type & (CXTYPEMASK|CXp_TRYBLOCK))     \
@@ -1339,7 +1333,7 @@ See L<perlcall/LIGHTWEIGHT CALLBACKS>.
        CV * const cv = _nOnclAshIngNamE_;                              \
        PADLIST * const padlist = CvPADLIST(cv);                        \
        cx = &cxstack[cxstack_ix];                                      \
-       assert(cx->cx_type & CXp_MULTICALL);                            \
+       assert(CxMULTICALL(cx));                                        \
        CvDEPTH(multicall_cv) = cx->blk_sub.olddepth;                   \
         SvREFCNT_dec_NN(multicall_cv);                                  \
        cx->cx_type = (CXt_SUB|CXp_MULTICALL|flags);                    \
index f8127f3..1f91532 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1291,7 +1291,7 @@ S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
            /* diag_listed_as: Exiting subroutine via %s */
            Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
                           context_name[CxTYPE(cx)], OP_NAME(PL_op));
-           if (CxTYPE(cx) == CXt_NULL)
+           if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
                return -1;
            break;
        case CXt_LOOP_LAZYIV:
@@ -1438,7 +1438,7 @@ S_dopoptoloop(pTHX_ I32 startingblock)
            /* diag_listed_as: Exiting subroutine via %s */
            Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
                           context_name[CxTYPE(cx)], OP_NAME(PL_op));
-           if ((CxTYPE(cx)) == CXt_NULL)
+           if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
                return -1;
            break;
        case CXt_LOOP_LAZYIV:
@@ -2412,10 +2412,19 @@ PP(pp_return)
     assert(cxstack_ix >= 0);
     if (cxix < cxstack_ix) {
         if (cxix < 0) {
-            if (!CxMULTICALL(cxstack))
+            if (!(       PL_curstackinfo->si_type == PERLSI_SORT
+                  || (   PL_curstackinfo->si_type == PERLSI_MULTICALL
+                      && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
+                 )
+            )
                 DIE(aTHX_ "Can't return outside a subroutine");
-            /* We must be in a sort block, which is a CXt_NULL not a
-             * CXt_SUB. Handle specially. */
+            /* We must be in:
+             *  a sort block, which is a CXt_NULL not a CXt_SUB;
+             *  or a /(?{...})/ block.
+             * Handle specially. */
+            assert(CxTYPE(&cxstack[0]) == CXt_NULL
+                    || (   CxTYPE(&cxstack[0]) == CXt_SUB
+                        && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
             if (cxstack_ix > 0) {
                 /* See comment below about context popping. Since we know
                  * we're scalar and not lvalue, we can preserve the return
index 5cab129..706e2d6 100644 (file)
--- a/pp_sort.c
+++ b/pp_sort.c
@@ -1670,7 +1670,7 @@ PP(pp_sort)
             gimme = G_SCALAR;
            PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
            if (!(flags & OPf_SPECIAL)) {
-               cx->cx_type = CXt_SUB;
+               cx->cx_type = CXt_SUB|CXp_MULTICALL;
                PUSHSUB(cx);
                if (!is_xsub) {
                    PADLIST * const padlist = CvPADLIST(cv);
@@ -1692,15 +1692,12 @@ PP(pp_sort)
                }
            }
             else {
-                /* mimic PUSHSUB. Note that we're cheating and using a
-                 * CXt_NULL block as a CXt_SUB block */
+                /* /sort BLOCK: CXt_NULL */
                 cx->cx_u.cx_blk.blku_old_tmpsfloor = PL_tmps_floor;
                 PL_tmps_floor = PL_tmps_ix;
             }
             cx->cx_u.cx_blk.blku_old_savestack_ix = old_savestack_ix;
 
-           cx->cx_type |= CXp_MULTICALL;
-           
            start = p1 - max;
            sortsvp(aTHX_ start, max,
                    (is_xsub ? S_sortcv_xsub : hasargs ? S_sortcv_stacked : S_sortcv),
diff --git a/sv.c b/sv.c
index 87c48ac..558ecd5 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -16292,13 +16292,10 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv)
                sv_insert(varname, 0, 0, " ", 1);
        }
     }
-    else if (PL_curstackinfo->si_type == PERLSI_SORT
-             &&  CxMULTICALL(&cxstack[cxstack_ix]))
-    {
+    else if (PL_curstackinfo->si_type == PERLSI_SORT && cxstack_ix == 0)
         /* we've reached the end of a sort block or sub,
          * and the uninit value is probably what that code returned */
         desc = "sort";
-    }
 
     /* PL_warn_uninit_sv is constant */
     GCC_DIAG_IGNORE(-Wformat-nonliteral);
index f40ac6f..b226123 100644 (file)
@@ -1756,6 +1756,12 @@ ab[c\\\](??{"x"})]{3}d   ab\\](d y       -       -
 ^(A)((?(?{return 1})abc|xyz))$ Aabc    y       $1-$2   A-abc   -
 ^(A)((?(?{return 0})abc|xyz))$ Axyz    y       $1-$2   A-xyz   -
 
+# using 'return' in code blocks with additional scopes to pop
+^(A)(?{ { 1; return "xyz"} })B$        AB      y       $1-$^R  A-xyz   -
+^(A)((??{ { 1; return "xyz" } }))$     Axyz    y       $1-$2   A-xyz   -
+^(A)((?(?{ { 1; return 1 } })abc|xyz))$        Aabc    y       $1-$2   A-abc   -
+^(A)((?(?{ { 1; return 0 } })abc|xyz))$        Axyz    y       $1-$2   A-xyz   -
+
 # pattern modifier flags should propagate into returned (??{}) pattern
 # p,d,l not tested