X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Upper.xs;h=7ccd9dc9f6c5fe376cba2f43620ee8b16725f660;hb=47d05ad590cff62def1004f1eb061932ac460668;hp=aea8e105409a012f837d0b131c932f3fdb5d5580;hpb=3b4d356e9978cbfe6a923932425275b123219dd0;p=perl%2Fmodules%2FScope-Upper.git diff --git a/Upper.xs b/Upper.xs index aea8e10..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; @@ -995,19 +994,6 @@ STATIC I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) { for (i = cxstack_ix; i > cxix; --i) { PERL_CONTEXT *cx = cxstack + i; switch (CxTYPE(cx)) { -#if SU_HAS_PERL(5, 10, 0) - case CXt_BLOCK: - SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is block\n", ud, i)); - /* Given and when blocks are actually followed by a simple block, so skip - * it if needed. */ - if (cxix > 0) { /* Implies i > 0 */ - PERL_CONTEXT *next = cx - 1; - if (CxTYPE(next) == CXt_GIVEN || CxTYPE(next) == CXt_WHEN) - --cxix; - } - depth++; - break; -#endif #if SU_HAS_PERL(5, 11, 0) case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: @@ -1185,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; } @@ -1798,6 +1784,117 @@ STATIC int su_uid_validate(pTHX_ SV *uid) { return su_uid_storage_check(depth, seq); } +/* --- Context operations -------------------------------------------------- */ + +/* 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; + + 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) + return 0; + + cx = cxstack + cxix; + if (CxTYPE(cx) == CXt_BLOCK) { + PERL_CONTEXT *prev = cx - 1; + + switch (CxTYPE(prev)) { +#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 == prev->blk_oldcop) + 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) + return cxix - 1; + break; + } + } + + 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) { @@ -1856,51 +1953,21 @@ STATIC void su_setup(pTHX) { /* --- XS ------------------------------------------------------------------ */ -#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 - -#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) \ @@ -1930,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)) { @@ -2011,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); @@ -2025,11 +2091,12 @@ PROTOTYPE: ;$ PREINIT: I32 cxix; PPCODE: - SU_GET_CONTEXT(0, 0); - if (--cxix < 0) - cxix = 0; - if (PL_DBsub) - SU_SKIP_DB(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); @@ -2040,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; @@ -2062,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; @@ -2083,19 +2150,13 @@ PREINIT: I32 cxix, level; PPCODE: SU_GET_LEVEL(0, 0); - cxix = cxstack_ix; - if (PL_DBsub) { - SU_SKIP_DB(cxix); - while (cxix > 0) { - if (--level < 0) - break; - --cxix; - SU_SKIP_DB(cxix); - } - } else { - cxix -= level; - if (cxix < 0) - cxix = 0; + 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); @@ -2132,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; @@ -2159,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; @@ -2174,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; @@ -2191,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; @@ -2210,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; @@ -2227,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)) { @@ -2258,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);