X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=d50660d36e55abea5d099f8f149f562bd95a08cb;hb=4a9e32d883a2352f4baeab6cfa9a5ebeadedb121;hp=71ee84855908434ef2696e076eec826d6e43af9f;hpb=553e7bb0c885d7b666ab73f45e41f7e6dab46330;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 71ee848..d50660d 100644 --- a/op.c +++ b/op.c @@ -495,8 +495,6 @@ Perl_op_free(pTHX_ OP *o) op_free(kid); } } - if (type == OP_NULL) - type = (OPCODE)o->op_targ; #ifdef PERL_DEBUG_READONLY_OPS Slab_to_rw(o); @@ -504,10 +502,16 @@ Perl_op_free(pTHX_ OP *o) /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ - if (type == OP_NEXTSTATE || type == OP_DBSTATE) { + if (type == OP_NEXTSTATE || type == OP_DBSTATE + || (type == OP_NULL /* the COP might have been null'ed */ + && ((OPCODE)o->op_targ == OP_NEXTSTATE + || (OPCODE)o->op_targ == OP_DBSTATE))) { cop_free((COP*)o); } + if (type == OP_NULL) + type = (OPCODE)o->op_targ; + op_clear(o); if (o->op_latefree) { o->op_latefreed = 1; @@ -548,7 +552,7 @@ Perl_op_clear(pTHX_ OP *o) switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ if (PL_madskills && o->op_targ != OP_NULL) { - o->op_type = (optype)o->op_targ; + o->op_type = (Optype)o->op_targ; o->op_targ = 0; goto retry; } @@ -672,7 +676,6 @@ S_cop_free(pTHX_ COP* cop) { PERL_ARGS_ASSERT_COP_FREE; - CopLABEL_free(cop); CopFILE_free(cop); CopSTASH_free(cop); if (! specialWARN(cop->cop_warnings)) @@ -1135,6 +1138,20 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_OR: case OP_AND: + kid = cLOGOPo->op_first; + if (kid->op_type == OP_NOT + && (kid->op_flags & OPf_KIDS) + && !PL_madskills) { + if (o->op_type == OP_AND) { + o->op_type = OP_OR; + o->op_ppaddr = PL_ppaddr[OP_OR]; + } else { + o->op_type = OP_AND; + o->op_ppaddr = PL_ppaddr[OP_AND]; + } + op_null(kid); + } + case OP_DOR: case OP_COND_EXPR: case OP_ENTERGIVEN: @@ -2428,6 +2445,7 @@ Perl_fold_constants(pTHX_ register OP *o) OP *old_next; SV * const oldwarnhook = PL_warnhook; SV * const olddiehook = PL_diehook; + COP not_compiling; dJMPENV; PERL_ARGS_ASSERT_FOLD_CONSTANTS; @@ -2492,6 +2510,13 @@ Perl_fold_constants(pTHX_ register OP *o) oldscope = PL_scopestack_ix; create_eval_scope(G_FAKINGEVAL); + /* Verify that we don't need to save it: */ + assert(PL_curcop == &PL_compiling); + StructCopy(&PL_compiling, ¬_compiling, COP); + PL_curcop = ¬_compiling; + /* The above ensures that we run with all the correct hints of the + currently compiling COP, but that IN_PERL_RUNTIME is not true. */ + assert(IN_PERL_RUNTIME); PL_warnhook = PERL_WARNHOOK_FATAL; PL_diehook = NULL; JMPENV_PUSH(ret); @@ -2510,7 +2535,7 @@ Perl_fold_constants(pTHX_ register OP *o) case 3: /* Something tried to die. Abandon constant folding. */ /* Pretend the error never happened. */ - sv_setpvn(ERRSV,"",0); + CLEAR_ERRSV(); o->op_next = old_next; break; default: @@ -2525,6 +2550,7 @@ Perl_fold_constants(pTHX_ register OP *o) JMPENV_POP; PL_warnhook = oldwarnhook; PL_diehook = olddiehook; + PL_curcop = &PL_compiling; if (PL_scopestack_ix > oldscope) delete_eval_scope(); @@ -4326,10 +4352,11 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (PL_eval_start) PL_eval_start = 0; else { - /* FIXME for MAD */ - op_free(o); - o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling))); - o->op_private |= OPpCONST_ARYBASE; + if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */ + op_free(o); + o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling))); + o->op_private |= OPpCONST_ARYBASE; + } } } return o; @@ -4359,10 +4386,6 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) CopHINTS_set(&PL_compiling, CopHINTS_get(cop)); cop->op_next = (OP*)cop; - if (label) { - CopLABEL_set(cop, label); - PL_hints |= HINT_BLOCK_SCOPE; - } cop->cop_seq = seq; /* CopARYBASE is now "virtual", in that it's stored as a flag bit in CopHINTS and a possible value in cop_hints_hash, so no need to copy it. @@ -4374,6 +4397,16 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->cop_hints_hash->refcounted_he_refcnt++; HINTS_REFCNT_UNLOCK; } + if (label) { + cop->cop_hints_hash + = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label); + + PL_hints |= HINT_BLOCK_SCOPE; + /* It seems that we need to defer freeing this pointer, as other parts + of the grammar end up wanting to copy it after this op has been + created. */ + SAVEFREEPV(label); + } if (PL_parser && PL_parser->copline == NOLINE) CopLINE_set(cop, CopLINE(PL_curcop)); @@ -4400,6 +4433,8 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) } } + if (flags & OPf_SPECIAL) + op_null((OP*)cop); return prepend_elem(OP_LINESEQ, (OP*)cop, o); } @@ -4421,7 +4456,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) LOGOP *logop; OP *o; OP *first = *firstp; - OP * const other = *otherp; + OP *other = *otherp; + int prepend_not = 0; PERL_ARGS_ASSERT_NEW_LOGOP; @@ -4429,22 +4465,22 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) return newBINOP(type, flags, scalar(first), scalar(other)); scalarboolean(first); - /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ + /* optimize AND and OR ops that have NOTs as children */ if (first->op_type == OP_NOT - && (first->op_flags & OPf_SPECIAL) && (first->op_flags & OPf_KIDS) + && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */ + || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */ && !PL_madskills) { if (type == OP_AND || type == OP_OR) { if (type == OP_AND) type = OP_OR; else type = OP_AND; - o = first; - first = *firstp = cUNOPo->op_first; - if (o->op_next) - first->op_next = o->op_next; - cUNOPo->op_first = NULL; - op_free(o); + 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 */ + } } } if (first->op_type == OP_CONST) { @@ -4561,7 +4597,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) CHECKOP(type,logop); - o = newUNOP(OP_NULL, 0, (OP*)logop); + o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop); other->op_next = o; return o; @@ -5042,7 +5078,7 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, PERL_ARGS_ASSERT_NEWGIVWHENOP; NewOp(1101, enterop, 1, LOGOP); - enterop->op_type = (optype)enter_opcode; + enterop->op_type = (Optype)enter_opcode; enterop->op_ppaddr = PL_ppaddr[enter_opcode]; enterop->op_flags = (U8) OPf_KIDS; enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg); @@ -6535,7 +6571,7 @@ Perl_ck_exists(pTHX_ OP *o) else if (kid->op_type == OP_AELEM) o->op_flags |= OPf_SPECIAL; else if (kid->op_type != OP_HELEM) - Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element", + Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine", OP_DESC(o)); op_null(kid); } @@ -7394,7 +7430,9 @@ Perl_ck_open(pTHX_ OP *o) if (table) { SV **svp = hv_fetchs(table, "open_IN", FALSE); if (svp && *svp) { - const I32 mode = mode_from_discipline(*svp); + STRLEN len = 0; + const char *d = SvPV_const(*svp, len); + const I32 mode = mode_from_discipline(d, len); if (mode & O_BINARY) o->op_private |= OPpOPEN_IN_RAW; else if (mode & O_TEXT) @@ -7403,7 +7441,9 @@ Perl_ck_open(pTHX_ OP *o) svp = hv_fetchs(table, "open_OUT", FALSE); if (svp && *svp) { - const I32 mode = mode_from_discipline(*svp); + STRLEN len = 0; + const char *d = SvPV_const(*svp, len); + const I32 mode = mode_from_discipline(d, len); if (mode & O_BINARY) o->op_private |= OPpOPEN_OUT_RAW; else if (mode & O_TEXT)