X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b13702a2b676b84fd7641c481a27970b9259f5ff..9e67a8c1b21482ed5fada053dd462eb23320dc86:/op.c diff --git a/op.c b/op.c index ff2848a..e611dbe 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() */ @@ -594,7 +656,7 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) !(is_our || isALPHA(name[1]) || ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) || - (name[1] == '_' && (*name == '$' || len > 2)))) + (name[1] == '_' && len > 2))) { if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) && isASCII(name[1]) @@ -607,13 +669,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 */ @@ -719,10 +774,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) { @@ -796,6 +864,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 @@ -860,6 +929,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: @@ -983,6 +1053,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; @@ -1188,6 +1262,7 @@ Perl_op_null(pTHX_ OP *o) void Perl_op_refcnt_lock(pTHX) + PERL_TSA_ACQUIRE(PL_op_mutex) { #ifdef USE_ITHREADS dVAR; @@ -1198,6 +1273,7 @@ Perl_op_refcnt_lock(pTHX) void Perl_op_refcnt_unlock(pTHX) + PERL_TSA_RELEASE(PL_op_mutex) { #ifdef USE_ITHREADS dVAR; @@ -1211,7 +1287,7 @@ 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 @@ -1222,22 +1298,22 @@ 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. It may passed as NULL if +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: @@ -1263,7 +1339,7 @@ For example: For lower-level direct manipulation of C and C, -see C, C, C. +see C>, C>, C>. =cut */ @@ -1362,7 +1438,7 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) /* =for apidoc op_parent -Returns the parent OP of o, if it has a parent. Returns NULL otherwise. +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 @@ -1399,7 +1475,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; @@ -1418,7 +1494,7 @@ 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; @@ -1521,8 +1597,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); @@ -1539,7 +1618,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 || @@ -1552,13 +1631,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 :-) */ @@ -2295,7 +2380,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; @@ -2335,6 +2420,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 @@ -2365,7 +2457,7 @@ S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op) 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 @@ -2585,13 +2677,13 @@ S_finalize_op(pTHX_ OP* o) Propagate lvalue ("modifiable") context to an op and its children. C represents the context type, roughly based on the type of op that -would do the modifying, although C is represented by OP_NULL, +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>. @@ -2606,7 +2698,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)]; @@ -2711,7 +2809,7 @@ S_lvref(pTHX_ OP *o, I32 type) case OP_ASLICE: case OP_HSLICE: OpTYPE_set(o, OP_LVREFSLICE); - o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM; + o->op_private &= OPpLVAL_INTRO; return; case OP_NULL: if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ @@ -2749,6 +2847,14 @@ S_lvref(pTHX_ OP *o, I32 type) 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) { @@ -2789,9 +2895,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; } @@ -2799,6 +2903,7 @@ 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) @@ -2836,6 +2941,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 */ @@ -2843,15 +2957,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; @@ -2939,9 +3050,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) @@ -2995,7 +3112,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) break; case OP_KEYS: - if (type != OP_SASSIGN && type != OP_LEAVESUBLV) + if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type)) goto nomod; goto lvalue_func; case OP_SUBSTR: @@ -3007,8 +3124,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: @@ -3069,6 +3196,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; @@ -3077,6 +3215,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: @@ -3119,7 +3259,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 && @@ -3185,6 +3325,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: @@ -3195,6 +3341,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; @@ -3609,7 +3757,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); @@ -3618,7 +3766,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) { @@ -3635,6 +3783,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 && @@ -4032,7 +4191,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) @@ -4140,7 +4299,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; @@ -4233,12 +4393,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; @@ -4303,13 +4463,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; } } @@ -4319,8 +4489,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); @@ -4371,9 +4541,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; @@ -4673,7 +4847,7 @@ 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 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. @@ -4816,8 +4990,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 */ @@ -4857,7 +5031,7 @@ and, shifted up eight bits, the eight bits of C, except that 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 */ @@ -4912,7 +5086,7 @@ method name. C is the opcode. C gives the eight bits of C, and, shifted up eight bits, the eight bits of C. C supplies a constant method name; it must be a shared COW string. -Supported optypes: OP_METHOD_NAMED. +Supported optypes: C. =cut */ @@ -5193,7 +5367,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; @@ -5688,7 +5862,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; @@ -5752,7 +5926,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 */ @@ -5809,9 +5983,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 */ @@ -5819,15 +5991,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 @@ -6105,15 +6269,15 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) Loads the module whose name is pointed to by the string part of name. 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 +C, C, or C (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() +arguments can be used to specify arguments to the module's C 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 +terminated with a final C pointer. Note that this list can only +be omitted when the C flag has been used. +Otherwise at least a single C pointer to designate the default import list is required. The reference count for each specified C parameter is decremented. @@ -6714,24 +6878,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) || type == OP_CUSTOM); scalarboolean(first); - /* optimize AND and OR ops that have NOTs as children */ - if (first->op_type == OP_NOT - && (first->op_flags & OPf_KIDS) - && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */ - || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */ - ) { - if (type == OP_AND || type == OP_OR) { - if (type == OP_AND) - type = OP_OR; - else - type = OP_AND; - op_null(first); - if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */ - op_null(other); - prepend_not = 1; /* prepend a NOT op later */ - } - } - } + /* search for a constant op that could let us fold the test */ if ((cstop = search_const(first))) { if (cstop->op_private & OPpCONST_STRICT) @@ -6741,6 +6888,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) || (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) || (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) { + /* Elide the (constant) lhs, since it can't affect the outcome */ *firstp = NULL; if (other->op_type == OP_CONST) other->op_private |= OPpCONST_SHORTCIRCUIT; @@ -6758,6 +6906,9 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) return other; } else { + /* Elide the rhs, since the outcome is entirely determined by + * the (constant) lhs */ + /* check for C, or C */ const OP *o2 = other; if ( ! (o2->op_type == OP_LIST @@ -6778,7 +6929,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) *otherp = NULL; if (cstop->op_type == OP_CONST) cstop->op_private |= OPpCONST_SHORTCIRCUIT; - op_free(other); + op_free(other); return first; } } @@ -6825,13 +6976,29 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) } } - if (!other) - return first; - if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ - logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other)); + /* optimize AND and OR ops that have NOTs as children */ + if (first->op_type == OP_NOT + && (first->op_flags & OPf_KIDS) + && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */ + || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */ + ) { + if (type == OP_AND || type == OP_OR) { + if (type == OP_AND) + type = OP_OR; + else + type = OP_AND; + op_null(first); + if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */ + op_null(other); + prepend_not = 1; /* prepend a NOT op later */ + } + } + } + + logop = alloc_LOGOP(type, first, LINKLIST(other)); logop->op_flags |= (U8)flags; logop->op_private = (U8)(1 | (flags >> 8)); @@ -6902,7 +7069,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) live->op_folded = 1; return live; } - logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop)); + logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop)); logop->op_flags |= (U8)flags; logop->op_private = (U8)(1 | (flags >> 8)); logop->op_next = LINKLIST(falseop); @@ -6951,7 +7118,7 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) PERL_ARGS_ASSERT_NEWRANGE; - range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right)); + range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right)); range->op_flags = OPf_KIDS; leftstart = LINKLIST(left); range->op_private = (U8)(1 | (flags >> 8)); @@ -7086,7 +7253,7 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) o->op_flags |= flags; o = op_scope(o); - o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ + o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/ return o; } @@ -7224,7 +7391,7 @@ loop (iteration through a list of values). This is a heavyweight loop, with structure that allows exiting the loop by C and suchlike. C optionally supplies the variable that will be aliased to each -item in turn; if null, it defaults to C<$_> (either lexical or global). +item in turn; if null, it defaults to C<$_>. C supplies the list of values to iterate over. C supplies the main body of the loop, and C optionally supplies a C block that operates as a second half of the body. All of these optree @@ -7287,13 +7454,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) } } else { - const PADOFFSET offset = pad_findmy_pvs("$_", 0); - if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { - sv = newGVOP(OP_GV, 0, PL_defgv); - } - else { - padoff = offset; - } + sv = newGVOP(OP_GV, 0, PL_defgv); iterpflags |= OPpITER_DEF; } @@ -7475,9 +7636,10 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, OP *o; PERL_ARGS_ASSERT_NEWGIVWHENOP; + PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */ - enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL); - enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg); + enterop = alloc_LOGOP(enter_opcode, block, NULL); + enterop->op_targ = 0; enterop->op_private = 0; o = newUNOP(leave_opcode, 0, (OP *) enterop); @@ -7596,8 +7758,7 @@ Constructs, checks, and returns an op tree expressing a C block. C supplies the expression that will be locally assigned to a lexical variable, and C supplies the body of the C construct; they are consumed by this function and become part of the constructed op tree. -C is the pad offset of the scalar lexical variable that will -be affected. If it is 0, the global $_ will be used. +C must be zero (it used to identity the pad slot of lexical $_). =cut */ @@ -7606,11 +7767,14 @@ OP * Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) { PERL_ARGS_ASSERT_NEWGIVENOP; + PERL_UNUSED_ARG(defsv_off); + + assert(!defsv_off); return newGIVWHENOP( ref_array_or_hash(cond), block, OP_ENTERGIVEN, OP_LEAVEGIVEN, - defsv_off); + 0); } /* @@ -7733,7 +7897,7 @@ static void const_av_xsub(pTHX_ CV* cv); =for apidoc cv_const_sv If C is a constant sub eligible for inlining, returns the constant -value returned by the sub. Otherwise, returns NULL. +value returned by the sub. Otherwise, returns C. Constant subs can be created with C or as described in L. @@ -8377,6 +8541,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, : NULL; if (block) { + assert(PL_parser); /* This makes sub {}; work as expected. */ if (block->op_type == OP_STUB) { const line_t l = PL_parser->copline; @@ -8394,7 +8559,8 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, block->op_next = 0; if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv)) const_sv = - S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv)); + S_op_const_sv(aTHX_ start, PL_compcv, + cBOOL(CvCLONE(PL_compcv))); else const_sv = NULL; } @@ -8402,7 +8568,6 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, const_sv = NULL; if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) { - assert (block); cv_ckproto_len_flags((const CV *)gv, o ? (const GV *)cSVOPo->op_sv : NULL, ps, ps_len, ps_utf8|CV_CKPROTO_CURSTASH); @@ -8422,10 +8587,12 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (ckWARN(WARN_REDEFINE) || ( ckWARN_d(WARN_REDEFINE) && ( !const_sv || SvRV(gv) == const_sv - || sv_cmp(SvRV(gv), const_sv) ))) + || sv_cmp(SvRV(gv), const_sv) ))) { + assert(cSVOPo); Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Constant subroutine %"SVf" redefined", SVfARG(cSVOPo->op_sv)); + } SvREFCNT_inc_simple_void_NN(PL_compcv); CopLINE_set(PL_curcop, oldline); @@ -8800,15 +8967,15 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) /* =for apidoc newCONSTSUB_flags -Creates a constant sub equivalent to Perl C which is +Creates a constant sub equivalent to Perl S> which is eligible for inlining at compile-time. -Currently, the only useful value for C is SVf_UTF8. +Currently, the only useful value for C is C. The newly created subroutine takes ownership of a reference to the passed in SV. -Passing NULL for SV creates a constant sub equivalent to C, +Passing C for SV creates a constant sub equivalent to S>, which won't be called if used as a destructor, but will suppress the overhead of a call to C. (This form, however, isn't eligible for inlining at compile time.) @@ -9003,7 +9170,7 @@ Perl_newSTUB(pTHX_ GV *gv, bool fake) assert(!GvCVu(gv)); GvCV_set(gv, cv); GvCVGEN(gv) = 0; - if (!fake && HvENAME_HEK(GvSTASH(gv))) + if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv))) gv_method_changed(gv); if (SvFAKE(gv)) { cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV); @@ -9512,7 +9679,7 @@ Perl_ck_eval(pTHX_ OP *o) op_sibling_splice(o, NULL, -1, NULL); op_free(o); - enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL); + enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL); /* establish postfix order */ enter->op_next = (OP*)enter; @@ -9710,6 +9877,20 @@ Perl_ck_ftst(pTHX_ OP *o) op_free(o); return newop; } + + if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) { + SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2); + if (name) { + /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)", + array_passed_to_stat, name); + } + else { + /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat); + } + } + scalar((OP *) kid); if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) o->op_private |= OPpFT_ACCESS; if (type != OP_STAT && type != OP_LSTAT @@ -10046,7 +10227,6 @@ Perl_ck_grep(pTHX_ OP *o) LOGOP *gwop; OP *kid; const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; - PADOFFSET offset; PERL_ARGS_ASSERT_CK_GREP; @@ -10071,17 +10251,10 @@ Perl_ck_grep(pTHX_ OP *o) Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type); kid = kUNOP->op_first; - gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid)); + gwop = alloc_LOGOP(type, o, LINKLIST(kid)); kid->op_next = (OP*)gwop; - offset = pad_findmy_pvs("$_", 0); - if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { - o->op_private = gwop->op_private = 0; - gwop->op_targ = pad_alloc(type, SVs_PADTMP); - } - else { - o->op_private = gwop->op_private = OPpGREP_LEX; - gwop->op_targ = o->op_targ = offset; - } + o->op_private = gwop->op_private = 0; + gwop->op_targ = pad_alloc(type, SVs_PADTMP); kid = OpSIBLING(cLISTOPo->op_first); for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid)) @@ -10332,15 +10505,9 @@ Perl_ck_sassign(pTHX_ OP *o) OP * Perl_ck_match(pTHX_ OP *o) { + PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_CK_MATCH; - if (o->op_type != OP_QR && PL_compcv) { - const PADOFFSET offset = pad_findmy_pvs("$_", 0); - if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) { - o->op_targ = offset; - o->op_private |= OPpTARGET_MY; - } - } if (o->op_type == OP_MATCH || o->op_type == OP_QR) o->op_private |= OPpRUNTIME; return o; @@ -10597,6 +10764,12 @@ Perl_ck_require(pTHX_ OP *o) s = SvPVX(sv); len = SvCUR(sv); end = s + len; + /* treat ::foo::bar as foo::bar */ + if (len >= 2 && s[0] == ':' && s[1] == ':') + DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s); + if (s == end) + DIE(aTHX_ "Bareword in require maps to empty filename"); + for (; s < end; s++) { if (*s == ':' && s[1] == ':') { *s = '/'; @@ -11167,11 +11340,20 @@ OP * Perl_ck_entersub_args_list(pTHX_ OP *entersubop) { OP *aop; + PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST; + aop = cUNOPx(entersubop)->op_first; if (!OpHAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) { + /* skip the extra attributes->import() call implicitly added in + * something like foo(my $x : bar) + */ + if ( aop->op_type == OP_ENTERSUB + && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID + ) + continue; list(aop); op_lvalue(aop, OP_ENTERSUB); } @@ -11893,13 +12075,14 @@ Perl_ck_each(pTHX_ OP *o) || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV ) ) - /* we let ck_fun handle it */ - break; + goto bad; default: - Perl_croak_nocontext( + qerror(Perl_mess(aTHX_ "Experimental %s on scalar is now forbidden", - PL_op_desc[orig_type]); - break; + PL_op_desc[orig_type])); + bad: + bad_type_pv(1, "hash or array", o, kid); + return o; } } return ck_fun(o); @@ -12194,7 +12377,7 @@ enum { that's flagged OA_DANGEROUS */ AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's not in any of the categories above */ - AAS_DEFAV = 0x200, /* contains just a single '@_' on RHS */ + AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */ }; @@ -12314,6 +12497,15 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p) break; case OP_UNDEF: + /* undef counts as a scalar on the RHS: + * (undef, $x) = ...; # only 1 scalar on LHS: always safe + * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe + */ + if (rhs) + (*scalars_p)++; + flags = AAS_SAFE_SCALAR; + break; + case OP_PUSHMARK: case OP_STUB: /* these are all no-ops; they don't push a potentially common SV @@ -12334,7 +12526,8 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p) default: if (PL_opargs[o->op_type] & OA_DANGEROUS) { (*scalars_p) += 2; - return AAS_DANGEROUS; + flags = AAS_DANGEROUS; + break; } if ( (PL_opargs[o->op_type] & OA_TARGLEX) @@ -12463,7 +12656,7 @@ S_inplace_aassign(pTHX_ OP *o) { * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller. */ -void +STATIC void S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) { dVAR; @@ -12851,6 +13044,8 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) is_last = TRUE; index_skip = action_count; action |= MDEREF_FLAG_last; + if (index_type != MDEREF_INDEX_none) + arg--; } if (pass) @@ -13117,6 +13312,11 @@ Perl_rpeep(pTHX_ OP *o) } redo: + + /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */ + assert(!oldoldop || oldoldop->op_next == oldop); + assert(!oldop || oldop->op_next == o); + /* By default, this op has now been optimised. A couple of cases below clear this again. */ o->op_opt = 1; @@ -13438,9 +13638,10 @@ Perl_rpeep(pTHX_ OP *o) op_null(o); if (oldop) oldop->op_next = nextop; + o = nextop; /* Skip (old)oldop assignment since the current oldop's op_next already points to the next op. */ - continue; + goto redo; } } break; @@ -13474,7 +13675,7 @@ Perl_rpeep(pTHX_ OP *o) /* XXX: We avoid setting op_seq here to prevent later calls to rpeep() from mistakenly concluding that optimisation has already occurred. This doesn't fix the real problem, - though (See 20010220.007). AMS 20010719 */ + though (See 20010220.007 (#5874)). AMS 20010719 */ /* op_seq functionality is now replaced by op_opt */ o->op_opt = 0; /* FALLTHROUGH */ @@ -13628,7 +13829,7 @@ Perl_rpeep(pTHX_ OP *o) /* Note that you'd normally expect targs to be * contiguous in my($a,$b,$c), but that's not the case * when external modules start doing things, e.g. - i* Function::Parameters */ + * Function::Parameters */ if (p->op_targ != base + count) break; assert(p->op_targ == base + count); @@ -13652,9 +13853,21 @@ Perl_rpeep(pTHX_ OP *o) break; /* there's a biggest base we can fit into a - * SAVEt_CLEARPADRANGE in pp_padrange */ - if (intro && base > - (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))) + * SAVEt_CLEARPADRANGE in pp_padrange. + * (The sizeof() stuff will be constant-folded, and is + * intended to avoid getting "comparison is always false" + * compiler warnings. See the comments above + * MEM_WRAP_CHECK for more explanation on why we do this + * in a weird way to avoid compiler warnings.) + */ + if ( intro + && (8*sizeof(base) > + 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT + ? base + : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) + ) > + (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) + ) break; /* Success! We've got another valid pad op to optimise away */ @@ -13672,10 +13885,10 @@ Perl_rpeep(pTHX_ OP *o) * optimise away would have exactly the same effect as the * padrange. * In particular in void context, we can only optimise to - * a padrange if see see the complete sequence + * a padrange if we see the complete sequence * pushmark, pad*v, ...., list - * which has the net effect of of leaving the markstack as it - * was. Not pushing on to the stack (whereas padsv does touch + * which has the net effect of leaving the markstack as it + * was. Not pushing onto the stack (whereas padsv does touch * the stack) makes no difference in void context. */ assert(followop); @@ -13837,7 +14050,8 @@ Perl_rpeep(pTHX_ OP *o) oldoldop = NULL; goto redo; } - o = oldop; + o = oldop->op_next; + goto redo; } else if (o->op_next->op_type == OP_RV2SV) { if (!(o->op_next->op_private & OPpDEREF)) { @@ -13886,11 +14100,11 @@ Perl_rpeep(pTHX_ OP *o) || o->op_next->op_type == OP_NULL)) o->op_next = o->op_next->op_next; - /* if we're an OR and our next is a AND in void context, we'll - follow it's op_other on short circuit, same for reverse. + /* If we're an OR and our next is an AND in void context, we'll + follow its op_other on short circuit, same for reverse. We can't do this with OP_DOR since if it's true, its return value is the underlying value which must be evaluated - by the next op */ + by the next op. */ if (o->op_next && ( (IS_AND_OP(o) && IS_OR_OP(o->op_next)) @@ -13955,6 +14169,7 @@ Perl_rpeep(pTHX_ OP *o) case OP_DORASSIGN: case OP_RANGE: case OP_ONCE: + case OP_ARGDEFELEM: while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; DEFER(cLOGOP->op_other); @@ -14134,6 +14349,11 @@ Perl_rpeep(pTHX_ OP *o) op_null(o); enter->op_private |= OPpITER_REVERSED; iter->op_private |= OPpITER_REVERSED; + + oldoldop = NULL; + oldop = ourlast; + o = oldop->op_next; + goto redo; break; } @@ -14247,7 +14467,7 @@ Perl_rpeep(pTHX_ OP *o) || !r /* .... = (); */ || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */ || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */ - || (lscalars < 2) /* ($x) = ... */ + || (lscalars < 2) /* ($x, undef) = ... */ ) { NOOP; /* always safe */ } @@ -14291,7 +14511,7 @@ Perl_rpeep(pTHX_ OP *o) /* ... = ($x) * may have to handle aggregate on LHS, but we can't - * have common scalars*/ + * have common scalars. */ if (rscalars < 2) o->op_private &= ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1); @@ -14333,7 +14553,7 @@ Perl_peep(pTHX_ OP *o) =for apidoc Ao||custom_op_xop Return the XOP structure for a given custom op. This macro should be -considered internal to OP_NAME and the other access macros: use them instead. +considered internal to C and the other access macros: use them instead. This macro does call a function. Prior to 5.19.6, this was implemented as a function. @@ -14433,10 +14653,12 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) } } } - /* Some gcc releases emit a warning for this function: + /* On some platforms (HP-UX, IA64) gcc emits a warning for this function: * op.c: In function 'Perl_custom_op_get_field': * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized] - * Whether this is true, is currently unknown. */ + * This is because on those platforms (with -DEBUGGING) NOT_REACHED + * expands to assert(0), which expands to ((0) ? (void)0 : + * __assert(...)), and gcc doesn't know that __assert can never return. */ return any; } } @@ -14470,8 +14692,8 @@ Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop) =for apidoc core_prototype This function assigns the prototype of the named core function to C, or -to a new mortal SV if C is NULL. It returns the modified C, or -NULL if the core function has no prototype. C is a code as returned +to a new mortal SV if C is C. It returns the modified C, or +C if the core function has no prototype. C is a code as returned by C. It must not be equal to 0. =cut @@ -14510,13 +14732,7 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, case KEY_keys: retsetpvs("\\[%@]", OP_KEYS); case KEY_values: retsetpvs("\\[%@]", OP_VALUES); case KEY_each: retsetpvs("\\[%@]", OP_EACH); - case KEY_push: retsetpvs("\\@@", OP_PUSH); - case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT); - case KEY_pop: retsetpvs(";\\@", OP_POP); - case KEY_shift: retsetpvs(";\\@", OP_SHIFT); case KEY_pos: retsetpvs(";\\[$*]", OP_POS); - case KEY_splice: - retsetpvs("\\@;$$@", OP_SPLICE); case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__: retsetpvs("", 0); case KEY_evalbytes: @@ -14596,6 +14812,12 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code, newOP(OP_CALLER,0) ) ); + case OP_EACH: + case OP_KEYS: + case OP_VALUES: + o = newUNOP(OP_AVHVSWITCH,0,argop); + o->op_private = opnum-OP_EACH; + return o; case OP_SELECT: /* which represents OP_SSELECT as well */ if (code) return newCONDOP( @@ -14804,6 +15026,7 @@ const_av_xsub(pTHX_ CV* cv) XSRETURN(AvFILLp(av)+1); } + /* * ex: set ts=8 sts=4 sw=4 et: */