X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=0b4da4dfef8f1b45919540f3e9c78f5d4c013dd9;hb=4386d69d88a88d6f902f645c767ed76a8c9ecf0e;hp=c1f115d965f4da6019dc5cb22d9a766879db4877;hpb=ae423868f0b6096a2e2c476339cbdb24c6f2b3de;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index c1f115d..0b4da4d 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -234,7 +234,7 @@ PP(pp_substcont) FREETMPS; /* Prevent excess tmp stack */ /* Are we done */ - if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig, + if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig, s == m, cx->sb_targ, NULL, ((cx->sb_rflags & REXEC_COPY_STR) ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) @@ -325,6 +325,8 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) { UV *p = (UV*)*rsp; U32 i; + + PERL_ARGS_ASSERT_RXRES_SAVE; PERL_UNUSED_CONTEXT; if (!p || p[1] < RX_NPARENS(rx)) { @@ -363,6 +365,8 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) { UV *p = (UV*)*rsp; U32 i; + + PERL_ARGS_ASSERT_RXRES_RESTORE; PERL_UNUSED_CONTEXT; RX_MATCH_COPY_FREE(rx); @@ -390,6 +394,8 @@ void Perl_rxres_free(pTHX_ void **rsp) { UV * const p = (UV*)*rsp; + + PERL_ARGS_ASSERT_RXRES_FREE; PERL_UNUSED_CONTEXT; if (p) { @@ -1224,14 +1230,17 @@ PP(pp_flop) static const char * const context_name[] = { "pseudo-block", + "when", + NULL, /* CXt_BLOCK never actually needs "block" */ + "given", + NULL, /* CXt_LOOP_FOR never actually needs "loop" */ + NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */ + NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */ + NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */ "subroutine", + "format", "eval", - "loop", "substitution", - "block", - "format", - "given", - "when" }; STATIC I32 @@ -1240,6 +1249,8 @@ S_dopoptolabel(pTHX_ const char *label) dVAR; register I32 i; + PERL_ARGS_ASSERT_DOPOPTOLABEL; + for (i = cxstack_ix; i >= 0; i--) { register const PERL_CONTEXT * const cx = &cxstack[i]; switch (CxTYPE(cx)) { @@ -1256,7 +1267,10 @@ S_dopoptolabel(pTHX_ const char *label) if (CxTYPE(cx) == CXt_NULL) return -1; break; - case CXt_LOOP: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) { DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n", (long)i, CxLABEL(cx))); @@ -1319,6 +1333,9 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) { dVAR; I32 i; + + PERL_ARGS_ASSERT_DOPOPTOSUB_AT; + for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT * const cx = &cxstk[i]; switch (CxTYPE(cx)) { @@ -1371,7 +1388,10 @@ S_dopoptoloop(pTHX_ I32 startingblock) if ((CxTYPE(cx)) == CXt_NULL) return -1; break; - case CXt_LOOP: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); return i; } @@ -1392,7 +1412,12 @@ S_dopoptogiven(pTHX_ I32 startingblock) case CXt_GIVEN: DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i)); return i; - case CXt_LOOP: + case CXt_LOOP_PLAIN: + assert(!CxFOREACHDEF(cx)); + break; + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: if (CxFOREACHDEF(cx)) { DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i)); return i; @@ -1443,7 +1468,10 @@ Perl_dounwind(pTHX_ I32 cxix) case CXt_EVAL: POPEVAL(cx); break; - case CXt_LOOP: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: POPLOOP(cx); break; case CXt_NULL: @@ -1461,6 +1489,9 @@ void Perl_qerror(pTHX_ SV *err) { dVAR; + + PERL_ARGS_ASSERT_QERROR; + if (PL_in_eval) sv_catsv(ERRSV, err); else if (PL_errors) @@ -1654,11 +1685,11 @@ PP(pp_caller) SV * const sv = newSV(0); gv_efullname3(sv, cvgv, NULL); mPUSHs(sv); - mPUSHi((I32)CxHASARGS(cx)); + PUSHs(boolSV(CxHASARGS(cx))); } else { PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP)); - mPUSHi((I32)CxHASARGS(cx)); + PUSHs(boolSV(CxHASARGS(cx))); } } else { @@ -1669,10 +1700,10 @@ PP(pp_caller) if (gimme == G_VOID) PUSHs(&PL_sv_undef); else - mPUSHi(gimme & G_ARRAY); + PUSHs(boolSV((gimme & G_WANT) == G_ARRAY)); if (CxTYPE(cx) == CXt_EVAL) { /* eval STRING */ - if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { + if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { PUSHs(cx->blk_eval.cur_text); PUSHs(&PL_sv_no); } @@ -1821,9 +1852,9 @@ PP(pp_enteriter) register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; SV **svp; - U16 cxtype = CXt_LOOP | CXp_FOREACH; + U8 cxtype = CXt_LOOP_FOR; #ifdef USE_ITHREADS - void *iterdata; + PAD *iterdata; #endif ENTER; @@ -1835,13 +1866,11 @@ PP(pp_enteriter) SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ), SVs_PADSTALE, SVs_PADSTALE); } + SAVEPADSVANDMORTALIZE(PL_op->op_targ); #ifndef USE_ITHREADS svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */ - SAVESPTR(*svp); #else - SAVEPADSV(PL_op->op_targ); - iterdata = INT2PTR(void*, PL_op->op_targ); - cxtype |= CXp_PADVAR; + iterdata = NULL; #endif } else { @@ -1850,7 +1879,7 @@ PP(pp_enteriter) SAVEGENERICSV(*svp); *svp = newSV(0); #ifdef USE_ITHREADS - iterdata = (void*)gv; + iterdata = (PAD*)gv; #endif } @@ -1861,18 +1890,23 @@ PP(pp_enteriter) PUSHBLOCK(cx, cxtype, SP); #ifdef USE_ITHREADS - PUSHLOOP(cx, iterdata, MARK); + PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ); #else - PUSHLOOP(cx, svp, MARK); + PUSHLOOP_FOR(cx, svp, MARK, 0); #endif if (PL_op->op_flags & OPf_STACKED) { - cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); - if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) { + SV *maybe_ary = POPs; + if (SvTYPE(maybe_ary) != SVt_PVAV) { dPOPss; - SV * const right = (SV*)cx->blk_loop.iterary; + SV * const right = maybe_ary; SvGETMAGIC(sv); SvGETMAGIC(right); if (RANGE_IS_NUMERIC(sv,right)) { + cx->cx_type &= ~CXTYPEMASK; + cx->cx_type |= CXt_LOOP_LAZYIV; + /* Make sure that no-one re-orders cop.h and breaks our + assumptions */ + assert(CxTYPE(cx) == CXt_LOOP_LAZYIV); #ifdef NV_PRESERVES_UV if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) || (SvNV(sv) > (NV)IV_MAX))) @@ -1893,34 +1927,50 @@ PP(pp_enteriter) (SvNV(right) > (NV)UV_MAX)))))) #endif DIE(aTHX_ "Range iterator outside integer range"); - cx->blk_loop.iterix = SvIV(sv); - cx->blk_loop.itermax = SvIV(right); + cx->blk_loop.state_u.lazyiv.cur = SvIV(sv); + cx->blk_loop.state_u.lazyiv.end = SvIV(right); #ifdef DEBUGGING /* for correct -Dstv display */ cx->blk_oldsp = sp - PL_stack_base; #endif } else { - cx->blk_loop.iterlval = newSVsv(sv); - (void) SvPV_force_nolen(cx->blk_loop.iterlval); + cx->cx_type &= ~CXTYPEMASK; + cx->cx_type |= CXt_LOOP_LAZYSV; + /* Make sure that no-one re-orders cop.h and breaks our + assumptions */ + assert(CxTYPE(cx) == CXt_LOOP_LAZYSV); + cx->blk_loop.state_u.lazysv.cur = newSVsv(sv); + cx->blk_loop.state_u.lazysv.end = right; + SvREFCNT_inc(right); + (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur); + /* This will do the upgrade to SVt_PV, and warn if the value + is uninitialised. */ (void) SvPV_nolen_const(right); + /* Doing this avoids a check every time in pp_iter in pp_hot.c + to replace !SvOK() with a pointer to "". */ + if (!SvOK(right)) { + SvREFCNT_dec(right); + cx->blk_loop.state_u.lazysv.end = &PL_sv_no; + } } } - else if (PL_op->op_private & OPpITER_REVERSED) { - cx->blk_loop.itermax = 0; - cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1; - + else /* SvTYPE(maybe_ary) == SVt_PVAV */ { + cx->blk_loop.state_u.ary.ary = (AV*)maybe_ary; + SvREFCNT_inc(maybe_ary); + cx->blk_loop.state_u.ary.ix = + (PL_op->op_private & OPpITER_REVERSED) ? + AvFILL(cx->blk_loop.state_u.ary.ary) + 1 : + -1; } } - else { - cx->blk_loop.iterary = PL_curstack; - AvFILLp(PL_curstack) = SP - PL_stack_base; + else { /* iterating over items on the stack */ + cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */ if (PL_op->op_private & OPpITER_REVERSED) { - cx->blk_loop.itermax = MARK - PL_stack_base + 1; - cx->blk_loop.iterix = cx->blk_oldsp + 1; + cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1; } else { - cx->blk_loop.iterix = MARK - PL_stack_base; + cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base; } } @@ -1937,8 +1987,8 @@ PP(pp_enterloop) SAVETMPS; ENTER; - PUSHBLOCK(cx, CXt_LOOP, SP); - PUSHLOOP(cx, 0, SP); + PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); + PUSHLOOP_PLAIN(cx, SP); RETURN; } @@ -1953,7 +2003,7 @@ PP(pp_leaveloop) SV **mark; POPBLOCK(cx,newpm); - assert(CxTYPE(cx) == CXt_LOOP); + assert(CxTYPE_is_LOOP(cx)); mark = newsp; newsp = PL_stack_base + cx->blk_loop.resetsp; @@ -2140,8 +2190,11 @@ PP(pp_last) cxstack_ix++; /* temporarily protect top context */ mark = newsp; switch (CxTYPE(cx)) { - case CXt_LOOP: - pop2 = CXt_LOOP; + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: + pop2 = CxTYPE(cx); newsp = PL_stack_base + cx->blk_loop.resetsp; nextop = cx->blk_loop.my_op->op_lastop->op_next; break; @@ -2183,7 +2236,10 @@ PP(pp_last) cxstack_ix--; /* Stack values are safe: */ switch (pop2) { - case CXt_LOOP: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: POPLOOP(cx); /* release loop vars ... */ LEAVE; break; @@ -2273,6 +2329,8 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) OP **ops = opstack; static const char too_deep[] = "Target of goto is too deeply nested"; + PERL_ARGS_ASSERT_DOFINDLABEL; + if (ops >= oplimit) Perl_croak(aTHX_ too_deep); if (o->op_type == OP_LEAVE || @@ -2437,7 +2495,7 @@ PP(pp_goto) else { AV* const padlist = CvPADLIST(cv); if (CxTYPE(cx) == CXt_EVAL) { - PL_in_eval = cx->blk_eval.old_in_eval; + PL_in_eval = CxOLD_IN_EVAL(cx); PL_eval_root = cx->blk_eval.old_eval_root; cx->cx_type = CXt_SUB; } @@ -2541,7 +2599,10 @@ PP(pp_goto) break; } /* else fall through */ - case CXt_LOOP: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: gotoprobe = cx->blk_oldcop->op_sibling; break; case CXt_SUBST: @@ -2673,6 +2734,8 @@ S_save_lines(pTHX_ AV *array, SV *sv) const char * const send = SvPVX_const(sv) + SvCUR(sv); I32 line = 1; + PERL_ARGS_ASSERT_SAVE_LINES; + while (s && s < send) { const char *t; SV * const tmpstr = newSV_type(SVt_PVMG); @@ -2760,6 +2823,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) CV* runcv = NULL; /* initialise to avoid compiler warnings */ STRLEN len; + PERL_ARGS_ASSERT_SV_COMPILE_2OP; + ENTER; lex_start(sv, NULL, FALSE); SAVETMPS; @@ -2807,7 +2872,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) PL_op->op_type = OP_ENTEREVAL; PL_op->op_flags = 0; /* Avoid uninit warning. */ PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP); - PUSHEVAL(cx, 0, NULL); + PUSHEVAL(cx, 0); if (runtime) (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); @@ -2999,9 +3064,9 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type == OP_REQUIRE) scalar(PL_eval_root); - else if (gimme & G_VOID) + else if ((gimme & G_WANT) == G_VOID) scalarvoid(PL_eval_root); - else if (gimme & G_ARRAY) + else if ((gimme & G_WANT) == G_ARRAY) list(PL_eval_root); else scalar(PL_eval_root); @@ -3040,6 +3105,8 @@ S_check_type_and_open(pTHX_ const char *name) Stat_t st; const int st_rc = PerlLIO_stat(name, &st); + PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN; + if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { return NULL; } @@ -3053,6 +3120,8 @@ S_doopen_pm(pTHX_ const char *name, const STRLEN namelen) { PerlIO *fp; + PERL_ARGS_ASSERT_DOOPEN_PM; + if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) { SV *const pmcsv = newSV(namelen + 2); char *const pmc = SvPVX(pmcsv); @@ -3495,6 +3564,11 @@ PP(pp_require) SAVEHINTS(); PL_hints = 0; + if (PL_compiling.cop_hints_hash) { + Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); + PL_compiling.cop_hints_hash = NULL; + } + SAVECOMPILEWARNINGS(); if (PL_dowarn & G_WARN_ALL_ON) PL_compiling.cop_warnings = pWARN_ALL ; @@ -3513,7 +3587,7 @@ PP(pp_require) /* switch to eval mode */ PUSHBLOCK(cx, CXt_EVAL, SP); - PUSHEVAL(cx, name, NULL); + PUSHEVAL(cx, name); cx->blk_eval.retop = PL_op->op_next; SAVECOPLINE(&PL_compiling); @@ -3536,6 +3610,19 @@ PP(pp_require) return op; } +/* This is a op added to hold the hints hash for + pp_entereval. The hash can be modified by the code + being eval'ed, so we return a copy instead. */ + +PP(pp_hintseval) +{ + dVAR; + dSP; + mXPUSHs((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv)); + RETURN; +} + + PP(pp_entereval) { dVAR; dSP; @@ -3612,7 +3699,7 @@ PP(pp_entereval) runcv = find_runcv(&seq); PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); - PUSHEVAL(cx, 0, NULL); + PUSHEVAL(cx, 0); cx->blk_eval.retop = PL_op->op_next; /* prepare to compile string */ @@ -3729,7 +3816,7 @@ Perl_create_eval_scope(pTHX_ U32 flags) SAVETMPS; PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); - PUSHEVAL(cx, 0, 0); + PUSHEVAL(cx, 0); PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) @@ -3849,8 +3936,11 @@ S_make_matcher(pTHX_ REGEXP *re) { dVAR; PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED); + + PERL_ARGS_ASSERT_MAKE_MATCHER; + PM_SETRE(matcher, ReREFCNT_inc(re)); - + SAVEFREEOP((OP *) matcher); ENTER; SAVETMPS; SAVEOP(); @@ -3862,6 +3952,8 @@ S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) { dVAR; dSP; + + PERL_ARGS_ASSERT_MATCHER_MATCHES_SV; PL_op = (OP *) matcher; XPUSHs(sv); @@ -3875,7 +3967,10 @@ STATIC void S_destroy_matcher(pTHX_ PMOP *matcher) { dVAR; + + PERL_ARGS_ASSERT_DESTROY_MATCHER; PERL_UNUSED_ARG(matcher); + FREETMPS; LEAVE; } @@ -4379,6 +4474,8 @@ S_doparseform(pTHX_ SV *sv) bool unchopnum = FALSE; int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ + PERL_ARGS_ASSERT_DOPARSEFORM; + if (len == 0) Perl_croak(aTHX_ "Null picture in formline"); @@ -4621,6 +4718,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) bool read_from_cache = FALSE; STRLEN umaxlen; + PERL_ARGS_ASSERT_RUN_USER_FILTER; + assert(maxlen >= 0); umaxlen = maxlen; @@ -4787,6 +4886,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) static bool S_path_is_absolute(const char *name) { + PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE; + if (PERL_FILE_IS_ABSOLUTE(name) #ifdef MACOS_TRADITIONAL || (*name == ':')