X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Upper.xs;h=906065a73020430db9eebed6735ada1ed05836c9;hb=dcc300c85d8832a6e0ad6852f68ea4ec5899348d;hp=63d267b928aeb3c3a059d464001ac61d71bbb030;hpb=2b4a5dedb43b2b9ce4020d7257ede8c2040e232e;p=perl%2Fmodules%2FScope-Upper.git diff --git a/Upper.xs b/Upper.xs index 63d267b..906065a 100644 --- a/Upper.xs +++ b/Upper.xs @@ -116,6 +116,11 @@ STATIC SV *su_newSV_type(pTHX_ svtype t) { # define CvISXSUB(C) CvXSUB(C) #endif +#ifndef PadlistARRAY +# define PadlistARRAY(P) AvARRAY(P) +# define PadARRAY(P) AvARRAY(P) +#endif + #ifndef CxHASARGS # define CxHASARGS(C) ((C)->blk_sub.hasargs) #endif @@ -128,6 +133,22 @@ STATIC SV *su_newSV_type(pTHX_ svtype t) { # define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D)) #endif +#ifndef OP_GIMME_REVERSE +STATIC U8 su_op_gimme_reverse(U8 gimme) { + switch (gimme) { + case G_VOID: + return OPf_WANT_VOID; + case G_ARRAY: + return OPf_WANT_LIST; + default: + break; + } + + return OPf_WANT_SCALAR; +} +#define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G) +#endif + #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif @@ -265,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; @@ -660,6 +680,8 @@ typedef struct { /* ... Reap ................................................................ */ +#define SU_SAVE_LAST_CX (!SU_HAS_PERL(5, 8, 4) || (SU_HAS_PERL(5, 9, 5) && !SU_HAS_PERL(5, 14, 0)) || SU_HAS_PERL(5, 15, 0)) + typedef struct { su_ud_common ci; SV *cb; @@ -667,10 +689,10 @@ typedef struct { STATIC void su_call(pTHX_ void *ud_) { su_ud_reap *ud = (su_ud_reap *) ud_; -#if SU_HAS_PERL(5, 9, 5) - PERL_CONTEXT saved_cx; +#if SU_SAVE_LAST_CX I32 cxix; -#endif + PERL_CONTEXT saved_cx; +#endif /* SU_SAVE_LAST_CX */ dSP; @@ -686,22 +708,18 @@ STATIC void su_call(pTHX_ void *ud_) { PUSHMARK(SP); PUTBACK; +#if SU_SAVE_LAST_CX /* If the recently popped context isn't saved there, it will be overwritten by * the sub scope from call_sv, although it's still needed in our caller. */ - -#if SU_HAS_PERL(5, 9, 5) - if (cxstack_ix < cxstack_max) - cxix = cxstack_ix + 1; - else - cxix = Perl_cxinc(aTHX); + cxix = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX); saved_cx = cxstack[cxix]; -#endif +#endif /* SU_SAVE_LAST_CX */ call_sv(ud->cb, G_VOID); -#if SU_HAS_PERL(5, 9, 5) +#if SU_SAVE_LAST_CX cxstack[cxix] = saved_cx; -#endif +#endif /* SU_SAVE_LAST_CX */ PUTBACK; @@ -890,9 +908,9 @@ done: #if SU_DEBUG # ifdef DEBUGGING -# define SU_CXNAME PL_block_type[CxTYPE(&cxstack[cxstack_ix])] +# define SU_CXNAME(C) PL_block_type[CxTYPE(C)] # else -# define SU_CXNAME "XXX" +# define SU_CXNAME(C) "XXX" # endif #endif @@ -905,7 +923,7 @@ STATIC void su_pop(pTHX_ void *ud) { PerlIO_printf(Perl_debug_log, "%p: --- pop a %s\n" "%p: leave scope at depth=%2d scope_ix=%2d cur_top=%2d cur_base=%2d\n", - ud, SU_CXNAME, + ud, SU_CXNAME(cxstack + cxstack_ix), ud, depth, PL_scopestack_ix,PL_savestack_ix,PL_scopestack[PL_scopestack_ix]) ); @@ -976,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: @@ -1097,22 +1102,6 @@ STATIC void su_unwind(pTHX_ void *ud_) { /* --- Uplevel ------------------------------------------------------------- */ -#ifndef OP_GIMME_REVERSE -STATIC U8 su_op_gimme_reverse(U8 gimme) { - switch (gimme) { - case G_VOID: - return OPf_WANT_VOID; - case G_ARRAY: - return OPf_WANT_LIST; - default: - break; - } - - return OPf_WANT_SCALAR; -} -#define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G) -#endif - #define SU_UPLEVEL_SAVE(f, t) STMT_START { sud->old_##f = PL_##f; PL_##f = (t); } STMT_END #define SU_UPLEVEL_RESTORE(f) STMT_START { PL_##f = sud->old_##f; } STMT_END @@ -1182,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; } @@ -1251,7 +1240,7 @@ done: #endif /* SU_UPLEVEL_HIJACKS_RUNOPS */ -#define su_at_underscore(C) AvARRAY(AvARRAY(CvPADLIST(C))[CvDEPTH(C)])[0] +#define su_at_underscore(C) PadARRAY(PadlistARRAY(CvPADLIST(C))[CvDEPTH(C)])[0] STATIC void su_uplevel_restore(pTHX_ void *sus_) { su_uplevel_ud *sud = sus_; @@ -1795,6 +1784,87 @@ 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_up(pTHX_ I32 cxix) { +#define su_context_up(C) su_context_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) + cxix -= 2; + else + --cxix; + 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; + break; + } + } else { + --cxix; + } + + return cxix; +} + /* --- Interpreter setup/teardown ------------------------------------------ */ STATIC void su_teardown(pTHX_ void *param) { @@ -1853,34 +1923,6 @@ 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) { \ @@ -1895,8 +1937,6 @@ STATIC void su_setup(pTHX) { } else { \ default_cx: \ cxix = cxstack_ix; \ - if (PL_DBsub) \ - SU_SKIP_DB(cxix); \ } \ } STMT_END @@ -1928,6 +1968,7 @@ XS(XS_Scope__Upper_unwind) { PERL_UNUSED_VAR(ax); /* -Wall */ SU_GET_CONTEXT(0, items - 1); + cxix = su_context_skip_db(cxix); do { PERL_CONTEXT *cx = cxstack + cxix; switch (CxTYPE(cx)) { @@ -2008,10 +2049,9 @@ void HERE() PROTOTYPE: PREINIT: - I32 cxix = cxstack_ix; + I32 cxix; PPCODE: - if (PL_DBsub) - SU_SKIP_DB(cxix); + cxix = su_context_skip_db(cxstack_ix); EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); @@ -2023,10 +2063,9 @@ PREINIT: I32 cxix; PPCODE: SU_GET_CONTEXT(0, 0); - if (--cxix < 0) - cxix = 0; - if (PL_DBsub) - SU_SKIP_DB(cxix); + cxix = su_context_skip_db(cxix); + cxix = su_context_up(cxix); + cxix = su_context_skip_db(cxix); EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); @@ -2080,19 +2119,10 @@ 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_skip_db(cxstack_ix); + while (--level >= 0) { + cxix = su_context_up(cxix); + cxix = su_context_skip_db(cxix); } EXTEND(SP, 1); mPUSHi(cxix); @@ -2135,6 +2165,8 @@ PPCODE: 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; @@ -2157,6 +2189,7 @@ PREINIT: su_ud_reap *ud; CODE: SU_GET_CONTEXT(1, 1); + cxix = su_context_skip_db(cxix); Newx(ud, 1, su_ud_reap); SU_UD_ORIGIN(ud) = NULL; SU_UD_HANDLER(ud) = su_reap; @@ -2172,6 +2205,7 @@ PREINIT: su_ud_localize *ud; CODE: SU_GET_CONTEXT(2, 2); + cxix = su_context_skip_db(cxix); Newx(ud, 1, su_ud_localize); SU_UD_ORIGIN(ud) = NULL; SU_UD_HANDLER(ud) = su_localize; @@ -2190,6 +2224,7 @@ CODE: croak("Can't infer the element localization type from a glob and the value"); SU_GET_CONTEXT(3, 3); Newx(ud, 1, su_ud_localize); + cxix = su_context_skip_db(cxix); SU_UD_ORIGIN(ud) = NULL; SU_UD_HANDLER(ud) = su_localize; size = su_ud_localize_init(ud, sv, val, elem); @@ -2208,6 +2243,7 @@ PREINIT: su_ud_localize *ud; CODE: SU_GET_CONTEXT(2, 2); + cxix = su_context_skip_db(cxix); Newx(ud, 1, su_ud_localize); SU_UD_ORIGIN(ud) = NULL; SU_UD_HANDLER(ud) = su_localize; @@ -2256,7 +2292,8 @@ PREINIT: SV *uid; PPCODE: SU_GET_CONTEXT(0, 0); - uid = su_uid_get(cxix); + cxix = su_context_skip_db(cxix); + uid = su_uid_get(cxix); EXTEND(SP, 1); PUSHs(uid); XSRETURN(1);