From: Vincent Pit Date: Tue, 11 Sep 2012 23:27:42 +0000 (+0200) Subject: Normalize words X-Git-Tag: v0.20~11 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=47d05ad590cff62def1004f1eb061932ac460668 Normalize words --- diff --git a/Upper.xs b/Upper.xs index 906065a..7ccd9dc 100644 --- a/Upper.xs +++ b/Upper.xs @@ -1820,8 +1820,9 @@ STATIC I32 su_context_skip_db(pTHX_ I32 cxix) { return cxix; } -STATIC I32 su_context_up(pTHX_ I32 cxix) { -#define su_context_up(C) su_context_up(aTHX_ (C)) + +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) @@ -1843,28 +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; + return cxix - 1; break; - default: - --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; } - } else { - --cxix; } 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) { @@ -1923,21 +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; \ - } \ +#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,8 +1997,7 @@ XS(XS_Scope__Upper_unwind) { PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(ax); /* -Wall */ - SU_GET_CONTEXT(0, items - 1); - cxix = su_context_skip_db(cxix); + SU_GET_CONTEXT(0, items - 1, cxstack_ix); do { PERL_CONTEXT *cx = cxstack + cxix; switch (CxTYPE(cx)) { @@ -2051,7 +2080,7 @@ PROTOTYPE: PREINIT: I32 cxix; PPCODE: - cxix = su_context_skip_db(cxstack_ix); + cxix = su_context_here(); EXTEND(SP, 1); mPUSHi(cxix); XSRETURN(1); @@ -2062,10 +2091,12 @@ PROTOTYPE: ;$ PREINIT: I32 cxix; PPCODE: - SU_GET_CONTEXT(0, 0); - cxix = su_context_skip_db(cxix); - cxix = su_context_up(cxix); - cxix = su_context_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); @@ -2076,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; @@ -2098,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; @@ -2119,10 +2150,13 @@ PREINIT: I32 cxix, level; PPCODE: SU_GET_LEVEL(0, 0); - cxix = su_context_skip_db(cxstack_ix); + cxix = su_context_here(); while (--level >= 0) { - cxix = su_context_up(cxix); + if (cxix <= 0) + break; + --cxix; cxix = su_context_skip_db(cxix); + cxix = su_context_normalize_up(cxix); } EXTEND(SP, 1); mPUSHi(cxix); @@ -2159,7 +2193,7 @@ 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--; @@ -2188,8 +2222,8 @@ PREINIT: I32 cxix; su_ud_reap *ud; CODE: - SU_GET_CONTEXT(1, 1); - cxix = su_context_skip_db(cxix); + 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; @@ -2204,8 +2238,8 @@ PREINIT: I32 size; su_ud_localize *ud; CODE: - SU_GET_CONTEXT(2, 2); - cxix = su_context_skip_db(cxix); + 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; @@ -2222,9 +2256,9 @@ 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); - 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); @@ -2242,8 +2276,8 @@ PREINIT: I32 size; su_ud_localize *ud; CODE: - SU_GET_CONTEXT(2, 2); - cxix = su_context_skip_db(cxix); + 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; @@ -2260,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)) { @@ -2291,9 +2325,8 @@ PREINIT: I32 cxix; SV *uid; PPCODE: - SU_GET_CONTEXT(0, 0); - cxix = su_context_skip_db(cxix); - uid = su_uid_get(cxix); + SU_GET_CONTEXT(0, 0, su_context_here()); + uid = su_uid_get(cxix); EXTEND(SP, 1); PUSHs(uid); XSRETURN(1); diff --git a/t/05-words.t b/t/05-words.t index 2496460..8a8a583 100644 --- a/t/05-words.t +++ b/t/05-words.t @@ -5,7 +5,7 @@ use warnings; use Test::More; -plan tests => 23 * ($^P ? 4 : 5) + ($^P ? 1 : 2) + 7 + 15 * 2; +plan tests => 23 * ($^P ? 4 : 5) + ($^P ? 1 : 3) + 7 + 15 * 2; use Scope::Upper qw<:words>; @@ -128,7 +128,7 @@ for (1 .. 1) { for (my $i = 0; $i < 1; ++$i) { my $desc = 'for (;;) { 1 }'; - is HERE, 2, "$desc : here" unless $^P; + is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; is SUB, undef, "$desc : sub"; @@ -149,11 +149,11 @@ while ($flag) { my @list = (1); while (my $thing = shift @list) { my $desc = 'while (my $thing = ...) { 2 }'; - is HERE, "$]" <= 5.008_008 ? 1 : 2, "$desc : here" unless $^P; - is TOP, $top, "$desc : top"; - is UP, $top, "$desc : up"; - is SUB, undef, "$desc : sub"; - is EVAL, undef, "$desc : eval"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, undef, "$desc : sub"; + is EVAL, undef, "$desc : eval"; } do { @@ -186,7 +186,7 @@ grep { my $var = 'a'; $var =~ s{.}{ my $desc = 'subst'; - is HERE, 2, "$desc : here" unless $^P; + is HERE, 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $top, "$desc : up"; is SUB, undef, "$desc : sub"; @@ -199,7 +199,11 @@ is $var, $top, 'subst : fake block'; $var = 'a'; $var =~ s{.}{do { UP }}e; -is $var, 2, 'subst : real block' unless $^P; +is $var, 1, 'subst : do block optimized away' unless $^P; + +$var = 'a'; +$var =~ s{.}{do { my $x; UP }}e; +is $var, 1, 'subst : do block preserved' unless $^P; SKIP: { skip 'Perl 5.10 required to test given/when' => 4 * ($^P ? 4 : 5) @@ -210,7 +214,7 @@ SKIP: { my $desc = 'given'; my $base = HERE; given (1) { - is HERE, $base + 2, "$desc : here" unless $^P; + is HERE, $base + 1, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $base, "$desc : up"; is SUB, undef, "$desc : sub"; @@ -226,7 +230,7 @@ TEST_GIVEN given (1) { my $given = HERE; when (1) { - is HERE, $base + 4, "$desc : here" unless $^P; + is HERE, $base + 3, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $given, "$desc : up"; is SUB, undef, "$desc : sub"; @@ -243,7 +247,7 @@ TEST_GIVEN_WHEN given (1) { my $given = HERE; default { - is HERE, $base + 4, "$desc : here" unless $^P; + is HERE, $base + 3, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $given, "$desc : up"; is SUB, undef, "$desc : sub"; @@ -260,7 +264,7 @@ TEST_GIVEN_DEFAULT for (1) { my $loop = HERE; when (1) { - is HERE, $base + 3, "$desc : here" unless $^P; + is HERE, $base + 2, "$desc : here" unless $^P; is TOP, $top, "$desc : top"; is UP, $loop, "$desc : up"; is SUB, undef, "$desc : sub";