Make levels absolute

diff --git a/Upper.xs b/Upper.xs
index a0f11598100be1373f21847723074466ae90fe9c..9c510f99ba5f20b6d5811966233d9c291ee4085d 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -489,22 +489,22 @@ STATIC void su_pop(pTHX_ void *ud) {
 
 /* --- Initialize the stack and the action userdata ------------------------ */
 
-STATIC I32 su_init(pTHX_ I32 level, void *ud, I32 size) {
+STATIC I32 su_init(pTHX_ I32 cxix, void *ud, I32 size) {
 #define su_init(L, U, S) su_init(aTHX_ (L), (U), (S))
  I32 i, depth = 0, *origin;
  I32 cur, last, step;
 
  LEAVE;
 
- if (level <= 0) {
+ if (cxix >= cxstack_ix) {
   SU_UD_HANDLER(ud)(aTHX_ ud);
   goto done;
  }
 
- SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for level %d\n", ud, level));
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for cx %d\n", ud, cxix));
 
- for (i = 0; i < level; ++i) {
-  PERL_CONTEXT *cx = &cxstack[cxstack_ix - i];
+ for (i = cxstack_ix; i > cxix; --i) {
+  PERL_CONTEXT *cx = cxstack + i;
   switch (CxTYPE(cx)) {
 #if SU_HAS_PERL(5, 11, 0)
    case CXt_LOOP_FOR:
@@ -612,43 +612,31 @@ STATIC void su_unwind(pTHX_ void *ud_) {
 
 /* --- XS ------------------------------------------------------------------ */
 
-#define SU_GET_LEVEL(A)   \
- STMT_START {             \
-  if (items > A) {        \
-   SV *lsv = ST(A);       \
-   if (SvOK(lsv))         \
-    level = SvIV(lsv);    \
-   if (level < 0)         \
-    XSRETURN(0);          \
-  }                       \
-  if (level > cxstack_ix) \
-   level = cxstack_ix;    \
+#define SU_GET_CONTEXT(A, B)   \
+ STMT_START {                  \
+  if (items > A) {             \
+   SV *csv = ST(B);            \
+   if (SvOK(csv))              \
+    cxix = SvIV(csv);          \
+   if (cxix < 0)               \
+    cxix = 0;                  \
+   else if (cxix > cxstack_ix) \
+    cxix = cxstack_ix;         \
+  } else                       \
+   cxix = cxstack_ix;          \
  } STMT_END
 
-#define SU_GET_CONTEXT(A, B) \
- STMT_START {                \
-  if (items > A) {           \
-   SV *lsv = ST(B);          \
-   if (SvOK(lsv))            \
-    level = SvIV(lsv);       \
-   if (level < 0)            \
-    level = 0;               \
-   else if (level > cxix)    \
-    level = cxix;            \
-  }                          \
- } STMT_END
-
-#define SU_DOPOPTOCX(t)                    \
- STMT_START {                              \
-  I32 i, cxix = cxstack_ix, level = 0;     \
-  SU_GET_CONTEXT(0, 0);                    \
-  for (i = cxix - level; i >= 0; --i) {    \
-   if (CxTYPE(&cxstack[i]) == t) {         \
-    ST(0) = sv_2mortal(newSViv(cxix - i)); \
-    XSRETURN(1);                           \
-   }                                       \
-  }                                        \
-  XSRETURN_UNDEF;                          \
+#define SU_DOPOPTOCX(t)                \
+ STMT_START {                          \
+  I32 cxix;                            \
+  SU_GET_CONTEXT(0, 0);                \
+  for (; cxix >= 0; --cxix) {          \
+   if (CxTYPE(cxstack + cxix) == t) {  \
+    ST(0) = sv_2mortal(newSViv(cxix)); \
+    XSRETURN(1);                       \
+   }                                   \
+  }                                    \
+  XSRETURN_UNDEF;                      \
  } STMT_END
 
 XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */
@@ -660,13 +648,12 @@ XS(XS_Scope__Upper_unwind) {
  dXSARGS;
 #endif
  dMY_CXT;
- I32 cxix = cxstack_ix, level = 0;
+ I32 cxix;
 
  PERL_UNUSED_VAR(cv); /* -W */
  PERL_UNUSED_VAR(ax); /* -Wall */
 
  SU_GET_CONTEXT(0, items - 1);
- cxix -= level;
  do {
   PERL_CONTEXT *cx = cxstack + cxix;
   switch (CxTYPE(cx)) {
@@ -702,7 +689,7 @@ BOOT:
  HV *stash;
  MY_CXT_INIT;
  stash = gv_stashpv(__PACKAGE__, 1);
- newCONSTSUB(stash, "HERE", newSViv(0));
+ newCONSTSUB(stash, "TOP", newSViv(0));
  newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL);
 }
 
@@ -715,7 +702,7 @@ CODE:
 #endif /* SU_THREADSAFE */
 
 SV *
-TOP()
+HERE()
 PROTOTYPE:
 CODE:
  RETVAL = newSViv(cxstack_ix);
@@ -726,14 +713,12 @@ SV *
 UP(...)
 PROTOTYPE: ;$
 PREINIT:
- I32 i = 0;
- I32 cxix = cxstack_ix;
+ I32 cxix;
 CODE:
- if (items)
-  i = SvIV(ST(0));
- if (++i > cxix)
-  i = cxix;
- RETVAL = newSViv(i);
+ SU_GET_CONTEXT(0, 0);
+ if (--cxix < 0)
+  cxix = 0;
+ RETVAL = newSViv(cxix);
 OUTPUT:
  RETVAL
 
@@ -741,13 +726,12 @@ SV *
 DOWN(...)
 PROTOTYPE: ;$
 PREINIT:
- I32 i = 0;
+ I32 cxix;
 CODE:
- if (items)
-  i = SvIV(ST(0));
- if (--i < 0)
-  i = 0;
- RETVAL = newSViv(i);
+ SU_GET_CONTEXT(0, 0);
+ if (++cxix > cxstack_ix)
+  cxix = cxstack_ix;
+ RETVAL = newSViv(cxix);
 OUTPUT:
  RETVAL
 
@@ -767,16 +751,18 @@ void
 CALLER(...)
 PROTOTYPE: ;$
 PREINIT:
- I32 cxix = cxstack_ix, caller = 0, level = 0;
+ I32 cxix, caller = 0;
 PPCODE:
  if (items) {
   SV *csv = ST(0);
   if (SvOK(csv))
    caller = SvIV(csv);
+  if (caller < 0)
+   caller = 0;
  }
  cxix = cxstack_ix;
  while (cxix > 0) {
-  PERL_CONTEXT *cx = cxstack + cxix--;
+  PERL_CONTEXT *cx = cxstack + cxix;
   switch (CxTYPE(cx)) {
    case CXt_SUB:
    case CXt_EVAL:
@@ -786,20 +772,19 @@ PPCODE:
      goto done;
     break;
   }
-  ++level;
+  --cxix;
  }
 done:
- ST(0) = sv_2mortal(newSViv(level));
+ ST(0) = sv_2mortal(newSViv(cxix));
  XSRETURN(1);
 
 void
 want_at(...)
 PROTOTYPE: ;$
 PREINIT:
- I32 cxix = cxstack_ix, level = 0;
+ I32 cxix;
 PPCODE:
  SU_GET_CONTEXT(0, 0);
- cxix -= level;
  while (cxix > 0) {
   PERL_CONTEXT *cx = cxstack + cxix--;
   switch (CxTYPE(cx)) {
@@ -822,24 +807,24 @@ void
 reap(SV *hook, ...)
 PROTOTYPE: &;$
 PREINIT:
- I32 level = 0;
+ I32 cxix;
  su_ud_reap *ud;
 CODE:
- SU_GET_LEVEL(1);
+ SU_GET_CONTEXT(1, 1);
  Newx(ud, 1, su_ud_reap);
  SU_UD_ORIGIN(ud)  = NULL;
  SU_UD_HANDLER(ud) = su_reap;
  ud->cb = newSVsv(hook);
- su_init(level, ud, 3);
+ su_init(cxix, ud, 3);
 
 void
 localize(SV *sv, SV *val, ...)
 PROTOTYPE: $$;$
 PREINIT:
- I32 level = 0;
+ I32 cxix;
  su_ud_localize *ud;
 CODE:
- SU_GET_LEVEL(2);
+ SU_GET_CONTEXT(2, 2);
  Newx(ud, 1, su_ud_localize);
  SU_UD_ORIGIN(ud)  = NULL;
  SU_UD_HANDLER(ud) = su_localize;
@@ -847,16 +832,16 @@ CODE:
  ud->sv   = sv;
  ud->val  = newSVsv(val);
  ud->elem = NULL;
- su_init(level, ud, 3);
+ su_init(cxix, ud, 3);
 
 void
 localize_elem(SV *sv, SV *elem, SV *val, ...)
 PROTOTYPE: $$$;$
 PREINIT:
- I32 level = 0;
+ I32 cxix;
  su_ud_localize *ud;
 CODE:
- SU_GET_LEVEL(3);
+ SU_GET_CONTEXT(3, 3);
  Newx(ud, 1, su_ud_localize);
  SU_UD_ORIGIN(ud)  = NULL;
  SU_UD_HANDLER(ud) = su_localize;
@@ -865,16 +850,16 @@ CODE:
  ud->val  = newSVsv(val);
  SvREFCNT_inc(elem);
  ud->elem = elem;
- su_init(level, ud, 4);
+ su_init(cxix, ud, 4);
 
 void
 localize_delete(SV *sv, SV *elem, ...)
 PROTOTYPE: $$;$
 PREINIT:
- I32 level = 0;
+ I32 cxix;
  su_ud_localize *ud;
 CODE:
- SU_GET_LEVEL(2);
+ SU_GET_CONTEXT(2, 2);
  Newx(ud, 1, su_ud_localize);
  SU_UD_ORIGIN(ud)  = NULL;
  SU_UD_HANDLER(ud) = su_localize;
@@ -883,4 +868,4 @@ CODE:
  ud->val  = NULL;
  SvREFCNT_inc(elem);
  ud->elem = elem;
- su_init(level, ud, 4);
+ su_init(cxix, ud, 4);

diff --git a/t/05-words.t b/t/05-words.t
index a52a362adcd15d38b5af9941e2c60ecede089220..318581d2c5f40e7f552fae6613a4a6df324395c3 100644 (file)
--- a/t/05-words.t
+++ b/t/05-words.t
@@ -15,44 +15,44 @@ is SUB,  undef, 'main : sub';
 is EVAL, undef, 'main : eval';
 
 {
- is HERE, 0, '{ 1 } : here';
- is TOP,  1, '{ 1 } : top';
- is UP,   1, '{ 1 } : up';
- is DOWN, 0, '{ 1 } : down';
- is DOWN(UP), 0, '{ 1 } : up then down';
- is UP(DOWN), 1, '{ 1 } : down then up';
+ is HERE, 1, '{ 1 } : here';
+ is TOP,  0, '{ 1 } : top';
+ is UP,   0, '{ 1 } : up';
+ is DOWN, 1, '{ 1 } : down';
+ is DOWN(UP), 1, '{ 1 } : up then down';
+ is UP(DOWN), 0, '{ 1 } : down then up';
 }
 
 do {
- is TOP, 1, 'do { 1 } : top';
- is SUB, undef, 'do { 1 } : sub';
+ is HERE, 1,     'do { 1 } : here';
+ is SUB,  undef, 'do { 1 } : sub';
  is EVAL, undef, 'do { 1 } : eval';
 };
 
 eval {
- is TOP, 1, 'eval { 1 } : top';
- is SUB, undef, 'eval { 1 } : sub';
- is EVAL, 0, 'eval { 1 } : eval';
+ is HERE, 1,     'eval { 1 } : here';
+ is SUB,  undef, 'eval { 1 } : sub';
+ is EVAL, 1,     'eval { 1 } : eval';
 };
 
 eval q[
- is TOP, 1, 'eval "1" : top';
- is SUB, undef, 'eval "1" : sub';
- is EVAL, 0, 'eval "1" : eval';
+ is HERE, 1,     'eval "1" : here';
+ is SUB,  undef, 'eval "1" : sub';
+ is EVAL, 1,     'eval "1" : eval';
 ];
 
 do {
- is TOP, 1, 'do { 1 } while (0) : top';
+ is HERE, 1, 'do { 1 } while (0) : here';
 } while (0);
 
 sub {
- is TOP, 1, 'sub { 1 } : top';
- is SUB, 0, 'sub { 1 } : sub';
+ is HERE, 1,     'sub { 1 } : here';
+ is SUB,  1,     'sub { 1 } : sub';
  is EVAL, undef, 'sub { 1 } : eval';
 }->();
 
 for (1) {
- is TOP, 1, 'for () { 1 } : top';
+ is HERE, 1, 'for () { 1 } : here';
 }
 
 do {
@@ -61,13 +61,13 @@ do {
    sub {
     eval q[
      {
-      is HERE, 0, 'mixed : here';
-      is TOP,  6, 'mixed : top';
-      is SUB,  2, 'mixed : first sub';
-      is SUB(SUB), 2, 'mixed : still first sub';
-      is EVAL, 1, 'mixed : first eval';
-      is EVAL(EVAL),     1, 'mixed : still first eval';
-      is EVAL(UP(EVAL)), 4, 'mixed : second eval';
+      is HERE,           6, 'mixed : here';
+      is TOP,            0, 'mixed : top';
+      is SUB,            4, 'mixed : first sub';
+      is SUB(SUB),       4, 'mixed : still first sub';
+      is EVAL,           5, 'mixed : first eval';
+      is EVAL(EVAL),     5, 'mixed : still first eval';
+      is EVAL(UP(EVAL)), 2, 'mixed : second eval';
      }
     ];
    }->();
@@ -76,22 +76,22 @@ do {
 } while (0);
 
 {
- is CALLER,    1, '{ } : caller';
- is CALLER(0), 1, '{ } : caller 0';
- is CALLER(1), 1, '{ } : caller 1';
+ is CALLER,    0, '{ } : caller';
+ is CALLER(0), 0, '{ } : caller 0';
+ is CALLER(1), 0, '{ } : caller 1';
  sub {
-  is CALLER,    0, '{ sub { } } : caller';
-  is CALLER(0), 0, '{ sub { } } : caller 0';
-  is CALLER(1), 2, '{ sub { } } : caller 1';
+  is CALLER,    2, '{ sub { } } : caller';
+  is CALLER(0), 2, '{ sub { } } : caller 0';
+  is CALLER(1), 0, '{ sub { } } : caller 1';
   for (1) {
-   is CALLER,    1, '{ sub { for { } } } : caller';
-   is CALLER(0), 1, '{ sub { for { } } } : caller 0';
-   is CALLER(1), 3, '{ sub { for { } } } : caller 1';
+   is CALLER,    2, '{ sub { for { } } } : caller';
+   is CALLER(0), 2, '{ sub { for { } } } : caller 0';
+   is CALLER(1), 0, '{ sub { for { } } } : caller 1';
    eval {
-    is CALLER,    0, '{ sub { for { eval { } } } } : caller';
-    is CALLER(0), 0, '{ sub { for { eval { } } } } : caller 0';
+    is CALLER,    4, '{ sub { for { eval { } } } } : caller';
+    is CALLER(0), 4, '{ sub { for { eval { } } } } : caller 0';
     is CALLER(1), 2, '{ sub { for { eval { } } } } : caller 1';
-    is CALLER(2), 4, '{ sub { for { eval { } } } } : caller 2';
+    is CALLER(2), 0, '{ sub { for { eval { } } } } : caller 2';
    }
   }
  }->();