X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=729c25f0aa87bcd25f8606bd70d852c6c67e1967;hb=e853d2264b77e2bdc0758f8ab38e819629763e81;hp=943837e5e2cbb372e9a145f08da5972dfb5d6250;hpb=f92e1a16ee2379315520131bbe3465eb837abfa3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 943837e..729c25f 100644 --- a/op.c +++ b/op.c @@ -57,7 +57,7 @@ context is, either upward in the syntax tree, or either forward or backward in the execution order. (The bottom-up parser builds that part of the execution order it knows about, but if you follow the "next" links around, you'll find it's actually a closed loop through the -top level node. +top level node.) Whenever the bottom-up parser gets to a node that supplies context to its components, it invokes that portion of the top-down pass that applies @@ -103,6 +103,7 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #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) #if defined(PL_OP_SLAB_ALLOC) @@ -399,14 +400,6 @@ Perl_allocmy(pTHX_ const char *const name) /* check for duplicate declaration */ pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash)); - if (PL_parser->in_my_stash && *name != '$') { - yyerror(Perl_form(aTHX_ - "Can't declare class for non-scalar %s in \"%s\"", - name, - is_our ? "our" - : PL_parser->in_my == KEY_state ? "state" : "my")); - } - /* allocate a spare slot and store the name in that slot */ off = pad_add_name(name, @@ -490,6 +483,11 @@ Perl_op_free(pTHX_ OP *o) } } + /* Call the op_free hook if it has been set. Do it now so that it's called + * at the right time for refcounted ops, but still before all of the kids + * are freed. */ + CALL_OPFREEHOOK(o); + if (o->op_flags & OPf_KIDS) { register OP *kid, *nextkid; for (kid = cUNOPo->op_first; kid; kid = nextkid) { @@ -874,12 +872,8 @@ Perl_scalar(pTHX_ OP *o) for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) scalar(kid); break; - case OP_SPLIT: - if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { - if (!kPMOP->op_pmreplrootu.op_pmreplroot) - deprecate_old("implicit split to @_"); - } /* FALL THROUGH */ + case OP_SPLIT: case OP_MATCH: case OP_QR: case OP_SUBST: @@ -1193,12 +1187,6 @@ Perl_scalarvoid(pTHX_ OP *o) /* FALL THROUGH */ case OP_SCALAR: return scalar(o); - case OP_SPLIT: - if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { - if (!kPMOP->op_pmreplrootu.op_pmreplroot) - deprecate_old("implicit split to @_"); - } - break; } if (useless && ckWARN(WARN_VOID)) Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless); @@ -2772,7 +2760,7 @@ Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot) /* faked up qw list? */ if (slot == '(' && tm->mad_type == MAD_SV && - SvPVX((const SV *)tm->mad_val)[0] == 'q') + SvPVX((SV *)tm->mad_val)[0] == 'q') slot = 'x'; if (o) { @@ -2929,7 +2917,7 @@ Perl_newMADsv(pTHX_ char key, SV* sv) } MADPROP * -Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen) +Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen) { MADPROP *mp; Newxz(mp, 1, MADPROP); @@ -3347,6 +3335,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix)); PAD_SETSV(cPADOPo->op_padix, swash); SvPADTMP_on(swash); + SvREADONLY_on(swash); #else cSVOPo->op_sv = swash; #endif @@ -3865,7 +3854,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) SV *meth; if (version->op_type != OP_CONST || !SvNIOKp(vesv)) - Perl_croak(aTHX_ "Version number must be constant number"); + Perl_croak(aTHX_ "Version number must be a constant number"); /* Make copy of idop so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); @@ -3963,7 +3952,11 @@ PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS (or 0 for no flags). ver, if specified, provides version semantics similar to C. The optional trailing SV* arguments can be used to specify arguments to the module's import() -method, similar to C. +method, similar to C. They must be +terminated with a final NULL pointer. Note that this list can only +be omitted when the PERL_LOADMOD_NOIMPORT flag has been used. +Otherwise at least a single NULL pointer to designate the default +import list is required. =cut */ @@ -4333,7 +4326,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) ((LISTOP*)right)->op_last->op_type == OP_CONST) { SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; - if (SvIVX(sv) == 0) + if (SvIOK(sv) && SvIVX(sv) == 0) sv_setiv(sv, PL_modcount+1); } } @@ -4355,6 +4348,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) PL_eval_start = 0; else { if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */ + deprecate("assignment to $["); op_free(o); o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling))); o->op_private |= OPpCONST_ARYBASE; @@ -4552,6 +4546,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) return newop; } op_free(first); + if (other->op_type == OP_LEAVE) + other = newUNOP(OP_NULL, OPf_SPECIAL, other); return other; } else { @@ -4689,6 +4685,8 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) op_free(first); op_free(dead); } + if (live->op_type == OP_LEAVE) + live = newUNOP(OP_NULL, OPf_SPECIAL, live); return live; } NewOp(1101, logop, 1, LOGOP); @@ -5223,6 +5221,8 @@ S_looks_like_bool(pTHX_ const OP *o) case OP_DEFINED: case OP_EXISTS: case OP_MATCH: case OP_EOF: + case OP_FLOP: + return TRUE; case OP_CONST: @@ -5231,7 +5231,9 @@ S_looks_like_bool(pTHX_ const OP *o) || cSVOPo->op_sv == &PL_sv_no) return TRUE; - + else + return FALSE; + /* FALL THROUGH */ default: return FALSE; @@ -5516,7 +5518,6 @@ CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { dVAR; - const char *aname; GV *gv; const char *ps; STRLEN ps_len; @@ -5532,6 +5533,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) || PL_madskills) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL; + bool has_name; if (proto) { assert(proto->op_type == OP_CONST); @@ -5540,20 +5542,23 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else ps = NULL; - if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) { + if (name) { + gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); + has_name = TRUE; + } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { SV * const sv = sv_newmortal(); Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]", PL_curstash ? "__ANON__" : "__ANON__::__ANON__", CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); - aname = SvPVX_const(sv); + gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV); + has_name = TRUE; + } else if (PL_curstash) { + gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV); + has_name = FALSE; + } else { + gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV); + has_name = FALSE; } - else - aname = NULL; - - gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV) - : gv_fetchpv(aname ? aname - : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), - gv_fetch_flags, SVt_PVCV); if (!PL_madskills) { if (o) @@ -5587,12 +5592,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv); -#ifdef GV_UNIQUE_CHECK - if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) { - Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name); - } -#endif - if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) #ifdef PERL_MAD @@ -5606,12 +5605,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); -#ifdef GV_UNIQUE_CHECK - if (exists && GvUNIQUE(gv)) { - Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name); - } -#endif - /* if the subroutine doesn't exist and wasn't pre-declared * with a prototype, assume it will be AUTOLOADed, * skipping the prototype check @@ -5689,69 +5682,34 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_compcv = NULL; goto done; } - if (attrs) { - HV *stash; - SV *rcv; - - /* Need to do a C - * before we clobber PL_compcv. - */ - if (cv && (!block + if (cv) { /* must reuse cv if autoloaded */ + /* transfer PL_compcv to cv */ + if (block #ifdef PERL_MAD - || block->op_type == OP_NULL + && block->op_type != OP_NULL #endif - )) { - rcv = MUTABLE_SV(cv); - /* Might have had built-in attributes applied -- propagate them. */ - CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); - if (CvGV(cv) && GvSTASH(CvGV(cv))) - stash = GvSTASH(CvGV(cv)); - else if (CvSTASH(cv)) - stash = CvSTASH(cv); - else - stash = PL_curstash; + ) { + cv_undef(cv); + CvFLAGS(cv) = CvFLAGS(PL_compcv); + if (!CvWEAKOUTSIDE(cv)) + SvREFCNT_dec(CvOUTSIDE(cv)); + CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); + CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); + CvOUTSIDE(PL_compcv) = 0; + CvPADLIST(cv) = CvPADLIST(PL_compcv); + CvPADLIST(PL_compcv) = 0; + /* inner references to PL_compcv must be fixed up ... */ + pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); + if (PERLDB_INTER)/* Advice debugger on the new sub. */ + ++PL_sub_generation; } else { - /* possibly about to re-define existing subr -- ignore old cv */ - rcv = MUTABLE_SV(PL_compcv); - if (name && GvSTASH(gv)) - stash = GvSTASH(gv); - else - stash = PL_curstash; - } - apply_attrs(stash, rcv, attrs, FALSE); - } - if (cv) { /* must reuse cv if autoloaded */ - if ( -#ifdef PERL_MAD - ( -#endif - !block -#ifdef PERL_MAD - || block->op_type == OP_NULL) && !PL_madskills -#endif - ) { - /* got here with just attrs -- work done, so bug out */ - SAVEFREESV(PL_compcv); - goto done; + /* Might have had built-in attributes applied -- propagate them. */ + CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); } - /* transfer PL_compcv to cv */ - cv_undef(cv); - CvFLAGS(cv) = CvFLAGS(PL_compcv); - if (!CvWEAKOUTSIDE(cv)) - SvREFCNT_dec(CvOUTSIDE(cv)); - CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); - CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); - CvOUTSIDE(PL_compcv) = 0; - CvPADLIST(cv) = CvPADLIST(PL_compcv); - CvPADLIST(PL_compcv) = 0; - /* inner references to PL_compcv must be fixed up ... */ - pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); /* ... before we throw it away */ SvREFCNT_dec(PL_compcv); PL_compcv = cv; - if (PERLDB_INTER)/* Advice debugger on the new sub. */ - ++PL_sub_generation; } else { cv = PL_compcv; @@ -5767,9 +5725,16 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */ } } - CvGV(cv) = gv; - CvFILE_set_from_cop(cv, PL_curcop); - CvSTASH(cv) = PL_curstash; + if (!CvGV(cv)) { + CvGV(cv) = gv; + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH(cv) = PL_curstash; + } + if (attrs) { + /* Need to do a C. */ + HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash; + apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE); + } if (ps) sv_setpvn(MUTABLE_SV(cv), ps, ps_len); @@ -5839,7 +5804,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvCONST_on(cv); } - if (name || aname) { + if (has_name) { if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { SV * const sv = newSV(0); SV * const tmpstr = sv_newmortal(); @@ -5949,6 +5914,11 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, Creates a constant sub equivalent to Perl C which is eligible for inlining at compile-time. +Passing NULL for SV creates a constant sub equivalent to C, +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.) + =cut */ @@ -6149,20 +6119,19 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM) : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM); -#ifdef GV_UNIQUE_CHECK - if (GvUNIQUE(gv)) { - Perl_croak(aTHX_ "Bad symbol for form (GV is unique)"); - } -#endif GvMULTI_on(gv); if ((cv = GvFORM(gv))) { if (ckWARN(WARN_REDEFINE)) { const line_t oldline = CopLINE(PL_curcop); if (PL_parser && PL_parser->copline != NOLINE) CopLINE_set(PL_curcop, PL_parser->copline); - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - o ? "Format %"SVf" redefined" - : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv)); + if (o) { + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv)); + } else { + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Format STDOUT redefined"); + } CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); @@ -6467,6 +6436,8 @@ Perl_ck_delete(pTHX_ OP *o) Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", OP_DESC(o)); } + if (kid->op_private & OPpLVAL_INTRO) + o->op_private |= OPpLVAL_INTRO; op_null(kid); } return o; @@ -6540,6 +6511,8 @@ Perl_ck_eval(pTHX_ OP *o) /* establish postfix order */ enter->op_next = (OP*)enter; + CHECKOP(OP_ENTERTRY, enter); + o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); o->op_type = OP_LEAVETRY; o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; @@ -7691,20 +7664,15 @@ Perl_ck_shift(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SHIFT; if (!(o->op_flags & OPf_KIDS)) { - OP *argop; - /* FIXME - this can be refactored to reduce code in #ifdefs */ -#ifdef PERL_MAD - OP * const oldo = o; -#else - op_free(o); -#endif - argop = newUNOP(OP_RV2AV, 0, + OP *argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv))); #ifdef PERL_MAD + OP * const oldo = o; o = newUNOP(type, 0, scalar(argop)); op_getmad(oldo,o,'O'); return o; #else + op_free(o); return newUNOP(type, 0, scalar(argop)); #endif } @@ -8561,7 +8529,7 @@ Perl_peep(pTHX_ register OP *o) /* Make the CONST have a shared SV */ svp = cSVOPx_svp(((BINOP*)o)->op_last); - if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { + if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) { key = SvPV_const(sv, keylen); lexname = newSVpvn_share(key, SvUTF8(sv) ? -(I32)keylen : (I32)keylen, @@ -8966,15 +8934,20 @@ const_sv_xsub(pTHX_ CV* cv) { dVAR; dXSARGS; + SV *const sv = MUTABLE_SV(XSANY.any_ptr); if (items != 0) { NOOP; #if 0 + /* diag_listed_as: SKIPME */ Perl_croak(aTHX_ "usage: %s::%s()", HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); #endif } + if (!sv) { + XSRETURN(0); + } EXTEND(sp, 1); - ST(0) = MUTABLE_SV(XSANY.any_ptr); + ST(0) = sv; XSRETURN(1); }