op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * Note that during the build of miniperl, a temporary copy of this file
  26  * is made, called opmini.c.
  27  *
  28  * A Perl program is compiled into a tree of OP nodes. Each op contains:
  29  *  * structural OP pointers to its children and siblings (op_sibling,
  30  *    op_first etc) that define the tree structure;
  31  *  * execution order OP pointers (op_next, plus sometimes op_other,
  32  *    op_lastop  etc) that define the execution sequence plus variants;
  33  *  * a pointer to the C "pp" function that would execute the op;
  34  *  * any data specific to that op.
  35  * For example, an OP_CONST op points to the pp_const() function and to an
  36  * SV containing the constant value. When pp_const() is executed, its job
  37  * is to push that SV onto the stack.
  38  *
  39  * OPs are mainly created by the newFOO() functions, which are mainly
  40  * called from the parser (in perly.y) as the code is parsed. For example
  41  * the Perl code $a + $b * $c would cause the equivalent of the following
  42  * to be called (oversimplifying a bit):
  43  *
  44  *  newBINOP(OP_ADD, flags,
  45  *      newSVREF($a),
  46  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  47  *  )
  48  *
  49  * As the parser reduces low-level rules, it creates little op subtrees;
  50  * as higher-level rules are resolved, these subtrees get joined together
  51  * as branches on a bigger subtree, until eventually a top-level rule like
  52  * a subroutine definition is reduced, at which point there is one large
  53  * parse tree left.
  54  *
  55  * The execution order pointers (op_next) are generated as the subtrees
  56  * are joined together. Consider this sub-expression: A*B + C/D: at the
  57  * point when it's just been parsed, the op tree looks like:
  58  *
  59  *   [+]
  60  *    |
  61  *   [*]------[/]
  62  *    |        |
  63  *    A---B    C---D
  64  *
  65  * with the intended execution order being:
  66  *
  67  *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
  68  *
  69  * At this point all the nodes' op_next pointers will have been set,
  70  * except that:
  71  *    * we don't know what the [NEXT] node will be yet;
  72  *    * we don't know what the [PREV] node will be yet, but when it gets
  73  *      created and needs its op_next set, it needs to be set to point to
  74  *      A, which is non-obvious.
  75  * To handle both those cases, we temporarily set the top node's
  76  * op_next to point to the first node to be executed in this subtree (A in
  77  * this case). This means that initially a subtree's op_next chain,
  78  * starting from the top node, will visit each node in execution sequence
  79  * then point back at the top node.
  80  * When we embed this subtree in a larger tree, its top op_next is used
  81  * to get the start node, then is set to point to its new neighbour.
  82  * For example the two separate [*],A,B and [/],C,D subtrees would
  83  * initially have had:
  84  *   [*] => A;  A => B;  B => [*]
  85  * and
  86  *   [/] => C;  C => D;  D => [/]
  87  * When these two subtrees were joined together to make the [+] subtree,
  88  * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
  89  * set to point to [/]'s op_next, i.e. C.
  90  *
  91  * This op_next linking is done by the LINKLIST() macro and its underlying
  92  * op_linklist() function. Given a top-level op, if its op_next is
  93  * non-null, it's already been linked, so leave it. Otherwise link it with
  94  * its children as described above, possibly recursively if any of the
  95  * children have a null op_next.
  96  *
  97  * In summary: given a subtree, its top-level node's op_next will either
  98  * be:
  99  *   NULL: the subtree hasn't been LINKLIST()ed yet;
 100  *   fake: points to the start op for this subtree;
 101  *   real: once the subtree has been embedded into a larger tree
 102  */
 103
 104 /*
 105
 106 Here's an older description from Larry.
 107
 108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
 109
 110     A bottom-up pass
 111     A top-down pass
 112     An execution-order pass
 113
 114 The bottom-up pass is represented by all the "newOP" routines and
 115 the ck_ routines.  The bottom-upness is actually driven by yacc.
 116 So at the point that a ck_ routine fires, we have no idea what the
 117 context is, either upward in the syntax tree, or either forward or
 118 backward in the execution order.  (The bottom-up parser builds that
 119 part of the execution order it knows about, but if you follow the "next"
 120 links around, you'll find it's actually a closed loop through the
 121 top level node.)
 122
 123 Whenever the bottom-up parser gets to a node that supplies context to
 124 its components, it invokes that portion of the top-down pass that applies
 125 to that part of the subtree (and marks the top node as processed, so
 126 if a node further up supplies context, it doesn't have to take the
 127 plunge again).  As a particular subcase of this, as the new node is
 128 built, it takes all the closed execution loops of its subcomponents
 129 and links them into a new closed loop for the higher level node.  But
 130 it's still not the real execution order.
 131
 132 The actual execution order is not known till we get a grammar reduction
 133 to a top-level unit like a subroutine or file that will be called by
 134 "name" rather than via a "next" pointer.  At that point, we can call
 135 into peep() to do that code's portion of the 3rd pass.  It has to be
 136 recursive, but it's recursive on basic blocks, not on tree nodes.
 137 */
 138
 139 /* To implement user lexical pragmas, there needs to be a way at run time to
 140    get the compile time state of %^H for that block.  Storing %^H in every
 141    block (or even COP) would be very expensive, so a different approach is
 142    taken.  The (running) state of %^H is serialised into a tree of HE-like
 143    structs.  Stores into %^H are chained onto the current leaf as a struct
 144    refcounted_he * with the key and the value.  Deletes from %^H are saved
 145    with a value of PL_sv_placeholder.  The state of %^H at any point can be
 146    turned back into a regular HV by walking back up the tree from that point's
 147    leaf, ignoring any key you've already seen (placeholder or not), storing
 148    the rest into the HV structure, then removing the placeholders. Hence
 149    memory is only used to store the %^H deltas from the enclosing COP, rather
 150    than the entire %^H on each COP.
 151
 152    To cause actions on %^H to write out the serialisation records, it has
 153    magic type 'H'. This magic (itself) does nothing, but its presence causes
 154    the values to gain magic type 'h', which has entries for set and clear.
 155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
 156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
 157    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
 158    it will be correctly restored when any inner compiling scope is exited.
 159 */
 160
 161 #include "EXTERN.h"
 162 #define PERL_IN_OP_C
 163 #include "perl.h"
 164 #include "keywords.h"
 165 #include "feature.h"
 166 #include "regcomp.h"
 167
 168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 171
 172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
 173
 174 /* Used to avoid recursion through the op tree in scalarvoid() and
 175    op_free()
 176 */
 177
 178 #define DEFERRED_OP_STEP 100
 179 #define DEFER_OP(o) \
 180   STMT_START { \
 181     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 182         defer_stack_alloc += DEFERRED_OP_STEP; \
 183         assert(defer_stack_alloc > 0); \
 184         Renew(defer_stack, defer_stack_alloc, OP *); \
 185     } \
 186     defer_stack[++defer_ix] = o; \
 187   } STMT_END
 188
 189 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 190
 191 /* remove any leading "empty" ops from the op_next chain whose first
 192  * node's address is stored in op_p. Store the updated address of the
 193  * first node in op_p.
 194  */
 195
 196 STATIC void
 197 S_prune_chain_head(OP** op_p)
 198 {
 199     while (*op_p
 200         && (   (*op_p)->op_type == OP_NULL
 201             || (*op_p)->op_type == OP_SCOPE
 202             || (*op_p)->op_type == OP_SCALAR
 203             || (*op_p)->op_type == OP_LINESEQ)
 204     )
 205         *op_p = (*op_p)->op_next;
 206 }
 207
 208
 209 /* See the explanatory comments above struct opslab in op.h. */
 210
 211 #ifdef PERL_DEBUG_READONLY_OPS
 212 #  define PERL_SLAB_SIZE 128
 213 #  define PERL_MAX_SLAB_SIZE 4096
 214 #  include <sys/mman.h>
 215 #endif
 216
 217 #ifndef PERL_SLAB_SIZE
 218 #  define PERL_SLAB_SIZE 64
 219 #endif
 220 #ifndef PERL_MAX_SLAB_SIZE
 221 #  define PERL_MAX_SLAB_SIZE 2048
 222 #endif
 223
 224 /* rounds up to nearest pointer */
 225 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 226 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 227
 228 static OPSLAB *
 229 S_new_slab(pTHX_ size_t sz)
 230 {
 231 #ifdef PERL_DEBUG_READONLY_OPS
 232     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 233                                    PROT_READ|PROT_WRITE,
 234                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 235     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 236                           (unsigned long) sz, slab));
 237     if (slab == MAP_FAILED) {
 238         perror("mmap failed");
 239         abort();
 240     }
 241     slab->opslab_size = (U16)sz;
 242 #else
 243     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 244 #endif
 245 #ifndef WIN32
 246     /* The context is unused in non-Windows */
 247     PERL_UNUSED_CONTEXT;
 248 #endif
 249     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 250     return slab;
 251 }
 252
 253 /* requires double parens and aTHX_ */
 254 #define DEBUG_S_warn(args)                                             \
 255     DEBUG_S(                                                            \
 256         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 257     )
 258
 259 void *
 260 Perl_Slab_Alloc(pTHX_ size_t sz)
 261 {
 262     OPSLAB *slab;
 263     OPSLAB *slab2;
 264     OPSLOT *slot;
 265     OP *o;
 266     size_t opsz, space;
 267
 268     /* We only allocate ops from the slab during subroutine compilation.
 269        We find the slab via PL_compcv, hence that must be non-NULL. It could
 270        also be pointing to a subroutine which is now fully set up (CvROOT()
 271        pointing to the top of the optree for that sub), or a subroutine
 272        which isn't using the slab allocator. If our sanity checks aren't met,
 273        don't use a slab, but allocate the OP directly from the heap.  */
 274     if (!PL_compcv || CvROOT(PL_compcv)
 275      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 276     {
 277         o = (OP*)PerlMemShared_calloc(1, sz);
 278         goto gotit;
 279     }
 280
 281     /* While the subroutine is under construction, the slabs are accessed via
 282        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 283        unneeded at runtime. Once a subroutine is constructed, the slabs are
 284        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 285        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 286        details.  */
 287     if (!CvSTART(PL_compcv)) {
 288         CvSTART(PL_compcv) =
 289             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 290         CvSLABBED_on(PL_compcv);
 291         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 292     }
 293     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 294
 295     opsz = SIZE_TO_PSIZE(sz);
 296     sz = opsz + OPSLOT_HEADER_P;
 297
 298     /* The slabs maintain a free list of OPs. In particular, constant folding
 299        will free up OPs, so it makes sense to re-use them where possible. A
 300        freed up slot is used in preference to a new allocation.  */
 301     if (slab->opslab_freed) {
 302         OP **too = &slab->opslab_freed;
 303         o = *too;
 304         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 305         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 306             DEBUG_S_warn((aTHX_ "Alas! too small"));
 307             o = *(too = &o->op_next);
 308             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 309         }
 310         if (o) {
 311             *too = o->op_next;
 312             Zero(o, opsz, I32 *);
 313             o->op_slabbed = 1;
 314             goto gotit;
 315         }
 316     }
 317
 318 #define INIT_OPSLOT \
 319             slot->opslot_slab = slab;                   \
 320             slot->opslot_next = slab2->opslab_first;    \
 321             slab2->opslab_first = slot;                 \
 322             o = &slot->opslot_op;                       \
 323             o->op_slabbed = 1
 324
 325     /* The partially-filled slab is next in the chain. */
 326     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 327     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 328         /* Remaining space is too small. */
 329
 330         /* If we can fit a BASEOP, add it to the free chain, so as not
 331            to waste it. */
 332         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 333             slot = &slab2->opslab_slots;
 334             INIT_OPSLOT;
 335             o->op_type = OP_FREED;
 336             o->op_next = slab->opslab_freed;
 337             slab->opslab_freed = o;
 338         }
 339
 340         /* Create a new slab.  Make this one twice as big. */
 341         slot = slab2->opslab_first;
 342         while (slot->opslot_next) slot = slot->opslot_next;
 343         slab2 = S_new_slab(aTHX_
 344                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 345                                         ? PERL_MAX_SLAB_SIZE
 346                                         : (DIFF(slab2, slot)+1)*2);
 347         slab2->opslab_next = slab->opslab_next;
 348         slab->opslab_next = slab2;
 349     }
 350     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 351
 352     /* Create a new op slot */
 353     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 354     assert(slot >= &slab2->opslab_slots);
 355     if (DIFF(&slab2->opslab_slots, slot)
 356          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 357         slot = &slab2->opslab_slots;
 358     INIT_OPSLOT;
 359     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 360
 361   gotit:
 362 #ifdef PERL_OP_PARENT
 363     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 364     assert(!o->op_moresib);
 365     assert(!o->op_sibparent);
 366 #endif
 367
 368     return (void *)o;
 369 }
 370
 371 #undef INIT_OPSLOT
 372
 373 #ifdef PERL_DEBUG_READONLY_OPS
 374 void
 375 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 376 {
 377     PERL_ARGS_ASSERT_SLAB_TO_RO;
 378
 379     if (slab->opslab_readonly) return;
 380     slab->opslab_readonly = 1;
 381     for (; slab; slab = slab->opslab_next) {
 382         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 383                               (unsigned long) slab->opslab_size, slab));*/
 384         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 385             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 386                              (unsigned long)slab->opslab_size, errno);
 387     }
 388 }
 389
 390 void
 391 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 392 {
 393     OPSLAB *slab2;
 394
 395     PERL_ARGS_ASSERT_SLAB_TO_RW;
 396
 397     if (!slab->opslab_readonly) return;
 398     slab2 = slab;
 399     for (; slab2; slab2 = slab2->opslab_next) {
 400         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 401                               (unsigned long) size, slab2));*/
 402         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 403                      PROT_READ|PROT_WRITE)) {
 404             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 405                              (unsigned long)slab2->opslab_size, errno);
 406         }
 407     }
 408     slab->opslab_readonly = 0;
 409 }
 410
 411 #else
 412 #  define Slab_to_rw(op)    NOOP
 413 #endif
 414
 415 /* This cannot possibly be right, but it was copied from the old slab
 416    allocator, to which it was originally added, without explanation, in
 417    commit 083fcd5. */
 418 #ifdef NETWARE
 419 #    define PerlMemShared PerlMem
 420 #endif
 421
 422 void
 423 Perl_Slab_Free(pTHX_ void *op)
 424 {
 425     OP * const o = (OP *)op;
 426     OPSLAB *slab;
 427
 428     PERL_ARGS_ASSERT_SLAB_FREE;
 429
 430     if (!o->op_slabbed) {
 431         if (!o->op_static)
 432             PerlMemShared_free(op);
 433         return;
 434     }
 435
 436     slab = OpSLAB(o);
 437     /* If this op is already freed, our refcount will get screwy. */
 438     assert(o->op_type != OP_FREED);
 439     o->op_type = OP_FREED;
 440     o->op_next = slab->opslab_freed;
 441     slab->opslab_freed = o;
 442     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 443     OpslabREFCNT_dec_padok(slab);
 444 }
 445
 446 void
 447 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 448 {
 449     const bool havepad = !!PL_comppad;
 450     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 451     if (havepad) {
 452         ENTER;
 453         PAD_SAVE_SETNULLPAD();
 454     }
 455     opslab_free(slab);
 456     if (havepad) LEAVE;
 457 }
 458
 459 void
 460 Perl_opslab_free(pTHX_ OPSLAB *slab)
 461 {
 462     OPSLAB *slab2;
 463     PERL_ARGS_ASSERT_OPSLAB_FREE;
 464     PERL_UNUSED_CONTEXT;
 465     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 466     assert(slab->opslab_refcnt == 1);
 467     do {
 468         slab2 = slab->opslab_next;
 469 #ifdef DEBUGGING
 470         slab->opslab_refcnt = ~(size_t)0;
 471 #endif
 472 #ifdef PERL_DEBUG_READONLY_OPS
 473         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 474                                                (void*)slab));
 475         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 476             perror("munmap failed");
 477             abort();
 478         }
 479 #else
 480         PerlMemShared_free(slab);
 481 #endif
 482         slab = slab2;
 483     } while (slab);
 484 }
 485
 486 void
 487 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 488 {
 489     OPSLAB *slab2;
 490     OPSLOT *slot;
 491 #ifdef DEBUGGING
 492     size_t savestack_count = 0;
 493 #endif
 494     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 495     slab2 = slab;
 496     do {
 497         for (slot = slab2->opslab_first;
 498              slot->opslot_next;
 499              slot = slot->opslot_next) {
 500             if (slot->opslot_op.op_type != OP_FREED
 501              && !(slot->opslot_op.op_savefree
 502 #ifdef DEBUGGING
 503                   && ++savestack_count
 504 #endif
 505                  )
 506             ) {
 507                 assert(slot->opslot_op.op_slabbed);
 508                 op_free(&slot->opslot_op);
 509                 if (slab->opslab_refcnt == 1) goto free;
 510             }
 511         }
 512     } while ((slab2 = slab2->opslab_next));
 513     /* > 1 because the CV still holds a reference count. */
 514     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 515 #ifdef DEBUGGING
 516         assert(savestack_count == slab->opslab_refcnt-1);
 517 #endif
 518         /* Remove the CV’s reference count. */
 519         slab->opslab_refcnt--;
 520         return;
 521     }
 522    free:
 523     opslab_free(slab);
 524 }
 525
 526 #ifdef PERL_DEBUG_READONLY_OPS
 527 OP *
 528 Perl_op_refcnt_inc(pTHX_ OP *o)
 529 {
 530     if(o) {
 531         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 532         if (slab && slab->opslab_readonly) {
 533             Slab_to_rw(slab);
 534             ++o->op_targ;
 535             Slab_to_ro(slab);
 536         } else {
 537             ++o->op_targ;
 538         }
 539     }
 540     return o;
 541
 542 }
 543
 544 PADOFFSET
 545 Perl_op_refcnt_dec(pTHX_ OP *o)
 546 {
 547     PADOFFSET result;
 548     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 549
 550     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 551
 552     if (slab && slab->opslab_readonly) {
 553         Slab_to_rw(slab);
 554         result = --o->op_targ;
 555         Slab_to_ro(slab);
 556     } else {
 557         result = --o->op_targ;
 558     }
 559     return result;
 560 }
 561 #endif
 562 /*
 563  * In the following definition, the ", (OP*)0" is just to make the compiler
 564  * think the expression is of the right type: croak actually does a Siglongjmp.
 565  */
 566 #define CHECKOP(type,o) \
 567     ((PL_op_mask && PL_op_mask[type])                           \
 568      ? ( op_free((OP*)o),                                       \
 569          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 570          (OP*)0 )                                               \
 571      : PL_check[type](aTHX_ (OP*)o))
 572
 573 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 574
 575 #define OpTYPE_set(o,type) \
 576     STMT_START {                                \
 577         o->op_type = (OPCODE)type;              \
 578         o->op_ppaddr = PL_ppaddr[type];         \
 579     } STMT_END
 580
 581 STATIC OP *
 582 S_no_fh_allowed(pTHX_ OP *o)
 583 {
 584     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 585
 586     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 587                  OP_DESC(o)));
 588     return o;
 589 }
 590
 591 STATIC OP *
 592 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 593 {
 594     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 595     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 596     return o;
 597 }
 598
 599 STATIC OP *
 600 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 601 {
 602     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 603
 604     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 605     return o;
 606 }
 607
 608 STATIC void
 609 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 610 {
 611     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 612
 613     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 614                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 615 }
 616
 617 /* remove flags var, its unused in all callers, move to to right end since gv
 618   and kid are always the same */
 619 STATIC void
 620 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 621 {
 622     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 623     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 624
 625     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
 626                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 627 }
 628
 629 STATIC void
 630 S_no_bareword_allowed(pTHX_ OP *o)
 631 {
 632     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 633
 634     qerror(Perl_mess(aTHX_
 635                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 636                      SVfARG(cSVOPo_sv)));
 637     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 638 }
 639
 640 /* "register" allocation */
 641
 642 PADOFFSET
 643 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 644 {
 645     PADOFFSET off;
 646     const bool is_our = (PL_parser->in_my == KEY_our);
 647
 648     PERL_ARGS_ASSERT_ALLOCMY;
 649
 650     if (flags & ~SVf_UTF8)
 651         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 652                    (UV)flags);
 653
 654     /* complain about "my $<special_var>" etc etc */
 655     if (len &&
 656         !(is_our ||
 657           isALPHA(name[1]) ||
 658           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
 659           (name[1] == '_' && len > 2)))
 660     {
 661         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 662          && isASCII(name[1])
 663          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 664             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 665                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 666                               PL_parser->in_my == KEY_state ? "state" : "my"));
 667         } else {
 668             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 669                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 670         }
 671     }
 672
 673     /* allocate a spare slot and store the name in that slot */
 674
 675     off = pad_add_name_pvn(name, len,
 676                        (is_our ? padadd_OUR :
 677                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 678                     PL_parser->in_my_stash,
 679                     (is_our
 680                         /* $_ is always in main::, even with our */
 681                         ? (PL_curstash && !memEQs(name,len,"$_")
 682                             ? PL_curstash
 683                             : PL_defstash)
 684                         : NULL
 685                     )
 686     );
 687     /* anon sub prototypes contains state vars should always be cloned,
 688      * otherwise the state var would be shared between anon subs */
 689
 690     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 691         CvCLONE_on(PL_compcv);
 692
 693     return off;
 694 }
 695
 696 /*
 697 =head1 Optree Manipulation Functions
 698
 699 =for apidoc alloccopstash
 700
 701 Available only under threaded builds, this function allocates an entry in
 702 C<PL_stashpad> for the stash passed to it.
 703
 704 =cut
 705 */
 706
 707 #ifdef USE_ITHREADS
 708 PADOFFSET
 709 Perl_alloccopstash(pTHX_ HV *hv)
 710 {
 711     PADOFFSET off = 0, o = 1;
 712     bool found_slot = FALSE;
 713
 714     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 715
 716     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 717
 718     for (; o < PL_stashpadmax; ++o) {
 719         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 720         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 721             found_slot = TRUE, off = o;
 722     }
 723     if (!found_slot) {
 724         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 725         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 726         off = PL_stashpadmax;
 727         PL_stashpadmax += 10;
 728     }
 729
 730     PL_stashpad[PL_stashpadix = off] = hv;
 731     return off;
 732 }
 733 #endif
 734
 735 /* free the body of an op without examining its contents.
 736  * Always use this rather than FreeOp directly */
 737
 738 static void
 739 S_op_destroy(pTHX_ OP *o)
 740 {
 741     FreeOp(o);
 742 }
 743
 744 /* Destructor */
 745
 746 /*
 747 =for apidoc Am|void|op_free|OP *o
 748
 749 Free an op.  Only use this when an op is no longer linked to from any
 750 optree.
 751
 752 =cut
 753 */
 754
 755 void
 756 Perl_op_free(pTHX_ OP *o)
 757 {
 758     dVAR;
 759     OPCODE type;
 760     SSize_t defer_ix = -1;
 761     SSize_t defer_stack_alloc = 0;
 762     OP **defer_stack = NULL;
 763
 764     do {
 765
 766         /* Though ops may be freed twice, freeing the op after its slab is a
 767            big no-no. */
 768         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 769         /* During the forced freeing of ops after compilation failure, kidops
 770            may be freed before their parents. */
 771         if (!o || o->op_type == OP_FREED)
 772             continue;
 773
 774         type = o->op_type;
 775
 776         /* an op should only ever acquire op_private flags that we know about.
 777          * If this fails, you may need to fix something in regen/op_private.
 778          * Don't bother testing if:
 779          *   * the op_ppaddr doesn't match the op; someone may have
 780          *     overridden the op and be doing strange things with it;
 781          *   * we've errored, as op flags are often left in an
 782          *     inconsistent state then. Note that an error when
 783          *     compiling the main program leaves PL_parser NULL, so
 784          *     we can't spot faults in the main code, only
 785          *     evaled/required code */
 786 #ifdef DEBUGGING
 787         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
 788             && PL_parser
 789             && !PL_parser->error_count)
 790         {
 791             assert(!(o->op_private & ~PL_op_private_valid[type]));
 792         }
 793 #endif
 794
 795         if (o->op_private & OPpREFCOUNTED) {
 796             switch (type) {
 797             case OP_LEAVESUB:
 798             case OP_LEAVESUBLV:
 799             case OP_LEAVEEVAL:
 800             case OP_LEAVE:
 801             case OP_SCOPE:
 802             case OP_LEAVEWRITE:
 803                 {
 804                 PADOFFSET refcnt;
 805                 OP_REFCNT_LOCK;
 806                 refcnt = OpREFCNT_dec(o);
 807                 OP_REFCNT_UNLOCK;
 808                 if (refcnt) {
 809                     /* Need to find and remove any pattern match ops from the list
 810                        we maintain for reset().  */
 811                     find_and_forget_pmops(o);
 812                     continue;
 813                 }
 814                 }
 815                 break;
 816             default:
 817                 break;
 818             }
 819         }
 820
 821         /* Call the op_free hook if it has been set. Do it now so that it's called
 822          * at the right time for refcounted ops, but still before all of the kids
 823          * are freed. */
 824         CALL_OPFREEHOOK(o);
 825
 826         if (o->op_flags & OPf_KIDS) {
 827             OP *kid, *nextkid;
 828             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 829                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 830                 if (!kid || kid->op_type == OP_FREED)
 831                     /* During the forced freeing of ops after
 832                        compilation failure, kidops may be freed before
 833                        their parents. */
 834                     continue;
 835                 if (!(kid->op_flags & OPf_KIDS))
 836                     /* If it has no kids, just free it now */
 837                     op_free(kid);
 838                 else
 839                     DEFER_OP(kid);
 840             }
 841         }
 842         if (type == OP_NULL)
 843             type = (OPCODE)o->op_targ;
 844
 845         if (o->op_slabbed)
 846             Slab_to_rw(OpSLAB(o));
 847
 848         /* COP* is not cleared by op_clear() so that we may track line
 849          * numbers etc even after null() */
 850         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 851             cop_free((COP*)o);
 852         }
 853
 854         op_clear(o);
 855         FreeOp(o);
 856 #ifdef DEBUG_LEAKING_SCALARS
 857         if (PL_op == o)
 858             PL_op = NULL;
 859 #endif
 860     } while ( (o = POP_DEFERRED_OP()) );
 861
 862     Safefree(defer_stack);
 863 }
 864
 865 /* S_op_clear_gv(): free a GV attached to an OP */
 866
 867 STATIC
 868 #ifdef USE_ITHREADS
 869 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 870 #else
 871 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 872 #endif
 873 {
 874
 875     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 876             || o->op_type == OP_MULTIDEREF)
 877 #ifdef USE_ITHREADS
 878                 && PL_curpad
 879                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 880 #else
 881                 ? (GV*)(*svp) : NULL;
 882 #endif
 883     /* It's possible during global destruction that the GV is freed
 884        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 885        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 886        will trigger an assertion failure, because the entry to sv_clear
 887        checks that the scalar is not already freed.  A check of for
 888        !SvIS_FREED(gv) turns out to be invalid, because during global
 889        destruction the reference count can be forced down to zero
 890        (with SVf_BREAK set).  In which case raising to 1 and then
 891        dropping to 0 triggers cleanup before it should happen.  I
 892        *think* that this might actually be a general, systematic,
 893        weakness of the whole idea of SVf_BREAK, in that code *is*
 894        allowed to raise and lower references during global destruction,
 895        so any *valid* code that happens to do this during global
 896        destruction might well trigger premature cleanup.  */
 897     bool still_valid = gv && SvREFCNT(gv);
 898
 899     if (still_valid)
 900         SvREFCNT_inc_simple_void(gv);
 901 #ifdef USE_ITHREADS
 902     if (*ixp > 0) {
 903         pad_swipe(*ixp, TRUE);
 904         *ixp = 0;
 905     }
 906 #else
 907     SvREFCNT_dec(*svp);
 908     *svp = NULL;
 909 #endif
 910     if (still_valid) {
 911         int try_downgrade = SvREFCNT(gv) == 2;
 912         SvREFCNT_dec_NN(gv);
 913         if (try_downgrade)
 914             gv_try_downgrade(gv);
 915     }
 916 }
 917
 918
 919 void
 920 Perl_op_clear(pTHX_ OP *o)
 921 {
 922
 923     dVAR;
 924
 925     PERL_ARGS_ASSERT_OP_CLEAR;
 926
 927     switch (o->op_type) {
 928     case OP_NULL:       /* Was holding old type, if any. */
 929         /* FALLTHROUGH */
 930     case OP_ENTERTRY:
 931     case OP_ENTEREVAL:  /* Was holding hints. */
 932     case OP_ARGDEFELEM: /* Was holding signature index. */
 933         o->op_targ = 0;
 934         break;
 935     default:
 936         if (!(o->op_flags & OPf_REF)
 937             || (PL_check[o->op_type] != Perl_ck_ftst))
 938             break;
 939         /* FALLTHROUGH */
 940     case OP_GVSV:
 941     case OP_GV:
 942     case OP_AELEMFAST:
 943 #ifdef USE_ITHREADS
 944             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 945 #else
 946             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 947 #endif
 948         break;
 949     case OP_METHOD_REDIR:
 950     case OP_METHOD_REDIR_SUPER:
 951 #ifdef USE_ITHREADS
 952         if (cMETHOPx(o)->op_rclass_targ) {
 953             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 954             cMETHOPx(o)->op_rclass_targ = 0;
 955         }
 956 #else
 957         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 958         cMETHOPx(o)->op_rclass_sv = NULL;
 959 #endif
 960     case OP_METHOD_NAMED:
 961     case OP_METHOD_SUPER:
 962         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 963         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 964 #ifdef USE_ITHREADS
 965         if (o->op_targ) {
 966             pad_swipe(o->op_targ, 1);
 967             o->op_targ = 0;
 968         }
 969 #endif
 970         break;
 971     case OP_CONST:
 972     case OP_HINTSEVAL:
 973         SvREFCNT_dec(cSVOPo->op_sv);
 974         cSVOPo->op_sv = NULL;
 975 #ifdef USE_ITHREADS
 976         /** Bug #15654
 977           Even if op_clear does a pad_free for the target of the op,
 978           pad_free doesn't actually remove the sv that exists in the pad;
 979           instead it lives on. This results in that it could be reused as
 980           a target later on when the pad was reallocated.
 981         **/
 982         if(o->op_targ) {
 983           pad_swipe(o->op_targ,1);
 984           o->op_targ = 0;
 985         }
 986 #endif
 987         break;
 988     case OP_DUMP:
 989     case OP_GOTO:
 990     case OP_NEXT:
 991     case OP_LAST:
 992     case OP_REDO:
 993         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 994             break;
 995         /* FALLTHROUGH */
 996     case OP_TRANS:
 997     case OP_TRANSR:
 998         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 999             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
1000 #ifdef USE_ITHREADS
1001             if (cPADOPo->op_padix > 0) {
1002                 pad_swipe(cPADOPo->op_padix, TRUE);
1003                 cPADOPo->op_padix = 0;
1004             }
1005 #else
1006             SvREFCNT_dec(cSVOPo->op_sv);
1007             cSVOPo->op_sv = NULL;
1008 #endif
1009         }
1010         else {
1011             PerlMemShared_free(cPVOPo->op_pv);
1012             cPVOPo->op_pv = NULL;
1013         }
1014         break;
1015     case OP_SUBST:
1016         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1017         goto clear_pmop;
1018     case OP_PUSHRE:
1019 #ifdef USE_ITHREADS
1020         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
1021             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1022         }
1023 #else
1024         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1025 #endif
1026         /* FALLTHROUGH */
1027     case OP_MATCH:
1028     case OP_QR:
1029     clear_pmop:
1030         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1031             op_free(cPMOPo->op_code_list);
1032         cPMOPo->op_code_list = NULL;
1033         forget_pmop(cPMOPo);
1034         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1035         /* we use the same protection as the "SAFE" version of the PM_ macros
1036          * here since sv_clean_all might release some PMOPs
1037          * after PL_regex_padav has been cleared
1038          * and the clearing of PL_regex_padav needs to
1039          * happen before sv_clean_all
1040          */
1041 #ifdef USE_ITHREADS
1042         if(PL_regex_pad) {        /* We could be in destruction */
1043             const IV offset = (cPMOPo)->op_pmoffset;
1044             ReREFCNT_dec(PM_GETRE(cPMOPo));
1045             PL_regex_pad[offset] = &PL_sv_undef;
1046             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1047                            sizeof(offset));
1048         }
1049 #else
1050         ReREFCNT_dec(PM_GETRE(cPMOPo));
1051         PM_SETRE(cPMOPo, NULL);
1052 #endif
1053
1054         break;
1055
1056     case OP_ARGCHECK:
1057         PerlMemShared_free(cUNOP_AUXo->op_aux);
1058         break;
1059
1060     case OP_MULTIDEREF:
1061         {
1062             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1063             UV actions = items->uv;
1064             bool last = 0;
1065             bool is_hash = FALSE;
1066
1067             while (!last) {
1068                 switch (actions & MDEREF_ACTION_MASK) {
1069
1070                 case MDEREF_reload:
1071                     actions = (++items)->uv;
1072                     continue;
1073
1074                 case MDEREF_HV_padhv_helem:
1075                     is_hash = TRUE;
1076                 case MDEREF_AV_padav_aelem:
1077                     pad_free((++items)->pad_offset);
1078                     goto do_elem;
1079
1080                 case MDEREF_HV_gvhv_helem:
1081                     is_hash = TRUE;
1082                 case MDEREF_AV_gvav_aelem:
1083 #ifdef USE_ITHREADS
1084                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1085 #else
1086                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1087 #endif
1088                     goto do_elem;
1089
1090                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1091                     is_hash = TRUE;
1092                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1093 #ifdef USE_ITHREADS
1094                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1095 #else
1096                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1097 #endif
1098                     goto do_vivify_rv2xv_elem;
1099
1100                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1101                     is_hash = TRUE;
1102                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1103                     pad_free((++items)->pad_offset);
1104                     goto do_vivify_rv2xv_elem;
1105
1106                 case MDEREF_HV_pop_rv2hv_helem:
1107                 case MDEREF_HV_vivify_rv2hv_helem:
1108                     is_hash = TRUE;
1109                 do_vivify_rv2xv_elem:
1110                 case MDEREF_AV_pop_rv2av_aelem:
1111                 case MDEREF_AV_vivify_rv2av_aelem:
1112                 do_elem:
1113                     switch (actions & MDEREF_INDEX_MASK) {
1114                     case MDEREF_INDEX_none:
1115                         last = 1;
1116                         break;
1117                     case MDEREF_INDEX_const:
1118                         if (is_hash) {
1119 #ifdef USE_ITHREADS
1120                             /* see RT #15654 */
1121                             pad_swipe((++items)->pad_offset, 1);
1122 #else
1123                             SvREFCNT_dec((++items)->sv);
1124 #endif
1125                         }
1126                         else
1127                             items++;
1128                         break;
1129                     case MDEREF_INDEX_padsv:
1130                         pad_free((++items)->pad_offset);
1131                         break;
1132                     case MDEREF_INDEX_gvsv:
1133 #ifdef USE_ITHREADS
1134                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1135 #else
1136                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1137 #endif
1138                         break;
1139                     }
1140
1141                     if (actions & MDEREF_FLAG_last)
1142                         last = 1;
1143                     is_hash = FALSE;
1144
1145                     break;
1146
1147                 default:
1148                     assert(0);
1149                     last = 1;
1150                     break;
1151
1152                 } /* switch */
1153
1154                 actions >>= MDEREF_SHIFT;
1155             } /* while */
1156
1157             /* start of malloc is at op_aux[-1], where the length is
1158              * stored */
1159             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1160         }
1161         break;
1162     }
1163
1164     if (o->op_targ > 0) {
1165         pad_free(o->op_targ);
1166         o->op_targ = 0;
1167     }
1168 }
1169
1170 STATIC void
1171 S_cop_free(pTHX_ COP* cop)
1172 {
1173     PERL_ARGS_ASSERT_COP_FREE;
1174
1175     CopFILE_free(cop);
1176     if (! specialWARN(cop->cop_warnings))
1177         PerlMemShared_free(cop->cop_warnings);
1178     cophh_free(CopHINTHASH_get(cop));
1179     if (PL_curcop == cop)
1180        PL_curcop = NULL;
1181 }
1182
1183 STATIC void
1184 S_forget_pmop(pTHX_ PMOP *const o
1185               )
1186 {
1187     HV * const pmstash = PmopSTASH(o);
1188
1189     PERL_ARGS_ASSERT_FORGET_PMOP;
1190
1191     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1192         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1193         if (mg) {
1194             PMOP **const array = (PMOP**) mg->mg_ptr;
1195             U32 count = mg->mg_len / sizeof(PMOP**);
1196             U32 i = count;
1197
1198             while (i--) {
1199                 if (array[i] == o) {
1200                     /* Found it. Move the entry at the end to overwrite it.  */
1201                     array[i] = array[--count];
1202                     mg->mg_len = count * sizeof(PMOP**);
1203                     /* Could realloc smaller at this point always, but probably
1204                        not worth it. Probably worth free()ing if we're the
1205                        last.  */
1206                     if(!count) {
1207                         Safefree(mg->mg_ptr);
1208                         mg->mg_ptr = NULL;
1209                     }
1210                     break;
1211                 }
1212             }
1213         }
1214     }
1215     if (PL_curpm == o)
1216         PL_curpm = NULL;
1217 }
1218
1219 STATIC void
1220 S_find_and_forget_pmops(pTHX_ OP *o)
1221 {
1222     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1223
1224     if (o->op_flags & OPf_KIDS) {
1225         OP *kid = cUNOPo->op_first;
1226         while (kid) {
1227             switch (kid->op_type) {
1228             case OP_SUBST:
1229             case OP_PUSHRE:
1230             case OP_MATCH:
1231             case OP_QR:
1232                 forget_pmop((PMOP*)kid);
1233             }
1234             find_and_forget_pmops(kid);
1235             kid = OpSIBLING(kid);
1236         }
1237     }
1238 }
1239
1240 /*
1241 =for apidoc Am|void|op_null|OP *o
1242
1243 Neutralizes an op when it is no longer needed, but is still linked to from
1244 other ops.
1245
1246 =cut
1247 */
1248
1249 void
1250 Perl_op_null(pTHX_ OP *o)
1251 {
1252     dVAR;
1253
1254     PERL_ARGS_ASSERT_OP_NULL;
1255
1256     if (o->op_type == OP_NULL)
1257         return;
1258     op_clear(o);
1259     o->op_targ = o->op_type;
1260     OpTYPE_set(o, OP_NULL);
1261 }
1262
1263 void
1264 Perl_op_refcnt_lock(pTHX)
1265   PERL_TSA_ACQUIRE(PL_op_mutex)
1266 {
1267 #ifdef USE_ITHREADS
1268     dVAR;
1269 #endif
1270     PERL_UNUSED_CONTEXT;
1271     OP_REFCNT_LOCK;
1272 }
1273
1274 void
1275 Perl_op_refcnt_unlock(pTHX)
1276   PERL_TSA_RELEASE(PL_op_mutex)
1277 {
1278 #ifdef USE_ITHREADS
1279     dVAR;
1280 #endif
1281     PERL_UNUSED_CONTEXT;
1282     OP_REFCNT_UNLOCK;
1283 }
1284
1285
1286 /*
1287 =for apidoc op_sibling_splice
1288
1289 A general function for editing the structure of an existing chain of
1290 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1291 you to delete zero or more sequential nodes, replacing them with zero or
1292 more different nodes.  Performs the necessary op_first/op_last
1293 housekeeping on the parent node and op_sibling manipulation on the
1294 children.  The last deleted node will be marked as as the last node by
1295 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1296
1297 Note that op_next is not manipulated, and nodes are not freed; that is the
1298 responsibility of the caller.  It also won't create a new list op for an
1299 empty list etc; use higher-level functions like op_append_elem() for that.
1300
1301 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1302 the splicing doesn't affect the first or last op in the chain.
1303
1304 C<start> is the node preceding the first node to be spliced.  Node(s)
1305 following it will be deleted, and ops will be inserted after it.  If it is
1306 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1307 beginning.
1308
1309 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1310 If -1 or greater than or equal to the number of remaining kids, all
1311 remaining kids are deleted.
1312
1313 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1314 If C<NULL>, no nodes are inserted.
1315
1316 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1317 deleted.
1318
1319 For example:
1320
1321     action                    before      after         returns
1322     ------                    -----       -----         -------
1323
1324                               P           P
1325     splice(P, A, 2, X-Y-Z)    |           |             B-C
1326                               A-B-C-D     A-X-Y-Z-D
1327
1328                               P           P
1329     splice(P, NULL, 1, X-Y)   |           |             A
1330                               A-B-C-D     X-Y-B-C-D
1331
1332                               P           P
1333     splice(P, NULL, 3, NULL)  |           |             A-B-C
1334                               A-B-C-D     D
1335
1336                               P           P
1337     splice(P, B, 0, X-Y)      |           |             NULL
1338                               A-B-C-D     A-B-X-Y-C-D
1339
1340
1341 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1342 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1343
1344 =cut
1345 */
1346
1347 OP *
1348 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1349 {
1350     OP *first;
1351     OP *rest;
1352     OP *last_del = NULL;
1353     OP *last_ins = NULL;
1354
1355     if (start)
1356         first = OpSIBLING(start);
1357     else if (!parent)
1358         goto no_parent;
1359     else
1360         first = cLISTOPx(parent)->op_first;
1361
1362     assert(del_count >= -1);
1363
1364     if (del_count && first) {
1365         last_del = first;
1366         while (--del_count && OpHAS_SIBLING(last_del))
1367             last_del = OpSIBLING(last_del);
1368         rest = OpSIBLING(last_del);
1369         OpLASTSIB_set(last_del, NULL);
1370     }
1371     else
1372         rest = first;
1373
1374     if (insert) {
1375         last_ins = insert;
1376         while (OpHAS_SIBLING(last_ins))
1377             last_ins = OpSIBLING(last_ins);
1378         OpMAYBESIB_set(last_ins, rest, NULL);
1379     }
1380     else
1381         insert = rest;
1382
1383     if (start) {
1384         OpMAYBESIB_set(start, insert, NULL);
1385     }
1386     else {
1387         if (!parent)
1388             goto no_parent;
1389         cLISTOPx(parent)->op_first = insert;
1390         if (insert)
1391             parent->op_flags |= OPf_KIDS;
1392         else
1393             parent->op_flags &= ~OPf_KIDS;
1394     }
1395
1396     if (!rest) {
1397         /* update op_last etc */
1398         U32 type;
1399         OP *lastop;
1400
1401         if (!parent)
1402             goto no_parent;
1403
1404         /* ought to use OP_CLASS(parent) here, but that can't handle
1405          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1406          * either */
1407         type = parent->op_type;
1408         if (type == OP_CUSTOM) {
1409             dTHX;
1410             type = XopENTRYCUSTOM(parent, xop_class);
1411         }
1412         else {
1413             if (type == OP_NULL)
1414                 type = parent->op_targ;
1415             type = PL_opargs[type] & OA_CLASS_MASK;
1416         }
1417
1418         lastop = last_ins ? last_ins : start ? start : NULL;
1419         if (   type == OA_BINOP
1420             || type == OA_LISTOP
1421             || type == OA_PMOP
1422             || type == OA_LOOP
1423         )
1424             cLISTOPx(parent)->op_last = lastop;
1425
1426         if (lastop)
1427             OpLASTSIB_set(lastop, parent);
1428     }
1429     return last_del ? first : NULL;
1430
1431   no_parent:
1432     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1433 }
1434
1435
1436 #ifdef PERL_OP_PARENT
1437
1438 /*
1439 =for apidoc op_parent
1440
1441 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1442 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1443
1444 =cut
1445 */
1446
1447 OP *
1448 Perl_op_parent(OP *o)
1449 {
1450     PERL_ARGS_ASSERT_OP_PARENT;
1451     while (OpHAS_SIBLING(o))
1452         o = OpSIBLING(o);
1453     return o->op_sibparent;
1454 }
1455
1456 #endif
1457
1458
1459 /* replace the sibling following start with a new UNOP, which becomes
1460  * the parent of the original sibling; e.g.
1461  *
1462  *  op_sibling_newUNOP(P, A, unop-args...)
1463  *
1464  *  P              P
1465  *  |      becomes |
1466  *  A-B-C          A-U-C
1467  *                   |
1468  *                   B
1469  *
1470  * where U is the new UNOP.
1471  *
1472  * parent and start args are the same as for op_sibling_splice();
1473  * type and flags args are as newUNOP().
1474  *
1475  * Returns the new UNOP.
1476  */
1477
1478 STATIC OP *
1479 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1480 {
1481     OP *kid, *newop;
1482
1483     kid = op_sibling_splice(parent, start, 1, NULL);
1484     newop = newUNOP(type, flags, kid);
1485     op_sibling_splice(parent, start, 0, newop);
1486     return newop;
1487 }
1488
1489
1490 /* lowest-level newLOGOP-style function - just allocates and populates
1491  * the struct. Higher-level stuff should be done by S_new_logop() /
1492  * newLOGOP(). This function exists mainly to avoid op_first assignment
1493  * being spread throughout this file.
1494  */
1495
1496 LOGOP *
1497 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1498 {
1499     dVAR;
1500     LOGOP *logop;
1501     OP *kid = first;
1502     NewOp(1101, logop, 1, LOGOP);
1503     OpTYPE_set(logop, type);
1504     logop->op_first = first;
1505     logop->op_other = other;
1506     logop->op_flags = OPf_KIDS;
1507     while (kid && OpHAS_SIBLING(kid))
1508         kid = OpSIBLING(kid);
1509     if (kid)
1510         OpLASTSIB_set(kid, (OP*)logop);
1511     return logop;
1512 }
1513
1514
1515 /* Contextualizers */
1516
1517 /*
1518 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1519
1520 Applies a syntactic context to an op tree representing an expression.
1521 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1522 or C<G_VOID> to specify the context to apply.  The modified op tree
1523 is returned.
1524
1525 =cut
1526 */
1527
1528 OP *
1529 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1530 {
1531     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1532     switch (context) {
1533         case G_SCALAR: return scalar(o);
1534         case G_ARRAY:  return list(o);
1535         case G_VOID:   return scalarvoid(o);
1536         default:
1537             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1538                        (long) context);
1539     }
1540 }
1541
1542 /*
1543
1544 =for apidoc Am|OP*|op_linklist|OP *o
1545 This function is the implementation of the L</LINKLIST> macro.  It should
1546 not be called directly.
1547
1548 =cut
1549 */
1550
1551 OP *
1552 Perl_op_linklist(pTHX_ OP *o)
1553 {
1554     OP *first;
1555
1556     PERL_ARGS_ASSERT_OP_LINKLIST;
1557
1558     if (o->op_next)
1559         return o->op_next;
1560
1561     /* establish postfix order */
1562     first = cUNOPo->op_first;
1563     if (first) {
1564         OP *kid;
1565         o->op_next = LINKLIST(first);
1566         kid = first;
1567         for (;;) {
1568             OP *sibl = OpSIBLING(kid);
1569             if (sibl) {
1570                 kid->op_next = LINKLIST(sibl);
1571                 kid = sibl;
1572             } else {
1573                 kid->op_next = o;
1574                 break;
1575             }
1576         }
1577     }
1578     else
1579         o->op_next = o;
1580
1581     return o->op_next;
1582 }
1583
1584 static OP *
1585 S_scalarkids(pTHX_ OP *o)
1586 {
1587     if (o && o->op_flags & OPf_KIDS) {
1588         OP *kid;
1589         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1590             scalar(kid);
1591     }
1592     return o;
1593 }
1594
1595 STATIC OP *
1596 S_scalarboolean(pTHX_ OP *o)
1597 {
1598     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1599
1600     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1601          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1602         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1603          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1604          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1605         if (ckWARN(WARN_SYNTAX)) {
1606             const line_t oldline = CopLINE(PL_curcop);
1607
1608             if (PL_parser && PL_parser->copline != NOLINE) {
1609                 /* This ensures that warnings are reported at the first line
1610                    of the conditional, not the last.  */
1611                 CopLINE_set(PL_curcop, PL_parser->copline);
1612             }
1613             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1614             CopLINE_set(PL_curcop, oldline);
1615         }
1616     }
1617     return scalar(o);
1618 }
1619
1620 static SV *
1621 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1622 {
1623     assert(o);
1624     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1625            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1626     {
1627         const char funny  = o->op_type == OP_PADAV
1628                          || o->op_type == OP_RV2AV ? '@' : '%';
1629         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1630             GV *gv;
1631             if (cUNOPo->op_first->op_type != OP_GV
1632              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1633                 return NULL;
1634             return varname(gv, funny, 0, NULL, 0, subscript_type);
1635         }
1636         return
1637             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1638     }
1639 }
1640
1641 static SV *
1642 S_op_varname(pTHX_ const OP *o)
1643 {
1644     return S_op_varname_subscript(aTHX_ o, 1);
1645 }
1646
1647 static void
1648 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1649 { /* or not so pretty :-) */
1650     if (o->op_type == OP_CONST) {
1651         *retsv = cSVOPo_sv;
1652         if (SvPOK(*retsv)) {
1653             SV *sv = *retsv;
1654             *retsv = sv_newmortal();
1655             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1656                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1657         }
1658         else if (!SvOK(*retsv))
1659             *retpv = "undef";
1660     }
1661     else *retpv = "...";
1662 }
1663
1664 static void
1665 S_scalar_slice_warning(pTHX_ const OP *o)
1666 {
1667     OP *kid;
1668     const char lbrack =
1669         o->op_type == OP_HSLICE ? '{' : '[';
1670     const char rbrack =
1671         o->op_type == OP_HSLICE ? '}' : ']';
1672     SV *name;
1673     SV *keysv = NULL; /* just to silence compiler warnings */
1674     const char *key = NULL;
1675
1676     if (!(o->op_private & OPpSLICEWARNING))
1677         return;
1678     if (PL_parser && PL_parser->error_count)
1679         /* This warning can be nonsensical when there is a syntax error. */
1680         return;
1681
1682     kid = cLISTOPo->op_first;
1683     kid = OpSIBLING(kid); /* get past pushmark */
1684     /* weed out false positives: any ops that can return lists */
1685     switch (kid->op_type) {
1686     case OP_BACKTICK:
1687     case OP_GLOB:
1688     case OP_READLINE:
1689     case OP_MATCH:
1690     case OP_RV2AV:
1691     case OP_EACH:
1692     case OP_VALUES:
1693     case OP_KEYS:
1694     case OP_SPLIT:
1695     case OP_LIST:
1696     case OP_SORT:
1697     case OP_REVERSE:
1698     case OP_ENTERSUB:
1699     case OP_CALLER:
1700     case OP_LSTAT:
1701     case OP_STAT:
1702     case OP_READDIR:
1703     case OP_SYSTEM:
1704     case OP_TMS:
1705     case OP_LOCALTIME:
1706     case OP_GMTIME:
1707     case OP_ENTEREVAL:
1708         return;
1709     }
1710
1711     /* Don't warn if we have a nulled list either. */
1712     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1713         return;
1714
1715     assert(OpSIBLING(kid));
1716     name = S_op_varname(aTHX_ OpSIBLING(kid));
1717     if (!name) /* XS module fiddling with the op tree */
1718         return;
1719     S_op_pretty(aTHX_ kid, &keysv, &key);
1720     assert(SvPOK(name));
1721     sv_chop(name,SvPVX(name)+1);
1722     if (key)
1723        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1724         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1725                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1726                    "%c%s%c",
1727                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1728                     lbrack, key, rbrack);
1729     else
1730        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1731         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1732                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1733                     SVf"%c%"SVf"%c",
1734                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1735                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1736 }
1737
1738 OP *
1739 Perl_scalar(pTHX_ OP *o)
1740 {
1741     OP *kid;
1742
1743     /* assumes no premature commitment */
1744     if (!o || (PL_parser && PL_parser->error_count)
1745          || (o->op_flags & OPf_WANT)
1746          || o->op_type == OP_RETURN)
1747     {
1748         return o;
1749     }
1750
1751     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1752
1753     switch (o->op_type) {
1754     case OP_REPEAT:
1755         scalar(cBINOPo->op_first);
1756         if (o->op_private & OPpREPEAT_DOLIST) {
1757             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1758             assert(kid->op_type == OP_PUSHMARK);
1759             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1760                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1761                 o->op_private &=~ OPpREPEAT_DOLIST;
1762             }
1763         }
1764         break;
1765     case OP_OR:
1766     case OP_AND:
1767     case OP_COND_EXPR:
1768         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1769             scalar(kid);
1770         break;
1771         /* FALLTHROUGH */
1772     case OP_SPLIT:
1773     case OP_MATCH:
1774     case OP_QR:
1775     case OP_SUBST:
1776     case OP_NULL:
1777     default:
1778         if (o->op_flags & OPf_KIDS) {
1779             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1780                 scalar(kid);
1781         }
1782         break;
1783     case OP_LEAVE:
1784     case OP_LEAVETRY:
1785         kid = cLISTOPo->op_first;
1786         scalar(kid);
1787         kid = OpSIBLING(kid);
1788     do_kids:
1789         while (kid) {
1790             OP *sib = OpSIBLING(kid);
1791             if (sib && kid->op_type != OP_LEAVEWHEN
1792              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1793                 || (  sib->op_targ != OP_NEXTSTATE
1794                    && sib->op_targ != OP_DBSTATE  )))
1795                 scalarvoid(kid);
1796             else
1797                 scalar(kid);
1798             kid = sib;
1799         }
1800         PL_curcop = &PL_compiling;
1801         break;
1802     case OP_SCOPE:
1803     case OP_LINESEQ:
1804     case OP_LIST:
1805         kid = cLISTOPo->op_first;
1806         goto do_kids;
1807     case OP_SORT:
1808         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1809         break;
1810     case OP_KVHSLICE:
1811     case OP_KVASLICE:
1812     {
1813         /* Warn about scalar context */
1814         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1815         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1816         SV *name;
1817         SV *keysv;
1818         const char *key = NULL;
1819
1820         /* This warning can be nonsensical when there is a syntax error. */
1821         if (PL_parser && PL_parser->error_count)
1822             break;
1823
1824         if (!ckWARN(WARN_SYNTAX)) break;
1825
1826         kid = cLISTOPo->op_first;
1827         kid = OpSIBLING(kid); /* get past pushmark */
1828         assert(OpSIBLING(kid));
1829         name = S_op_varname(aTHX_ OpSIBLING(kid));
1830         if (!name) /* XS module fiddling with the op tree */
1831             break;
1832         S_op_pretty(aTHX_ kid, &keysv, &key);
1833         assert(SvPOK(name));
1834         sv_chop(name,SvPVX(name)+1);
1835         if (key)
1836   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1837             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1838                        "%%%"SVf"%c%s%c in scalar context better written "
1839                        "as $%"SVf"%c%s%c",
1840                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1841                         lbrack, key, rbrack);
1842         else
1843   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1844             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1845                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1846                        "written as $%"SVf"%c%"SVf"%c",
1847                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1848                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1849     }
1850     }
1851     return o;
1852 }
1853
1854 OP *
1855 Perl_scalarvoid(pTHX_ OP *arg)
1856 {
1857     dVAR;
1858     OP *kid;
1859     SV* sv;
1860     U8 want;
1861     SSize_t defer_stack_alloc = 0;
1862     SSize_t defer_ix = -1;
1863     OP **defer_stack = NULL;
1864     OP *o = arg;
1865
1866     PERL_ARGS_ASSERT_SCALARVOID;
1867
1868     do {
1869         SV *useless_sv = NULL;
1870         const char* useless = NULL;
1871
1872         if (o->op_type == OP_NEXTSTATE
1873             || o->op_type == OP_DBSTATE
1874             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1875                                           || o->op_targ == OP_DBSTATE)))
1876             PL_curcop = (COP*)o;                /* for warning below */
1877
1878         /* assumes no premature commitment */
1879         want = o->op_flags & OPf_WANT;
1880         if ((want && want != OPf_WANT_SCALAR)
1881             || (PL_parser && PL_parser->error_count)
1882             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1883         {
1884             continue;
1885         }
1886
1887         if ((o->op_private & OPpTARGET_MY)
1888             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1889         {
1890             /* newASSIGNOP has already applied scalar context, which we
1891                leave, as if this op is inside SASSIGN.  */
1892             continue;
1893         }
1894
1895         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1896
1897         switch (o->op_type) {
1898         default:
1899             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1900                 break;
1901             /* FALLTHROUGH */
1902         case OP_REPEAT:
1903             if (o->op_flags & OPf_STACKED)
1904                 break;
1905             if (o->op_type == OP_REPEAT)
1906                 scalar(cBINOPo->op_first);
1907             goto func_ops;
1908         case OP_SUBSTR:
1909             if (o->op_private == 4)
1910                 break;
1911             /* FALLTHROUGH */
1912         case OP_WANTARRAY:
1913         case OP_GV:
1914         case OP_SMARTMATCH:
1915         case OP_AV2ARYLEN:
1916         case OP_REF:
1917         case OP_REFGEN:
1918         case OP_SREFGEN:
1919         case OP_DEFINED:
1920         case OP_HEX:
1921         case OP_OCT:
1922         case OP_LENGTH:
1923         case OP_VEC:
1924         case OP_INDEX:
1925         case OP_RINDEX:
1926         case OP_SPRINTF:
1927         case OP_KVASLICE:
1928         case OP_KVHSLICE:
1929         case OP_UNPACK:
1930         case OP_PACK:
1931         case OP_JOIN:
1932         case OP_LSLICE:
1933         case OP_ANONLIST:
1934         case OP_ANONHASH:
1935         case OP_SORT:
1936         case OP_REVERSE:
1937         case OP_RANGE:
1938         case OP_FLIP:
1939         case OP_FLOP:
1940         case OP_CALLER:
1941         case OP_FILENO:
1942         case OP_EOF:
1943         case OP_TELL:
1944         case OP_GETSOCKNAME:
1945         case OP_GETPEERNAME:
1946         case OP_READLINK:
1947         case OP_TELLDIR:
1948         case OP_GETPPID:
1949         case OP_GETPGRP:
1950         case OP_GETPRIORITY:
1951         case OP_TIME:
1952         case OP_TMS:
1953         case OP_LOCALTIME:
1954         case OP_GMTIME:
1955         case OP_GHBYNAME:
1956         case OP_GHBYADDR:
1957         case OP_GHOSTENT:
1958         case OP_GNBYNAME:
1959         case OP_GNBYADDR:
1960         case OP_GNETENT:
1961         case OP_GPBYNAME:
1962         case OP_GPBYNUMBER:
1963         case OP_GPROTOENT:
1964         case OP_GSBYNAME:
1965         case OP_GSBYPORT:
1966         case OP_GSERVENT:
1967         case OP_GPWNAM:
1968         case OP_GPWUID:
1969         case OP_GGRNAM:
1970         case OP_GGRGID:
1971         case OP_GETLOGIN:
1972         case OP_PROTOTYPE:
1973         case OP_RUNCV:
1974         func_ops:
1975             useless = OP_DESC(o);
1976             break;
1977
1978         case OP_GVSV:
1979         case OP_PADSV:
1980         case OP_PADAV:
1981         case OP_PADHV:
1982         case OP_PADANY:
1983         case OP_AELEM:
1984         case OP_AELEMFAST:
1985         case OP_AELEMFAST_LEX:
1986         case OP_ASLICE:
1987         case OP_HELEM:
1988         case OP_HSLICE:
1989             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1990                 /* Otherwise it's "Useless use of grep iterator" */
1991                 useless = OP_DESC(o);
1992             break;
1993
1994         case OP_SPLIT:
1995             kid = cLISTOPo->op_first;
1996             if (kid && kid->op_type == OP_PUSHRE
1997                 && !kid->op_targ
1998                 && !(o->op_flags & OPf_STACKED)
1999 #ifdef USE_ITHREADS
2000                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
2001 #else
2002                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
2003 #endif
2004                 )
2005                 useless = OP_DESC(o);
2006             break;
2007
2008         case OP_NOT:
2009             kid = cUNOPo->op_first;
2010             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2011                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2012                 goto func_ops;
2013             }
2014             useless = "negative pattern binding (!~)";
2015             break;
2016
2017         case OP_SUBST:
2018             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2019                 useless = "non-destructive substitution (s///r)";
2020             break;
2021
2022         case OP_TRANSR:
2023             useless = "non-destructive transliteration (tr///r)";
2024             break;
2025
2026         case OP_RV2GV:
2027         case OP_RV2SV:
2028         case OP_RV2AV:
2029         case OP_RV2HV:
2030             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2031                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2032                 useless = "a variable";
2033             break;
2034
2035         case OP_CONST:
2036             sv = cSVOPo_sv;
2037             if (cSVOPo->op_private & OPpCONST_STRICT)
2038                 no_bareword_allowed(o);
2039             else {
2040                 if (ckWARN(WARN_VOID)) {
2041                     NV nv;
2042                     /* don't warn on optimised away booleans, eg
2043                      * use constant Foo, 5; Foo || print; */
2044                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2045                         useless = NULL;
2046                     /* the constants 0 and 1 are permitted as they are
2047                        conventionally used as dummies in constructs like
2048                        1 while some_condition_with_side_effects;  */
2049                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2050                         useless = NULL;
2051                     else if (SvPOK(sv)) {
2052                         SV * const dsv = newSVpvs("");
2053                         useless_sv
2054                             = Perl_newSVpvf(aTHX_
2055                                             "a constant (%s)",
2056                                             pv_pretty(dsv, SvPVX_const(sv),
2057                                                       SvCUR(sv), 32, NULL, NULL,
2058                                                       PERL_PV_PRETTY_DUMP
2059                                                       | PERL_PV_ESCAPE_NOCLEAR
2060                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2061                         SvREFCNT_dec_NN(dsv);
2062                     }
2063                     else if (SvOK(sv)) {
2064                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
2065                     }
2066                     else
2067                         useless = "a constant (undef)";
2068                 }
2069             }
2070             op_null(o);         /* don't execute or even remember it */
2071             break;
2072
2073         case OP_POSTINC:
2074             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2075             break;
2076
2077         case OP_POSTDEC:
2078             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2079             break;
2080
2081         case OP_I_POSTINC:
2082             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2083             break;
2084
2085         case OP_I_POSTDEC:
2086             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2087             break;
2088
2089         case OP_SASSIGN: {
2090             OP *rv2gv;
2091             UNOP *refgen, *rv2cv;
2092             LISTOP *exlist;
2093
2094             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2095                 break;
2096
2097             rv2gv = ((BINOP *)o)->op_last;
2098             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2099                 break;
2100
2101             refgen = (UNOP *)((BINOP *)o)->op_first;
2102
2103             if (!refgen || (refgen->op_type != OP_REFGEN
2104                             && refgen->op_type != OP_SREFGEN))
2105                 break;
2106
2107             exlist = (LISTOP *)refgen->op_first;
2108             if (!exlist || exlist->op_type != OP_NULL
2109                 || exlist->op_targ != OP_LIST)
2110                 break;
2111
2112             if (exlist->op_first->op_type != OP_PUSHMARK
2113                 && exlist->op_first != exlist->op_last)
2114                 break;
2115
2116             rv2cv = (UNOP*)exlist->op_last;
2117
2118             if (rv2cv->op_type != OP_RV2CV)
2119                 break;
2120
2121             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2122             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2123             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2124
2125             o->op_private |= OPpASSIGN_CV_TO_GV;
2126             rv2gv->op_private |= OPpDONT_INIT_GV;
2127             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2128
2129             break;
2130         }
2131
2132         case OP_AASSIGN: {
2133             inplace_aassign(o);
2134             break;
2135         }
2136
2137         case OP_OR:
2138         case OP_AND:
2139             kid = cLOGOPo->op_first;
2140             if (kid->op_type == OP_NOT
2141                 && (kid->op_flags & OPf_KIDS)) {
2142                 if (o->op_type == OP_AND) {
2143                     OpTYPE_set(o, OP_OR);
2144                 } else {
2145                     OpTYPE_set(o, OP_AND);
2146                 }
2147                 op_null(kid);
2148             }
2149             /* FALLTHROUGH */
2150
2151         case OP_DOR:
2152         case OP_COND_EXPR:
2153         case OP_ENTERGIVEN:
2154         case OP_ENTERWHEN:
2155             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2156                 if (!(kid->op_flags & OPf_KIDS))
2157                     scalarvoid(kid);
2158                 else
2159                     DEFER_OP(kid);
2160         break;
2161
2162         case OP_NULL:
2163             if (o->op_flags & OPf_STACKED)
2164                 break;
2165             /* FALLTHROUGH */
2166         case OP_NEXTSTATE:
2167         case OP_DBSTATE:
2168         case OP_ENTERTRY:
2169         case OP_ENTER:
2170             if (!(o->op_flags & OPf_KIDS))
2171                 break;
2172             /* FALLTHROUGH */
2173         case OP_SCOPE:
2174         case OP_LEAVE:
2175         case OP_LEAVETRY:
2176         case OP_LEAVELOOP:
2177         case OP_LINESEQ:
2178         case OP_LEAVEGIVEN:
2179         case OP_LEAVEWHEN:
2180         kids:
2181             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2182                 if (!(kid->op_flags & OPf_KIDS))
2183                     scalarvoid(kid);
2184                 else
2185                     DEFER_OP(kid);
2186             break;
2187         case OP_LIST:
2188             /* If the first kid after pushmark is something that the padrange
2189                optimisation would reject, then null the list and the pushmark.
2190             */
2191             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2192                 && (  !(kid = OpSIBLING(kid))
2193                       || (  kid->op_type != OP_PADSV
2194                             && kid->op_type != OP_PADAV
2195                             && kid->op_type != OP_PADHV)
2196                       || kid->op_private & ~OPpLVAL_INTRO
2197                       || !(kid = OpSIBLING(kid))
2198                       || (  kid->op_type != OP_PADSV
2199                             && kid->op_type != OP_PADAV
2200                             && kid->op_type != OP_PADHV)
2201                       || kid->op_private & ~OPpLVAL_INTRO)
2202             ) {
2203                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2204                 op_null(o); /* NULL the list */
2205             }
2206             goto kids;
2207         case OP_ENTEREVAL:
2208             scalarkids(o);
2209             break;
2210         case OP_SCALAR:
2211             scalar(o);
2212             break;
2213         }
2214
2215         if (useless_sv) {
2216             /* mortalise it, in case warnings are fatal.  */
2217             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2218                            "Useless use of %"SVf" in void context",
2219                            SVfARG(sv_2mortal(useless_sv)));
2220         }
2221         else if (useless) {
2222             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2223                            "Useless use of %s in void context",
2224                            useless);
2225         }
2226     } while ( (o = POP_DEFERRED_OP()) );
2227
2228     Safefree(defer_stack);
2229
2230     return arg;
2231 }
2232
2233 static OP *
2234 S_listkids(pTHX_ OP *o)
2235 {
2236     if (o && o->op_flags & OPf_KIDS) {
2237         OP *kid;
2238         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2239             list(kid);
2240     }
2241     return o;
2242 }
2243
2244 OP *
2245 Perl_list(pTHX_ OP *o)
2246 {
2247     OP *kid;
2248
2249     /* assumes no premature commitment */
2250     if (!o || (o->op_flags & OPf_WANT)
2251          || (PL_parser && PL_parser->error_count)
2252          || o->op_type == OP_RETURN)
2253     {
2254         return o;
2255     }
2256
2257     if ((o->op_private & OPpTARGET_MY)
2258         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2259     {
2260         return o;                               /* As if inside SASSIGN */
2261     }
2262
2263     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2264
2265     switch (o->op_type) {
2266     case OP_FLOP:
2267         list(cBINOPo->op_first);
2268         break;
2269     case OP_REPEAT:
2270         if (o->op_private & OPpREPEAT_DOLIST
2271          && !(o->op_flags & OPf_STACKED))
2272         {
2273             list(cBINOPo->op_first);
2274             kid = cBINOPo->op_last;
2275             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2276              && SvIVX(kSVOP_sv) == 1)
2277             {
2278                 op_null(o); /* repeat */
2279                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2280                 /* const (rhs): */
2281                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2282             }
2283         }
2284         break;
2285     case OP_OR:
2286     case OP_AND:
2287     case OP_COND_EXPR:
2288         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2289             list(kid);
2290         break;
2291     default:
2292     case OP_MATCH:
2293     case OP_QR:
2294     case OP_SUBST:
2295     case OP_NULL:
2296         if (!(o->op_flags & OPf_KIDS))
2297             break;
2298         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2299             list(cBINOPo->op_first);
2300             return gen_constant_list(o);
2301         }
2302         listkids(o);
2303         break;
2304     case OP_LIST:
2305         listkids(o);
2306         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2307             op_null(cUNOPo->op_first); /* NULL the pushmark */
2308             op_null(o); /* NULL the list */
2309         }
2310         break;
2311     case OP_LEAVE:
2312     case OP_LEAVETRY:
2313         kid = cLISTOPo->op_first;
2314         list(kid);
2315         kid = OpSIBLING(kid);
2316     do_kids:
2317         while (kid) {
2318             OP *sib = OpSIBLING(kid);
2319             if (sib && kid->op_type != OP_LEAVEWHEN)
2320                 scalarvoid(kid);
2321             else
2322                 list(kid);
2323             kid = sib;
2324         }
2325         PL_curcop = &PL_compiling;
2326         break;
2327     case OP_SCOPE:
2328     case OP_LINESEQ:
2329         kid = cLISTOPo->op_first;
2330         goto do_kids;
2331     }
2332     return o;
2333 }
2334
2335 static OP *
2336 S_scalarseq(pTHX_ OP *o)
2337 {
2338     if (o) {
2339         const OPCODE type = o->op_type;
2340
2341         if (type == OP_LINESEQ || type == OP_SCOPE ||
2342             type == OP_LEAVE || type == OP_LEAVETRY)
2343         {
2344             OP *kid, *sib;
2345             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2346                 if ((sib = OpSIBLING(kid))
2347                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2348                     || (  sib->op_targ != OP_NEXTSTATE
2349                        && sib->op_targ != OP_DBSTATE  )))
2350                 {
2351                     scalarvoid(kid);
2352                 }
2353             }
2354             PL_curcop = &PL_compiling;
2355         }
2356         o->op_flags &= ~OPf_PARENS;
2357         if (PL_hints & HINT_BLOCK_SCOPE)
2358             o->op_flags |= OPf_PARENS;
2359     }
2360     else
2361         o = newOP(OP_STUB, 0);
2362     return o;
2363 }
2364
2365 STATIC OP *
2366 S_modkids(pTHX_ OP *o, I32 type)
2367 {
2368     if (o && o->op_flags & OPf_KIDS) {
2369         OP *kid;
2370         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2371             op_lvalue(kid, type);
2372     }
2373     return o;
2374 }
2375
2376
2377 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2378  * const fields. Also, convert CONST keys to HEK-in-SVs.
2379  * rop is the op that retrieves the hash;
2380  * key_op is the first key
2381  */
2382
2383 STATIC void
2384 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2385 {
2386     PADNAME *lexname;
2387     GV **fields;
2388     bool check_fields;
2389
2390     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2391     if (rop) {
2392         if (rop->op_first->op_type == OP_PADSV)
2393             /* @$hash{qw(keys here)} */
2394             rop = (UNOP*)rop->op_first;
2395         else {
2396             /* @{$hash}{qw(keys here)} */
2397             if (rop->op_first->op_type == OP_SCOPE
2398                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2399                 {
2400                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2401                 }
2402             else
2403                 rop = NULL;
2404         }
2405     }
2406
2407     lexname = NULL; /* just to silence compiler warnings */
2408     fields  = NULL; /* just to silence compiler warnings */
2409
2410     check_fields =
2411             rop
2412          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2413              SvPAD_TYPED(lexname))
2414          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2415          && isGV(*fields) && GvHV(*fields);
2416
2417     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2418         SV **svp, *sv;
2419         if (key_op->op_type != OP_CONST)
2420             continue;
2421         svp = cSVOPx_svp(key_op);
2422
2423         /* make sure it's not a bareword under strict subs */
2424         if (key_op->op_private & OPpCONST_BARE &&
2425             key_op->op_private & OPpCONST_STRICT)
2426         {
2427             no_bareword_allowed((OP*)key_op);
2428         }
2429
2430         /* Make the CONST have a shared SV */
2431         if (   !SvIsCOW_shared_hash(sv = *svp)
2432             && SvTYPE(sv) < SVt_PVMG
2433             && SvOK(sv)
2434             && !SvROK(sv))
2435         {
2436             SSize_t keylen;
2437             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2438             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2439             SvREFCNT_dec_NN(sv);
2440             *svp = nsv;
2441         }
2442
2443         if (   check_fields
2444             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2445         {
2446             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2447                         "in variable %"PNf" of type %"HEKf,
2448                         SVfARG(*svp), PNfARG(lexname),
2449                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2450         }
2451     }
2452 }
2453
2454
2455 /*
2456 =for apidoc finalize_optree
2457
2458 This function finalizes the optree.  Should be called directly after
2459 the complete optree is built.  It does some additional
2460 checking which can't be done in the normal C<ck_>xxx functions and makes
2461 the tree thread-safe.
2462
2463 =cut
2464 */
2465 void
2466 Perl_finalize_optree(pTHX_ OP* o)
2467 {
2468     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2469
2470     ENTER;
2471     SAVEVPTR(PL_curcop);
2472
2473     finalize_op(o);
2474
2475     LEAVE;
2476 }
2477
2478 #ifdef USE_ITHREADS
2479 /* Relocate sv to the pad for thread safety.
2480  * Despite being a "constant", the SV is written to,
2481  * for reference counts, sv_upgrade() etc. */
2482 PERL_STATIC_INLINE void
2483 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2484 {
2485     PADOFFSET ix;
2486     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2487     if (!*svp) return;
2488     ix = pad_alloc(OP_CONST, SVf_READONLY);
2489     SvREFCNT_dec(PAD_SVl(ix));
2490     PAD_SETSV(ix, *svp);
2491     /* XXX I don't know how this isn't readonly already. */
2492     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2493     *svp = NULL;
2494     *targp = ix;
2495 }
2496 #endif
2497
2498
2499 STATIC void
2500 S_finalize_op(pTHX_ OP* o)
2501 {
2502     PERL_ARGS_ASSERT_FINALIZE_OP;
2503
2504     assert(o->op_type != OP_FREED);
2505
2506     switch (o->op_type) {
2507     case OP_NEXTSTATE:
2508     case OP_DBSTATE:
2509         PL_curcop = ((COP*)o);          /* for warnings */
2510         break;
2511     case OP_EXEC:
2512         if (OpHAS_SIBLING(o)) {
2513             OP *sib = OpSIBLING(o);
2514             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2515                 && ckWARN(WARN_EXEC)
2516                 && OpHAS_SIBLING(sib))
2517             {
2518                     const OPCODE type = OpSIBLING(sib)->op_type;
2519                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2520                         const line_t oldline = CopLINE(PL_curcop);
2521                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2522                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2523                             "Statement unlikely to be reached");
2524                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2525                             "\t(Maybe you meant system() when you said exec()?)\n");
2526                         CopLINE_set(PL_curcop, oldline);
2527                     }
2528             }
2529         }
2530         break;
2531
2532     case OP_GV:
2533         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2534             GV * const gv = cGVOPo_gv;
2535             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2536                 /* XXX could check prototype here instead of just carping */
2537                 SV * const sv = sv_newmortal();
2538                 gv_efullname3(sv, gv, NULL);
2539                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2540                     "%"SVf"() called too early to check prototype",
2541                     SVfARG(sv));
2542             }
2543         }
2544         break;
2545
2546     case OP_CONST:
2547         if (cSVOPo->op_private & OPpCONST_STRICT)
2548             no_bareword_allowed(o);
2549         /* FALLTHROUGH */
2550 #ifdef USE_ITHREADS
2551     case OP_HINTSEVAL:
2552         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2553 #endif
2554         break;
2555
2556 #ifdef USE_ITHREADS
2557     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2558     case OP_METHOD_NAMED:
2559     case OP_METHOD_SUPER:
2560     case OP_METHOD_REDIR:
2561     case OP_METHOD_REDIR_SUPER:
2562         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2563         break;
2564 #endif
2565
2566     case OP_HELEM: {
2567         UNOP *rop;
2568         SVOP *key_op;
2569         OP *kid;
2570
2571         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2572             break;
2573
2574         rop = (UNOP*)((BINOP*)o)->op_first;
2575
2576         goto check_keys;
2577
2578     case OP_HSLICE:
2579         S_scalar_slice_warning(aTHX_ o);
2580         /* FALLTHROUGH */
2581
2582     case OP_KVHSLICE:
2583         kid = OpSIBLING(cLISTOPo->op_first);
2584         if (/* I bet there's always a pushmark... */
2585             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2586             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2587         {
2588             break;
2589         }
2590
2591         key_op = (SVOP*)(kid->op_type == OP_CONST
2592                                 ? kid
2593                                 : OpSIBLING(kLISTOP->op_first));
2594
2595         rop = (UNOP*)((LISTOP*)o)->op_last;
2596
2597       check_keys:
2598         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2599             rop = NULL;
2600         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2601         break;
2602     }
2603     case OP_ASLICE:
2604         S_scalar_slice_warning(aTHX_ o);
2605         break;
2606
2607     case OP_SUBST: {
2608         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2609             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2610         break;
2611     }
2612     default:
2613         break;
2614     }
2615
2616     if (o->op_flags & OPf_KIDS) {
2617         OP *kid;
2618
2619 #ifdef DEBUGGING
2620         /* check that op_last points to the last sibling, and that
2621          * the last op_sibling/op_sibparent field points back to the
2622          * parent, and that the only ops with KIDS are those which are
2623          * entitled to them */
2624         U32 type = o->op_type;
2625         U32 family;
2626         bool has_last;
2627
2628         if (type == OP_NULL) {
2629             type = o->op_targ;
2630             /* ck_glob creates a null UNOP with ex-type GLOB
2631              * (which is a list op. So pretend it wasn't a listop */
2632             if (type == OP_GLOB)
2633                 type = OP_NULL;
2634         }
2635         family = PL_opargs[type] & OA_CLASS_MASK;
2636
2637         has_last = (   family == OA_BINOP
2638                     || family == OA_LISTOP
2639                     || family == OA_PMOP
2640                     || family == OA_LOOP
2641                    );
2642         assert(  has_last /* has op_first and op_last, or ...
2643               ... has (or may have) op_first: */
2644               || family == OA_UNOP
2645               || family == OA_UNOP_AUX
2646               || family == OA_LOGOP
2647               || family == OA_BASEOP_OR_UNOP
2648               || family == OA_FILESTATOP
2649               || family == OA_LOOPEXOP
2650               || family == OA_METHOP
2651               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2652               || type == OP_SASSIGN
2653               || type == OP_CUSTOM
2654               || type == OP_NULL /* new_logop does this */
2655               );
2656
2657         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2658 #  ifdef PERL_OP_PARENT
2659             if (!OpHAS_SIBLING(kid)) {
2660                 if (has_last)
2661                     assert(kid == cLISTOPo->op_last);
2662                 assert(kid->op_sibparent == o);
2663             }
2664 #  else
2665             if (has_last && !OpHAS_SIBLING(kid))
2666                 assert(kid == cLISTOPo->op_last);
2667 #  endif
2668         }
2669 #endif
2670
2671         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2672             finalize_op(kid);
2673     }
2674 }
2675
2676 /*
2677 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2678
2679 Propagate lvalue ("modifiable") context to an op and its children.
2680 C<type> represents the context type, roughly based on the type of op that
2681 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2682 because it has no op type of its own (it is signalled by a flag on
2683 the lvalue op).
2684
2685 This function detects things that can't be modified, such as C<$x+1>, and
2686 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2687 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2688
2689 It also flags things that need to behave specially in an lvalue context,
2690 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2691
2692 =cut
2693 */
2694
2695 static void
2696 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2697 {
2698     CV *cv = PL_compcv;
2699     PadnameLVALUE_on(pn);
2700     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2701         cv = CvOUTSIDE(cv);
2702         /* RT #127786: cv can be NULL due to an eval within the DB package
2703          * called from an anon sub - anon subs don't have CvOUTSIDE() set
2704          * unless they contain an eval, but calling eval within DB
2705          * pretends the eval was done in the caller's scope.
2706          */
2707         if (!cv)
2708             break;
2709         assert(CvPADLIST(cv));
2710         pn =
2711            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2712         assert(PadnameLEN(pn));
2713         PadnameLVALUE_on(pn);
2714     }
2715 }
2716
2717 static bool
2718 S_vivifies(const OPCODE type)
2719 {
2720     switch(type) {
2721     case OP_RV2AV:     case   OP_ASLICE:
2722     case OP_RV2HV:     case OP_KVASLICE:
2723     case OP_RV2SV:     case   OP_HSLICE:
2724     case OP_AELEMFAST: case OP_KVHSLICE:
2725     case OP_HELEM:
2726     case OP_AELEM:
2727         return 1;
2728     }
2729     return 0;
2730 }
2731
2732 static void
2733 S_lvref(pTHX_ OP *o, I32 type)
2734 {
2735     dVAR;
2736     OP *kid;
2737     switch (o->op_type) {
2738     case OP_COND_EXPR:
2739         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2740              kid = OpSIBLING(kid))
2741             S_lvref(aTHX_ kid, type);
2742         /* FALLTHROUGH */
2743     case OP_PUSHMARK:
2744         return;
2745     case OP_RV2AV:
2746         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2747         o->op_flags |= OPf_STACKED;
2748         if (o->op_flags & OPf_PARENS) {
2749             if (o->op_private & OPpLVAL_INTRO) {
2750                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2751                       "localized parenthesized array in list assignment"));
2752                 return;
2753             }
2754           slurpy:
2755             OpTYPE_set(o, OP_LVAVREF);
2756             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2757             o->op_flags |= OPf_MOD|OPf_REF;
2758             return;
2759         }
2760         o->op_private |= OPpLVREF_AV;
2761         goto checkgv;
2762     case OP_RV2CV:
2763         kid = cUNOPo->op_first;
2764         if (kid->op_type == OP_NULL)
2765             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2766                 ->op_first;
2767         o->op_private = OPpLVREF_CV;
2768         if (kid->op_type == OP_GV)
2769             o->op_flags |= OPf_STACKED;
2770         else if (kid->op_type == OP_PADCV) {
2771             o->op_targ = kid->op_targ;
2772             kid->op_targ = 0;
2773             op_free(cUNOPo->op_first);
2774             cUNOPo->op_first = NULL;
2775             o->op_flags &=~ OPf_KIDS;
2776         }
2777         else goto badref;
2778         break;
2779     case OP_RV2HV:
2780         if (o->op_flags & OPf_PARENS) {
2781           parenhash:
2782             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2783                                  "parenthesized hash in list assignment"));
2784                 return;
2785         }
2786         o->op_private |= OPpLVREF_HV;
2787         /* FALLTHROUGH */
2788     case OP_RV2SV:
2789       checkgv:
2790         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2791         o->op_flags |= OPf_STACKED;
2792         break;
2793     case OP_PADHV:
2794         if (o->op_flags & OPf_PARENS) goto parenhash;
2795         o->op_private |= OPpLVREF_HV;
2796         /* FALLTHROUGH */
2797     case OP_PADSV:
2798         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2799         break;
2800     case OP_PADAV:
2801         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2802         if (o->op_flags & OPf_PARENS) goto slurpy;
2803         o->op_private |= OPpLVREF_AV;
2804         break;
2805     case OP_AELEM:
2806     case OP_HELEM:
2807         o->op_private |= OPpLVREF_ELEM;
2808         o->op_flags   |= OPf_STACKED;
2809         break;
2810     case OP_ASLICE:
2811     case OP_HSLICE:
2812         OpTYPE_set(o, OP_LVREFSLICE);
2813         o->op_private &= OPpLVAL_INTRO;
2814         return;
2815     case OP_NULL:
2816         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2817             goto badref;
2818         else if (!(o->op_flags & OPf_KIDS))
2819             return;
2820         if (o->op_targ != OP_LIST) {
2821             S_lvref(aTHX_ cBINOPo->op_first, type);
2822             return;
2823         }
2824         /* FALLTHROUGH */
2825     case OP_LIST:
2826         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2827             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2828             S_lvref(aTHX_ kid, type);
2829         }
2830         return;
2831     case OP_STUB:
2832         if (o->op_flags & OPf_PARENS)
2833             return;
2834         /* FALLTHROUGH */
2835     default:
2836       badref:
2837         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2838         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2839                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2840                       ? "do block"
2841                       : OP_DESC(o),
2842                      PL_op_desc[type]));
2843         return;
2844     }
2845     OpTYPE_set(o, OP_LVREF);
2846     o->op_private &=
2847         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2848     if (type == OP_ENTERLOOP)
2849         o->op_private |= OPpLVREF_ITER;
2850 }
2851
2852 PERL_STATIC_INLINE bool
2853 S_potential_mod_type(I32 type)
2854 {
2855     /* Types that only potentially result in modification.  */
2856     return type == OP_GREPSTART || type == OP_ENTERSUB
2857         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
2858 }
2859
2860 OP *
2861 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2862 {
2863     dVAR;
2864     OP *kid;
2865     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2866     int localize = -1;
2867
2868     if (!o || (PL_parser && PL_parser->error_count))
2869         return o;
2870
2871     if ((o->op_private & OPpTARGET_MY)
2872         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2873     {
2874         return o;
2875     }
2876
2877     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2878
2879     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2880
2881     switch (o->op_type) {
2882     case OP_UNDEF:
2883         PL_modcount++;
2884         return o;
2885     case OP_STUB:
2886         if ((o->op_flags & OPf_PARENS))
2887             break;
2888         goto nomod;
2889     case OP_ENTERSUB:
2890         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2891             !(o->op_flags & OPf_STACKED)) {
2892             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
2893             assert(cUNOPo->op_first->op_type == OP_NULL);
2894             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2895             break;
2896         }
2897         else {                          /* lvalue subroutine call */
2898             o->op_private |= OPpLVAL_INTRO;
2899             PL_modcount = RETURN_UNLIMITED_NUMBER;
2900             if (S_potential_mod_type(type)) {
2901                 o->op_private |= OPpENTERSUB_INARGS;
2902                 break;
2903             }
2904             else {                      /* Compile-time error message: */
2905                 OP *kid = cUNOPo->op_first;
2906                 CV *cv;
2907                 GV *gv;
2908                 SV *namesv;
2909
2910                 if (kid->op_type != OP_PUSHMARK) {
2911                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2912                         Perl_croak(aTHX_
2913                                 "panic: unexpected lvalue entersub "
2914                                 "args: type/targ %ld:%"UVuf,
2915                                 (long)kid->op_type, (UV)kid->op_targ);
2916                     kid = kLISTOP->op_first;
2917                 }
2918                 while (OpHAS_SIBLING(kid))
2919                     kid = OpSIBLING(kid);
2920                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2921                     break;      /* Postpone until runtime */
2922                 }
2923
2924                 kid = kUNOP->op_first;
2925                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2926                     kid = kUNOP->op_first;
2927                 if (kid->op_type == OP_NULL)
2928                     Perl_croak(aTHX_
2929                                "Unexpected constant lvalue entersub "
2930                                "entry via type/targ %ld:%"UVuf,
2931                                (long)kid->op_type, (UV)kid->op_targ);
2932                 if (kid->op_type != OP_GV) {
2933                     break;
2934                 }
2935
2936                 gv = kGVOP_gv;
2937                 cv = isGV(gv)
2938                     ? GvCV(gv)
2939                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2940                         ? MUTABLE_CV(SvRV(gv))
2941                         : NULL;
2942                 if (!cv)
2943                     break;
2944                 if (CvLVALUE(cv))
2945                     break;
2946                 if (flags & OP_LVALUE_NO_CROAK)
2947                     return NULL;
2948
2949                 namesv = cv_name(cv, NULL, 0);
2950                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2951                                      "subroutine call of &%"SVf" in %s",
2952                                      SVfARG(namesv), PL_op_desc[type]),
2953                            SvUTF8(namesv));
2954                 return o;
2955             }
2956         }
2957         /* FALLTHROUGH */
2958     default:
2959       nomod:
2960         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2961         /* grep, foreach, subcalls, refgen */
2962         if (S_potential_mod_type(type))
2963             break;
2964         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2965                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2966                       ? "do block"
2967                       : OP_DESC(o)),
2968                      type ? PL_op_desc[type] : "local"));
2969         return o;
2970
2971     case OP_PREINC:
2972     case OP_PREDEC:
2973     case OP_POW:
2974     case OP_MULTIPLY:
2975     case OP_DIVIDE:
2976     case OP_MODULO:
2977     case OP_ADD:
2978     case OP_SUBTRACT:
2979     case OP_CONCAT:
2980     case OP_LEFT_SHIFT:
2981     case OP_RIGHT_SHIFT:
2982     case OP_BIT_AND:
2983     case OP_BIT_XOR:
2984     case OP_BIT_OR:
2985     case OP_I_MULTIPLY:
2986     case OP_I_DIVIDE:
2987     case OP_I_MODULO:
2988     case OP_I_ADD:
2989     case OP_I_SUBTRACT:
2990         if (!(o->op_flags & OPf_STACKED))
2991             goto nomod;
2992         PL_modcount++;
2993         break;
2994
2995     case OP_REPEAT:
2996         if (o->op_flags & OPf_STACKED) {
2997             PL_modcount++;
2998             break;
2999         }
3000         if (!(o->op_private & OPpREPEAT_DOLIST))
3001             goto nomod;
3002         else {
3003             const I32 mods = PL_modcount;
3004             modkids(cBINOPo->op_first, type);
3005             if (type != OP_AASSIGN)
3006                 goto nomod;
3007             kid = cBINOPo->op_last;
3008             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3009                 const IV iv = SvIV(kSVOP_sv);
3010                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3011                     PL_modcount =
3012                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3013             }
3014             else
3015                 PL_modcount = RETURN_UNLIMITED_NUMBER;
3016         }
3017         break;
3018
3019     case OP_COND_EXPR:
3020         localize = 1;
3021         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3022             op_lvalue(kid, type);
3023         break;
3024
3025     case OP_RV2AV:
3026     case OP_RV2HV:
3027         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3028            PL_modcount = RETURN_UNLIMITED_NUMBER;
3029             return o;           /* Treat \(@foo) like ordinary list. */
3030         }
3031         /* FALLTHROUGH */
3032     case OP_RV2GV:
3033         if (scalar_mod_type(o, type))
3034             goto nomod;
3035         ref(cUNOPo->op_first, o->op_type);
3036         /* FALLTHROUGH */
3037     case OP_ASLICE:
3038     case OP_HSLICE:
3039         localize = 1;
3040         /* FALLTHROUGH */
3041     case OP_AASSIGN:
3042         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
3043         if (type == OP_LEAVESUBLV && (
3044                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3045              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3046            ))
3047             o->op_private |= OPpMAYBE_LVSUB;
3048         /* FALLTHROUGH */
3049     case OP_NEXTSTATE:
3050     case OP_DBSTATE:
3051        PL_modcount = RETURN_UNLIMITED_NUMBER;
3052         break;
3053     case OP_KVHSLICE:
3054     case OP_KVASLICE:
3055     case OP_AKEYS:
3056         if (type == OP_LEAVESUBLV)
3057             o->op_private |= OPpMAYBE_LVSUB;
3058         goto nomod;
3059     case OP_AVHVSWITCH:
3060         if (type == OP_LEAVESUBLV
3061          && (o->op_private & 3) + OP_EACH == OP_KEYS)
3062             o->op_private |= OPpMAYBE_LVSUB;
3063         goto nomod;
3064     case OP_AV2ARYLEN:
3065         PL_hints |= HINT_BLOCK_SCOPE;
3066         if (type == OP_LEAVESUBLV)
3067             o->op_private |= OPpMAYBE_LVSUB;
3068         PL_modcount++;
3069         break;
3070     case OP_RV2SV:
3071         ref(cUNOPo->op_first, o->op_type);
3072         localize = 1;
3073         /* FALLTHROUGH */
3074     case OP_GV:
3075         PL_hints |= HINT_BLOCK_SCOPE;
3076         /* FALLTHROUGH */
3077     case OP_SASSIGN:
3078     case OP_ANDASSIGN:
3079     case OP_ORASSIGN:
3080     case OP_DORASSIGN:
3081         PL_modcount++;
3082         break;
3083
3084     case OP_AELEMFAST:
3085     case OP_AELEMFAST_LEX:
3086         localize = -1;
3087         PL_modcount++;
3088         break;
3089
3090     case OP_PADAV:
3091     case OP_PADHV:
3092        PL_modcount = RETURN_UNLIMITED_NUMBER;
3093         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3094             return o;           /* Treat \(@foo) like ordinary list. */
3095         if (scalar_mod_type(o, type))
3096             goto nomod;
3097         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3098           && type == OP_LEAVESUBLV)
3099             o->op_private |= OPpMAYBE_LVSUB;
3100         /* FALLTHROUGH */
3101     case OP_PADSV:
3102         PL_modcount++;
3103         if (!type) /* local() */
3104             Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3105                               PNfARG(PAD_COMPNAME(o->op_targ)));
3106         if (!(o->op_private & OPpLVAL_INTRO)
3107          || (  type != OP_SASSIGN && type != OP_AASSIGN
3108             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
3109             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3110         break;
3111
3112     case OP_PUSHMARK:
3113         localize = 0;
3114         break;
3115
3116     case OP_KEYS:
3117         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3118             goto nomod;
3119         goto lvalue_func;
3120     case OP_SUBSTR:
3121         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3122             goto nomod;
3123         /* FALLTHROUGH */
3124     case OP_POS:
3125     case OP_VEC:
3126       lvalue_func:
3127         if (type == OP_LEAVESUBLV)
3128             o->op_private |= OPpMAYBE_LVSUB;
3129         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3130             /* substr and vec */
3131             /* If this op is in merely potential (non-fatal) modifiable
3132                context, then apply OP_ENTERSUB context to
3133                the kid op (to avoid croaking).  Other-
3134                wise pass this op’s own type so the correct op is mentioned
3135                in error messages.  */
3136             op_lvalue(OpSIBLING(cBINOPo->op_first),
3137                       S_potential_mod_type(type)
3138                         ? (I32)OP_ENTERSUB
3139                         : o->op_type);
3140         }
3141         break;
3142
3143     case OP_AELEM:
3144     case OP_HELEM:
3145         ref(cBINOPo->op_first, o->op_type);
3146         if (type == OP_ENTERSUB &&
3147              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3148             o->op_private |= OPpLVAL_DEFER;
3149         if (type == OP_LEAVESUBLV)
3150             o->op_private |= OPpMAYBE_LVSUB;
3151         localize = 1;
3152         PL_modcount++;
3153         break;
3154
3155     case OP_LEAVE:
3156     case OP_LEAVELOOP:
3157         o->op_private |= OPpLVALUE;
3158         /* FALLTHROUGH */
3159     case OP_SCOPE:
3160     case OP_ENTER:
3161     case OP_LINESEQ:
3162         localize = 0;
3163         if (o->op_flags & OPf_KIDS)
3164             op_lvalue(cLISTOPo->op_last, type);
3165         break;
3166
3167     case OP_NULL:
3168         localize = 0;
3169         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3170             goto nomod;
3171         else if (!(o->op_flags & OPf_KIDS))
3172             break;
3173         if (o->op_targ != OP_LIST) {
3174             op_lvalue(cBINOPo->op_first, type);
3175             break;
3176         }
3177         /* FALLTHROUGH */
3178     case OP_LIST:
3179         localize = 0;
3180         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3181             /* elements might be in void context because the list is
3182                in scalar context or because they are attribute sub calls */
3183             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3184                 op_lvalue(kid, type);
3185         break;
3186
3187     case OP_COREARGS:
3188         return o;
3189
3190     case OP_AND:
3191     case OP_OR:
3192         if (type == OP_LEAVESUBLV
3193          || !S_vivifies(cLOGOPo->op_first->op_type))
3194             op_lvalue(cLOGOPo->op_first, type);
3195         if (type == OP_LEAVESUBLV
3196          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3197             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3198         goto nomod;
3199
3200     case OP_SREFGEN:
3201         if (type == OP_NULL) { /* local */
3202           local_refgen:
3203             if (!FEATURE_MYREF_IS_ENABLED)
3204                 Perl_croak(aTHX_ "The experimental declared_refs "
3205                                  "feature is not enabled");
3206             Perl_ck_warner_d(aTHX_
3207                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3208                     "Declaring references is experimental");
3209             op_lvalue(cUNOPo->op_first, OP_NULL);
3210             return o;
3211         }
3212         if (type != OP_AASSIGN && type != OP_SASSIGN
3213          && type != OP_ENTERLOOP)
3214             goto nomod;
3215         /* Don’t bother applying lvalue context to the ex-list.  */
3216         kid = cUNOPx(cUNOPo->op_first)->op_first;
3217         assert (!OpHAS_SIBLING(kid));
3218         goto kid_2lvref;
3219     case OP_REFGEN:
3220         if (type == OP_NULL) /* local */
3221             goto local_refgen;
3222         if (type != OP_AASSIGN) goto nomod;
3223         kid = cUNOPo->op_first;
3224       kid_2lvref:
3225         {
3226             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3227             S_lvref(aTHX_ kid, type);
3228             if (!PL_parser || PL_parser->error_count == ec) {
3229                 if (!FEATURE_REFALIASING_IS_ENABLED)
3230                     Perl_croak(aTHX_
3231                        "Experimental aliasing via reference not enabled");
3232                 Perl_ck_warner_d(aTHX_
3233                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3234                                 "Aliasing via reference is experimental");
3235             }
3236         }
3237         if (o->op_type == OP_REFGEN)
3238             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3239         op_null(o);
3240         return o;
3241
3242     case OP_SPLIT:
3243         kid = cLISTOPo->op_first;
3244         if (kid && kid->op_type == OP_PUSHRE &&
3245                 (  kid->op_targ
3246                 || o->op_flags & OPf_STACKED
3247 #ifdef USE_ITHREADS
3248                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3249 #else
3250                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3251 #endif
3252         )) {
3253             /* This is actually @array = split.  */
3254             PL_modcount = RETURN_UNLIMITED_NUMBER;
3255             break;
3256         }
3257         goto nomod;
3258
3259     case OP_SCALAR:
3260         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3261         goto nomod;
3262     }
3263
3264     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3265        their argument is a filehandle; thus \stat(".") should not set
3266        it. AMS 20011102 */
3267     if (type == OP_REFGEN &&
3268         PL_check[o->op_type] == Perl_ck_ftst)
3269         return o;
3270
3271     if (type != OP_LEAVESUBLV)
3272         o->op_flags |= OPf_MOD;
3273
3274     if (type == OP_AASSIGN || type == OP_SASSIGN)
3275         o->op_flags |= OPf_SPECIAL
3276                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
3277     else if (!type) { /* local() */
3278         switch (localize) {
3279         case 1:
3280             o->op_private |= OPpLVAL_INTRO;
3281             o->op_flags &= ~OPf_SPECIAL;
3282             PL_hints |= HINT_BLOCK_SCOPE;
3283             break;
3284         case 0:
3285             break;
3286         case -1:
3287             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3288                            "Useless localization of %s", OP_DESC(o));
3289         }
3290     }
3291     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3292              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3293         o->op_flags |= OPf_REF;
3294     return o;
3295 }
3296
3297 STATIC bool
3298 S_scalar_mod_type(const OP *o, I32 type)
3299 {
3300     switch (type) {
3301     case OP_POS:
3302     case OP_SASSIGN:
3303         if (o && o->op_type == OP_RV2GV)
3304             return FALSE;
3305         /* FALLTHROUGH */
3306     case OP_PREINC:
3307     case OP_PREDEC:
3308     case OP_POSTINC:
3309     case OP_POSTDEC:
3310     case OP_I_PREINC:
3311     case OP_I_PREDEC:
3312     case OP_I_POSTINC:
3313     case OP_I_POSTDEC:
3314     case OP_POW:
3315     case OP_MULTIPLY:
3316     case OP_DIVIDE:
3317     case OP_MODULO:
3318     case OP_REPEAT:
3319     case OP_ADD:
3320     case OP_SUBTRACT:
3321     case OP_I_MULTIPLY:
3322     case OP_I_DIVIDE:
3323     case OP_I_MODULO:
3324     case OP_I_ADD:
3325     case OP_I_SUBTRACT:
3326     case OP_LEFT_SHIFT:
3327     case OP_RIGHT_SHIFT:
3328     case OP_BIT_AND:
3329     case OP_BIT_XOR:
3330     case OP_BIT_OR:
3331     case OP_NBIT_AND:
3332     case OP_NBIT_XOR:
3333     case OP_NBIT_OR:
3334     case OP_SBIT_AND:
3335     case OP_SBIT_XOR:
3336     case OP_SBIT_OR:
3337     case OP_CONCAT:
3338     case OP_SUBST:
3339     case OP_TRANS:
3340     case OP_TRANSR:
3341     case OP_READ:
3342     case OP_SYSREAD:
3343     case OP_RECV:
3344     case OP_ANDASSIGN:
3345     case OP_ORASSIGN:
3346     case OP_DORASSIGN:
3347     case OP_VEC:
3348     case OP_SUBSTR:
3349         return TRUE;
3350     default:
3351         return FALSE;
3352     }
3353 }
3354
3355 STATIC bool
3356 S_is_handle_constructor(const OP *o, I32 numargs)
3357 {
3358     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3359
3360     switch (o->op_type) {
3361     case OP_PIPE_OP:
3362     case OP_SOCKPAIR:
3363         if (numargs == 2)
3364             return TRUE;
3365         /* FALLTHROUGH */
3366     case OP_SYSOPEN:
3367     case OP_OPEN:
3368     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3369     case OP_SOCKET:
3370     case OP_OPEN_DIR:
3371     case OP_ACCEPT:
3372         if (numargs == 1)
3373             return TRUE;
3374         /* FALLTHROUGH */
3375     default:
3376         return FALSE;
3377     }
3378 }
3379
3380 static OP *
3381 S_refkids(pTHX_ OP *o, I32 type)
3382 {
3383     if (o && o->op_flags & OPf_KIDS) {
3384         OP *kid;
3385         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3386             ref(kid, type);
3387     }
3388     return o;
3389 }
3390
3391 OP *
3392 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3393 {
3394     dVAR;
3395     OP *kid;
3396
3397     PERL_ARGS_ASSERT_DOREF;
3398
3399     if (PL_parser && PL_parser->error_count)
3400         return o;
3401
3402     switch (o->op_type) {
3403     case OP_ENTERSUB:
3404         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3405             !(o->op_flags & OPf_STACKED)) {
3406             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3407             assert(cUNOPo->op_first->op_type == OP_NULL);
3408             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3409             o->op_flags |= OPf_SPECIAL;
3410         }
3411         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3412             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3413                               : type == OP_RV2HV ? OPpDEREF_HV
3414                               : OPpDEREF_SV);
3415             o->op_flags |= OPf_MOD;
3416         }
3417
3418         break;
3419
3420     case OP_COND_EXPR:
3421         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3422             doref(kid, type, set_op_ref);
3423         break;
3424     case OP_RV2SV:
3425         if (type == OP_DEFINED)
3426             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3427         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3428         /* FALLTHROUGH */
3429     case OP_PADSV:
3430         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3431             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3432                               : type == OP_RV2HV ? OPpDEREF_HV
3433                               : OPpDEREF_SV);
3434             o->op_flags |= OPf_MOD;
3435         }
3436         break;
3437
3438     case OP_RV2AV:
3439     case OP_RV2HV:
3440         if (set_op_ref)
3441             o->op_flags |= OPf_REF;
3442         /* FALLTHROUGH */
3443     case OP_RV2GV:
3444         if (type == OP_DEFINED)
3445             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3446         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3447         break;
3448
3449     case OP_PADAV:
3450     case OP_PADHV:
3451         if (set_op_ref)
3452             o->op_flags |= OPf_REF;
3453         break;
3454
3455     case OP_SCALAR:
3456     case OP_NULL:
3457         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3458             break;
3459         doref(cBINOPo->op_first, type, set_op_ref);
3460         break;
3461     case OP_AELEM:
3462     case OP_HELEM:
3463         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3464         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3465             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3466                               : type == OP_RV2HV ? OPpDEREF_HV
3467                               : OPpDEREF_SV);
3468             o->op_flags |= OPf_MOD;
3469         }
3470         break;
3471
3472     case OP_SCOPE:
3473     case OP_LEAVE:
3474         set_op_ref = FALSE;
3475         /* FALLTHROUGH */
3476     case OP_ENTER:
3477     case OP_LIST:
3478         if (!(o->op_flags & OPf_KIDS))
3479             break;
3480         doref(cLISTOPo->op_last, type, set_op_ref);
3481         break;
3482     default:
3483         break;
3484     }
3485     return scalar(o);
3486
3487 }
3488
3489 STATIC OP *
3490 S_dup_attrlist(pTHX_ OP *o)
3491 {
3492     OP *rop;
3493
3494     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3495
3496     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3497      * where the first kid is OP_PUSHMARK and the remaining ones
3498      * are OP_CONST.  We need to push the OP_CONST values.
3499      */
3500     if (o->op_type == OP_CONST)
3501         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3502     else {
3503         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3504         rop = NULL;
3505         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3506             if (o->op_type == OP_CONST)
3507                 rop = op_append_elem(OP_LIST, rop,
3508                                   newSVOP(OP_CONST, o->op_flags,
3509                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3510         }
3511     }
3512     return rop;
3513 }
3514
3515 STATIC void
3516 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3517 {
3518     PERL_ARGS_ASSERT_APPLY_ATTRS;
3519     {
3520         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3521
3522         /* fake up C<use attributes $pkg,$rv,@attrs> */
3523
3524 #define ATTRSMODULE "attributes"
3525 #define ATTRSMODULE_PM "attributes.pm"
3526
3527         Perl_load_module(
3528           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3529           newSVpvs(ATTRSMODULE),
3530           NULL,
3531           op_prepend_elem(OP_LIST,
3532                           newSVOP(OP_CONST, 0, stashsv),
3533                           op_prepend_elem(OP_LIST,
3534                                           newSVOP(OP_CONST, 0,
3535                                                   newRV(target)),
3536                                           dup_attrlist(attrs))));
3537     }
3538 }
3539
3540 STATIC void
3541 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3542 {
3543     OP *pack, *imop, *arg;
3544     SV *meth, *stashsv, **svp;
3545
3546     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3547
3548     if (!attrs)
3549         return;
3550
3551     assert(target->op_type == OP_PADSV ||
3552            target->op_type == OP_PADHV ||
3553            target->op_type == OP_PADAV);
3554
3555     /* Ensure that attributes.pm is loaded. */
3556     /* Don't force the C<use> if we don't need it. */
3557     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3558     if (svp && *svp != &PL_sv_undef)
3559         NOOP;   /* already in %INC */
3560     else
3561         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3562                                newSVpvs(ATTRSMODULE), NULL);
3563
3564     /* Need package name for method call. */
3565     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3566
3567     /* Build up the real arg-list. */
3568     stashsv = newSVhek(HvNAME_HEK(stash));
3569
3570     arg = newOP(OP_PADSV, 0);
3571     arg->op_targ = target->op_targ;
3572     arg = op_prepend_elem(OP_LIST,
3573                        newSVOP(OP_CONST, 0, stashsv),
3574                        op_prepend_elem(OP_LIST,
3575                                     newUNOP(OP_REFGEN, 0,
3576                                             arg),
3577                                     dup_attrlist(attrs)));
3578
3579     /* Fake up a method call to import */
3580     meth = newSVpvs_share("import");
3581     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3582                    op_append_elem(OP_LIST,
3583                                op_prepend_elem(OP_LIST, pack, arg),
3584                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3585
3586     /* Combine the ops. */
3587     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3588 }
3589
3590 /*
3591 =notfor apidoc apply_attrs_string
3592
3593 Attempts to apply a list of attributes specified by the C<attrstr> and
3594 C<len> arguments to the subroutine identified by the C<cv> argument which
3595 is expected to be associated with the package identified by the C<stashpv>
3596 argument (see L<attributes>).  It gets this wrong, though, in that it
3597 does not correctly identify the boundaries of the individual attribute
3598 specifications within C<attrstr>.  This is not really intended for the
3599 public API, but has to be listed here for systems such as AIX which
3600 need an explicit export list for symbols.  (It's called from XS code
3601 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3602 to respect attribute syntax properly would be welcome.
3603
3604 =cut
3605 */
3606
3607 void
3608 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3609                         const char *attrstr, STRLEN len)
3610 {
3611     OP *attrs = NULL;
3612
3613     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3614
3615     if (!len) {
3616         len = strlen(attrstr);
3617     }
3618
3619     while (len) {
3620         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3621         if (len) {
3622             const char * const sstr = attrstr;
3623             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3624             attrs = op_append_elem(OP_LIST, attrs,
3625                                 newSVOP(OP_CONST, 0,
3626                                         newSVpvn(sstr, attrstr-sstr)));
3627         }
3628     }
3629
3630     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3631                      newSVpvs(ATTRSMODULE),
3632                      NULL, op_prepend_elem(OP_LIST,
3633                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3634                                   op_prepend_elem(OP_LIST,
3635                                                newSVOP(OP_CONST, 0,
3636                                                        newRV(MUTABLE_SV(cv))),
3637                                                attrs)));
3638 }
3639
3640 STATIC void
3641 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3642 {
3643     OP *new_proto = NULL;
3644     STRLEN pvlen;
3645     char *pv;
3646     OP *o;
3647
3648     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3649
3650     if (!*attrs)
3651         return;
3652
3653     o = *attrs;
3654     if (o->op_type == OP_CONST) {
3655         pv = SvPV(cSVOPo_sv, pvlen);
3656         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3657             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3658             SV ** const tmpo = cSVOPx_svp(o);
3659             SvREFCNT_dec(cSVOPo_sv);
3660             *tmpo = tmpsv;
3661             new_proto = o;
3662             *attrs = NULL;
3663         }
3664     } else if (o->op_type == OP_LIST) {
3665         OP * lasto;
3666         assert(o->op_flags & OPf_KIDS);
3667         lasto = cLISTOPo->op_first;
3668         assert(lasto->op_type == OP_PUSHMARK);
3669         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3670             if (o->op_type == OP_CONST) {
3671                 pv = SvPV(cSVOPo_sv, pvlen);
3672                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3673                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3674                     SV ** const tmpo = cSVOPx_svp(o);
3675                     SvREFCNT_dec(cSVOPo_sv);
3676                     *tmpo = tmpsv;
3677                     if (new_proto && ckWARN(WARN_MISC)) {
3678                         STRLEN new_len;
3679                         const char * newp = SvPV(cSVOPo_sv, new_len);
3680                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3681                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3682                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3683                         op_free(new_proto);
3684                     }
3685                     else if (new_proto)
3686                         op_free(new_proto);
3687                     new_proto = o;
3688                     /* excise new_proto from the list */
3689                     op_sibling_splice(*attrs, lasto, 1, NULL);
3690                     o = lasto;
3691                     continue;
3692                 }
3693             }
3694             lasto = o;
3695         }
3696         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3697            would get pulled in with no real need */
3698         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3699             op_free(*attrs);
3700             *attrs = NULL;
3701         }
3702     }
3703
3704     if (new_proto) {
3705         SV *svname;
3706         if (isGV(name)) {
3707             svname = sv_newmortal();
3708             gv_efullname3(svname, name, NULL);
3709         }
3710         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3711             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3712         else
3713             svname = (SV *)name;
3714         if (ckWARN(WARN_ILLEGALPROTO))
3715             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3716         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3717             STRLEN old_len, new_len;
3718             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3719             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3720
3721             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3722                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3723                 " in %"SVf,
3724                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3725                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3726                 SVfARG(svname));
3727         }
3728         if (*proto)
3729             op_free(*proto);
3730         *proto = new_proto;
3731     }
3732 }
3733
3734 static void
3735 S_cant_declare(pTHX_ OP *o)
3736 {
3737     if (o->op_type == OP_NULL
3738      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3739         o = cUNOPo->op_first;
3740     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3741                              o->op_type == OP_NULL
3742                                && o->op_flags & OPf_SPECIAL
3743                                  ? "do block"
3744                                  : OP_DESC(o),
3745                              PL_parser->in_my == KEY_our   ? "our"   :
3746                              PL_parser->in_my == KEY_state ? "state" :
3747                                                              "my"));
3748 }
3749
3750 STATIC OP *
3751 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3752 {
3753     I32 type;
3754     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3755
3756     PERL_ARGS_ASSERT_MY_KID;
3757
3758     if (!o || (PL_parser && PL_parser->error_count))
3759         return o;
3760
3761     type = o->op_type;
3762
3763     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3764         OP *kid;
3765         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3766             my_kid(kid, attrs, imopsp);
3767         return o;
3768     } else if (type == OP_UNDEF || type == OP_STUB) {
3769         return o;
3770     } else if (type == OP_RV2SV ||      /* "our" declaration */
3771                type == OP_RV2AV ||
3772                type == OP_RV2HV) {
3773         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3774             S_cant_declare(aTHX_ o);
3775         } else if (attrs) {
3776             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3777             assert(PL_parser);
3778             PL_parser->in_my = FALSE;
3779             PL_parser->in_my_stash = NULL;
3780             apply_attrs(GvSTASH(gv),
3781                         (type == OP_RV2SV ? GvSV(gv) :
3782                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3783                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3784                         attrs);
3785         }
3786         o->op_private |= OPpOUR_INTRO;
3787         return o;
3788     }
3789     else if (type == OP_REFGEN || type == OP_SREFGEN) {
3790         if (!FEATURE_MYREF_IS_ENABLED)
3791             Perl_croak(aTHX_ "The experimental declared_refs "
3792                              "feature is not enabled");
3793         Perl_ck_warner_d(aTHX_
3794              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3795             "Declaring references is experimental");
3796         /* Kid is a nulled OP_LIST, handled above.  */
3797         my_kid(cUNOPo->op_first, attrs, imopsp);
3798         return o;
3799     }
3800     else if (type != OP_PADSV &&
3801              type != OP_PADAV &&
3802              type != OP_PADHV &&
3803              type != OP_PUSHMARK)
3804     {
3805         S_cant_declare(aTHX_ o);
3806         return o;
3807     }
3808     else if (attrs && type != OP_PUSHMARK) {
3809         HV *stash;
3810
3811         assert(PL_parser);
3812         PL_parser->in_my = FALSE;
3813         PL_parser->in_my_stash = NULL;
3814
3815         /* check for C<my Dog $spot> when deciding package */
3816         stash = PAD_COMPNAME_TYPE(o->op_targ);
3817         if (!stash)
3818             stash = PL_curstash;
3819         apply_attrs_my(stash, o, attrs, imopsp);
3820     }
3821     o->op_flags |= OPf_MOD;
3822     o->op_private |= OPpLVAL_INTRO;
3823     if (stately)
3824         o->op_private |= OPpPAD_STATE;
3825     return o;
3826 }
3827
3828 OP *
3829 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3830 {
3831     OP *rops;
3832     int maybe_scalar = 0;
3833
3834     PERL_ARGS_ASSERT_MY_ATTRS;
3835
3836 /* [perl #17376]: this appears to be premature, and results in code such as
3837    C< our(%x); > executing in list mode rather than void mode */
3838 #if 0
3839     if (o->op_flags & OPf_PARENS)
3840         list(o);
3841     else
3842         maybe_scalar = 1;
3843 #else
3844     maybe_scalar = 1;
3845 #endif
3846     if (attrs)
3847         SAVEFREEOP(attrs);
3848     rops = NULL;
3849     o = my_kid(o, attrs, &rops);
3850     if (rops) {
3851         if (maybe_scalar && o->op_type == OP_PADSV) {
3852             o = scalar(op_append_list(OP_LIST, rops, o));
3853             o->op_private |= OPpLVAL_INTRO;
3854         }
3855         else {
3856             /* The listop in rops might have a pushmark at the beginning,
3857                which will mess up list assignment. */
3858             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3859             if (rops->op_type == OP_LIST &&
3860                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3861             {
3862                 OP * const pushmark = lrops->op_first;
3863                 /* excise pushmark */
3864                 op_sibling_splice(rops, NULL, 1, NULL);
3865                 op_free(pushmark);
3866             }
3867             o = op_append_list(OP_LIST, o, rops);
3868         }
3869     }
3870     PL_parser->in_my = FALSE;
3871     PL_parser->in_my_stash = NULL;
3872     return o;
3873 }
3874
3875 OP *
3876 Perl_sawparens(pTHX_ OP *o)
3877 {
3878     PERL_UNUSED_CONTEXT;
3879     if (o)
3880         o->op_flags |= OPf_PARENS;
3881     return o;
3882 }
3883
3884 OP *
3885 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3886 {
3887     OP *o;
3888     bool ismatchop = 0;
3889     const OPCODE ltype = left->op_type;
3890     const OPCODE rtype = right->op_type;
3891
3892     PERL_ARGS_ASSERT_BIND_MATCH;
3893
3894     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3895           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3896     {
3897       const char * const desc
3898           = PL_op_desc[(
3899                           rtype == OP_SUBST || rtype == OP_TRANS
3900                        || rtype == OP_TRANSR
3901                        )
3902                        ? (int)rtype : OP_MATCH];
3903       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3904       SV * const name =
3905         S_op_varname(aTHX_ left);
3906       if (name)
3907         Perl_warner(aTHX_ packWARN(WARN_MISC),
3908              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3909              desc, SVfARG(name), SVfARG(name));
3910       else {
3911         const char * const sample = (isary
3912              ? "@array" : "%hash");
3913         Perl_warner(aTHX_ packWARN(WARN_MISC),
3914              "Applying %s to %s will act on scalar(%s)",
3915              desc, sample, sample);
3916       }
3917     }
3918
3919     if (rtype == OP_CONST &&
3920         cSVOPx(right)->op_private & OPpCONST_BARE &&
3921         cSVOPx(right)->op_private & OPpCONST_STRICT)
3922     {
3923         no_bareword_allowed(right);
3924     }
3925
3926     /* !~ doesn't make sense with /r, so error on it for now */
3927     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3928         type == OP_NOT)
3929         /* diag_listed_as: Using !~ with %s doesn't make sense */
3930         yyerror("Using !~ with s///r doesn't make sense");
3931     if (rtype == OP_TRANSR && type == OP_NOT)
3932         /* diag_listed_as: Using !~ with %s doesn't make sense */
3933         yyerror("Using !~ with tr///r doesn't make sense");
3934
3935     ismatchop = (rtype == OP_MATCH ||
3936                  rtype == OP_SUBST ||
3937                  rtype == OP_TRANS || rtype == OP_TRANSR)
3938              && !(right->op_flags & OPf_SPECIAL);
3939     if (ismatchop && right->op_private & OPpTARGET_MY) {
3940         right->op_targ = 0;
3941         right->op_private &= ~OPpTARGET_MY;
3942     }
3943     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3944         if (left->op_type == OP_PADSV
3945          && !(left->op_private & OPpLVAL_INTRO))
3946         {
3947             right->op_targ = left->op_targ;
3948             op_free(left);
3949             o = right;
3950         }
3951         else {
3952             right->op_flags |= OPf_STACKED;
3953             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3954             ! (rtype == OP_TRANS &&
3955                right->op_private & OPpTRANS_IDENTICAL) &&
3956             ! (rtype == OP_SUBST &&
3957                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3958                 left = op_lvalue(left, rtype);
3959             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3960                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3961             else
3962                 o = op_prepend_elem(rtype, scalar(left), right);
3963         }
3964         if (type == OP_NOT)
3965             return newUNOP(OP_NOT, 0, scalar(o));
3966         return o;
3967     }
3968     else
3969         return bind_match(type, left,
3970                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3971 }
3972
3973 OP *
3974 Perl_invert(pTHX_ OP *o)
3975 {
3976     if (!o)
3977         return NULL;
3978     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3979 }
3980
3981 /*
3982 =for apidoc Amx|OP *|op_scope|OP *o
3983
3984 Wraps up an op tree with some additional ops so that at runtime a dynamic
3985 scope will be created.  The original ops run in the new dynamic scope,
3986 and then, provided that they exit normally, the scope will be unwound.
3987 The additional ops used to create and unwind the dynamic scope will
3988 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3989 instead if the ops are simple enough to not need the full dynamic scope
3990 structure.
3991
3992 =cut
3993 */
3994
3995 OP *
3996 Perl_op_scope(pTHX_ OP *o)
3997 {
3998     dVAR;
3999     if (o) {
4000         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
4001             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
4002             OpTYPE_set(o, OP_LEAVE);
4003         }
4004         else if (o->op_type == OP_LINESEQ) {
4005             OP *kid;
4006             OpTYPE_set(o, OP_SCOPE);
4007             kid = ((LISTOP*)o)->op_first;
4008             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4009                 op_null(kid);
4010
4011                 /* The following deals with things like 'do {1 for 1}' */
4012                 kid = OpSIBLING(kid);
4013                 if (kid &&
4014                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4015                     op_null(kid);
4016             }
4017         }
4018         else
4019             o = newLISTOP(OP_SCOPE, 0, o, NULL);
4020     }
4021     return o;
4022 }
4023
4024 OP *
4025 Perl_op_unscope(pTHX_ OP *o)
4026 {
4027     if (o && o->op_type == OP_LINESEQ) {
4028         OP *kid = cLISTOPo->op_first;
4029         for(; kid; kid = OpSIBLING(kid))
4030             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4031                 op_null(kid);
4032     }
4033     return o;
4034 }
4035
4036 /*
4037 =for apidoc Am|int|block_start|int full
4038
4039 Handles compile-time scope entry.
4040 Arranges for hints to be restored on block
4041 exit and also handles pad sequence numbers to make lexical variables scope
4042 right.  Returns a savestack index for use with C<block_end>.
4043
4044 =cut
4045 */
4046
4047 int
4048 Perl_block_start(pTHX_ int full)
4049 {
4050     const int retval = PL_savestack_ix;
4051
4052     PL_compiling.cop_seq = PL_cop_seqmax;
4053     COP_SEQMAX_INC;
4054     pad_block_start(full);
4055     SAVEHINTS();
4056     PL_hints &= ~HINT_BLOCK_SCOPE;
4057     SAVECOMPILEWARNINGS();
4058     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4059     SAVEI32(PL_compiling.cop_seq);
4060     PL_compiling.cop_seq = 0;
4061
4062     CALL_BLOCK_HOOKS(bhk_start, full);
4063
4064     return retval;
4065 }
4066
4067 /*
4068 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4069
4070 Handles compile-time scope exit.  C<floor>
4071 is the savestack index returned by
4072 C<block_start>, and C<seq> is the body of the block.  Returns the block,
4073 possibly modified.
4074
4075 =cut
4076 */
4077
4078 OP*
4079 Perl_block_end(pTHX_ I32 floor, OP *seq)
4080 {
4081     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4082     OP* retval = scalarseq(seq);
4083     OP *o;
4084
4085     /* XXX Is the null PL_parser check necessary here? */
4086     assert(PL_parser); /* Let’s find out under debugging builds.  */
4087     if (PL_parser && PL_parser->parsed_sub) {
4088         o = newSTATEOP(0, NULL, NULL);
4089         op_null(o);
4090         retval = op_append_elem(OP_LINESEQ, retval, o);
4091     }
4092
4093     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4094
4095     LEAVE_SCOPE(floor);
4096     if (needblockscope)
4097         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4098     o = pad_leavemy();
4099
4100     if (o) {
4101         /* pad_leavemy has created a sequence of introcv ops for all my
4102            subs declared in the block.  We have to replicate that list with
4103            clonecv ops, to deal with this situation:
4104
4105                sub {
4106                    my sub s1;
4107                    my sub s2;
4108                    sub s1 { state sub foo { \&s2 } }
4109                }->()
4110
4111            Originally, I was going to have introcv clone the CV and turn
4112            off the stale flag.  Since &s1 is declared before &s2, the
4113            introcv op for &s1 is executed (on sub entry) before the one for
4114            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
4115            cloned, since it is a state sub) closes over &s2 and expects
4116            to see it in its outer CV’s pad.  If the introcv op clones &s1,
4117            then &s2 is still marked stale.  Since &s1 is not active, and
4118            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4119            ble will not stay shared’ warning.  Because it is the same stub
4120            that will be used when the introcv op for &s2 is executed, clos-
4121            ing over it is safe.  Hence, we have to turn off the stale flag
4122            on all lexical subs in the block before we clone any of them.
4123            Hence, having introcv clone the sub cannot work.  So we create a
4124            list of ops like this:
4125
4126                lineseq
4127                   |
4128                   +-- introcv
4129                   |
4130                   +-- introcv
4131                   |
4132                   +-- introcv
4133                   |
4134                   .
4135                   .
4136                   .
4137                   |
4138                   +-- clonecv
4139                   |
4140                   +-- clonecv
4141                   |
4142                   +-- clonecv
4143                   |
4144                   .
4145                   .
4146                   .
4147          */
4148         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4149         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4150         for (;; kid = OpSIBLING(kid)) {
4151             OP *newkid = newOP(OP_CLONECV, 0);
4152             newkid->op_targ = kid->op_targ;
4153             o = op_append_elem(OP_LINESEQ, o, newkid);
4154             if (kid == last) break;
4155         }
4156         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4157     }
4158
4159     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4160
4161     return retval;
4162 }
4163
4164 /*
4165 =head1 Compile-time scope hooks
4166
4167 =for apidoc Aox||blockhook_register
4168
4169 Register a set of hooks to be called when the Perl lexical scope changes
4170 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4171
4172 =cut
4173 */
4174
4175 void
4176 Perl_blockhook_register(pTHX_ BHK *hk)
4177 {
4178     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4179
4180     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4181 }
4182
4183 void
4184 Perl_newPROG(pTHX_ OP *o)
4185 {
4186     PERL_ARGS_ASSERT_NEWPROG;
4187
4188     if (PL_in_eval) {
4189         PERL_CONTEXT *cx;
4190         I32 i;
4191         if (PL_eval_root)
4192                 return;
4193         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4194                                ((PL_in_eval & EVAL_KEEPERR)
4195                                 ? OPf_SPECIAL : 0), o);
4196
4197         cx = CX_CUR();
4198         assert(CxTYPE(cx) == CXt_EVAL);
4199
4200         if ((cx->blk_gimme & G_WANT) == G_VOID)
4201             scalarvoid(PL_eval_root);
4202         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4203             list(PL_eval_root);
4204         else
4205             scalar(PL_eval_root);
4206
4207         PL_eval_start = op_linklist(PL_eval_root);
4208         PL_eval_root->op_private |= OPpREFCOUNTED;
4209         OpREFCNT_set(PL_eval_root, 1);
4210         PL_eval_root->op_next = 0;
4211         i = PL_savestack_ix;
4212         SAVEFREEOP(o);
4213         ENTER;
4214         CALL_PEEP(PL_eval_start);
4215         finalize_optree(PL_eval_root);
4216         S_prune_chain_head(&PL_eval_start);
4217         LEAVE;
4218         PL_savestack_ix = i;
4219     }
4220     else {
4221         if (o->op_type == OP_STUB) {
4222             /* This block is entered if nothing is compiled for the main
4223                program. This will be the case for an genuinely empty main
4224                program, or one which only has BEGIN blocks etc, so already
4225                run and freed.
4226
4227                Historically (5.000) the guard above was !o. However, commit
4228                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4229                c71fccf11fde0068, changed perly.y so that newPROG() is now
4230                called with the output of block_end(), which returns a new
4231                OP_STUB for the case of an empty optree. ByteLoader (and
4232                maybe other things) also take this path, because they set up
4233                PL_main_start and PL_main_root directly, without generating an
4234                optree.
4235
4236                If the parsing the main program aborts (due to parse errors,
4237                or due to BEGIN or similar calling exit), then newPROG()
4238                isn't even called, and hence this code path and its cleanups
4239                are skipped. This shouldn't make a make a difference:
4240                * a non-zero return from perl_parse is a failure, and
4241                  perl_destruct() should be called immediately.
4242                * however, if exit(0) is called during the parse, then
4243                  perl_parse() returns 0, and perl_run() is called. As
4244                  PL_main_start will be NULL, perl_run() will return
4245                  promptly, and the exit code will remain 0.
4246             */
4247
4248             PL_comppad_name = 0;
4249             PL_compcv = 0;
4250             S_op_destroy(aTHX_ o);
4251             return;
4252         }
4253         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4254         PL_curcop = &PL_compiling;
4255         PL_main_start = LINKLIST(PL_main_root);
4256         PL_main_root->op_private |= OPpREFCOUNTED;
4257         OpREFCNT_set(PL_main_root, 1);
4258         PL_main_root->op_next = 0;
4259         CALL_PEEP(PL_main_start);
4260         finalize_optree(PL_main_root);
4261         S_prune_chain_head(&PL_main_start);
4262         cv_forget_slab(PL_compcv);
4263         PL_compcv = 0;
4264
4265         /* Register with debugger */
4266         if (PERLDB_INTER) {
4267             CV * const cv = get_cvs("DB::postponed", 0);
4268             if (cv) {
4269                 dSP;
4270                 PUSHMARK(SP);
4271                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4272                 PUTBACK;
4273                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4274             }
4275         }
4276     }
4277 }
4278
4279 OP *
4280 Perl_localize(pTHX_ OP *o, I32 lex)
4281 {
4282     PERL_ARGS_ASSERT_LOCALIZE;
4283
4284     if (o->op_flags & OPf_PARENS)
4285 /* [perl #17376]: this appears to be premature, and results in code such as
4286    C< our(%x); > executing in list mode rather than void mode */
4287 #if 0
4288         list(o);
4289 #else
4290         NOOP;
4291 #endif
4292     else {
4293         if ( PL_parser->bufptr > PL_parser->oldbufptr
4294             && PL_parser->bufptr[-1] == ','
4295             && ckWARN(WARN_PARENTHESIS))
4296         {
4297             char *s = PL_parser->bufptr;
4298             bool sigil = FALSE;
4299
4300             /* some heuristics to detect a potential error */
4301             while (*s && (strchr(", \t\n", *s)))
4302                 s++;
4303
4304             while (1) {
4305                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4306                        && *++s
4307                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4308                     s++;
4309                     sigil = TRUE;
4310                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4311                         s++;
4312                     while (*s && (strchr(", \t\n", *s)))
4313                         s++;
4314                 }
4315                 else
4316                     break;
4317             }
4318             if (sigil && (*s == ';' || *s == '=')) {
4319                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4320                                 "Parentheses missing around \"%s\" list",
4321                                 lex
4322                                     ? (PL_parser->in_my == KEY_our
4323                                         ? "our"
4324                                         : PL_parser->in_my == KEY_state
4325                                             ? "state"
4326                                             : "my")
4327                                     : "local");
4328             }
4329         }
4330     }
4331     if (lex)
4332         o = my(o);
4333     else
4334         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4335     PL_parser->in_my = FALSE;
4336     PL_parser->in_my_stash = NULL;
4337     return o;
4338 }
4339
4340 OP *
4341 Perl_jmaybe(pTHX_ OP *o)
4342 {
4343     PERL_ARGS_ASSERT_JMAYBE;
4344
4345     if (o->op_type == OP_LIST) {
4346         OP * const o2
4347             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4348         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4349     }
4350     return o;
4351 }
4352
4353 PERL_STATIC_INLINE OP *
4354 S_op_std_init(pTHX_ OP *o)
4355 {
4356     I32 type = o->op_type;
4357
4358     PERL_ARGS_ASSERT_OP_STD_INIT;
4359
4360     if (PL_opargs[type] & OA_RETSCALAR)
4361         scalar(o);
4362     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4363         o->op_targ = pad_alloc(type, SVs_PADTMP);
4364
4365     return o;
4366 }
4367
4368 PERL_STATIC_INLINE OP *
4369 S_op_integerize(pTHX_ OP *o)
4370 {
4371     I32 type = o->op_type;
4372
4373     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4374
4375     /* integerize op. */
4376     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4377     {
4378         dVAR;
4379         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4380     }
4381
4382     if (type == OP_NEGATE)
4383         /* XXX might want a ck_negate() for this */
4384         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4385
4386     return o;
4387 }
4388
4389 static OP *
4390 S_fold_constants(pTHX_ OP *o)
4391 {
4392     dVAR;
4393     OP * VOL curop;
4394     OP *newop;
4395     VOL I32 type = o->op_type;
4396     bool is_stringify;
4397     SV * VOL sv = NULL;
4398     int ret = 0;
4399     OP *old_next;
4400     SV * const oldwarnhook = PL_warnhook;
4401     SV * const olddiehook  = PL_diehook;
4402     COP not_compiling;
4403     U8 oldwarn = PL_dowarn;
4404     I32 old_cxix;
4405     dJMPENV;
4406
4407     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4408
4409     if (!(PL_opargs[type] & OA_FOLDCONST))
4410         goto nope;
4411
4412     switch (type) {
4413     case OP_UCFIRST:
4414     case OP_LCFIRST:
4415     case OP_UC:
4416     case OP_LC:
4417     case OP_FC:
4418 #ifdef USE_LOCALE_CTYPE
4419         if (IN_LC_COMPILETIME(LC_CTYPE))
4420             goto nope;
4421 #endif
4422         break;
4423     case OP_SLT:
4424     case OP_SGT:
4425     case OP_SLE:
4426     case OP_SGE:
4427     case OP_SCMP:
4428 #ifdef USE_LOCALE_COLLATE
4429         if (IN_LC_COMPILETIME(LC_COLLATE))
4430             goto nope;
4431 #endif
4432         break;
4433     case OP_SPRINTF:
4434         /* XXX what about the numeric ops? */
4435 #ifdef USE_LOCALE_NUMERIC
4436         if (IN_LC_COMPILETIME(LC_NUMERIC))
4437             goto nope;
4438 #endif
4439         break;
4440     case OP_PACK:
4441         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4442           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4443             goto nope;
4444         {
4445             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4446             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4447             {
4448                 const char *s = SvPVX_const(sv);
4449                 while (s < SvEND(sv)) {
4450                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4451                     s++;
4452                 }
4453             }
4454         }
4455         break;
4456     case OP_REPEAT:
4457         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4458         break;
4459     case OP_SREFGEN:
4460         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4461          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4462             goto nope;
4463     }
4464
4465     if (PL_parser && PL_parser->error_count)
4466         goto nope;              /* Don't try to run w/ errors */
4467
4468     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4469         switch (curop->op_type) {
4470         case OP_CONST:
4471             if (   (curop->op_private & OPpCONST_BARE)
4472                 && (curop->op_private & OPpCONST_STRICT)) {
4473                 no_bareword_allowed(curop);
4474                 goto nope;
4475             }
4476             /* FALLTHROUGH */
4477         case OP_LIST:
4478         case OP_SCALAR:
4479         case OP_NULL:
4480         case OP_PUSHMARK:
4481             /* Foldable; move to next op in list */
4482             break;
4483
4484         default:
4485             /* No other op types are considered foldable */
4486             goto nope;
4487         }
4488     }
4489
4490     curop = LINKLIST(o);
4491     old_next = o->op_next;
4492     o->op_next = 0;
4493     PL_op = curop;
4494
4495     old_cxix = cxstack_ix;
4496     create_eval_scope(NULL, G_FAKINGEVAL);
4497
4498     /* Verify that we don't need to save it:  */
4499     assert(PL_curcop == &PL_compiling);
4500     StructCopy(&PL_compiling, &not_compiling, COP);
4501     PL_curcop = &not_compiling;
4502     /* The above ensures that we run with all the correct hints of the
4503        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4504     assert(IN_PERL_RUNTIME);
4505     PL_warnhook = PERL_WARNHOOK_FATAL;
4506     PL_diehook  = NULL;
4507     JMPENV_PUSH(ret);
4508
4509     /* Effective $^W=1.  */
4510     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4511         PL_dowarn |= G_WARN_ON;
4512
4513     switch (ret) {
4514     case 0:
4515         CALLRUNOPS(aTHX);
4516         sv = *(PL_stack_sp--);
4517         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4518             pad_swipe(o->op_targ,  FALSE);
4519         }
4520         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4521             SvREFCNT_inc_simple_void(sv);
4522             SvTEMP_off(sv);
4523         }
4524         else { assert(SvIMMORTAL(sv)); }
4525         break;
4526     case 3:
4527         /* Something tried to die.  Abandon constant folding.  */
4528         /* Pretend the error never happened.  */
4529         CLEAR_ERRSV();
4530         o->op_next = old_next;
4531         break;
4532     default:
4533         JMPENV_POP;
4534         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4535         PL_warnhook = oldwarnhook;
4536         PL_diehook  = olddiehook;
4537         /* XXX note that this croak may fail as we've already blown away
4538          * the stack - eg any nested evals */
4539         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4540     }
4541     JMPENV_POP;
4542     PL_dowarn   = oldwarn;
4543     PL_warnhook = oldwarnhook;
4544     PL_diehook  = olddiehook;
4545     PL_curcop = &PL_compiling;
4546
4547     /* if we croaked, depending on how we croaked the eval scope
4548      * may or may not have already been popped */
4549     if (cxstack_ix > old_cxix) {
4550         assert(cxstack_ix == old_cxix + 1);
4551         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4552         delete_eval_scope();
4553     }
4554     if (ret)
4555         goto nope;
4556
4557     /* OP_STRINGIFY and constant folding are used to implement qq.
4558        Here the constant folding is an implementation detail that we
4559        want to hide.  If the stringify op is itself already marked
4560        folded, however, then it is actually a folded join.  */
4561     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4562     op_free(o);
4563     assert(sv);
4564     if (is_stringify)
4565         SvPADTMP_off(sv);
4566     else if (!SvIMMORTAL(sv)) {
4567         SvPADTMP_on(sv);
4568         SvREADONLY_on(sv);
4569     }
4570     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4571     if (!is_stringify) newop->op_folded = 1;
4572     return newop;
4573
4574  nope:
4575     return o;
4576 }
4577
4578 static OP *
4579 S_gen_constant_list(pTHX_ OP *o)
4580 {
4581     dVAR;
4582     OP *curop;
4583     const SSize_t oldtmps_floor = PL_tmps_floor;
4584     SV **svp;
4585     AV *av;
4586
4587     list(o);
4588     if (PL_parser && PL_parser->error_count)
4589         return o;               /* Don't attempt to run with errors */
4590
4591     curop = LINKLIST(o);
4592     o->op_next = 0;
4593     CALL_PEEP(curop);
4594     S_prune_chain_head(&curop);
4595     PL_op = curop;
4596     Perl_pp_pushmark(aTHX);
4597     CALLRUNOPS(aTHX);
4598     PL_op = curop;
4599     assert (!(curop->op_flags & OPf_SPECIAL));
4600     assert(curop->op_type == OP_RANGE);
4601     Perl_pp_anonlist(aTHX);
4602     PL_tmps_floor = oldtmps_floor;
4603
4604     OpTYPE_set(o, OP_RV2AV);
4605     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4606     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4607     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4608     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4609
4610     /* replace subtree with an OP_CONST */
4611     curop = ((UNOP*)o)->op_first;
4612     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4613     op_free(curop);
4614
4615     if (AvFILLp(av) != -1)
4616         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4617         {
4618             SvPADTMP_on(*svp);
4619             SvREADONLY_on(*svp);
4620         }
4621     LINKLIST(o);
4622     return list(o);
4623 }
4624
4625 /*
4626 =head1 Optree Manipulation Functions
4627 */
4628
4629 /* List constructors */
4630
4631 /*
4632 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4633
4634 Append an item to the list of ops contained directly within a list-type
4635 op, returning the lengthened list.  C<first> is the list-type op,
4636 and C<last> is the op to append to the list.  C<optype> specifies the
4637 intended opcode for the list.  If C<first> is not already a list of the
4638 right type, it will be upgraded into one.  If either C<first> or C<last>
4639 is null, the other is returned unchanged.
4640
4641 =cut
4642 */
4643
4644 OP *
4645 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4646 {
4647     if (!first)
4648         return last;
4649
4650     if (!last)
4651         return first;
4652
4653     if (first->op_type != (unsigned)type
4654         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4655     {
4656         return newLISTOP(type, 0, first, last);
4657     }
4658
4659     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4660     first->op_flags |= OPf_KIDS;
4661     return first;
4662 }
4663
4664 /*
4665 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4666
4667 Concatenate the lists of ops contained directly within two list-type ops,
4668 returning the combined list.  C<first> and C<last> are the list-type ops
4669 to concatenate.  C<optype> specifies the intended opcode for the list.
4670 If either C<first> or C<last> is not already a list of the right type,
4671 it will be upgraded into one.  If either C<first> or C<last> is null,
4672 the other is returned unchanged.
4673
4674 =cut
4675 */
4676
4677 OP *
4678 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4679 {
4680     if (!first)
4681         return last;
4682
4683     if (!last)
4684         return first;
4685
4686     if (first->op_type != (unsigned)type)
4687         return op_prepend_elem(type, first, last);
4688
4689     if (last->op_type != (unsigned)type)
4690         return op_append_elem(type, first, last);
4691
4692     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4693     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4694     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4695     first->op_flags |= (last->op_flags & OPf_KIDS);
4696
4697     S_op_destroy(aTHX_ last);
4698
4699     return first;
4700 }
4701
4702 /*
4703 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4704
4705 Prepend an item to the list of ops contained directly within a list-type
4706 op, returning the lengthened list.  C<first> is the op to prepend to the
4707 list, and C<last> is the list-type op.  C<optype> specifies the intended
4708 opcode for the list.  If C<last> is not already a list of the right type,
4709 it will be upgraded into one.  If either C<first> or C<last> is null,
4710 the other is returned unchanged.
4711
4712 =cut
4713 */
4714
4715 OP *
4716 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4717 {
4718     if (!first)
4719         return last;
4720
4721     if (!last)
4722         return first;
4723
4724     if (last->op_type == (unsigned)type) {
4725         if (type == OP_LIST) {  /* already a PUSHMARK there */
4726             /* insert 'first' after pushmark */
4727             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4728             if (!(first->op_flags & OPf_PARENS))
4729                 last->op_flags &= ~OPf_PARENS;
4730         }
4731         else
4732             op_sibling_splice(last, NULL, 0, first);
4733         last->op_flags |= OPf_KIDS;
4734         return last;
4735     }
4736
4737     return newLISTOP(type, 0, first, last);
4738 }
4739
4740 /*
4741 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4742
4743 Converts C<o> into a list op if it is not one already, and then converts it
4744 into the specified C<type>, calling its check function, allocating a target if
4745 it needs one, and folding constants.
4746
4747 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4748 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4749 C<op_convert_list> to make it the right type.
4750
4751 =cut
4752 */
4753
4754 OP *
4755 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4756 {
4757     dVAR;
4758     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4759     if (!o || o->op_type != OP_LIST)
4760         o = force_list(o, 0);
4761     else
4762     {
4763         o->op_flags &= ~OPf_WANT;
4764         o->op_private &= ~OPpLVAL_INTRO;
4765     }
4766
4767     if (!(PL_opargs[type] & OA_MARK))
4768         op_null(cLISTOPo->op_first);
4769     else {
4770         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4771         if (kid2 && kid2->op_type == OP_COREARGS) {
4772             op_null(cLISTOPo->op_first);
4773             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4774         }
4775     }
4776
4777     OpTYPE_set(o, type);
4778     o->op_flags |= flags;
4779     if (flags & OPf_FOLDED)
4780         o->op_folded = 1;
4781
4782     o = CHECKOP(type, o);
4783     if (o->op_type != (unsigned)type)
4784         return o;
4785
4786     return fold_constants(op_integerize(op_std_init(o)));
4787 }
4788
4789 /* Constructors */
4790
4791
4792 /*
4793 =head1 Optree construction
4794
4795 =for apidoc Am|OP *|newNULLLIST
4796
4797 Constructs, checks, and returns a new C<stub> op, which represents an
4798 empty list expression.
4799
4800 =cut
4801 */
4802
4803 OP *
4804 Perl_newNULLLIST(pTHX)
4805 {
4806     return newOP(OP_STUB, 0);
4807 }
4808
4809 /* promote o and any siblings to be a list if its not already; i.e.
4810  *
4811  *  o - A - B
4812  *
4813  * becomes
4814  *
4815  *  list
4816  *    |
4817  *  pushmark - o - A - B
4818  *
4819  * If nullit it true, the list op is nulled.
4820  */