X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=c46bbfce0ea5d385fb9e2f0f5374428ae6a47461;hb=7e107e90b7bd52c7fb110ac98da6bb7ab38e8959;hp=4804bf11c38d2bf5acdfe97d83f01058c6624990;hpb=dd2155a49b710f23bc6d72169e5b1d71d8b3aa03;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 4804bf1..c46bbfc 100644 --- a/op.c +++ b/op.c @@ -104,7 +104,7 @@ S_Slab_Free(pTHX_ void *op) #define CHECKOP(type,o) \ ((PL_op_mask && PL_op_mask[type]) \ ? ( op_free((OP*)o), \ - Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \ + Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ Nullop ) \ : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) @@ -216,74 +216,6 @@ Perl_allocmy(pTHX_ char *name) return off; } - -#ifdef USE_5005THREADS -/* find_threadsv is not reentrant */ -PADOFFSET -Perl_find_threadsv(pTHX_ const char *name) -{ - char *p; - PADOFFSET key; - SV **svp; - /* We currently only handle names of a single character */ - p = strchr(PL_threadsv_names, *name); - if (!p) - return NOT_IN_PAD; - key = p - PL_threadsv_names; - MUTEX_LOCK(&thr->mutex); - svp = av_fetch(thr->threadsv, key, FALSE); - if (svp) - MUTEX_UNLOCK(&thr->mutex); - else { - SV *sv = NEWSV(0, 0); - av_store(thr->threadsv, key, sv); - thr->threadsvp = AvARRAY(thr->threadsv); - MUTEX_UNLOCK(&thr->mutex); - /* - * Some magic variables used to be automagically initialised - * in gv_fetchpv. Those which are now per-thread magicals get - * initialised here instead. - */ - switch (*name) { - case '_': - break; - case ';': - sv_setpv(sv, "\034"); - sv_magic(sv, 0, PERL_MAGIC_sv, name, 1); - break; - case '&': - case '`': - case '\'': - PL_sawampersand = TRUE; - /* FALL THROUGH */ - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - SvREADONLY_on(sv); - /* FALL THROUGH */ - - /* XXX %! tied to Errno.pm needs to be added here. - * See gv_fetchpv(). */ - /* case '!': */ - - default: - sv_magic(sv, 0, PERL_MAGIC_sv, name, 1); - } - DEBUG_S(PerlIO_printf(Perl_error_log, - "find_threadsv: new SV %p for $%s%c\n", - sv, (*name < 32) ? "^" : "", - (*name < 32) ? toCTRL(*name) : *name)); - } - return key; -} -#endif /* USE_5005THREADS */ - /* Destructor */ void @@ -341,17 +273,8 @@ Perl_op_clear(pTHX_ OP *o) switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ case OP_ENTEREVAL: /* Was holding hints. */ -#ifdef USE_5005THREADS - case OP_THREADSV: /* Was holding index into thr->threadsv AV. */ -#endif o->op_targ = 0; break; -#ifdef USE_5005THREADS - case OP_ENTERITER: - if (!(o->op_flags & OPf_SPECIAL)) - break; - /* FALL THROUGH */ -#endif /* USE_5005THREADS */ default: if (!(o->op_flags & OPf_REF) || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst))) @@ -725,6 +648,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_GGRNAM: case OP_GGRGID: case OP_GETLOGIN: + case OP_PROTOTYPE: func_ops: if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) useless = OP_DESC(o); @@ -1189,12 +1113,6 @@ Perl_mod(pTHX_ OP *o, I32 type) } break; -#ifdef USE_5005THREADS - case OP_THREADSV: - PL_modcount++; /* XXX ??? */ - break; -#endif /* USE_5005THREADS */ - case OP_PUSHMARK: break; @@ -1680,7 +1598,7 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) int maybe_scalar = 0; /* [perl #17376]: this appears to be premature, and results in code such as - C< my(%x); > executing in list mode rather than void mode */ + C< our(%x); > executing in list mode rather than void mode */ #if 0 if (o->op_flags & OPf_PARENS) list(o); @@ -1816,6 +1734,8 @@ int Perl_block_start(pTHX_ int full) { int retval = PL_savestack_ix; + /* If there were syntax errors, don't try to start a block */ + if (PL_yynerrs) return retval; pad_block_start(full); SAVEHINTS(); @@ -1838,9 +1758,16 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) { int needblockscope = PL_hints & HINT_BLOCK_SCOPE; line_t copline = PL_copline; - /* there should be a nextstate in every block */ - OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq); - PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */ + OP* retval = scalarseq(seq); + /* If there were syntax errors, don't try to close a block */ + if (PL_yynerrs) return retval; + if (!seq) { + /* scalarseq() gave us an OP_STUB */ + retval->op_flags |= OPf_PARENS; + /* there should be a nextstate in every block */ + retval = newSTATEOP(0, Nullch, retval); + PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */ + } LEAVE_SCOPE(floor); PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); if (needblockscope) @@ -1852,13 +1779,7 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) STATIC OP * S_newDEFSVOP(pTHX) { -#ifdef USE_5005THREADS - OP *o = newOP(OP_THREADSV, 0); - o->op_targ = find_threadsv("_"); - return o; -#else return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); -#endif /* USE_5005THREADS */ } void @@ -1942,12 +1863,7 @@ Perl_jmaybe(pTHX_ OP *o) { if (o->op_type == OP_LIST) { OP *o2; -#ifdef USE_5005THREADS - o2 = newOP(OP_THREADSV, 0); - o2->op_targ = find_threadsv(";"); -#else o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), -#endif /* USE_5005THREADS */ o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); } return o; @@ -2731,34 +2647,18 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) if (CopLINE(PL_curcop) < PL_multi_end) CopLINE_set(PL_curcop, (line_t)PL_multi_end); } -#ifdef USE_5005THREADS - else if (repl->op_type == OP_THREADSV - && strchr("&`'123456789+", - PL_threadsv_names[repl->op_targ])) - { - curop = 0; - } -#endif /* USE_5005THREADS */ else if (repl->op_type == OP_CONST) curop = repl; else { OP *lastop = 0; for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { if (PL_opargs[curop->op_type] & OA_DANGEROUS) { -#ifdef USE_5005THREADS - if (curop->op_type == OP_THREADSV) { - repl_has_vars = 1; - if (strchr("&`'123456789+", curop->op_private)) - break; - } -#else if (curop->op_type == OP_GV) { GV *gv = cGVOPx_gv(curop); repl_has_vars = 1; if (strchr("&`'123456789+", *GvENAME(gv))) break; } -#endif /* USE_5005THREADS */ else if (curop->op_type == OP_RV2CV) break; else if (curop->op_type == OP_RV2SV || @@ -3768,12 +3668,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); } else { -#ifdef USE_5005THREADS - padoff = find_threadsv("_"); - iterflags |= OPf_SPECIAL; -#else sv = newGVOP(OP_GV, 0, PL_defgv); -#endif } if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART); @@ -3861,17 +3756,8 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) void Perl_cv_undef(pTHX_ CV *cv) { - CV *outsidecv; CV *freecv = Nullcv; -#ifdef USE_5005THREADS - if (CvMUTEXP(cv)) { - MUTEX_DESTROY(CvMUTEXP(cv)); - Safefree(CvMUTEXP(cv)); - CvMUTEXP(cv) = 0; - } -#endif /* USE_5005THREADS */ - #ifdef USE_ITHREADS if (CvFILE(cv) && !CvXSUB(cv)) { /* for XSUBs CvFILE point directly to static memory; __FILE__ */ @@ -3881,16 +3767,11 @@ Perl_cv_undef(pTHX_ CV *cv) #endif if (!CvXSUB(cv) && CvROOT(cv)) { -#ifdef USE_5005THREADS - if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr)) - Perl_croak(aTHX_ "Can't undef active subroutine"); -#else if (CvDEPTH(cv)) Perl_croak(aTHX_ "Can't undef active subroutine"); -#endif /* USE_5005THREADS */ ENTER; - PAD_SAVE_SETNULLPAD; + PAD_SAVE_SETNULLPAD(); op_free(CvROOT(cv)); CvROOT(cv) = Nullop; @@ -3898,20 +3779,21 @@ Perl_cv_undef(pTHX_ CV *cv) } SvPOK_off((SV*)cv); /* forget prototype */ CvGV(cv) = Nullgv; - outsidecv = CvOUTSIDE(cv); + + pad_undef(cv); + /* Since closure prototypes have the same lifetime as the containing * CV, they don't hold a refcount on the outside CV. This avoids * the refcount loop between the outer CV (which keeps a refcount to * the closure prototype in the pad entry for pp_anoncode()) and the * closure prototype, and the ensuing memory leak. --GSAR */ if (!CvANON(cv) || CvCLONED(cv)) - freecv = outsidecv; + freecv = CvOUTSIDE(cv); CvOUTSIDE(cv) = Nullcv; if (CvCONST(cv)) { SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); CvCONST_off(cv); } - pad_undef(cv, outsidecv); if (freecv) SvREFCNT_dec(freecv); if (CvXSUB(cv)) { @@ -4204,9 +4086,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) SAVEFREESV(PL_compcv); goto done; } + /* transfer PL_compcv to cv */ cv_undef(cv); CvFLAGS(cv) = CvFLAGS(PL_compcv); 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; @@ -4228,13 +4112,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvGV(cv) = gv; CvFILE_set_from_cop(cv, PL_curcop); CvSTASH(cv) = PL_curstash; -#ifdef USE_5005THREADS - CvOWNER(cv) = 0; - if (!CvMUTEXP(cv)) { - New(666, CvMUTEXP(cv), 1, perl_mutex); - MUTEX_INIT(CvMUTEXP(cv)); - } -#endif /* USE_5005THREADS */ if (ps) sv_setpv((SV*)cv, ps); @@ -4474,11 +4351,6 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) } } CvGV(cv) = gv; -#ifdef USE_5005THREADS - New(666, CvMUTEXP(cv), 1, perl_mutex); - MUTEX_INIT(CvMUTEXP(cv)); - CvOWNER(cv) = 0; -#endif /* USE_5005THREADS */ (void)gv_fetchfile(filename); CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be an external constant string */ @@ -4737,7 +4609,29 @@ Perl_ck_anoncode(pTHX_ OP *o) OP * Perl_ck_bitop(pTHX_ OP *o) { +#define OP_IS_NUMCOMPARE(op) \ + ((op) == OP_LT || (op) == OP_I_LT || \ + (op) == OP_GT || (op) == OP_I_GT || \ + (op) == OP_LE || (op) == OP_I_LE || \ + (op) == OP_GE || (op) == OP_I_GE || \ + (op) == OP_EQ || (op) == OP_I_EQ || \ + (op) == OP_NE || (op) == OP_I_NE || \ + (op) == OP_NCMP || (op) == OP_I_NCMP) o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); + if (o->op_type == OP_BIT_OR + || o->op_type == OP_BIT_AND + || o->op_type == OP_BIT_XOR) + { + OPCODE typfirst = cBINOPo->op_first->op_type; + OPCODE typlast = cBINOPo->op_first->op_sibling->op_type; + if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast)) + if (ckWARN(WARN_PRECEDENCE)) + Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE), + "Possible precedence problem on bitwise %c operator", + o->op_type == OP_BIT_OR ? '|' + : o->op_type == OP_BIT_AND ? '&' : '^' + ); + } return o; } @@ -5690,21 +5584,9 @@ Perl_ck_shift(pTHX_ OP *o) OP *argop; op_free(o); -#ifdef USE_5005THREADS - if (!CvUNIQUE(PL_compcv)) { - argop = newOP(OP_PADAV, OPf_REF); - argop->op_targ = 0; /* PAD_SV(0) is @_ */ - } - else { - argop = newUNOP(OP_RV2AV, 0, - scalar(newGVOP(OP_GV, 0, - gv_fetchpv("ARGV", TRUE, SVt_PVAV)))); - } -#else argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ? PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV)))); -#endif /* USE_5005THREADS */ return newUNOP(type, 0, scalar(argop)); } return scalar(modkids(ck_fun(o), type));