Fix debugger compatibility with perl 5.17.1 and above

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

diff --git a/Upper.xs b/Upper.xs
index b1d9a08ef9b9a1ef08163998992b2d11091111f9..3de19a9b6e5c04726e706fd1eda47d405c9a15a3 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -1071,23 +1071,17 @@ STATIC I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) {
 
 STATIC void su_unwind(pTHX_ void *ud_) {
  dMY_CXT;
- I32 cxix    = MY_CXT.unwind_storage.cxix;
- I32 items   = MY_CXT.unwind_storage.items - 1;
- SV **savesp = MY_CXT.unwind_storage.savesp;
+ I32 cxix  = MY_CXT.unwind_storage.cxix;
+ I32 items = MY_CXT.unwind_storage.items;
  I32 mark;
 
  PERL_UNUSED_VAR(ud_);
 
- if (savesp)
-  PL_stack_sp = savesp;
+ PL_stack_sp = MY_CXT.unwind_storage.savesp;
 
  if (cxstack_ix > cxix)
   dounwind(cxix);
 
- /* Hide the level */
- if (items >= 0)
-  PL_stack_sp--;
-
  mark = PL_markstack[cxstack[cxix].blk_oldmarksp];
  *PL_markstack_ptr = PL_stack_sp - PL_stack_base - items;
 
@@ -1125,18 +1119,15 @@ STATIC void su_unwind(pTHX_ void *ud_) {
 STATIC void su_yield(pTHX_ void *ud_) {
  dMY_CXT;
  PERL_CONTEXT *cx;
+ const char   *which = ud_;
  I32 cxix      = MY_CXT.yield_storage.cxix;
- I32 items     = MY_CXT.yield_storage.items - 1;
- SV **savesp   = MY_CXT.yield_storage.savesp;
+ I32 items     = MY_CXT.yield_storage.items;
  opcode  type  = OP_NULL;
  U8      flags = 0;
  OP     *next;
 
  PERL_UNUSED_VAR(ud_);
 
- if (savesp)
-  PL_stack_sp = savesp;
-
  cx = cxstack + cxix;
  switch (CxTYPE(cx)) {
   case CXt_BLOCK: {
@@ -1253,22 +1244,19 @@ cxt_when:
    break;
 #endif
   case CXt_SUBST:
-   croak("yield() cannot target a substitution context");
+   croak("%s() can't target a substitution context", which);
    break;
   default:
-   croak("yield() don't know how to leave a %s context", SU_CXNAME(cxstack + cxix));
+   croak("%s() doesn't know how to leave a %s context",
+          which,                         SU_CXNAME(cxstack + cxix));
    break;
  }
 
+ PL_stack_sp = MY_CXT.yield_storage.savesp;
+
  if (cxstack_ix > cxix)
   dounwind(cxix);
 
- /* Hide the level */
- if (items >= 0)
-  PL_stack_sp--;
- else
-  items = 0;
-
  /* Copy the arguments passed to yield() where the leave op expects to find
   * them. */
  if (items)
@@ -1989,6 +1977,9 @@ STATIC I32 su_context_skip_db(pTHX_ I32 cxix) {
   PERL_CONTEXT *cx = cxstack + i;
 
   switch (CxTYPE(cx)) {
+#if SU_HAS_PERL(5, 17, 1)
+   case CXt_LOOP_PLAIN:
+#endif
    case CXt_BLOCK:
     if (cx->blk_oldcop && CopSTASH(cx->blk_oldcop) == GvSTASH(PL_DBgv))
      continue;
@@ -2203,17 +2194,18 @@ XS(XS_Scope__Upper_unwind) {
      continue;
    case CXt_EVAL:
    case CXt_FORMAT:
-    MY_CXT.unwind_storage.cxix  = cxix;
-    MY_CXT.unwind_storage.items = items;
+    MY_CXT.unwind_storage.cxix   = cxix;
+    MY_CXT.unwind_storage.items  = items;
+    MY_CXT.unwind_storage.savesp = PL_stack_sp;
+    if (items > 0) {
+     MY_CXT.unwind_storage.items--;
+     MY_CXT.unwind_storage.savesp--;
+    }
     /* pp_entersub will want to sanitize the stack after returning from there
-     * Screw that, we're insane */
-    if (GIMME_V == G_SCALAR) {
-     MY_CXT.unwind_storage.savesp = PL_stack_sp;
-     /* dXSARGS calls POPMARK, so we need to match PL_markstack_ptr[1] */
+     * Screw that, we're insane!
+     * dXSARGS calls POPMARK, so we need to match PL_markstack_ptr[1] */
+    if (GIMME_V == G_SCALAR)
      PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
-    } else {
-     MY_CXT.unwind_storage.savesp = NULL;
-    }
     SAVEDESTRUCTOR_X(su_unwind, NULL);
     return;
    default:
@@ -2223,6 +2215,8 @@ XS(XS_Scope__Upper_unwind) {
  croak("Can't return outside a subroutine");
 }
 
+STATIC const char su_yield_name[] = "yield";
+
 XS(XS_Scope__Upper_yield); /* prototype to pass -Wmissing-prototypes */
 
 XS(XS_Scope__Upper_yield) {
@@ -2238,16 +2232,43 @@ XS(XS_Scope__Upper_yield) {
  PERL_UNUSED_VAR(ax); /* -Wall */
 
  SU_GET_CONTEXT(0, items - 1, su_context_here());
- MY_CXT.yield_storage.cxix  = cxix;
- MY_CXT.yield_storage.items = items;
+ MY_CXT.yield_storage.cxix   = cxix;
+ MY_CXT.yield_storage.items  = items;
+ MY_CXT.yield_storage.savesp = PL_stack_sp;
+ if (items > 0) {
+  MY_CXT.yield_storage.items--;
+  MY_CXT.yield_storage.savesp--;
+ }
  /* See XS_Scope__Upper_unwind */
- if (GIMME_V == G_SCALAR) {
-  MY_CXT.yield_storage.savesp = PL_stack_sp;
+ if (GIMME_V == G_SCALAR)
   PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
- } else {
-  MY_CXT.yield_storage.savesp = NULL;
- }
- SAVEDESTRUCTOR_X(su_yield, NULL);
+ SAVEDESTRUCTOR_X(su_yield, su_yield_name);
+ return;
+}
+
+STATIC const char su_leave_name[] = "leave";
+
+XS(XS_Scope__Upper_leave); /* prototype to pass -Wmissing-prototypes */
+
+XS(XS_Scope__Upper_leave) {
+#ifdef dVAR
+ dVAR; dXSARGS;
+#else
+ dXSARGS;
+#endif
+ dMY_CXT;
+ I32 cxix;
+
+ PERL_UNUSED_VAR(cv); /* -W */
+ PERL_UNUSED_VAR(ax); /* -Wall */
+
+ MY_CXT.yield_storage.cxix   = su_context_here();
+ MY_CXT.yield_storage.items  = items;
+ MY_CXT.yield_storage.savesp = PL_stack_sp;
+ /* See XS_Scope__Upper_unwind */
+ if (GIMME_V == G_SCALAR)
+  PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
+ SAVEDESTRUCTOR_X(su_yield, su_leave_name);
  return;
 }
 
@@ -2270,6 +2291,7 @@ BOOT:
 
  newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL);
  newXSproto("Scope::Upper::yield",  XS_Scope__Upper_yield,  file, NULL);
+ newXSproto("Scope::Upper::leave",  XS_Scope__Upper_leave,  file, NULL);
 
  su_setup();
 }