X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Upper.xs;h=7ccd9dc9f6c5fe376cba2f43620ee8b16725f660;hb=47d05ad590cff62def1004f1eb061932ac460668;hp=c5da0e16220581b24d7d688b6db6c4dced614d96;hpb=3a43f1ed62c266c8108a25266b461393336016b5;p=perl%2Fmodules%2FScope-Upper.git diff --git a/Upper.xs b/Upper.xs index c5da0e1..7ccd9dc 100644 --- a/Upper.xs +++ b/Upper.xs @@ -286,7 +286,6 @@ STATIC void su_uid_storage_dup(pTHX_ su_uid_storage *new_cxt, const su_uid_stora if (old_map) { su_uid **new_map = new_cxt->map; STRLEN old_used = old_cxt->used; - STRLEN old_alloc = old_cxt->alloc; STRLEN new_used, new_alloc; STRLEN i; @@ -1172,7 +1171,7 @@ STATIC int su_uplevel_goto_static(const OP *o) { case OP_GOTO: return 1; default: - if (su_uplevel_goto_static(cUNOPo->op_first)) + if (su_uplevel_goto_static(((const UNOP *) o)->op_first)) return 1; break; } @@ -1787,36 +1786,43 @@ STATIC int su_uid_validate(pTHX_ SV *uid) { /* --- Context operations -------------------------------------------------- */ -#if SU_HAS_PERL(5, 8, 9) -# define SU_SKIP_DB_MAX 2 -#else -# define SU_SKIP_DB_MAX 3 -#endif - -/* Skip context sequences of 1 to SU_SKIP_DB_MAX (included) block contexts - * followed by a DB sub */ - -#define SU_SKIP_DB(C) \ - STMT_START { \ - I32 skipped = 0; \ - PERL_CONTEXT *base = cxstack; \ - PERL_CONTEXT *cx = base + (C); \ - while (cx >= base && (C) > skipped && CxTYPE(cx) == CXt_BLOCK) \ - --cx, ++skipped; \ - if (cx >= base && (C) > skipped) { \ - switch (CxTYPE(cx)) { \ - case CXt_SUB: \ - if (skipped <= SU_SKIP_DB_MAX && cx->blk_sub.cv == GvCV(PL_DBsub)) \ - (C) -= skipped + 1; \ - break; \ - default: \ - break; \ - } \ - } \ - } STMT_END +/* Remove sequences of BLOCKs having DB for stash, followed by a SUB context + * for the debugger callback. */ + +STATIC I32 su_context_skip_db(pTHX_ I32 cxix) { +#define su_context_skip_db(C) su_context_skip_db(aTHX_ (C)) + I32 i; + + if (!PL_DBsub) + return cxix; -STATIC I32 su_context_up(pTHX_ I32 cxix) { -#define su_context_up(C) su_context_up(aTHX_ (C)) + for (i = cxix; i > 0; --i) { + PERL_CONTEXT *cx = cxstack + i; + + switch (CxTYPE(cx)) { + case CXt_BLOCK: + if (cx->blk_oldcop && CopSTASH(cx->blk_oldcop) == GvSTASH(PL_DBgv)) + continue; + break; + case CXt_SUB: + if (cx->blk_sub.cv == GvCV(PL_DBsub)) { + cxix = i - 1; + continue; + } + break; + default: + break; + } + + break; + } + + return cxix; +} + + +STATIC I32 su_context_normalize_up(pTHX_ I32 cxix) { +#define su_context_normalize_up(C) su_context_normalize_up(aTHX_ (C)) PERL_CONTEXT *cx; if (cxix <= 0) @@ -1838,31 +1844,57 @@ STATIC I32 su_context_up(pTHX_ I32 cxix) { case CXt_LOOP: #endif if (cx->blk_oldcop == prev->blk_oldcop) - cxix -= 2; - else - --cxix; + return cxix - 1; break; case CXt_SUBST: if (cx->blk_oldcop && cx->blk_oldcop->op_sibling && cx->blk_oldcop->op_sibling->op_type == OP_SUBST) - cxix -= 2; - else - --cxix; - break; - default: - --cxix; + return cxix - 1; break; } - } else { - --cxix; } - if (PL_DBsub) - SU_SKIP_DB(cxix); + return cxix; +} + +STATIC I32 su_context_normalize_down(pTHX_ I32 cxix) { +#define su_context_normalize_down(C) su_context_normalize_down(aTHX_ (C)) + PERL_CONTEXT *next; + + if (cxix >= cxstack_ix) + return cxstack_ix; + + next = cxstack + cxix + 1; + if (CxTYPE(next) == CXt_BLOCK) { + PERL_CONTEXT *cx = next - 1; + + switch (CxTYPE(cx)) { +#if SU_HAS_PERL(5, 10, 0) + case CXt_GIVEN: + case CXt_WHEN: +#endif +#if SU_HAS_PERL(5, 11, 0) + /* That's the only subcategory that can cause an extra BLOCK context */ + case CXt_LOOP_PLAIN: +#else + case CXt_LOOP: +#endif + if (cx->blk_oldcop == next->blk_oldcop) + return cxix + 1; + break; + case CXt_SUBST: + if (next->blk_oldcop && next->blk_oldcop->op_sibling + && next->blk_oldcop->op_sibling->op_type == OP_SUBST) + return cxix + 1; + break; + } + } return cxix; } +#define su_context_here() su_context_normalize_up(su_context_skip_db(cxstack_ix)) + /* --- Interpreter setup/teardown ------------------------------------------ */ STATIC void su_teardown(pTHX_ void *param) { @@ -1921,23 +1953,21 @@ STATIC void su_setup(pTHX) { /* --- XS ------------------------------------------------------------------ */ -#define SU_GET_CONTEXT(A, B) \ - STMT_START { \ - if (items > A) { \ - SV *csv = ST(B); \ - if (!SvOK(csv)) \ - goto default_cx; \ - cxix = SvIV(csv); \ - if (cxix < 0) \ - cxix = 0; \ - else if (cxix > cxstack_ix) \ - cxix = cxstack_ix; \ - } else { \ -default_cx: \ - cxix = cxstack_ix; \ - if (PL_DBsub) \ - SU_SKIP_DB(cxix); \ - } \ +#define SU_GET_CONTEXT(A, B, D) \ + STMT_START { \ + if (items > A) { \ + SV *csv = ST(B); \ + if (!SvOK(csv)) \ + goto default_cx; \ + cxix = SvIV(csv); \ + if (cxix < 0) \ + cxix = 0; \ + else if (cxix > cxstack_ix) \ + goto default_cx; \ + } else { \ +default_cx: \ + cxix = (D); \ + } \ } STMT_END #define SU_GET_LEVEL(A, B) \ @@ -1967,7 +1997,7 @@ XS(XS_Scope__Upper_unwind) { PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(ax); /* -Wall */ - SU_GET_CONTEXT(0, items - 1); + SU_GET_CONTEXT(0, items - 1, cxstack_ix); do { PERL_CONTEXT *cx = cxstack + cxix; switch (CxTYPE(cx)) { @@ -2048,10 +2078,9 @@ void HERE() PROTOTYPE: PREINIT: - I32 cxix = cxstack_ix; + I32 cxix; PPCODE: - if (PL_DBsub) - SU_SKIP_DB(cxix); + cxix = su_context_here(); EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); @@ -2062,8 +2091,12 @@ PROTOTYPE: ;$ PREINIT: I32 cxix; PPCODE: - SU_GET_CONTEXT(0, 0); - cxix = su_context_up(cxix); + SU_GET_CONTEXT(0, 0, su_context_here()); + if (cxix > 0) { + --cxix; + cxix = su_context_skip_db(cxix); + cxix = su_context_normalize_up(cxix); + } EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); @@ -2074,7 +2107,7 @@ PROTOTYPE: ;$ PREINIT: I32 cxix; PPCODE: - SU_GET_CONTEXT(0, 0); + SU_GET_CONTEXT(0, 0, cxstack_ix); EXTEND(SP, 1); for (; cxix >= 0; --cxix) { PERL_CONTEXT *cx = cxstack + cxix; @@ -2096,7 +2129,7 @@ PROTOTYPE: ;$ PREINIT: I32 cxix; PPCODE: - SU_GET_CONTEXT(0, 0); + SU_GET_CONTEXT(0, 0, cxstack_ix); EXTEND(SP, 1); for (; cxix >= 0; --cxix) { PERL_CONTEXT *cx = cxstack + cxix; @@ -2117,11 +2150,14 @@ PREINIT: I32 cxix, level; PPCODE: SU_GET_LEVEL(0, 0); - cxix = cxstack_ix; - if (PL_DBsub) - SU_SKIP_DB(cxix); - while (--level >= 0) - cxix = su_context_up(cxix); + cxix = su_context_here(); + while (--level >= 0) { + if (cxix <= 0) + break; + --cxix; + cxix = su_context_skip_db(cxix); + cxix = su_context_normalize_up(cxix); + } EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); @@ -2157,12 +2193,14 @@ PROTOTYPE: ;$ PREINIT: I32 cxix; PPCODE: - SU_GET_CONTEXT(0, 0); + SU_GET_CONTEXT(0, 0, cxstack_ix); EXTEND(SP, 1); while (cxix > 0) { PERL_CONTEXT *cx = cxstack + cxix--; switch (CxTYPE(cx)) { case CXt_SUB: + if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub)) + continue; case CXt_EVAL: case CXt_FORMAT: { I32 gimme = cx->blk_gimme; @@ -2184,7 +2222,8 @@ PREINIT: I32 cxix; su_ud_reap *ud; CODE: - SU_GET_CONTEXT(1, 1); + SU_GET_CONTEXT(1, 1, su_context_skip_db(cxstack_ix)); + cxix = su_context_normalize_down(cxix); Newx(ud, 1, su_ud_reap); SU_UD_ORIGIN(ud) = NULL; SU_UD_HANDLER(ud) = su_reap; @@ -2199,7 +2238,8 @@ PREINIT: I32 size; su_ud_localize *ud; CODE: - SU_GET_CONTEXT(2, 2); + SU_GET_CONTEXT(2, 2, su_context_skip_db(cxstack_ix)); + cxix = su_context_normalize_down(cxix); Newx(ud, 1, su_ud_localize); SU_UD_ORIGIN(ud) = NULL; SU_UD_HANDLER(ud) = su_localize; @@ -2216,7 +2256,8 @@ PREINIT: CODE: if (SvTYPE(sv) >= SVt_PVGV) croak("Can't infer the element localization type from a glob and the value"); - SU_GET_CONTEXT(3, 3); + SU_GET_CONTEXT(3, 3, su_context_skip_db(cxstack_ix)); + cxix = su_context_normalize_down(cxix); Newx(ud, 1, su_ud_localize); SU_UD_ORIGIN(ud) = NULL; SU_UD_HANDLER(ud) = su_localize; @@ -2235,7 +2276,8 @@ PREINIT: I32 size; su_ud_localize *ud; CODE: - SU_GET_CONTEXT(2, 2); + SU_GET_CONTEXT(2, 2, su_context_skip_db(cxstack_ix)); + cxix = su_context_normalize_down(cxix); Newx(ud, 1, su_ud_localize); SU_UD_ORIGIN(ud) = NULL; SU_UD_HANDLER(ud) = su_localize; @@ -2252,7 +2294,7 @@ PPCODE: code = SvRV(code); if (SvTYPE(code) < SVt_PVCV) croak("First argument to uplevel must be a code reference"); - SU_GET_CONTEXT(1, items - 1); + SU_GET_CONTEXT(1, items - 1, cxstack_ix); do { PERL_CONTEXT *cx = cxstack + cxix; switch (CxTYPE(cx)) { @@ -2283,7 +2325,7 @@ PREINIT: I32 cxix; SV *uid; PPCODE: - SU_GET_CONTEXT(0, 0); + SU_GET_CONTEXT(0, 0, su_context_here()); uid = su_uid_get(cxix); EXTEND(SP, 1); PUSHs(uid);