X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/796b6530911f5ebd6a26275873610304e63d5d19..e118fea3ba754e973a9016295ef418b1aacb88b1:/op.c diff --git a/op.c b/op.c index 08788ce..fdf41a7 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 @@ -1188,6 +1257,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 +1268,7 @@ Perl_op_refcnt_lock(pTHX) void Perl_op_refcnt_unlock(pTHX) + PERL_TSA_RELEASE(PL_op_mutex) { #ifdef USE_ITHREADS dVAR; @@ -1399,7 +1470,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; @@ -1417,7 +1488,7 @@ S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags) * being spread throughout this file. */ -LOGOP * +STATIC LOGOP * S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) { dVAR; @@ -1521,8 +1592,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 +1613,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 +1626,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 +2375,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 +2415,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 @@ -2606,7 +2693,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 +2804,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 +2842,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 +2890,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 +2898,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 +2936,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 +2952,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 +3045,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 +3107,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 +3119,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 +3191,11 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) goto nomod; case OP_SREFGEN: + if (type == OP_NULL) { /* local */ + local_refgen: + op_lvalue(cUNOPo->op_first, OP_NULL); + return o; + } if (type != OP_AASSIGN && type != OP_SASSIGN && type != OP_ENTERLOOP) goto nomod; @@ -3077,6 +3204,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: @@ -3185,6 +3314,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 +3330,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 +3746,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 +3755,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 +3772,11 @@ 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) { + /* 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 +4174,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 +4282,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 +4376,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 +4446,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 +4472,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 +4524,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; @@ -5193,7 +5350,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; @@ -5809,9 +5966,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 +5974,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 @@ -6714,24 +6861,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 +6871,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 +6889,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 +6912,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,12 +6959,28 @@ 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 */ + /* 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 = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other)); logop->op_flags |= (U8)flags; logop->op_private = (U8)(1 | (flags >> 8)); @@ -7086,7 +7236,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 +7374,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 +7437,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 +7619,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->op_targ = 0; enterop->op_private = 0; o = newUNOP(leave_opcode, 0, (OP *) enterop); @@ -7596,8 +7741,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 C<$_> will be used. +C must be zero (it used to identity the pad slot of lexical $_). =cut */ @@ -7606,11 +7750,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); } /* @@ -8377,6 +8524,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 +8542,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 +8551,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 +8570,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,7 +8950,7 @@ 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 C. @@ -8808,7 +8958,7 @@ Currently, the only useful value for C is C. The newly created subroutine takes ownership of a reference to the passed in SV. -Passing C 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 +9153,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); @@ -9710,6 +9860,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 +10210,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; @@ -10073,15 +10236,8 @@ Perl_ck_grep(pTHX_ OP *o) gwop = S_alloc_LOGOP(aTHX_ 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 +10488,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 +10747,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 +11323,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 +12058,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 +12360,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 */ }; @@ -12343,7 +12509,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) @@ -12472,7 +12639,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; @@ -13126,6 +13293,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; @@ -13447,9 +13619,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; @@ -13637,7 +13810,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); @@ -13661,9 +13834,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 */ @@ -13681,10 +13866,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); @@ -13846,7 +14031,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)) { @@ -13895,11 +14081,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)) @@ -14143,6 +14329,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; } @@ -14442,10 +14633,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; } } @@ -14519,13 +14712,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: @@ -14605,6 +14792,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(