Silence a couple of warnings reported by gcc

[perl/modules/Scope-Upper.git] / Upper.xs

diff --git a/Upper.xs b/Upper.xs
index aea8e105409a012f837d0b131c932f3fdb5d5580..906065a73020430db9eebed6735ada1ed05836c9 100644 (file)
--- 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,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) {
@@ -1856,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) {             \
@@ -1898,8 +1937,6 @@ STATIC void su_setup(pTHX) {
   } else {                     \
 default_cx:                    \
    cxix = cxstack_ix;          \
-   if (PL_DBsub)               \
-    SU_SKIP_DB(cxix);          \
   }                            \
  } STMT_END
 
@@ -1931,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)) {
@@ -2011,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);
@@ -2026,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);
@@ -2083,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);
@@ -2138,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;
@@ -2160,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;
@@ -2175,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;
@@ -2193,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);
@@ -2211,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;
@@ -2259,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);