X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/dd9035cd5bdeced1187df399d27d526f3b30194b..73134a2eb4055c76fe5b154da95e09118f716fd8:/op.c diff --git a/op.c b/op.c index 47f8300..b0a04dd 100644 --- a/op.c +++ b/op.c @@ -103,8 +103,9 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #include "perl.h" #include "keywords.h" -#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) -#define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o) +#define CALL_PEEP(o) PL_peepp(aTHX_ o) +#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o) +#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o) #if defined(PL_OP_SLAB_ALLOC) @@ -305,10 +306,16 @@ Perl_Slab_Free(pTHX_ void *op) ? ( op_free((OP*)o), \ Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ (OP*)0 ) \ - : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) + : PL_check[type](aTHX_ (OP*)o)) #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) +#define CHANGE_TYPE(o,type) \ + STMT_START { \ + o->op_type = (OPCODE)type; \ + o->op_ppaddr = PL_ppaddr[type]; \ + } STMT_END + STATIC const char* S_gv_ename(pTHX_ GV *gv) { @@ -568,7 +575,7 @@ Perl_op_clear(pTHX_ OP *o) break; default: if (!(o->op_flags & OPf_REF) - || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst))) + || (PL_check[o->op_type] != Perl_ck_ftst)) break; /* FALL THROUGH */ case OP_GVSV: @@ -644,6 +651,7 @@ Perl_op_clear(pTHX_ OP *o) break; /* FALL THROUGH */ case OP_TRANS: + case OP_TRANSR: if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { @@ -716,7 +724,7 @@ S_cop_free(pTHX_ COP* cop) CopSTASH_free(cop); if (! specialWARN(cop->cop_warnings)) PerlMemShared_free(cop->cop_warnings); - Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash); + cophh_free(CopHINTHASH_get(cop)); } STATIC void @@ -817,14 +825,47 @@ Perl_op_refcnt_unlock(pTHX) /* Contextualizers */ -#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) +/* +=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, +or C to specify the context to apply. The modified op tree +is returned. -static OP * -S_linklist(pTHX_ OP *o) +=cut +*/ + +OP * +Perl_op_contextualize(pTHX_ OP *o, I32 context) +{ + PERL_ARGS_ASSERT_OP_CONTEXTUALIZE; + switch (context) { + case G_SCALAR: return scalar(o); + case G_ARRAY: return list(o); + case G_VOID: return scalarvoid(o); + default: + Perl_croak(aTHX_ "panic: op_contextualize bad context"); + return o; + } +} + +/* +=head1 Optree Manipulation Functions + +=for apidoc Am|OP*|op_linklist|OP *o +This function is the implementation of the L macro. It should +not be called directly. + +=cut +*/ + +OP * +Perl_op_linklist(pTHX_ OP *o) { OP *first; - PERL_ARGS_ASSERT_LINKLIST; + PERL_ARGS_ASSERT_OP_LINKLIST; if (o->op_next) return o->op_next; @@ -869,7 +910,8 @@ S_scalarboolean(pTHX_ OP *o) PERL_ARGS_ASSERT_SCALARBOOLEAN; - if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { + if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST + && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) { if (ckWARN(WARN_SYNTAX)) { const line_t oldline = CopLINE(PL_curcop); @@ -1104,12 +1146,21 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_NOT: kid = cUNOPo->op_first; if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && - kid->op_type != OP_TRANS) { + kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) { goto func_ops; } useless = "negative pattern binding (!~)"; break; + case OP_SUBST: + if (cPMOPo->op_pmflags & PMf_NONDESTRUCT) + useless = "non-destructive substitution (s///r)"; + break; + + case OP_TRANSR: + useless = "non-destructive transliteration (tr///r)"; + break; + case OP_RV2GV: case OP_RV2SV: case OP_RV2AV: @@ -1358,24 +1409,32 @@ S_modkids(pTHX_ OP *o, I32 type) if (o && o->op_flags & OPf_KIDS) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) - mod(kid, type); + op_lvalue(kid, type); } return o; } -/* Propagate lvalue ("modifiable") context to an op and its children. - * 'type' represents the context type, roughly based on the type of op that - * would do the modifying, although local() is represented by OP_NULL. - * It's responsible for detecting things that can't be modified, flag - * things that need to behave specially in an lvalue context (e.g., "$$x = 5" - * might have to vivify a reference in $x), and so on. - * - * For example, "$a+1 = 2" would cause mod() to be called with o being - * OP_ADD and type being OP_SASSIGN, and would output an error. - */ +/* +=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, +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. + +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>. + +=cut +*/ OP * -Perl_mod(pTHX_ OP *o, I32 type) +Perl_op_lvalue(pTHX_ OP *o, I32 type) { dVAR; OP *kid; @@ -1559,7 +1618,7 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_COND_EXPR: localize = 1; for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) - mod(kid, type); + op_lvalue(kid, type); break; case OP_RV2AV: @@ -1647,7 +1706,7 @@ Perl_mod(pTHX_ OP *o, I32 type) o->op_targ = pad_alloc(o->op_type, SVs_PADMY); assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL); if (o->op_flags & OPf_KIDS) - mod(cBINOPo->op_first->op_sibling, type); + op_lvalue(cBINOPo->op_first->op_sibling, type); break; case OP_AELEM: @@ -1668,7 +1727,7 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_LINESEQ: localize = 0; if (o->op_flags & OPf_KIDS) - mod(cLISTOPo->op_last, type); + op_lvalue(cLISTOPo->op_last, type); break; case OP_NULL: @@ -1678,27 +1737,27 @@ Perl_mod(pTHX_ OP *o, I32 type) else if (!(o->op_flags & OPf_KIDS)) break; if (o->op_targ != OP_LIST) { - mod(cBINOPo->op_first, type); + op_lvalue(cBINOPo->op_first, type); break; } /* FALL THROUGH */ case OP_LIST: localize = 0; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) - mod(kid, type); + op_lvalue(kid, type); break; case OP_RETURN: if (type != OP_LEAVESUBLV) goto nomod; - break; /* mod()ing was handled by ck_return() */ + break; /* op_lvalue()ing was handled by ck_return() */ } /* [20011101.069] 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 && - PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)) + PL_check[o->op_type] == Perl_ck_ftst) return o; if (type != OP_LEAVESUBLV) @@ -1726,6 +1785,14 @@ Perl_mod(pTHX_ OP *o, I32 type) return o; } +/* Do not use this. It will be removed after 5.14. */ +OP * +Perl_mod(pTHX_ OP *o, I32 type) +{ + return op_lvalue(o,type); +} + + STATIC bool S_scalar_mod_type(const OP *o, I32 type) { @@ -1764,6 +1831,7 @@ S_scalar_mod_type(const OP *o, I32 type) case OP_CONCAT: case OP_SUBST: case OP_TRANS: + case OP_TRANSR: case OP_READ: case OP_SYSREAD: case OP_RECV: @@ -1928,7 +1996,7 @@ S_dup_attrlist(pTHX_ OP *o) rop = NULL; for (o = cLISTOPo->op_first; o; o=o->op_sibling) { if (o->op_type == OP_CONST) - rop = append_elem(OP_LIST, rop, + rop = op_append_elem(OP_LIST, rop, newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv))); } @@ -1964,9 +2032,9 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, newSVpvs(ATTRSMODULE), NULL, - prepend_elem(OP_LIST, + op_prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, stashsv), - prepend_elem(OP_LIST, + op_prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newRV(target)), dup_attrlist(attrs)))); @@ -2001,23 +2069,23 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) arg = newOP(OP_PADSV, 0); arg->op_targ = target->op_targ; - arg = prepend_elem(OP_LIST, + arg = op_prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, stashsv), - prepend_elem(OP_LIST, + op_prepend_elem(OP_LIST, newUNOP(OP_REFGEN, 0, - mod(arg, OP_REFGEN)), + op_lvalue(arg, OP_REFGEN)), dup_attrlist(attrs))); /* Fake up a method call to import */ meth = newSVpvs_share("import"); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, - append_elem(OP_LIST, - prepend_elem(OP_LIST, pack, list(arg)), + op_append_elem(OP_LIST, + op_prepend_elem(OP_LIST, pack, list(arg)), newSVOP(OP_METHOD_NAMED, 0, meth))); imop->op_private |= OPpENTERSUB_NOMOD; /* Combine the ops. */ - *imopsp = append_elem(OP_LIST, *imopsp, imop); + *imopsp = op_append_elem(OP_LIST, *imopsp, imop); } /* @@ -2054,7 +2122,7 @@ Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, if (len) { const char * const sstr = attrstr; for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; - attrs = append_elem(OP_LIST, attrs, + attrs = op_append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, newSVpvn(sstr, attrstr-sstr))); } @@ -2062,9 +2130,9 @@ Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, newSVpvs(ATTRSMODULE), - NULL, prepend_elem(OP_LIST, + NULL, op_prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), - prepend_elem(OP_LIST, + op_prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, newRV(MUTABLE_SV(cv))), attrs))); @@ -2075,6 +2143,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) { dVAR; I32 type; + const bool stately = PL_parser && PL_parser->in_my == KEY_state; PERL_ARGS_ASSERT_MY_KID; @@ -2145,7 +2214,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) } o->op_flags |= OPf_MOD; o->op_private |= OPpLVAL_INTRO; - if (PL_parser->in_my == KEY_state) + if (stately) o->op_private |= OPpPAD_STATE; return o; } @@ -2175,11 +2244,11 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) o = my_kid(o, attrs, &rops); if (rops) { if (maybe_scalar && o->op_type == OP_PADSV) { - o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o)); + o = scalar(op_append_list(OP_LIST, rops, o)); o->op_private |= OPpLVAL_INTRO; } else - o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); + o = op_append_list(OP_LIST, o, rops); } PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; @@ -2209,7 +2278,10 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) || ltype == OP_PADHV) && ckWARN(WARN_MISC)) { const char * const desc - = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS) + = PL_op_desc[( + rtype == OP_SUBST || rtype == OP_TRANS + || rtype == OP_TRANSR + ) ? (int)rtype : OP_MATCH]; const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV) ? "@array" : "%hash"); @@ -2225,9 +2297,17 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) no_bareword_allowed(right); } - ismatchop = rtype == OP_MATCH || - rtype == OP_SUBST || - rtype == OP_TRANS; + /* !~ doesn't make sense with /r, so error on it for now */ + if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) && + type == OP_NOT) + yyerror("Using !~ with s///r doesn't make sense"); + if (rtype == OP_TRANSR && type == OP_NOT) + yyerror("Using !~ with tr///r doesn't make sense"); + + ismatchop = (rtype == OP_MATCH || + rtype == OP_SUBST || + rtype == OP_TRANS || rtype == OP_TRANSR) + && !(right->op_flags & OPf_SPECIAL); if (ismatchop && right->op_private & OPpTARGET_MY) { right->op_targ = 0; right->op_private &= ~OPpTARGET_MY; @@ -2236,16 +2316,18 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) OP *newleft; right->op_flags |= OPf_STACKED; - if (rtype != OP_MATCH && + if (rtype != OP_MATCH && rtype != OP_TRANSR && ! (rtype == OP_TRANS && - right->op_private & OPpTRANS_IDENTICAL)) - newleft = mod(left, rtype); + right->op_private & OPpTRANS_IDENTICAL) && + ! (rtype == OP_SUBST && + (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT))) + newleft = op_lvalue(left, rtype); else newleft = left; - if (right->op_type == OP_TRANS) + if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR) o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right); else - o = prepend_elem(rtype, scalar(newleft), right); + o = op_prepend_elem(rtype, scalar(newleft), right); if (type == OP_NOT) return newUNOP(OP_NOT, 0, scalar(o)); return o; @@ -2263,13 +2345,27 @@ Perl_invert(pTHX_ OP *o) return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); } +/* +=for apidoc Amx|OP *|op_scope|OP *o + +Wraps up an op tree with some additional ops so that at runtime a dynamic +scope will be created. The original ops run in the new dynamic scope, +and then, provided that they exit normally, the scope will be unwound. +The additional ops used to create and unwind the dynamic scope will +normally be an C/C pair, but a C op may be used +instead if the ops are simple enough to not need the full dynamic scope +structure. + +=cut +*/ + OP * -Perl_scope(pTHX_ OP *o) +Perl_op_scope(pTHX_ OP *o) { dVAR; if (o) { if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { - o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); + o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); o->op_type = OP_LEAVE; o->op_ppaddr = PL_ppaddr[OP_LEAVE]; } @@ -2293,17 +2389,21 @@ Perl_scope(pTHX_ OP *o) } return o; } - + int Perl_block_start(pTHX_ int full) { dVAR; const int retval = PL_savestack_ix; + pad_block_start(full); SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; SAVECOMPILEWARNINGS(); PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); + + CALL_BLOCK_HOOKS(bhk_start, full); + return retval; } @@ -2312,15 +2412,40 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) { dVAR; const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; - OP* const retval = scalarseq(seq); + OP* retval = scalarseq(seq); + + CALL_BLOCK_HOOKS(bhk_pre_end, &retval); + LEAVE_SCOPE(floor); CopHINTS_set(&PL_compiling, PL_hints); if (needblockscope) PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ pad_leavemy(); + + CALL_BLOCK_HOOKS(bhk_post_end, &retval); + return retval; } +/* +=head1 Compile-time scope hooks + +=for apidoc Aox||blockhook_register + +Register a set of hooks to be called when the Perl lexical scope changes +at compile time. See L. + +=cut +*/ + +void +Perl_blockhook_register(pTHX_ BHK *hk) +{ + PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER; + + Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk))); +} + STATIC OP * S_newDEFSVOP(pTHX) { @@ -2349,7 +2474,10 @@ Perl_newPROG(pTHX_ OP *o) PL_eval_root = newUNOP(OP_LEAVEEVAL, ((PL_in_eval & EVAL_KEEPERR) ? OPf_SPECIAL : 0), o); - PL_eval_start = linklist(PL_eval_root); + /* don't use LINKLIST, since PL_eval_root might indirect through + * a rather expensive function call and LINKLIST evaluates its + * argument more than once */ + PL_eval_start = op_linklist(PL_eval_root); PL_eval_root->op_private |= OPpREFCOUNTED; OpREFCNT_set(PL_eval_root, 1); PL_eval_root->op_next = 0; @@ -2362,7 +2490,7 @@ Perl_newPROG(pTHX_ OP *o) S_op_destroy(aTHX_ o); return; } - PL_main_root = scope(sawparens(scalarvoid(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; @@ -2441,7 +2569,7 @@ Perl_localize(pTHX_ OP *o, I32 lex) if (lex) o = my(o); else - o = mod(o, OP_NULL); /* a bit kludgey */ + o = op_lvalue(o, OP_NULL); /* a bit kludgey */ PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; return o; @@ -2455,7 +2583,7 @@ Perl_jmaybe(pTHX_ OP *o) if (o->op_type == OP_LIST) { OP * const o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV))); - o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); + o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o)); } return o; } @@ -2509,6 +2637,7 @@ S_fold_constants(pTHX_ register OP *o) case OP_SLE: case OP_SGE: case OP_SCMP: + case OP_SPRINTF: /* XXX what about the numeric ops? */ if (PL_hints & HINT_LOCALE) goto nope; @@ -2615,19 +2744,19 @@ S_gen_constant_list(pTHX_ register OP *o) PL_op = curop = LINKLIST(o); o->op_next = 0; CALL_PEEP(curop); - pp_pushmark(); + Perl_pp_pushmark(aTHX); CALLRUNOPS(aTHX); PL_op = curop; assert (!(curop->op_flags & OPf_SPECIAL)); assert(curop->op_type == OP_RANGE); - pp_anonlist(); + Perl_pp_anonlist(aTHX); PL_tmps_floor = oldtmps_floor; o->op_type = OP_RV2AV; o->op_ppaddr = PL_ppaddr[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 peep() */ + o->op_opt = 0; /* needs to be revisited in rpeep() */ curop = ((UNOP*)o)->op_first; ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--)); #ifdef PERL_MAD @@ -2635,7 +2764,7 @@ S_gen_constant_list(pTHX_ register OP *o) #else op_free(curop); #endif - linklist(o); + LINKLIST(o); return list(o); } @@ -2662,10 +2791,27 @@ Perl_convert(pTHX_ I32 type, I32 flags, OP *o) return fold_constants(o); } +/* +=head1 Optree Manipulation Functions +*/ + /* List constructors */ +/* +=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 +is null, the other is returned unchanged. + +=cut +*/ + OP * -Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) +Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last) { if (!first) return last; @@ -2689,48 +2835,74 @@ Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) return first; } +/* +=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, +the other is returned unchanged. + +=cut +*/ + OP * -Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) +Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last) { if (!first) - return (OP*)last; + return last; if (!last) - return (OP*)first; + return first; if (first->op_type != (unsigned)type) - return prepend_elem(type, (OP*)first, (OP*)last); + return op_prepend_elem(type, first, last); if (last->op_type != (unsigned)type) - return append_elem(type, (OP*)first, (OP*)last); + return op_append_elem(type, first, last); - first->op_last->op_sibling = last->op_first; - first->op_last = last->op_last; + ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first; + ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last; first->op_flags |= (last->op_flags & OPf_KIDS); #ifdef PERL_MAD - if (last->op_first && first->op_madprop) { - MADPROP *mp = last->op_first->op_madprop; + if (((LISTOP*)last)->op_first && first->op_madprop) { + MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop; if (mp) { while (mp->mad_next) mp = mp->mad_next; mp->mad_next = first->op_madprop; } else { - last->op_first->op_madprop = first->op_madprop; + ((LISTOP*)last)->op_first->op_madprop = first->op_madprop; } } first->op_madprop = last->op_madprop; last->op_madprop = 0; #endif - S_op_destroy(aTHX_ (OP*)last); + S_op_destroy(aTHX_ last); - return (OP*)first; + return first; } +/* +=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, +the other is returned unchanged. + +=cut +*/ + OP * -Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) +Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last) { if (!first) return last; @@ -3009,6 +3181,17 @@ Perl_mad_free(pTHX_ MADPROP* mp) #endif +/* +=head1 Optree construction + +=for apidoc Am|OP *|newNULLLIST + +Constructs, checks, and returns a new C op, which represents an +empty list expression. + +=cut +*/ + OP * Perl_newNULLLIST(pTHX) { @@ -3024,6 +3207,18 @@ S_force_list(pTHX_ OP *o) return o; } +/* +=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 +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. + +=cut +*/ + OP * Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) { @@ -3060,6 +3255,17 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) return CHECKOP(type, listop); } +/* +=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 +eight bits of C, and, shifted up eight bits, the eight bits +of C. + +=cut +*/ + OP * Perl_newOP(pTHX_ I32 type, I32 flags) { @@ -3088,6 +3294,20 @@ Perl_newOP(pTHX_ I32 type, I32 flags) return CHECKOP(type, o); } +/* +=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 +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 +child of the unary op; it is consumed by this function and become part +of the constructed op tree. + +=cut +*/ + OP * Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) { @@ -3120,6 +3340,20 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) return fold_constants((OP *) unop); } +/* +=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 +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 +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. + +=cut +*/ + OP * Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) { @@ -3293,8 +3527,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) U8 range_mark = UTF_TO_NATIVE(0xff); sv_catpvn(transv, (char *)&range_mark, 1); } - t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff, - UNICODE_ALLOW_SUPER); + t = uvuni_to_utf8(tmpbuf, 0x7fffffff); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); t = (const U8*)SvPVX_const(transv); tlen = SvCUR(transv); @@ -3518,6 +3751,16 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) return o; } +/* +=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 +and, shifted up eight bits, the eight bits of C. + +=cut +*/ + OP * Perl_newPMOP(pTHX_ I32 type, I32 flags) { @@ -3534,8 +3777,24 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) if (PL_hints & HINT_RE_TAINT) pmop->op_pmflags |= PMf_RETAINT; - if (PL_hints & HINT_LOCALE) - pmop->op_pmflags |= PMf_LOCALE; + if (PL_hints & HINT_LOCALE) { + set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET); + } + else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) { + set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET); + } + if (PL_hints & HINT_RE_FLAGS) { + SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_ + PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0 + ); + if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags); + reflags = Perl_refcounted_he_fetch_pvn(aTHX_ + PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0 + ); + if (reflags && SvOK(reflags)) { + set_regex_charset(&(pmop->op_pmflags), SvIV(reflags)); + } + } #ifdef USE_ITHREADS @@ -3588,7 +3847,10 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) PERL_ARGS_ASSERT_PMRUNTIME; - if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) { + if ( + o->op_type == OP_SUBST + || o->op_type == OP_TRANS || o->op_type == OP_TRANSR + ) { /* last element in list is the replacement; pop it */ OP* kid; repl = cLISTOPx(expr)->op_last; @@ -3610,7 +3872,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) op_free(oe); } - if (o->op_type == OP_TRANS) { + if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) { return pmtrans(o, expr, repl); } @@ -3623,7 +3885,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) if (expr->op_type == OP_CONST) { SV *pat = ((SVOP*)expr)->op_sv; - U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME; + U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; if (o->op_flags & OPf_SPECIAL) pm_flags |= RXf_SPLIT; @@ -3667,7 +3929,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP); /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ - PL_cv_has_eval = 1; + if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1; /* establish postfix order */ if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) { @@ -3680,7 +3942,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) expr->op_next = (OP*)rcop; } - prepend_elem(o->op_type, scalar((OP*)rcop), o); + op_prepend_elem(o->op_type, scalar((OP*)rcop), o); } if (repl) { @@ -3734,7 +3996,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN))) { pm->op_pmflags |= PMf_CONST; /* const for long enough */ - prepend_elem(o->op_type, scalar(repl), o); + op_prepend_elem(o->op_type, scalar(repl), o); } else { if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */ @@ -3762,6 +4024,17 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) return (OP*)pm; } +/* +=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 +takes ownership of one reference to it. + +=cut +*/ + OP * Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) { @@ -3788,6 +4061,21 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) } #ifdef USE_ITHREADS + +/* +=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 +eight bits of C. A pad slot is automatically allocated, and +is populated with I; this function takes ownership of one reference +to it. + +This function only exists if Perl has been compiled to use ithreads. + +=cut +*/ + OP * Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) { @@ -3816,7 +4104,20 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) padop->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, padop); } -#endif + +#endif /* !USE_ITHREADS */ + +/* +=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 +reference; calling this function does not transfer ownership of any +reference to it. + +=cut +*/ OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) @@ -3833,6 +4134,18 @@ Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) #endif } +/* +=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 +must have been allocated using L; the memory will +be freed when the op is destroyed. + +=cut +*/ + OP * Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) { @@ -3921,6 +4234,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) #ifdef PERL_MAD OP *pegop = newOP(OP_NULL,0); #endif + SV *use_version = NULL; PERL_ARGS_ASSERT_UTILIZE; @@ -3953,8 +4267,8 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) /* Fake up a method call to VERSION */ meth = newSVpvs_share("VERSION"); veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, - append_elem(OP_LIST, - prepend_elem(OP_LIST, pack, list(version)), + op_append_elem(OP_LIST, + op_prepend_elem(OP_LIST, pack, list(version)), newSVOP(OP_METHOD_NAMED, 0, meth))); } } @@ -3967,7 +4281,9 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) } else if (SvNIOKp(((SVOP*)idop)->op_sv)) { imop = NULL; /* use 5.0; */ - if (!aver) + if (aver) + use_version = ((SVOP*)idop)->op_sv; + else idop->op_private |= OPpCONST_NOVER; } else { @@ -3983,8 +4299,8 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) meth = aver ? newSVpvs_share("import") : newSVpvs_share("unimport"); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, - append_elem(OP_LIST, - prepend_elem(OP_LIST, pack, list(arg)), + op_append_elem(OP_LIST, + op_prepend_elem(OP_LIST, pack, list(arg)), newSVOP(OP_METHOD_NAMED, 0, meth))); } @@ -3993,12 +4309,32 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")), NULL, NULL, - append_elem(OP_LINESEQ, - append_elem(OP_LINESEQ, + op_append_elem(OP_LINESEQ, + op_append_elem(OP_LINESEQ, newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)), newSTATEOP(0, NULL, veop)), newSTATEOP(0, NULL, imop) )); + if (use_version) { + /* If we request a version >= 5.9.5, load feature.pm with the + * feature bundle that corresponds to the required version. */ + use_version = sv_2mortal(new_version(use_version)); + + if (vcmp(use_version, + sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { + SV *const importsv = vnormal(use_version); + *SvPVX_mutable(importsv) = ':'; + ENTER_with_name("load_feature"); + Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); + LEAVE_with_name("load_feature"); + } + /* If a version >= 5.11.0 is requested, strictures are on by default! */ + if (vcmp(use_version, + sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) { + PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS); + } + } + /* The "did you use incorrect case?" warning used to be here. * The problem is that on case-insensitive filesystems one * might get false positives for "use" (and "require"): @@ -4102,7 +4438,7 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) imop = NULL; sv = va_arg(*args, SV*); while (sv) { - imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); sv = va_arg(*args, SV*); } } @@ -4115,7 +4451,7 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) ENTER; SAVEVPTR(PL_curcop); - lex_start(NULL, NULL, FALSE); + lex_start(NULL, NULL, 0); utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); LEAVE; @@ -4140,7 +4476,7 @@ Perl_dofile(pTHX_ OP *term, I32 force_builtin) if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, - append_elem(OP_LIST, term, + op_append_elem(OP_LIST, term, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv)))))); } @@ -4150,6 +4486,22 @@ Perl_dofile(pTHX_ OP *term, I32 force_builtin) return doop; } +/* +=head1 Optree construction + +=for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval + +Constructs, checks, and returns an C (list slice) op. I +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 +the slice; they are consumed by this function and become part of the +constructed op tree. + +=cut +*/ + OP * Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) { @@ -4202,6 +4554,29 @@ S_is_list_assignment(pTHX_ register const OP *o) 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 +constructed. Which type of assignment it is is automatically determined. +I 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. + +=cut +*/ + OP * Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) { @@ -4211,12 +4586,12 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (optype) { if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { return newLOGOP(optype, 0, - mod(scalar(left), optype), + op_lvalue(scalar(left), optype), newUNOP(OP_SASSIGN, 0, scalar(right))); } else { return newBINOP(optype, OPf_STACKED, - mod(scalar(left), optype), scalar(right)); + op_lvalue(scalar(left), optype), scalar(right)); } } @@ -4230,10 +4605,11 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) /* Grandfathering $[ assignment here. Bletch.*/ /* Only simple assignments like C<< ($[) = 1 >> are allowed */ PL_eval_start = (left->op_type == OP_CONST) ? right : NULL; - left = mod(left, OP_AASSIGN); + left = op_lvalue(left, OP_AASSIGN); if (PL_eval_start) PL_eval_start = 0; else if (left->op_type == OP_CONST) { + deprecate("assignment to $["); /* FIXME for MAD */ /* Result of assignment is always 1 (or we'd be dead already) */ return newSVOP(OP_CONST, 0, newSViv(1)); @@ -4429,12 +4805,13 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) right = newOP(OP_UNDEF, 0); if (right->op_type == OP_READLINE) { right->op_flags |= OPf_STACKED; - return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right)); + return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN), + scalar(right)); } else { PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ o = newBINOP(OP_SASSIGN, flags, - scalar(right), mod(scalar(left), OP_SASSIGN) ); + scalar(right), op_lvalue(scalar(left), OP_SASSIGN) ); if (PL_eval_start) PL_eval_start = 0; else { @@ -4449,6 +4826,24 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) return o; } +/* +=for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o + +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 L (or L). +If I