X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/87ebf1e3df9537a204b21f0405c6e60f2acdcc47..84610c522ba9c4c14999a7c317050818363d5b7c:/op.c diff --git a/op.c b/op.c index 2a76ae4..51ffac2 100644 --- a/op.c +++ b/op.c @@ -22,13 +22,19 @@ /* This file contains the functions that create, manipulate and optimize * the OP structures that hold a compiled perl program. * - * A Perl program is compiled into a tree of OPs. Each op contains - * structural pointers (eg to its siblings and the next op in the - * execution sequence), a pointer to the function that would execute the - * op, plus any data specific to that op. For example, an OP_CONST op - * points to the pp_const() function and to an SV containing the constant - * value. When pp_const() is executed, its job is to push that SV onto the - * stack. + * Note that during the build of miniperl, a temporary copy of this file + * is made, called opmini.c. + * + * A Perl program is compiled into a tree of OP nodes. Each op contains: + * * structural OP pointers to its children and siblings (op_sibling, + * op_first etc) that define the tree structure; + * * execution order OP pointers (op_next, plus sometimes op_other, + * op_lastop etc) that define the execution sequence plus variants; + * * a pointer to the C "pp" function that would execute the op; + * * any data specific to that op. + * For example, an OP_CONST op points to the pp_const() function and to an + * SV containing the constant value. When pp_const() is executed, its job + * is to push that SV onto the stack. * * OPs are mainly created by the newFOO() functions, which are mainly * called from the parser (in perly.y) as the code is parsed. For example @@ -40,11 +46,65 @@ * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c)) * ) * - * Note that during the build of miniperl, a temporary copy of this file - * is made, called opmini.c. + * As the parser reduces low-level rules, it creates little op subtrees; + * as higher-level rules are resolved, these subtrees get joined together + * as branches on a bigger subtree, until eventually a top-level rule like + * a subroutine definition is reduced, at which point there is one large + * parse tree left. + * + * The execution order pointers (op_next) are generated as the subtrees + * are joined together. Consider this sub-expression: A*B + C/D: at the + * point when it's just been parsed, the op tree looks like: + * + * [+] + * | + * [*]------[/] + * | | + * A---B C---D + * + * with the intended execution order being: + * + * [PREV] => A => B => [*] => C => D => [/] => [+] => [NEXT] + * + * At this point all the nodes' op_next pointers will have been set, + * except that: + * * we don't know what the [NEXT] node will be yet; + * * we don't know what the [PREV] node will be yet, but when it gets + * created and needs its op_next set, it needs to be set to point to + * A, which is non-obvious. + * To handle both those cases, we temporarily set the top node's + * op_next to point to the first node to be executed in this subtree (A in + * this case). This means that initially a subtree's op_next chain, + * starting from the top node, will visit each node in execution sequence + * then point back at the top node. + * When we embed this subtree in a larger tree, its top op_next is used + * to get the start node, then is set to point to its new neighbour. + * For example the two separate [*],A,B and [/],C,D subtrees would + * initially have had: + * [*] => A; A => B; B => [*] + * and + * [/] => C; C => D; D => [/] + * When these two subtrees were joined together to make the [+] subtree, + * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was + * set to point to [/]'s op_next, i.e. C. + * + * This op_next linking is done by the LINKLIST() macro and its underlying + * op_linklist() function. Given a top-level op, if its op_next is + * non-null, it's already been linked, so leave it. Otherwise link it with + * its children as described above, possibly recursively if any of the + * children have a null op_next. + * + * In summary: given a subtree, its top-level node's op_next will either + * be: + * NULL: the subtree hasn't been LINKLIST()ed yet; + * fake: points to the start op for this subtree; + * real: once the subtree has been embedded into a larger tree */ /* + +Here's an older description from Larry. + Perl's compiler is essentially a 3-pass compiler with interleaved phases: A bottom-up pass @@ -109,6 +169,8 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o) #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o) +static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar"; + /* Used to avoid recursion through the op tree in scalarvoid() and op_free() */ @@ -297,9 +359,11 @@ Perl_Slab_Alloc(pTHX_ size_t sz) DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab)); gotit: - /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */ - o->op_lastsib = 1; - assert(!o->op_sibling); +#ifdef PERL_OP_PARENT + /* moresib == 0, op_sibling == 0 implies a solitary unattached op */ + assert(!o->op_moresib); + assert(!o->op_sibparent); +#endif return (void *)o; } @@ -400,7 +464,7 @@ Perl_opslab_free(pTHX_ OPSLAB *slab) PERL_UNUSED_CONTEXT; DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab)); assert(slab->opslab_refcnt == 1); - for (; slab; slab = slab2) { + do { slab2 = slab->opslab_next; #ifdef DEBUGGING slab->opslab_refcnt = ~(size_t)0; @@ -415,20 +479,21 @@ Perl_opslab_free(pTHX_ OPSLAB *slab) #else PerlMemShared_free(slab); #endif - } + slab = slab2; + } while (slab); } void Perl_opslab_force_free(pTHX_ OPSLAB *slab) { OPSLAB *slab2; - OPSLOT *slot; #ifdef DEBUGGING size_t savestack_count = 0; #endif PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE; slab2 = slab; do { + OPSLOT *slot; for (slot = slab2->opslab_first; slot->opslot_next; slot = slot->opslot_next) { @@ -507,7 +572,7 @@ Perl_op_refcnt_dec(pTHX_ OP *o) #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) -#define CHANGE_TYPE(o,type) \ +#define OpTYPE_set(o,type) \ STMT_START { \ o->op_type = (OPCODE)type; \ o->op_ppaddr = PL_ppaddr[type]; \ @@ -557,7 +622,7 @@ S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t) SV * const namesv = cv_name((CV *)gv, NULL, 0); PERL_ARGS_ASSERT_BAD_TYPE_GV; - yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", + yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)", (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv)); } @@ -567,7 +632,7 @@ S_no_bareword_allowed(pTHX_ OP *o) PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED; qerror(Perl_mess(aTHX_ - "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", + "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use", SVfARG(cSVOPo_sv))); o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */ } @@ -587,11 +652,12 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) (UV)flags); /* complain about "my $" etc etc */ - if (len && - !(is_our || - isALPHA(name[1]) || - ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) || - (name[1] == '_' && (*name == '$' || len > 2)))) + if ( len + && !( is_our + || isALPHA(name[1]) + || ( (flags & SVf_UTF8) + && isIDFIRST_utf8_safe((U8 *)name+1, name + len)) + || (name[1] == '_' && len > 2))) { if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) && isASCII(name[1]) @@ -604,13 +670,6 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8); } } - else if (len == 2 && name[1] == '_' && !is_our) - /* diag_listed_as: Use of my $_ is experimental */ - Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC), - "Use of %s $_ is experimental", - PL_parser->in_my == KEY_state - ? "state" - : "my"); /* allocate a spare slot and store the name in that slot */ @@ -716,10 +775,23 @@ Perl_op_free(pTHX_ OP *o) type = o->op_type; /* an op should only ever acquire op_private flags that we know about. - * If this fails, you may need to fix something in regen/op_private */ - if (o->op_ppaddr == PL_ppaddr[o->op_type]) { + * If this fails, you may need to fix something in regen/op_private. + * Don't bother testing if: + * * the op_ppaddr doesn't match the op; someone may have + * overridden the op and be doing strange things with it; + * * we've errored, as op flags are often left in an + * inconsistent state then. Note that an error when + * compiling the main program leaves PL_parser NULL, so + * we can't spot faults in the main code, only + * evaled/required code */ +#ifdef DEBUGGING + if ( o->op_ppaddr == PL_ppaddr[o->op_type] + && PL_parser + && !PL_parser->error_count) + { assert(!(o->op_private & ~PL_op_private_valid[type])); } +#endif if (o->op_private & OPpREFCOUNTED) { switch (type) { @@ -782,10 +854,8 @@ Perl_op_free(pTHX_ OP *o) op_clear(o); FreeOp(o); -#ifdef DEBUG_LEAKING_SCALARS if (PL_op == o) PL_op = NULL; -#endif } while ( (o = POP_DEFERRED_OP()) ); Safefree(defer_stack); @@ -793,6 +863,7 @@ Perl_op_free(pTHX_ OP *o) /* S_op_clear_gv(): free a GV attached to an OP */ +STATIC #ifdef USE_ITHREADS void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp) #else @@ -857,6 +928,7 @@ Perl_op_clear(pTHX_ OP *o) /* FALLTHROUGH */ case OP_ENTERTRY: case OP_ENTEREVAL: /* Was holding hints. */ + case OP_ARGDEFELEM: /* Was holding signature index. */ o->op_targ = 0; break; default: @@ -922,8 +994,9 @@ Perl_op_clear(pTHX_ OP *o) /* FALLTHROUGH */ case OP_TRANS: case OP_TRANSR: - if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { - assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR); + if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) + && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))) + { #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { pad_swipe(cPADOPo->op_padix, TRUE); @@ -942,14 +1015,20 @@ Perl_op_clear(pTHX_ OP *o) case OP_SUBST: op_free(cPMOPo->op_pmreplrootu.op_pmreplroot); goto clear_pmop; - case OP_PUSHRE: + + case OP_SPLIT: + if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */ + && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */ + { + if (o->op_private & OPpSPLIT_LEX) + pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff); + else #ifdef USE_ITHREADS - if (cPMOPo->op_pmreplrootu.op_pmtargetoff) { - pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); - } + pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); #else - SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); + SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); #endif + } /* FALLTHROUGH */ case OP_MATCH: case OP_QR: @@ -980,6 +1059,10 @@ Perl_op_clear(pTHX_ OP *o) break; + case OP_ARGCHECK: + PerlMemShared_free(cUNOP_AUXo->op_aux); + break; + case OP_MULTIDEREF: { UNOP_AUX_item *items = cUNOP_AUXo->op_aux; @@ -1149,7 +1232,7 @@ S_find_and_forget_pmops(pTHX_ OP *o) while (kid) { switch (kid->op_type) { case OP_SUBST: - case OP_PUSHRE: + case OP_SPLIT: case OP_MATCH: case OP_QR: forget_pmop((PMOP*)kid); @@ -1180,11 +1263,12 @@ Perl_op_null(pTHX_ OP *o) return; op_clear(o); o->op_targ = o->op_type; - CHANGE_TYPE(o, OP_NULL); + OpTYPE_set(o, OP_NULL); } void Perl_op_refcnt_lock(pTHX) + PERL_TSA_ACQUIRE(PL_op_mutex) { #ifdef USE_ITHREADS dVAR; @@ -1195,6 +1279,7 @@ Perl_op_refcnt_lock(pTHX) void Perl_op_refcnt_unlock(pTHX) + PERL_TSA_RELEASE(PL_op_mutex) { #ifdef USE_ITHREADS dVAR; @@ -1208,32 +1293,33 @@ Perl_op_refcnt_unlock(pTHX) =for apidoc op_sibling_splice A general function for editing the structure of an existing chain of -op_sibling nodes. By analogy with the perl-level splice() function, allows +op_sibling nodes. By analogy with the perl-level C function, allows you to delete zero or more sequential nodes, replacing them with zero or more different nodes. Performs the necessary op_first/op_last housekeeping on the parent node and op_sibling manipulation on the children. The last deleted node will be marked as as the last node by -updating the op_sibling or op_lastsib field as appropriate. +updating the op_sibling/op_sibparent or op_moresib field as appropriate. Note that op_next is not manipulated, and nodes are not freed; that is the responsibility of the caller. It also won't create a new list op for an empty list etc; use higher-level functions like op_append_elem() for that. -parent is the parent node of the sibling chain. +C is the parent node of the sibling chain. It may passed as C if +the splicing doesn't affect the first or last op in the chain. -start is the node preceding the first node to be spliced. Node(s) +C is the node preceding the first node to be spliced. Node(s) following it will be deleted, and ops will be inserted after it. If it is -NULL, the first node onwards is deleted, and nodes are inserted at the +C, the first node onwards is deleted, and nodes are inserted at the beginning. -del_count is the number of nodes to delete. If zero, no nodes are deleted. +C is the number of nodes to delete. If zero, no nodes are deleted. If -1 or greater than or equal to the number of remaining kids, all remaining kids are deleted. -insert is the first of a chain of nodes to be inserted in place of the nodes. -If NULL, no nodes are inserted. +C is the first of a chain of nodes to be inserted in place of the nodes. +If C, no nodes are inserted. -The head of the chain of deleted ops is returned, or NULL if no ops were +The head of the chain of deleted ops is returned, or C if no ops were deleted. For example: @@ -1257,18 +1343,27 @@ For example: splice(P, B, 0, X-Y) | | NULL A-B-C-D A-B-X-Y-C-D + +For lower-level direct manipulation of C and C, +see C>, C>, C>. + =cut */ OP * Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) { - OP *first = start ? OpSIBLING(start) : cLISTOPx(parent)->op_first; + OP *first; OP *rest; OP *last_del = NULL; OP *last_ins = NULL; - PERL_ARGS_ASSERT_OP_SIBLING_SPLICE; + if (start) + first = OpSIBLING(start); + else if (!parent) + goto no_parent; + else + first = cLISTOPx(parent)->op_first; assert(del_count >= -1); @@ -1277,8 +1372,7 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) while (--del_count && OpHAS_SIBLING(last_del)) last_del = OpSIBLING(last_del); rest = OpSIBLING(last_del); - OpSIBLING_set(last_del, NULL); - last_del->op_lastsib = 1; + OpLASTSIB_set(last_del, NULL); } else rest = first; @@ -1287,17 +1381,17 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) last_ins = insert; while (OpHAS_SIBLING(last_ins)) last_ins = OpSIBLING(last_ins); - OpSIBLING_set(last_ins, rest); - last_ins->op_lastsib = rest ? 0 : 1; + OpMAYBESIB_set(last_ins, rest, NULL); } else insert = rest; if (start) { - OpSIBLING_set(start, insert); - start->op_lastsib = insert ? 0 : 1; + OpMAYBESIB_set(start, insert, NULL); } else { + if (!parent) + goto no_parent; cLISTOPx(parent)->op_first = insert; if (insert) parent->op_flags |= OPf_KIDS; @@ -1307,12 +1401,25 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) if (!rest) { /* update op_last etc */ - U32 type = parent->op_type; + U32 type; OP *lastop; - if (type == OP_NULL) - type = parent->op_targ; - type = PL_opargs[type] & OA_CLASS_MASK; + if (!parent) + goto no_parent; + + /* ought to use OP_CLASS(parent) here, but that can't handle + * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't + * either */ + type = parent->op_type; + if (type == OP_CUSTOM) { + dTHX; + type = XopENTRYCUSTOM(parent, xop_class); + } + else { + if (type == OP_NULL) + type = parent->op_targ; + type = PL_opargs[type] & OA_CLASS_MASK; + } lastop = last_ins ? last_ins : start ? start : NULL; if ( type == OA_BINOP @@ -1322,22 +1429,23 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) ) cLISTOPx(parent)->op_last = lastop; - if (lastop) { - lastop->op_lastsib = 1; -#ifdef PERL_OP_PARENT - lastop->op_sibling = parent; -#endif - } + if (lastop) + OpLASTSIB_set(lastop, parent); } return last_del ? first : NULL; + + no_parent: + Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent"); } + +#ifdef PERL_OP_PARENT + /* =for apidoc op_parent -returns the parent OP of o, if it has a parent. Returns NULL otherwise. -(Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to -work. +Returns the parent OP of C, if it has a parent. Returns C otherwise. +This function is only available on perls built with C<-DPERL_OP_PARENT>. =cut */ @@ -1346,16 +1454,13 @@ OP * Perl_op_parent(OP *o) { PERL_ARGS_ASSERT_OP_PARENT; -#ifdef PERL_OP_PARENT while (OpHAS_SIBLING(o)) o = OpSIBLING(o); - return o->op_sibling; -#else - PERL_UNUSED_ARG(o); - return NULL; -#endif + return o->op_sibparent; } +#endif + /* replace the sibling following start with a new UNOP, which becomes * the parent of the original sibling; e.g. @@ -1376,7 +1481,7 @@ Perl_op_parent(OP *o) * Returns the new UNOP. */ -OP * +STATIC OP * S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags) { OP *kid, *newop; @@ -1395,24 +1500,20 @@ S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags) */ LOGOP * -S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) +Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) { dVAR; LOGOP *logop; OP *kid = first; NewOp(1101, logop, 1, LOGOP); - CHANGE_TYPE(logop, type); + OpTYPE_set(logop, type); logop->op_first = first; logop->op_other = other; logop->op_flags = OPf_KIDS; while (kid && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid); - if (kid) { - kid->op_lastsib = 1; -#ifdef PERL_OP_PARENT - kid->op_sibling = (OP*)logop; -#endif - } + if (kid) + OpLASTSIB_set(kid, (OP*)logop); return logop; } @@ -1423,7 +1524,7 @@ S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) =for apidoc Am|OP *|op_contextualize|OP *o|I32 context Applies a syntactic context to an op tree representing an expression. -I is the op tree, and I must be C, C, +C is the op tree, and C must be C, C, or C to specify the context to apply. The modified op tree is returned. @@ -1502,8 +1603,11 @@ S_scalarboolean(pTHX_ OP *o) { PERL_ARGS_ASSERT_SCALARBOOLEAN; - if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST - && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) { + if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST && + !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) || + (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN && + cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST && + !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) { if (ckWARN(WARN_SYNTAX)) { const line_t oldline = CopLINE(PL_curcop); @@ -1520,7 +1624,7 @@ S_scalarboolean(pTHX_ OP *o) } static SV * -S_op_varname(pTHX_ const OP *o) +S_op_varname_subscript(pTHX_ const OP *o, int subscript_type) { assert(o); assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV || @@ -1533,13 +1637,19 @@ S_op_varname(pTHX_ const OP *o) if (cUNOPo->op_first->op_type != OP_GV || !(gv = cGVOPx_gv(cUNOPo->op_first))) return NULL; - return varname(gv, funny, 0, NULL, 0, 1); + return varname(gv, funny, 0, NULL, 0, subscript_type); } return - varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1); + varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type); } } +static SV * +S_op_varname(pTHX_ const OP *o) +{ + return S_op_varname_subscript(aTHX_ o, 1); +} + static void S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv) { /* or not so pretty :-) */ @@ -1561,10 +1671,12 @@ static void S_scalar_slice_warning(pTHX_ const OP *o) { OP *kid; + const bool h = o->op_type == OP_HSLICE + || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE); const char lbrack = - o->op_type == OP_HSLICE ? '{' : '['; + h ? '{' : '['; const char rbrack = - o->op_type == OP_HSLICE ? '}' : ']'; + h ? '}' : ']'; SV *name; SV *keysv = NULL; /* just to silence compiler warnings */ const char *key = NULL; @@ -1601,9 +1713,6 @@ S_scalar_slice_warning(pTHX_ const OP *o) case OP_LOCALTIME: case OP_GMTIME: case OP_ENTEREVAL: - case OP_REACH: - case OP_RKEYS: - case OP_RVALUES: return; } @@ -1621,15 +1730,15 @@ S_scalar_slice_warning(pTHX_ const OP *o) if (key) /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Scalar value @%"SVf"%c%s%c better written as $%"SVf + "Scalar value @%" SVf "%c%s%c better written as $%" SVf "%c%s%c", SVfARG(name), lbrack, key, rbrack, SVfARG(name), lbrack, key, rbrack); else /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Scalar value @%"SVf"%c%"SVf"%c better written as $%" - SVf"%c%"SVf"%c", + "Scalar value @%" SVf "%c%" SVf "%c better written as $%" + SVf "%c%" SVf "%c", SVfARG(name), lbrack, SVfARG(keysv), rbrack, SVfARG(name), lbrack, SVfARG(keysv), rbrack); } @@ -1734,15 +1843,15 @@ Perl_scalar(pTHX_ OP *o) if (key) /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "%%%"SVf"%c%s%c in scalar context better written " - "as $%"SVf"%c%s%c", + "%%%" SVf "%c%s%c in scalar context better written " + "as $%" SVf "%c%s%c", SVfARG(name), lbrack, key, rbrack, SVfARG(name), lbrack, key, rbrack); else /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "%%%"SVf"%c%"SVf"%c in scalar context better " - "written as $%"SVf"%c%"SVf"%c", + "%%%" SVf "%c%" SVf "%c in scalar context better " + "written as $%" SVf "%c%" SVf "%c", SVfARG(name), lbrack, SVfARG(keysv), rbrack, SVfARG(name), lbrack, SVfARG(keysv), rbrack); } @@ -1756,7 +1865,6 @@ Perl_scalarvoid(pTHX_ OP *arg) dVAR; OP *kid; SV* sv; - U8 want; SSize_t defer_stack_alloc = 0; SSize_t defer_ix = -1; OP **defer_stack = NULL; @@ -1765,6 +1873,7 @@ Perl_scalarvoid(pTHX_ OP *arg) PERL_ARGS_ASSERT_SCALARVOID; do { + U8 want; SV *useless_sv = NULL; const char* useless = NULL; @@ -1891,16 +2000,7 @@ Perl_scalarvoid(pTHX_ OP *arg) break; case OP_SPLIT: - kid = cLISTOPo->op_first; - if (kid && kid->op_type == OP_PUSHRE - && !kid->op_targ - && !(o->op_flags & OPf_STACKED) -#ifdef USE_ITHREADS - && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff -#else - && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv -#endif - ) + if (!(o->op_private & OPpSPLIT_ASSIGN)) useless = OP_DESC(o); break; @@ -1960,7 +2060,7 @@ Perl_scalarvoid(pTHX_ OP *arg) SvREFCNT_dec_NN(dsv); } else if (SvOK(sv)) { - useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv)); + useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv)); } else useless = "a constant (undef)"; @@ -1970,19 +2070,19 @@ Perl_scalarvoid(pTHX_ OP *arg) break; case OP_POSTINC: - CHANGE_TYPE(o, OP_PREINC); /* pre-increment is faster */ + OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */ break; case OP_POSTDEC: - CHANGE_TYPE(o, OP_PREDEC); /* pre-decrement is faster */ + OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */ break; case OP_I_POSTINC: - CHANGE_TYPE(o, OP_I_PREINC); /* pre-increment is faster */ + OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */ break; case OP_I_POSTDEC: - CHANGE_TYPE(o, OP_I_PREDEC); /* pre-decrement is faster */ + OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */ break; case OP_SASSIGN: { @@ -2039,9 +2139,9 @@ Perl_scalarvoid(pTHX_ OP *arg) if (kid->op_type == OP_NOT && (kid->op_flags & OPf_KIDS)) { if (o->op_type == OP_AND) { - CHANGE_TYPE(o, OP_OR); + OpTYPE_set(o, OP_OR); } else { - CHANGE_TYPE(o, OP_AND); + OpTYPE_set(o, OP_AND); } op_null(kid); } @@ -2114,7 +2214,7 @@ Perl_scalarvoid(pTHX_ OP *arg) if (useless_sv) { /* mortalise it, in case warnings are fatal. */ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), - "Useless use of %"SVf" in void context", + "Useless use of %" SVf " in void context", SVfARG(sv_2mortal(useless_sv))); } else if (useless) { @@ -2279,7 +2379,7 @@ S_modkids(pTHX_ OP *o, I32 type) * key_op is the first key */ -void +STATIC void S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op) { PADNAME *lexname; @@ -2319,6 +2419,13 @@ S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op) continue; svp = cSVOPx_svp(key_op); + /* make sure it's not a bareword under strict subs */ + if (key_op->op_private & OPpCONST_BARE && + key_op->op_private & OPpCONST_STRICT) + { + no_bareword_allowed((OP*)key_op); + } + /* Make the CONST have a shared SV */ if ( !SvIsCOW_shared_hash(sv = *svp) && SvTYPE(sv) < SVt_PVMG @@ -2335,8 +2442,8 @@ S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op) if ( check_fields && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) { - Perl_croak(aTHX_ "No such class field \"%"SVf"\" " - "in variable %"PNf" of type %"HEKf, + Perl_croak(aTHX_ "No such class field \"%" SVf "\" " + "in variable %" PNf " of type %" HEKf, SVfARG(*svp), PNfARG(lexname), HEKfARG(HvNAME_HEK(PadnameTYPE(lexname)))); } @@ -2344,12 +2451,45 @@ S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op) } +/* do all the final processing on an optree (e.g. running the peephole + * optimiser on it), then attach it to cv (if cv is non-null) + */ + +static void +S_process_optree(pTHX_ CV *cv, OP *optree, OP* start) +{ + OP **startp; + + /* XXX for some reason, evals, require and main optrees are + * never attached to their CV; instead they just hang off + * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start + * and get manually freed when appropriate */ + if (cv) + startp = &CvSTART(cv); + else + startp = PL_in_eval? &PL_eval_start : &PL_main_start; + + *startp = start; + optree->op_private |= OPpREFCOUNTED; + OpREFCNT_set(optree, 1); + CALL_PEEP(*startp); + finalize_optree(optree); + S_prune_chain_head(startp); + + if (cv) { + /* now that optimizer has done its work, adjust pad values */ + pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT + : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); + } +} + + /* =for apidoc finalize_optree This function finalizes the optree. Should be called directly after the complete optree is built. It does some additional -checking which can't be done in the normal ck_xxx functions and makes +checking which can't be done in the normal Cxxx functions and makes the tree thread-safe. =cut @@ -2393,6 +2533,7 @@ S_finalize_op(pTHX_ OP* o) { PERL_ARGS_ASSERT_FINALIZE_OP; + assert(o->op_type != OP_FREED); switch (o->op_type) { case OP_NEXTSTATE: @@ -2428,7 +2569,7 @@ S_finalize_op(pTHX_ OP* o) SV * const sv = sv_newmortal(); gv_efullname3(sv, gv, NULL); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), - "%"SVf"() called too early to check prototype", + "%" SVf "() called too early to check prototype", SVfARG(sv)); } } @@ -2491,6 +2632,10 @@ S_finalize_op(pTHX_ OP* o) S_check_hash_fields_and_hekify(aTHX_ rop, key_op); break; } + case OP_NULL: + if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE) + break; + /* FALLTHROUGH */ case OP_ASLICE: S_scalar_slice_warning(aTHX_ o); break; @@ -2509,9 +2654,9 @@ S_finalize_op(pTHX_ OP* o) #ifdef DEBUGGING /* check that op_last points to the last sibling, and that - * the last op_sibling field points back to the parent, and - * that the only ops with KIDS are those which are entitled to - * them */ + * the last op_sibling/op_sibparent field points back to the + * parent, and that the only ops with KIDS are those which are + * entitled to them */ U32 type = o->op_type; U32 family; bool has_last; @@ -2539,8 +2684,6 @@ S_finalize_op(pTHX_ OP* o) || family == OA_FILESTATOP || family == OA_LOOPEXOP || family == OA_METHOP - /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */ - || type == OP_SASSIGN || type == OP_CUSTOM || type == OP_NULL /* new_logop does this */ ); @@ -2550,17 +2693,11 @@ S_finalize_op(pTHX_ OP* o) if (!OpHAS_SIBLING(kid)) { if (has_last) assert(kid == cLISTOPo->op_last); - assert(kid->op_sibling == o); + assert(kid->op_sibparent == o); } # else - if (OpHAS_SIBLING(kid)) { - assert(!kid->op_lastsib); - } - else { - assert(kid->op_lastsib); - if (has_last) - assert(kid == cLISTOPo->op_last); - } + if (has_last && !OpHAS_SIBLING(kid)) + assert(kid == cLISTOPo->op_last); # endif } #endif @@ -2574,14 +2711,14 @@ S_finalize_op(pTHX_ OP* o) =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type Propagate lvalue ("modifiable") context to an op and its children. -I represents the context type, roughly based on the type of op that -would do the modifying, although C is represented by OP_NULL, +C represents the context type, roughly based on the type of op that +would do the modifying, although C is represented by C, because it has no op type of its own (it is signalled by a flag on the lvalue op). This function detects things that can't be modified, such as C<$x+1>, and generates errors for them. For example, C<$x+1 = 2> would cause it to be -called with an op of type OP_ADD and a C argument of OP_SASSIGN. +called with an op of type C and a C argument of C. It also flags things that need to behave specially in an lvalue context, such as C<$$x = 5> which might have to vivify a reference in C<$x>. @@ -2596,7 +2733,13 @@ S_mark_padname_lvalue(pTHX_ PADNAME *pn) PadnameLVALUE_on(pn); while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) { cv = CvOUTSIDE(cv); - assert(cv); + /* RT #127786: cv can be NULL due to an eval within the DB package + * called from an anon sub - anon subs don't have CvOUTSIDE() set + * unless they contain an eval, but calling eval within DB + * pretends the eval was done in the caller's scope. + */ + if (!cv) + break; assert(CvPADLIST(cv)); pn = PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)]; @@ -2643,7 +2786,7 @@ S_lvref(pTHX_ OP *o, I32 type) return; } slurpy: - CHANGE_TYPE(o, OP_LVAVREF); + OpTYPE_set(o, OP_LVAVREF); o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE; o->op_flags |= OPf_MOD|OPf_REF; return; @@ -2653,7 +2796,7 @@ S_lvref(pTHX_ OP *o, I32 type) case OP_RV2CV: kid = cUNOPo->op_first; if (kid->op_type == OP_NULL) - kid = cUNOPx(kUNOP->op_first->op_sibling) + kid = cUNOPx(OpSIBLING(kUNOP->op_first)) ->op_first; o->op_private = OPpLVREF_CV; if (kid->op_type == OP_GV) @@ -2700,8 +2843,8 @@ S_lvref(pTHX_ OP *o, I32 type) break; case OP_ASLICE: case OP_HSLICE: - CHANGE_TYPE(o, OP_LVREFSLICE); - o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM; + OpTYPE_set(o, OP_LVREFSLICE); + o->op_private &= OPpLVAL_INTRO; return; case OP_NULL: if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ @@ -2733,13 +2876,21 @@ S_lvref(pTHX_ OP *o, I32 type) PL_op_desc[type])); return; } - CHANGE_TYPE(o, OP_LVREF); + OpTYPE_set(o, OP_LVREF); o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE; if (type == OP_ENTERLOOP) o->op_private |= OPpLVREF_ITER; } +PERL_STATIC_INLINE bool +S_potential_mod_type(I32 type) +{ + /* Types that only potentially result in modification. */ + return type == OP_GREPSTART || type == OP_ENTERSUB + || type == OP_REFGEN || type == OP_LEAVESUBLV; +} + OP * Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) { @@ -2772,7 +2923,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_ENTERSUB: if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { - CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */ + OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */ assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ break; @@ -2780,9 +2931,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) else { /* lvalue subroutine call */ o->op_private |= OPpLVAL_INTRO; PL_modcount = RETURN_UNLIMITED_NUMBER; - if (type == OP_GREPSTART || type == OP_ENTERSUB - || type == OP_REFGEN || type == OP_LEAVESUBLV) { - /* Potential lvalue context: */ + if (S_potential_mod_type(type)) { o->op_private |= OPpENTERSUB_INARGS; break; } @@ -2790,12 +2939,13 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) OP *kid = cUNOPo->op_first; CV *cv; GV *gv; + SV *namesv; if (kid->op_type != OP_PUSHMARK) { if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) Perl_croak(aTHX_ "panic: unexpected lvalue entersub " - "args: type/targ %ld:%"UVuf, + "args: type/targ %ld:%" UVuf, (long)kid->op_type, (UV)kid->op_targ); kid = kLISTOP->op_first; } @@ -2811,7 +2961,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) if (kid->op_type == OP_NULL) Perl_croak(aTHX_ "Unexpected constant lvalue entersub " - "entry via type/targ %ld:%"UVuf, + "entry via type/targ %ld:%" UVuf, (long)kid->op_type, (UV)kid->op_targ); if (kid->op_type != OP_GV) { break; @@ -2827,6 +2977,15 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) break; if (CvLVALUE(cv)) break; + if (flags & OP_LVALUE_NO_CROAK) + return NULL; + + namesv = cv_name(cv, NULL, 0); + yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue " + "subroutine call of &%" SVf " in %s", + SVfARG(namesv), PL_op_desc[type]), + SvUTF8(namesv)); + return o; } } /* FALLTHROUGH */ @@ -2834,15 +2993,12 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) nomod: if (flags & OP_LVALUE_NO_CROAK) return NULL; /* grep, foreach, subcalls, refgen */ - if (type == OP_GREPSTART || type == OP_ENTERSUB - || type == OP_REFGEN || type == OP_LEAVESUBLV) + if (S_potential_mod_type(type)) break; yyerror(Perl_form(aTHX_ "Can't modify %s in %s", (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) ? "do block" - : (o->op_type == OP_ENTERSUB - ? "non-lvalue subroutine call" - : OP_DESC(o))), + : OP_DESC(o)), type ? PL_op_desc[type] : "local")); return o; @@ -2930,9 +3086,15 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) break; case OP_KVHSLICE: case OP_KVASLICE: + case OP_AKEYS: if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; goto nomod; + case OP_AVHVSWITCH: + if (type == OP_LEAVESUBLV + && (o->op_private & 3) + OP_EACH == OP_KEYS) + o->op_private |= OPpMAYBE_LVSUB; + goto nomod; case OP_AV2ARYLEN: PL_hints |= HINT_BLOCK_SCOPE; if (type == OP_LEAVESUBLV) @@ -2973,7 +3135,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_PADSV: PL_modcount++; if (!type) /* local() */ - Perl_croak(aTHX_ "Can't localize lexical variable %"PNf, + Perl_croak(aTHX_ "Can't localize lexical variable %" PNf, PNfARG(PAD_COMPNAME(o->op_targ))); if (!(o->op_private & OPpLVAL_INTRO) || ( type != OP_SASSIGN && type != OP_AASSIGN @@ -2986,8 +3148,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) break; case OP_KEYS: - case OP_RKEYS: - if (type != OP_SASSIGN && type != OP_LEAVESUBLV) + if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type)) goto nomod; goto lvalue_func; case OP_SUBSTR: @@ -2999,8 +3160,18 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) lvalue_func: if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; - if (o->op_flags & OPf_KIDS) - op_lvalue(OpSIBLING(cBINOPo->op_first), type); + if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) { + /* substr and vec */ + /* If this op is in merely potential (non-fatal) modifiable + context, then apply OP_ENTERSUB context to + the kid op (to avoid croaking). Other- + wise pass this op’s own type so the correct op is mentioned + in error messages. */ + op_lvalue(OpSIBLING(cBINOPo->op_first), + S_potential_mod_type(type) + ? (I32)OP_ENTERSUB + : o->op_type); + } break; case OP_AELEM: @@ -3033,9 +3204,32 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) goto nomod; else if (!(o->op_flags & OPf_KIDS)) break; + if (o->op_targ != OP_LIST) { - op_lvalue(cBINOPo->op_first, type); - break; + OP *sib = OpSIBLING(cLISTOPo->op_first); + /* OP_TRANS and OP_TRANSR with argument have a weird optree + * that looks like + * + * null + * arg + * trans + * + * compared with things like OP_MATCH which have the argument + * as a child: + * + * match + * arg + * + * so handle specially to correctly get "Can't modify" croaks etc + */ + + if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR)) + { + /* this should trigger a "Can't modify transliteration" err */ + op_lvalue(sib, type); + } + op_lvalue(cBINOPo->op_first, type); + break; } /* FALLTHROUGH */ case OP_LIST: @@ -3061,6 +3255,17 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) goto nomod; case OP_SREFGEN: + if (type == OP_NULL) { /* local */ + local_refgen: + if (!FEATURE_MYREF_IS_ENABLED) + Perl_croak(aTHX_ "The experimental declared_refs " + "feature is not enabled"); + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__DECLARED_REFS), + "Declaring references is experimental"); + op_lvalue(cUNOPo->op_first, OP_NULL); + return o; + } if (type != OP_AASSIGN && type != OP_SASSIGN && type != OP_ENTERLOOP) goto nomod; @@ -3069,6 +3274,8 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) assert (!OpHAS_SIBLING(kid)); goto kid_2lvref; case OP_REFGEN: + if (type == OP_NULL) /* local */ + goto local_refgen; if (type != OP_AASSIGN) goto nomod; kid = cUNOPo->op_first; kid_2lvref: @@ -3090,16 +3297,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) return o; case OP_SPLIT: - kid = cLISTOPo->op_first; - if (kid && kid->op_type == OP_PUSHRE && - ( kid->op_targ - || o->op_flags & OPf_STACKED -#ifdef USE_ITHREADS - || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff -#else - || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv -#endif - )) { + if ((o->op_private & OPpSPLIT_ASSIGN)) { /* This is actually @array = split. */ PL_modcount = RETURN_UNLIMITED_NUMBER; break; @@ -3111,7 +3309,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) goto nomod; } - /* [20011101.069] File test operators interpret OPf_REF to mean that + /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that their argument is a filehandle; thus \stat(".") should not set it. AMS 20011102 */ if (type == OP_REFGEN && @@ -3122,7 +3320,8 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) o->op_flags |= OPf_MOD; if (type == OP_AASSIGN || type == OP_SASSIGN) - o->op_flags |= OPf_SPECIAL|OPf_REF; + o->op_flags |= OPf_SPECIAL + |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF); else if (!type) { /* local() */ switch (localize) { case 1: @@ -3138,7 +3337,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) } } else if (type != OP_GREPSTART && type != OP_ENTERSUB - && type != OP_LEAVESUBLV) + && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB) o->op_flags |= OPf_REF; return o; } @@ -3177,6 +3376,12 @@ S_scalar_mod_type(const OP *o, I32 type) case OP_BIT_AND: case OP_BIT_XOR: case OP_BIT_OR: + case OP_NBIT_AND: + case OP_NBIT_XOR: + case OP_NBIT_OR: + case OP_SBIT_AND: + case OP_SBIT_XOR: + case OP_SBIT_OR: case OP_CONCAT: case OP_SUBST: case OP_TRANS: @@ -3187,6 +3392,8 @@ S_scalar_mod_type(const OP *o, I32 type) case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: + case OP_VEC: + case OP_SUBSTR: return TRUE; default: return FALSE; @@ -3237,14 +3444,14 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) PERL_ARGS_ASSERT_DOREF; - if (!o || (PL_parser && PL_parser->error_count)) + if (PL_parser && PL_parser->error_count) return o; switch (o->op_type) { case OP_ENTERSUB: if ((type == OP_EXISTS || type == OP_DEFINED) && !(o->op_flags & OPf_STACKED)) { - CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */ + OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */ assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ o->op_flags |= OPf_SPECIAL; @@ -3356,24 +3563,26 @@ S_dup_attrlist(pTHX_ OP *o) STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) { - SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; - PERL_ARGS_ASSERT_APPLY_ATTRS; + { + SV * const stashsv = newSVhek(HvNAME_HEK(stash)); - /* fake up C */ + /* fake up C */ #define ATTRSMODULE "attributes" #define ATTRSMODULE_PM "attributes.pm" - Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, - newSVpvs(ATTRSMODULE), - NULL, - op_prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, stashsv), - op_prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, - newRV(target)), - dup_attrlist(attrs)))); + Perl_load_module( + aTHX_ PERL_LOADMOD_IMPORT_OPS, + newSVpvs(ATTRSMODULE), + NULL, + op_prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, stashsv), + op_prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV(target)), + dup_attrlist(attrs)))); + } } STATIC void @@ -3404,7 +3613,7 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE)); /* Build up the real arg-list. */ - stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; + stashsv = newSVhek(HvNAME_HEK(stash)); arg = newOP(OP_PADSV, 0); arg->op_targ = target->op_targ; @@ -3412,7 +3621,7 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) newSVOP(OP_CONST, 0, stashsv), op_prepend_elem(OP_LIST, newUNOP(OP_REFGEN, 0, - op_lvalue(arg, OP_REFGEN)), + arg), dup_attrlist(attrs))); /* Fake up a method call to import */ @@ -3517,7 +3726,7 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) STRLEN new_len; const char * newp = SvPV(cSVOPo_sv, new_len); Perl_warner(aTHX_ packWARN(WARN_MISC), - "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub", + "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub", UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp)); op_free(new_proto); } @@ -3558,8 +3767,8 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) const char * newp = SvPV(cSVOPx_sv(new_proto), new_len); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), - "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'" - " in %"SVf, + "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'" + " in %" SVf, UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp), UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp), SVfARG(svname)); @@ -3599,7 +3808,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) type = o->op_type; - if (type == OP_LIST) { + if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) my_kid(kid, attrs, imopsp); @@ -3608,7 +3817,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) return o; } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || - type == OP_RV2HV) { /* XXX does this let anything illegal in? */ + type == OP_RV2HV) { if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ S_cant_declare(aTHX_ o); } else if (attrs) { @@ -3625,6 +3834,17 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) o->op_private |= OPpOUR_INTRO; return o; } + else if (type == OP_REFGEN || type == OP_SREFGEN) { + if (!FEATURE_MYREF_IS_ENABLED) + Perl_croak(aTHX_ "The experimental declared_refs " + "feature is not enabled"); + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__DECLARED_REFS), + "Declaring references is experimental"); + /* Kid is a nulled OP_LIST, handled above. */ + my_kid(cUNOPo->op_first, attrs, imopsp); + return o; + } else if (type != OP_PADSV && type != OP_PADAV && type != OP_PADHV && @@ -3733,7 +3953,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) S_op_varname(aTHX_ left); if (name) Perl_warner(aTHX_ packWARN(WARN_MISC), - "Applying %s to %"SVf" will act on scalar(%"SVf")", + "Applying %s to %" SVf " will act on scalar(%" SVf ")", desc, SVfARG(name), SVfARG(name)); else { const char * const sample = (isary @@ -3827,11 +4047,11 @@ Perl_op_scope(pTHX_ OP *o) if (o) { if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) { o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); - CHANGE_TYPE(o, OP_LEAVE); + OpTYPE_set(o, OP_LEAVE); } else if (o->op_type == OP_LINESEQ) { OP *kid; - CHANGE_TYPE(o, OP_SCOPE); + OpTYPE_set(o, OP_SCOPE); kid = ((LISTOP*)o)->op_first; if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { op_null(kid); @@ -3895,9 +4115,9 @@ Perl_block_start(pTHX_ int full) /* =for apidoc Am|OP *|block_end|I32 floor|OP *seq -Handles compile-time scope exit. I +Handles compile-time scope exit. C is the savestack index returned by -C, and I is the body of the block. Returns the block, +C, and C is the body of the block. Returns the block, possibly modified. =cut @@ -4011,6 +4231,8 @@ Perl_blockhook_register(pTHX_ BHK *hk) void Perl_newPROG(pTHX_ OP *o) { + OP *start; + PERL_ARGS_ASSERT_NEWPROG; if (PL_in_eval) { @@ -4022,7 +4244,7 @@ Perl_newPROG(pTHX_ OP *o) ((PL_in_eval & EVAL_KEEPERR) ? OPf_SPECIAL : 0), o); - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_EVAL); if ((cx->blk_gimme & G_WANT) == G_VOID) @@ -4032,16 +4254,12 @@ Perl_newPROG(pTHX_ OP *o) else scalar(PL_eval_root); - PL_eval_start = op_linklist(PL_eval_root); - PL_eval_root->op_private |= OPpREFCOUNTED; - OpREFCNT_set(PL_eval_root, 1); + start = op_linklist(PL_eval_root); PL_eval_root->op_next = 0; i = PL_savestack_ix; SAVEFREEOP(o); ENTER; - CALL_PEEP(PL_eval_start); - finalize_optree(PL_eval_root); - S_prune_chain_head(&PL_eval_start); + S_process_optree(aTHX_ NULL, PL_eval_root, start); LEAVE; PL_savestack_ix = i; } @@ -4080,13 +4298,9 @@ Perl_newPROG(pTHX_ OP *o) } PL_main_root = op_scope(sawparens(scalarvoid(o))); PL_curcop = &PL_compiling; - PL_main_start = LINKLIST(PL_main_root); - PL_main_root->op_private |= OPpREFCOUNTED; - OpREFCNT_set(PL_main_root, 1); + start = LINKLIST(PL_main_root); PL_main_root->op_next = 0; - CALL_PEEP(PL_main_start); - finalize_optree(PL_main_root); - S_prune_chain_head(&PL_main_start); + S_process_optree(aTHX_ NULL, PL_main_root, start); cv_forget_slab(PL_compcv); PL_compcv = 0; @@ -4130,7 +4344,8 @@ Perl_localize(pTHX_ OP *o, I32 lex) s++; while (1) { - if (*s && strchr("@$%*", *s) && *++s + if (*s && (strchr("@$%", *s) || (!lex && *s == '*')) + && *++s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) { s++; sigil = TRUE; @@ -4214,7 +4429,7 @@ S_op_integerize(pTHX_ OP *o) } static OP * -S_fold_constants(pTHX_ OP *o) +S_fold_constants(pTHX_ OP *const o) { dVAR; OP * VOL curop; @@ -4223,12 +4438,12 @@ S_fold_constants(pTHX_ OP *o) bool is_stringify; SV * VOL sv = NULL; int ret = 0; - I32 oldscope; OP *old_next; SV * const oldwarnhook = PL_warnhook; SV * const olddiehook = PL_diehook; COP not_compiling; U8 oldwarn = PL_dowarn; + I32 old_cxix; dJMPENV; PERL_ARGS_ASSERT_FOLD_CONSTANTS; @@ -4293,13 +4508,23 @@ S_fold_constants(pTHX_ OP *o) goto nope; /* Don't try to run w/ errors */ for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { - const OPCODE type = curop->op_type; - if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) && - type != OP_LIST && - type != OP_SCALAR && - type != OP_NULL && - type != OP_PUSHMARK) - { + switch (curop->op_type) { + case OP_CONST: + if ( (curop->op_private & OPpCONST_BARE) + && (curop->op_private & OPpCONST_STRICT)) { + no_bareword_allowed(curop); + goto nope; + } + /* FALLTHROUGH */ + case OP_LIST: + case OP_SCALAR: + case OP_NULL: + case OP_PUSHMARK: + /* Foldable; move to next op in list */ + break; + + default: + /* No other op types are considered foldable */ goto nope; } } @@ -4309,8 +4534,8 @@ S_fold_constants(pTHX_ OP *o) o->op_next = 0; PL_op = curop; - oldscope = PL_scopestack_ix; - create_eval_scope(G_FAKINGEVAL); + old_cxix = cxstack_ix; + create_eval_scope(NULL, G_FAKINGEVAL); /* Verify that we don't need to save it: */ assert(PL_curcop == &PL_compiling); @@ -4361,9 +4586,13 @@ S_fold_constants(pTHX_ OP *o) PL_diehook = olddiehook; PL_curcop = &PL_compiling; - if (PL_scopestack_ix > oldscope) - delete_eval_scope(); - + /* if we croaked, depending on how we croaked the eval scope + * may or may not have already been popped */ + if (cxstack_ix > old_cxix) { + assert(cxstack_ix == old_cxix + 1); + assert(CxTYPE(CX_CUR()) == CXt_EVAL); + delete_eval_scope(); + } if (ret) goto nope; @@ -4392,29 +4621,88 @@ static OP * S_gen_constant_list(pTHX_ OP *o) { dVAR; - OP *curop; - const SSize_t oldtmps_floor = PL_tmps_floor; + OP *curop, *old_next; + SV * const oldwarnhook = PL_warnhook; + SV * const olddiehook = PL_diehook; + COP *old_curcop; + U8 oldwarn = PL_dowarn; SV **svp; AV *av; + I32 old_cxix; + COP not_compiling; + int ret = 0; + dJMPENV; + bool op_was_null; list(o); if (PL_parser && PL_parser->error_count) return o; /* Don't attempt to run with errors */ curop = LINKLIST(o); + old_next = o->op_next; o->op_next = 0; + op_was_null = o->op_type == OP_NULL; + if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */ + o->op_type = OP_CUSTOM; CALL_PEEP(curop); + if (op_was_null) + o->op_type = OP_NULL; S_prune_chain_head(&curop); PL_op = curop; - Perl_pp_pushmark(aTHX); - CALLRUNOPS(aTHX); - PL_op = curop; - assert (!(curop->op_flags & OPf_SPECIAL)); - assert(curop->op_type == OP_RANGE); - Perl_pp_anonlist(aTHX); - PL_tmps_floor = oldtmps_floor; - CHANGE_TYPE(o, OP_RV2AV); + old_cxix = cxstack_ix; + create_eval_scope(NULL, G_FAKINGEVAL); + + old_curcop = PL_curcop; + StructCopy(old_curcop, ¬_compiling, COP); + PL_curcop = ¬_compiling; + /* The above ensures that we run with all the correct hints of the + current COP, but that IN_PERL_RUNTIME is true. */ + assert(IN_PERL_RUNTIME); + PL_warnhook = PERL_WARNHOOK_FATAL; + PL_diehook = NULL; + JMPENV_PUSH(ret); + + /* Effective $^W=1. */ + if ( ! (PL_dowarn & G_WARN_ALL_MASK)) + PL_dowarn |= G_WARN_ON; + + switch (ret) { + case 0: + Perl_pp_pushmark(aTHX); + CALLRUNOPS(aTHX); + PL_op = curop; + assert (!(curop->op_flags & OPf_SPECIAL)); + assert(curop->op_type == OP_RANGE); + Perl_pp_anonlist(aTHX); + break; + case 3: + CLEAR_ERRSV(); + o->op_next = old_next; + break; + default: + JMPENV_POP; + PL_warnhook = oldwarnhook; + PL_diehook = olddiehook; + Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d", + ret); + } + + JMPENV_POP; + PL_dowarn = oldwarn; + PL_warnhook = oldwarnhook; + PL_diehook = olddiehook; + PL_curcop = old_curcop; + + if (cxstack_ix > old_cxix) { + assert(cxstack_ix == old_cxix + 1); + assert(CxTYPE(CX_CUR()) == CXt_EVAL); + delete_eval_scope(); + } + if (ret) + return o; + + OpTYPE_set(o, OP_RV2AV); o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ o->op_opt = 0; /* needs to be revisited in rpeep() */ @@ -4445,10 +4733,10 @@ S_gen_constant_list(pTHX_ OP *o) =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last Append an item to the list of ops contained directly within a list-type -op, returning the lengthened list. I is the list-type op, -and I is the op to append to the list. I specifies the -intended opcode for the list. If I is not already a list of the -right type, it will be upgraded into one. If either I or I +op, returning the lengthened list. C is the list-type op, +and C is the op to append to the list. C specifies the +intended opcode for the list. If C is not already a list of the +right type, it will be upgraded into one. If either C or C is null, the other is returned unchanged. =cut @@ -4478,10 +4766,10 @@ Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last) =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last Concatenate the lists of ops contained directly within two list-type ops, -returning the combined list. I and I are the list-type ops -to concatenate. I specifies the intended opcode for the list. -If either I or I is not already a list of the right type, -it will be upgraded into one. If either I or I is null, +returning the combined list. C and C are the list-type ops +to concatenate. C specifies the intended opcode for the list. +If either C or C is not already a list of the right type, +it will be upgraded into one. If either C or C is null, the other is returned unchanged. =cut @@ -4502,16 +4790,11 @@ Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last) if (last->op_type != (unsigned)type) return op_append_elem(type, first, last); - ((LISTOP*)first)->op_last->op_lastsib = 0; - OpSIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first); + OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first); ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last; - ((LISTOP*)first)->op_last->op_lastsib = 1; -#ifdef PERL_OP_PARENT - ((LISTOP*)first)->op_last->op_sibling = first; -#endif + OpLASTSIB_set(((LISTOP*)first)->op_last, first); first->op_flags |= (last->op_flags & OPf_KIDS); - S_op_destroy(aTHX_ last); return first; @@ -4521,10 +4804,10 @@ Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last) =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last Prepend an item to the list of ops contained directly within a list-type -op, returning the lengthened list. I is the op to prepend to the -list, and I is the list-type op. I specifies the intended -opcode for the list. If I is not already a list of the right type, -it will be upgraded into one. If either I or I is null, +op, returning the lengthened list. C is the op to prepend to the +list, and C is the list-type op. C specifies the intended +opcode for the list. If C is not already a list of the right type, +it will be upgraded into one. If either C or C is null, the other is returned unchanged. =cut @@ -4558,8 +4841,8 @@ Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last) /* =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o -Converts I into a list op if it is not one already, and then converts it -into the specified I, calling its check function, allocating a target if +Converts C into a list op if it is not one already, and then converts it +into the specified C, calling its check function, allocating a target if it needs one, and folding constants. A list-type op is usually constructed one kid at a time via C, @@ -4577,7 +4860,10 @@ Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) if (!o || o->op_type != OP_LIST) o = force_list(o, 0); else + { o->op_flags &= ~OPf_WANT; + o->op_private &= ~OPpLVAL_INTRO; + } if (!(PL_opargs[type] & OA_MARK)) op_null(cLISTOPo->op_first); @@ -4589,7 +4875,13 @@ Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) } } - CHANGE_TYPE(o, type); + if (type != OP_SPLIT) + /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let + * ck_split() create a real PMOP and leave the op's type as listop + * for now. Otherwise op_free() etc will crash. + */ + OpTYPE_set(o, type); + o->op_flags |= flags; if (flags & OPf_FOLDED) o->op_folded = 1; @@ -4642,8 +4934,7 @@ S_force_list(pTHX_ OP *o, bool nullit) if (o) { /* manually detach any siblings then add them back later */ rest = OpSIBLING(o); - OpSIBLING_set(o, NULL); - o->op_lastsib = 1; + OpLASTSIB_set(o, NULL); } o = newLISTOP(OP_LIST, 0, o, NULL); if (rest) @@ -4657,16 +4948,16 @@ S_force_list(pTHX_ OP *o, bool nullit) /* =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last -Constructs, checks, and returns an op of any list type. I is -the opcode. I gives the eight bits of C, except that -C will be set automatically if required. I and I +Constructs, checks, and returns an op of any list type. C is +the opcode. C gives the eight bits of C, except that +C will be set automatically if required. C and C supply up to two ops to be direct children of the list op; they are consumed by this function and become part of the constructed op tree. For most list operators, the check function expects all the kid ops to be -present already, so calling C (e.g.,) is not +present already, so calling C (e.g.) is not appropriate. What you want to do in that case is create an op of type -OP_LIST, append more children to it, and then call L. +C, append more children to it, and then call L. See L for more information. @@ -4684,7 +4975,7 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) NewOp(1101, listop, 1, LISTOP); - CHANGE_TYPE(listop, type); + OpTYPE_set(listop, type); if (first || last) flags |= OPf_KIDS; listop->op_flags = (U8)flags; @@ -4694,26 +4985,19 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) else if (!first && last) first = last; else if (first) - OpSIBLING_set(first, last); + OpMORESIB_set(first, last); listop->op_first = first; listop->op_last = last; if (type == OP_LIST) { OP* const pushop = newOP(OP_PUSHMARK, 0); - pushop->op_lastsib = 0; - OpSIBLING_set(pushop, first); + OpMORESIB_set(pushop, first); listop->op_first = pushop; listop->op_flags |= OPf_KIDS; if (!last) listop->op_last = pushop; } - if (first) - first->op_lastsib = 0; - if (listop->op_last) { - listop->op_last->op_lastsib = 1; -#ifdef PERL_OP_PARENT - listop->op_last->op_sibling = (OP*)listop; -#endif - } + if (listop->op_last) + OpLASTSIB_set(listop->op_last, (OP*)listop); return CHECKOP(type, listop); } @@ -4722,7 +5006,7 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) =for apidoc Am|OP *|newOP|I32 type|I32 flags Constructs, checks, and returns an op of any base type (any type that -has no extra fields). I is the opcode. I gives the +has no extra fields). C is the opcode. C gives the eight bits of C, and, shifted up eight bits, the eight bits of C. @@ -4746,7 +5030,7 @@ Perl_newOP(pTHX_ I32 type, I32 flags) || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); NewOp(1101, o, 1, OP); - CHANGE_TYPE(o, type); + OpTYPE_set(o, type); o->op_flags = (U8)flags; o->op_next = o; @@ -4761,11 +5045,11 @@ Perl_newOP(pTHX_ I32 type, I32 flags) /* =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first -Constructs, checks, and returns an op of any unary type. I is -the opcode. I gives the eight bits of C, except that +Constructs, checks, and returns an op of any unary type. C is +the opcode. C gives the eight bits of C, except that C will be set automatically if required, and, shifted up eight bits, the eight bits of C, except that the bit with value 1 -is automatically set. I supplies an optional op to be the direct +is automatically set. C supplies an optional op to be the direct child of the unary op; it is consumed by this function and become part of the constructed op tree. @@ -4798,15 +5082,13 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) first = force_list(first, 1); NewOp(1101, unop, 1, UNOP); - CHANGE_TYPE(unop, type); + OpTYPE_set(unop, type); unop->op_first = first; unop->op_flags = (U8)(flags | OPf_KIDS); unop->op_private = (U8)(1 | (flags >> 8)); -#ifdef PERL_OP_PARENT if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */ - first->op_sibling = (OP*)unop; -#endif + OpLASTSIB_set(first, (OP*)unop); unop = (UNOP*) CHECKOP(type, unop); if (unop->op_next) @@ -4818,8 +5100,8 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) /* =for apidoc newUNOP_AUX -Similar to C, but creates an UNOP_AUX struct instead, with op_aux -initialised to aux +Similar to C, but creates an C struct instead, with C +initialised to C =cut */ @@ -4841,10 +5123,8 @@ Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux) unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8)); unop->op_aux = aux; -#ifdef PERL_OP_PARENT if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */ - first->op_sibling = (OP*)unop; -#endif + OpLASTSIB_set(first, (OP*)unop); unop = (UNOP_AUX*) CHECKOP(type, unop); @@ -4855,13 +5135,13 @@ Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux) =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first Constructs, checks, and returns an op of method type with a method name -evaluated at runtime. I is the opcode. I gives the eight +evaluated at runtime. C is the opcode. C gives the eight bits of C, except that C will be set automatically, and, shifted up eight bits, the eight bits of C, except that -the bit with value 1 is automatically set. I supplies an +the bit with value 1 is automatically set. C supplies an op which evaluates method name; it is consumed by this function and become part of the constructed op tree. -Supported optypes: OP_METHOD. +Supported optypes: C. =cut */ @@ -4881,10 +5161,8 @@ S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth methop->op_u.op_first = dynamic_meth; methop->op_private = (U8)(1 | (flags >> 8)); -#ifdef PERL_OP_PARENT if (!OpHAS_SIBLING(dynamic_meth)) - dynamic_meth->op_sibling = (OP*)methop; -#endif + OpLASTSIB_set(dynamic_meth, (OP*)methop); } else { assert(const_meth); @@ -4900,7 +5178,7 @@ S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth methop->op_rclass_sv = NULL; #endif - CHANGE_TYPE(methop, type); + OpTYPE_set(methop, type); return CHECKOP(type, methop); } @@ -4914,11 +5192,11 @@ Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) { =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth Constructs, checks, and returns an op of method type with a constant -method name. I is the opcode. I gives the eight bits of +method name. C is the opcode. C gives the eight bits of C, and, shifted up eight bits, the eight bits of -C. I supplies a constant method name; +C. C supplies a constant method name; it must be a shared COW string. -Supported optypes: OP_METHOD_NAMED. +Supported optypes: C. =cut */ @@ -4932,11 +5210,11 @@ Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) { /* =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last -Constructs, checks, and returns an op of any binary type. I -is the opcode. I gives the eight bits of C, except +Constructs, checks, and returns an op of any binary type. C +is the opcode. C gives the eight bits of C, except that C will be set automatically, and, shifted up eight bits, the eight bits of C, except that the bit with value 1 or -2 is automatically set as required. I and I supply up to +2 is automatically set as required. C and C supply up to two ops to be the direct children of the binary op; they are consumed by this function and become part of the constructed op tree. @@ -4950,14 +5228,14 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) BINOP *binop; ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP - || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM); + || type == OP_NULL || type == OP_CUSTOM); NewOp(1101, binop, 1, BINOP); if (!first) first = newOP(OP_NULL, 0); - CHANGE_TYPE(binop, type); + OpTYPE_set(binop, type); binop->op_first = first; binop->op_flags = (U8)(flags | OPf_KIDS); if (!last) { @@ -4966,20 +5244,15 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) } else { binop->op_private = (U8)(2 | (flags >> 8)); - OpSIBLING_set(first, last); - first->op_lastsib = 0; + OpMORESIB_set(first, last); } -#ifdef PERL_OP_PARENT if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */ - last->op_sibling = (OP*)binop; -#endif + OpLASTSIB_set(last, (OP*)binop); binop->op_last = OpSIBLING(binop->op_first); -#ifdef PERL_OP_PARENT if (binop->op_last) - binop->op_last->op_sibling = (OP*)binop; -#endif + OpLASTSIB_set(binop->op_last, (OP*)binop); binop = (BINOP*)CHECKOP(type, binop); if (binop->op_next || binop->op_type != (OPCODE)type) @@ -5172,7 +5445,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } } - /* now see which range will peter our first, if either. */ + /* now see which range will peter out first, if either. */ tdiff = tlast - tfirst; rdiff = rlast - rfirst; tcount += tdiff + 1; @@ -5204,7 +5477,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) max = rfirst + diff; if (!grows) grows = (tfirst < rfirst && - UNISKIP(tfirst) < UNISKIP(rfirst + diff)); + UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff)); rfirst += diff + 1; } tfirst += diff + 1; @@ -5270,7 +5543,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) tbl[i] = (short)i; } else { - if (i < 128 && r[j] >= 128) + if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j])) grows = 1; tbl[i] = r[j++]; } @@ -5317,7 +5590,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) --j; } if (tbl[t[i]] == -1) { - if (t[i] < 128 && r[j] >= 128) + if ( UVCHR_IS_INVARIANT(t[i]) + && ! UVCHR_IS_INVARIANT(r[j])) grows = 1; tbl[t[i]] = r[j]; } @@ -5343,7 +5617,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) =for apidoc Am|OP *|newPMOP|I32 type|I32 flags Constructs, checks, and returns an op of any pattern matching type. -I is the opcode. I gives the eight bits of C +C is the opcode. C gives the eight bits of C and, shifted up eight bits, the eight bits of C. =cut @@ -5359,7 +5633,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) || type == OP_CUSTOM); NewOp(1101, pmop, 1, PMOP); - CHANGE_TYPE(pmop, type); + OpTYPE_set(pmop, type); pmop->op_flags = (U8)flags; pmop->op_private = (U8)(0 | (flags >> 8)); if (PL_opargs[type] & OA_RETSCALAR) @@ -5436,10 +5710,12 @@ S_set_haseval(pTHX) * constant), or convert expr into a runtime regcomp op sequence (if it's * not) * - * isreg indicates that the pattern is part of a regex construct, eg + * Flags currently has 2 bits of meaning: + * 1: isreg indicates that the pattern is part of a regex construct, eg * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or * split "pattern", which aren't. In the former case, expr will be a list * if the pattern contains more than one term (eg /a$b/). + * 2: The pattern is for a split. * * When the pattern has been compiled within a new anon CV (for * qr/(?{...})/ ), then floor indicates the savestack level just before @@ -5447,7 +5723,7 @@ S_set_haseval(pTHX) */ OP * -Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor) +Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor) { PMOP *pm; LOGOP *rcop; @@ -5455,6 +5731,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor) bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR); bool is_compiletime; bool has_code; + bool isreg = cBOOL(flags & 1); + bool is_split = cBOOL(flags & 2); PERL_ARGS_ASSERT_PMRUNTIME; @@ -5559,8 +5837,16 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor) U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; regexp_engine const *eng = current_re_engine(); - if (o->op_flags & OPf_SPECIAL) + if (is_split) { + /* make engine handle split ' ' specially */ + pm->op_pmflags |= PMf_SPLIT; rx_flags |= RXf_SPLIT; + } + + /* Skip compiling if parser found an error for this pattern */ + if (pm->op_pmflags & PMf_HAS_ERROR) { + return o; + } if (!has_code || !eng->op_comp) { /* compile-time simple constant pattern */ @@ -5578,7 +5864,13 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor) SSize_t i = 0; assert(PadnamelistMAXNAMED(PL_comppad_name) == 0); while (++i <= AvFILLp(PL_comppad)) { +# ifdef USE_PAD_RESET + /* under USE_PAD_RESET, pad swipe replaces a swiped + * folded constant with a fresh padtmp */ + assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i])); +# else assert(!PL_curpad[i]); +# endif } #endif /* But we know that one op is using this CV's slab. */ @@ -5643,7 +5935,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor) pm->op_pmflags |= PMf_CODELIST_PRIVATE; } - if (o->op_flags & OPf_SPECIAL) + if (is_split) + /* make engine handle split ' ' specially */ pm->op_pmflags |= PMf_SPLIT; /* the OP_REGCMAYBE is a placeholder in the non-threaded case @@ -5699,7 +5992,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor) expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1)); } - rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o); + rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o); rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) | (reglist ? OPf_STACKED : 0); rcop->op_targ = cv_targ; @@ -5763,7 +6056,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor) op_prepend_elem(o->op_type, scalar(repl), o); } else { - rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o); + rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o); rcop->op_private = 1; /* establish postfix order */ @@ -5784,8 +6077,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor) =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv Constructs, checks, and returns an op of any type that involves an -embedded SV. I is the opcode. I gives the eight bits -of C. I gives the SV to embed in the op; this function +embedded SV. C is the opcode. C gives the eight bits +of C. C gives the SV to embed in the op; this function takes ownership of one reference to it. =cut @@ -5805,7 +6098,7 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) || type == OP_CUSTOM); NewOp(1101, svop, 1, SVOP); - CHANGE_TYPE(svop, type); + OpTYPE_set(svop, type); svop->op_sv = sv; svop->op_next = (OP*)svop; svop->op_flags = (U8)flags; @@ -5820,9 +6113,7 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) /* =for apidoc Am|OP *|newDEFSVOP| -Constructs and returns an op to access C<$_>, either as a lexical -variable (if declared as C) in the current scope, or the -global C<$_>. +Constructs and returns an op to access C<$_>. =cut */ @@ -5830,15 +6121,7 @@ global C<$_>. OP * Perl_newDEFSVOP(pTHX) { - const PADOFFSET offset = pad_findmy_pvs("$_", 0); - if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); - } - else { - OP * const o = newOP(OP_PADSV, 0); - o->op_targ = offset; - return o; - } } #ifdef USE_ITHREADS @@ -5847,9 +6130,9 @@ Perl_newDEFSVOP(pTHX) =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv Constructs, checks, and returns an op of any type that involves a -reference to a pad element. I is the opcode. I gives the +reference to a pad element. C is the opcode. C gives the eight bits of C. A pad slot is automatically allocated, and -is populated with I; this function takes ownership of one reference +is populated with C; this function takes ownership of one reference to it. This function only exists if Perl has been compiled to use ithreads. @@ -5871,7 +6154,7 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) || type == OP_CUSTOM); NewOp(1101, padop, 1, PADOP); - CHANGE_TYPE(padop, type); + OpTYPE_set(padop, type); padop->op_padix = pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP); SvREFCNT_dec(PAD_SVl(padop->op_padix)); @@ -5892,8 +6175,8 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv Constructs, checks, and returns an op of any type that involves an -embedded reference to a GV. I is the opcode. I gives the -eight bits of C. I identifies the GV that the op should +embedded reference to a GV. C is the opcode. C gives the +eight bits of C. C identifies the GV that the op should reference; calling this function does not transfer ownership of any reference to it. @@ -5916,8 +6199,8 @@ Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv Constructs, checks, and returns an op of any type that involves an -embedded C-level pointer (PV). I is the opcode. I gives -the eight bits of C. I supplies the C-level pointer, which +embedded C-level pointer (PV). C is the opcode. C gives +the eight bits of C. C supplies the C-level pointer, which must have been allocated using C; the memory will be freed when the op is destroyed. @@ -5938,7 +6221,7 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); NewOp(1101, pvop, 1, PVOP); - CHANGE_TYPE(pvop, type); + OpTYPE_set(pvop, type); pvop->op_pv = pv; pvop->op_next = (OP*)pvop; pvop->op_flags = (U8)flags; @@ -6113,21 +6396,30 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) =for apidoc load_module -Loads the module whose name is pointed to by the string part of name. +Loads the module whose name is pointed to by the string part of C. Note that the actual module name, not its filename, should be given. -Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of -PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS -(or 0 for no flags). ver, if specified -and not NULL, provides version semantics -similar to C. The optional trailing SV* -arguments can be used to specify arguments to the module's import() -method, similar to C. They must be -terminated with a final NULL pointer. Note that this list can only -be omitted when the PERL_LOADMOD_NOIMPORT flag has been used. -Otherwise at least a single NULL pointer to designate the default -import list is required. - -The reference count for each specified C parameter is decremented. +Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL, +provides version semantics similar to C. The optional +trailing arguments can be used to specify arguments to the module's C +method, similar to C; their precise handling depends +on the flags. The flags argument is a bitwise-ORed collection of any of +C, C, or C +(or 0 for no flags). + +If C is set, the module is loaded as if with an empty +import list, as in C; this is the only circumstance in which +the trailing optional arguments may be omitted entirely. Otherwise, if +C is set, the trailing arguments must consist of +exactly one C, containing the op tree that produces the relevant import +arguments. Otherwise, the trailing arguments must all be C values that +will be used as import arguments; and the list must be terminated with C<(SV*) +NULL>. If neither C nor C is +set, the trailing C pointer is needed even if no import arguments are +desired. The reference count for each specified C argument is +decremented. In addition, the C argument is modified. + +If C is set, the module is loaded as if with C rather +than C. =cut */ @@ -6232,11 +6524,11 @@ Perl_dofile(pTHX_ OP *term, I32 force_builtin) =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval -Constructs, checks, and returns an C (list slice) op. I +Constructs, checks, and returns an C (list slice) op. C gives the eight bits of C, except that C will be set automatically, and, shifted up eight bits, the eight bits of C, except that the bit with value 1 or 2 is automatically -set as required. I and I supply the parameters of +set as required. C and C supply the parameters of the slice; they are consumed by this function and become part of the constructed op tree. @@ -6314,149 +6606,23 @@ S_assignment_type(pTHX_ const OP *o) return ret; } -/* - Helper function for newASSIGNOP to detect commonality between the - lhs and the rhs. (It is actually called very indirectly. newASSIGNOP - flags the op and the peephole optimizer calls this helper function - if the flag is set.) Marks all variables with PL_generation. If it - returns TRUE the assignment must be able to handle common variables. - - PL_generation sorcery: - An assignment like ($a,$b) = ($c,$d) is easier than - ($a,$b) = ($c,$a), since there is no need for temporary vars. - To detect whether there are common vars, the global var - PL_generation is incremented for each assign op we compile. - Then, while compiling the assign op, we run through all the - variables on both sides of the assignment, setting a spare slot - in each of them to PL_generation. If any of them already have - that value, we know we've got commonality. Also, if the - generation number is already set to PERL_INT_MAX, then - the variable is involved in aliasing, so we also have - potential commonality in that case. We could use a - single bit marker, but then we'd have to make 2 passes, first - to clear the flag, then to test and set it. And that - wouldn't help with aliasing, either. To find somewhere - to store these values, evil chicanery is done with SvUVX(). -*/ -PERL_STATIC_INLINE bool -S_aassign_common_vars(pTHX_ OP* o) -{ - OP *curop; - for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) { - if (PL_opargs[curop->op_type] & OA_DANGEROUS) { - if (curop->op_type == OP_GV || curop->op_type == OP_GVSV - || curop->op_type == OP_AELEMFAST) { - GV *gv = cGVOPx_gv(curop); - if (gv == PL_defgv - || (int)GvASSIGN_GENERATION(gv) == PL_generation) - return TRUE; - GvASSIGN_GENERATION_set(gv, PL_generation); - } - else if (curop->op_type == OP_PADSV || - curop->op_type == OP_PADAV || - curop->op_type == OP_PADHV || - curop->op_type == OP_AELEMFAST_LEX || - curop->op_type == OP_PADANY) - { - padcheck: - if (PAD_COMPNAME_GEN(curop->op_targ) - == (STRLEN)PL_generation - || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX) - return TRUE; - PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation); - } - else if (curop->op_type == OP_RV2CV) - return TRUE; - else if (curop->op_type == OP_RV2SV || - curop->op_type == OP_RV2AV || - curop->op_type == OP_RV2HV || - curop->op_type == OP_RV2GV) { - if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */ - return TRUE; - } - else if (curop->op_type == OP_PUSHRE) { - GV *const gv = -#ifdef USE_ITHREADS - ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff - ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff)) - : NULL; -#else - ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv; -#endif - if (gv) { - if (gv == PL_defgv - || (int)GvASSIGN_GENERATION(gv) == PL_generation) - return TRUE; - GvASSIGN_GENERATION_set(gv, PL_generation); - } - else if (curop->op_targ) - goto padcheck; - } - else if (curop->op_type == OP_PADRANGE) - /* Ignore padrange; checking its siblings is sufficient. */ - continue; - else - return TRUE; - } - else if (PL_opargs[curop->op_type] & OA_TARGLEX - && curop->op_private & OPpTARGET_MY) - goto padcheck; +/* +=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right - if (curop->op_flags & OPf_KIDS) { - if (aassign_common_vars(curop)) - return TRUE; - } - } - return FALSE; -} +Constructs, checks, and returns an assignment op. C and C +supply the parameters of the assignment; they are consumed by this +function and become part of the constructed op tree. -/* This variant only handles lexical aliases. It is called when - newASSIGNOP decides that we don’t have any common vars, as lexical ali- - ases trump that decision. */ -PERL_STATIC_INLINE bool -S_aassign_common_vars_aliases_only(pTHX_ OP *o) -{ - OP *curop; - for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) { - if ((curop->op_type == OP_PADSV || - curop->op_type == OP_PADAV || - curop->op_type == OP_PADHV || - curop->op_type == OP_AELEMFAST_LEX || - curop->op_type == OP_PADANY || - ( PL_opargs[curop->op_type] & OA_TARGLEX - && curop->op_private & OPpTARGET_MY )) - && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX) - return TRUE; +If C is C, C, or C, then +a suitable conditional optree is constructed. If C is the opcode +of a binary operator, such as C, then an op is constructed that +performs the binary operation and assigns the result to the left argument. +Either way, if C is non-zero then C has no effect. - if (curop->op_type == OP_PUSHRE && curop->op_targ - && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX) - return TRUE; - - if (curop->op_flags & OPf_KIDS) { - if (S_aassign_common_vars_aliases_only(aTHX_ curop)) - return TRUE; - } - } - return FALSE; -} - -/* -=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right - -Constructs, checks, and returns an assignment op. I and I -supply the parameters of the assignment; they are consumed by this -function and become part of the constructed op tree. - -If I is C, C, or C, then -a suitable conditional optree is constructed. If I is the opcode -of a binary operator, such as C, then an op is constructed that -performs the binary operation and assigns the result to the left argument. -Either way, if I is non-zero then I has no effect. - -If I is zero, then a plain scalar or list assignment is +If C is zero, then a plain scalar or list assignment is constructed. Which type of assignment it is is automatically determined. -I gives the eight bits of C, except that C +C gives the eight bits of C, except that C will be set automatically, and, shifted up eight bits, the eight bits of C, except that the bit with value 1 or 2 is automatically set as required. @@ -6472,9 +6638,10 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (optype) { if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { + right = scalar(right); return newLOGOP(optype, 0, op_lvalue(scalar(left), optype), - newUNOP(OP_SASSIGN, 0, scalar(right))); + newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right)); } else { return newBINOP(optype, OPf_STACKED, @@ -6486,7 +6653,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) static const char no_list_state[] = "Initialization of state variables" " in list context currently forbidden"; OP *curop; - bool maybe_common_vars = TRUE; if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE) left->op_private &= ~ OPpSLICEWARNING; @@ -6500,47 +6666,24 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (OP_TYPE_IS_OR_WAS(left, OP_LIST)) { OP* lop = ((LISTOP*)left)->op_first; - maybe_common_vars = FALSE; while (lop) { - if (lop->op_type == OP_PADSV || - lop->op_type == OP_PADAV || - lop->op_type == OP_PADHV || - lop->op_type == OP_PADANY) { - if (!(lop->op_private & OPpLVAL_INTRO)) - maybe_common_vars = TRUE; - - if (lop->op_private & OPpPAD_STATE) { - if (left->op_private & OPpLVAL_INTRO) { - /* Each variable in state($a, $b, $c) = ... */ - } - else { - /* Each state variable in - (state $a, my $b, our $c, $d, undef) = ... */ - } - yyerror(no_list_state); - } else { - /* Each my variable in - (state $a, my $b, our $c, $d, undef) = ... */ - } - } else if (lop->op_type == OP_UNDEF || - OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) { - /* undef may be interesting in - (state $a, undef, state $c) */ - } else { - /* Other ops in the list. */ - maybe_common_vars = TRUE; - } + if ((lop->op_type == OP_PADSV || + lop->op_type == OP_PADAV || + lop->op_type == OP_PADHV || + lop->op_type == OP_PADANY) + && (lop->op_private & OPpPAD_STATE) + ) + yyerror(no_list_state); lop = OpSIBLING(lop); } } - else if ((left->op_private & OPpLVAL_INTRO) + else if ( (left->op_private & OPpLVAL_INTRO) + && (left->op_private & OPpPAD_STATE) && ( left->op_type == OP_PADSV || left->op_type == OP_PADAV || left->op_type == OP_PADHV - || left->op_type == OP_PADANY)) - { - if (left->op_type == OP_PADSV) maybe_common_vars = FALSE; - if (left->op_private & OPpPAD_STATE) { + || left->op_type == OP_PADANY) + ) { /* All single variable list context state assignments, hence state ($a) = ... (state $a) = ... @@ -6552,100 +6695,96 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) (state %a) = ... */ yyerror(no_list_state); - } } - if (maybe_common_vars) { - /* The peephole optimizer will do the full check and pos- - sibly turn this off. */ - o->op_private |= OPpASSIGN_COMMON; - } + /* optimise @a = split(...) into: + * @{expr}: split(..., @{expr}) (where @a is not flattened) + * @a, my @a, local @a: split(...) (where @a is attached to + * the split op itself) + */ - if (right && right->op_type == OP_SPLIT - && !(right->op_flags & OPf_STACKED)) { - OP* tmpop = ((LISTOP*)right)->op_first; - PMOP * const pm = (PMOP*)tmpop; - assert (tmpop && (tmpop->op_type == OP_PUSHRE)); - if ( -#ifdef USE_ITHREADS - !pm->op_pmreplrootu.op_pmtargetoff -#else - !pm->op_pmreplrootu.op_pmtargetgv -#endif - && !pm->op_targ - ) { - if (!(left->op_private & OPpLVAL_INTRO) && - ( (left->op_type == OP_RV2AV && - (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV) - || left->op_type == OP_PADAV ) - ) { - if (tmpop != (OP *)pm) { + if ( right + && right->op_type == OP_SPLIT + /* don't do twice, e.g. @b = (@a = split) */ + && !(right->op_private & OPpSPLIT_ASSIGN)) + { + OP *gvop = NULL; + + if ( ( left->op_type == OP_RV2AV + && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV) + || left->op_type == OP_PADAV) + { + /* @pkg or @lex or local @pkg' or 'my @lex' */ + OP *tmpop; + if (gvop) { #ifdef USE_ITHREADS - pm->op_pmreplrootu.op_pmtargetoff - = cPADOPx(tmpop)->op_padix; - cPADOPx(tmpop)->op_padix = 0; /* steal it */ + ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff + = cPADOPx(gvop)->op_padix; + cPADOPx(gvop)->op_padix = 0; /* steal it */ #else - pm->op_pmreplrootu.op_pmtargetgv - = MUTABLE_GV(cSVOPx(tmpop)->op_sv); - cSVOPx(tmpop)->op_sv = NULL; /* steal it */ -#endif - right->op_private |= - left->op_private & OPpOUR_INTRO; - } - else { - pm->op_targ = left->op_targ; - left->op_targ = 0; /* filch it */ - } - detach_split: - tmpop = cUNOPo->op_first; /* to list (nulled) */ - tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ - /* detach rest of siblings from o subtree, - * and free subtree */ - op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL); - op_free(o); /* blow off assign */ - right->op_flags &= ~OPf_WANT; - /* "I don't know and I don't care." */ - return right; - } - else if (left->op_type == OP_RV2AV - || left->op_type == OP_PADAV) - { - /* Detach the array. */ -#ifdef DEBUGGING - OP * const ary = + ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv + = MUTABLE_GV(cSVOPx(gvop)->op_sv); + cSVOPx(gvop)->op_sv = NULL; /* steal it */ #endif - op_sibling_splice(cBINOPo->op_last, - cUNOPx(cBINOPo->op_last) - ->op_first, 1, NULL); - assert(ary == left); - /* Attach it to the split. */ - op_sibling_splice(right, cLISTOPx(right)->op_last, - 0, left); - right->op_flags |= OPf_STACKED; - /* Detach split and expunge aassign as above. */ - goto detach_split; - } - else if (PL_modcount < RETURN_UNLIMITED_NUMBER && - ((LISTOP*)right)->op_last->op_type == OP_CONST) - { - SV ** const svp = - &((SVOP*)((LISTOP*)right)->op_last)->op_sv; - SV * const sv = *svp; - if (SvIOK(sv) && SvIVX(sv) == 0) - { - if (right->op_private & OPpSPLIT_IMPLIM) { - /* our own SV, created in ck_split */ - SvREADONLY_off(sv); - sv_setiv(sv, PL_modcount+1); - } - else { - /* SV may belong to someone else */ - SvREFCNT_dec(sv); - *svp = newSViv(PL_modcount+1); - } - } - } - } + right->op_private |= + left->op_private & OPpOUR_INTRO; + } + else { + ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ; + left->op_targ = 0; /* steal it */ + right->op_private |= OPpSPLIT_LEX; + } + right->op_private |= left->op_private & OPpLVAL_INTRO; + + detach_split: + tmpop = cUNOPo->op_first; /* to list (nulled) */ + tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ + assert(OpSIBLING(tmpop) == right); + assert(!OpHAS_SIBLING(right)); + /* detach the split subtreee from the o tree, + * then free the residual o tree */ + op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL); + op_free(o); /* blow off assign */ + right->op_private |= OPpSPLIT_ASSIGN; + right->op_flags &= ~OPf_WANT; + /* "I don't know and I don't care." */ + return right; + } + else if (left->op_type == OP_RV2AV) { + /* @{expr} */ + + OP *pushop = cUNOPx(cBINOPo->op_last)->op_first; + assert(OpSIBLING(pushop) == left); + /* Detach the array ... */ + op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL); + /* ... and attach it to the split. */ + op_sibling_splice(right, cLISTOPx(right)->op_last, + 0, left); + right->op_flags |= OPf_STACKED; + /* Detach split and expunge aassign as above. */ + goto detach_split; + } + else if (PL_modcount < RETURN_UNLIMITED_NUMBER && + ((LISTOP*)right)->op_last->op_type == OP_CONST) + { + /* convert split(...,0) to split(..., PL_modcount+1) */ + SV ** const svp = + &((SVOP*)((LISTOP*)right)->op_last)->op_sv; + SV * const sv = *svp; + if (SvIOK(sv) && SvIVX(sv) == 0) + { + if (right->op_private & OPpSPLIT_IMPLIM) { + /* our own SV, created in ck_split */ + SvREADONLY_off(sv); + sv_setiv(sv, PL_modcount+1); + } + else { + /* SV may belong to someone else */ + SvREFCNT_dec(sv); + *svp = newSViv(PL_modcount+1); + } + } + } } return o; } @@ -6671,13 +6810,13 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) Constructs a state op (COP). The state op is normally a C op, but will be a C op if debugging is enabled for currently-compiled code. The state op is populated from C (or C). -If I