/* --- Pop a context back -------------------------------------------------- */
-#if SU_DEBUG && defined(DEBUGGING)
+#ifdef DEBUGGING
# define SU_CXNAME(C) PL_block_type[CxTYPE(C)]
#else
-# define SU_CXNAME(C) "XXX"
+# if SU_HAS_PERL(5, 11, 0)
+static const char *su_block_type[] = {
+ "NULL",
+ "WHEN",
+ "BLOCK",
+ "GIVEN",
+ "LOOP_FOR",
+ "LOOP_PLAIN",
+ "LOOP_LAZYSV",
+ "LOOP_LAZYIV",
+ "SUB",
+ "FORMAT",
+ "EVAL",
+ "SUBST"
+};
+# elif SU_HAS_PERL(5, 9, 3)
+static const char *su_block_type[] = {
+ "NULL",
+ "SUB",
+ "EVAL",
+ "WHEN",
+ "SUBST",
+ "BLOCK",
+ "FORMAT",
+ "GIVEN",
+ "LOOP_FOR",
+ "LOOP_PLAIN",
+ "LOOP_LAZYSV",
+ "LOOP_LAZYIV"
+};
+# else
+static const char *su_block_type[] = {
+ "NULL",
+ "SUB",
+ "EVAL",
+ "LOOP",
+ "SUBST",
+ "BLOCK"
+};
+# endif
+# define SU_CXNAME(C) su_block_type[CxTYPE(C)]
#endif
static void su_pop(pTHX_ void *ud) {
ud, 24, ' ', mark, base));
if (base < mark) {
+#if SU_HAS_PERL(5, 19, 4)
+ I32 save = -1;
+ PERL_CONTEXT *cx;
+#endif
+
SU_D(PerlIO_printf(Perl_debug_log, "%p: clear leftovers\n", ud));
+
+#if SU_HAS_PERL(5, 19, 4)
+ cx = cxstack + cxstack_ix;
+ if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
+ save = PL_scopestack[cx->blk_oldscopesp - 1];
+#endif
+
PL_savestack_ix = mark;
leave_scope(base);
+
+#if SU_HAS_PERL(5, 19, 4)
+ if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
+ PL_scopestack[cx->blk_oldscopesp - 1] = save;
+#endif
}
PL_savestack_ix = base;
static I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) {
#define su_init(U, C, S) su_init(aTHX_ (U), (C), (S))
- I32 i, depth = 1, pad, offset, *origin;
+ I32 i, depth, pad, offset, base, *origin;
SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for cx %d\n", ud, cxix));
SU_D(PerlIO_printf(Perl_debug_log, "%p: size=%d pad=%d offset=%d\n",
ud, size, pad, offset));
- 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:
- case CXt_LOOP_PLAIN:
- case CXt_LOOP_LAZYSV:
- case CXt_LOOP_LAZYIV:
-#else
- case CXt_LOOP:
-#endif
- SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is loop\n", ud, i));
- depth += 2;
- break;
- default:
- SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is other\n", ud, i));
- depth++;
- break;
- }
- }
+ depth = PL_scopestack_ix - cxstack[cxix].blk_oldscopesp;
SU_D(PerlIO_printf(Perl_debug_log, "%p: going down to depth %d\n", ud, depth));
Newx(origin, depth + 1, I32);
- origin[0] = PL_scopestack[PL_scopestack_ix - depth];
- PL_scopestack[PL_scopestack_ix - depth] += size;
- for (i = depth - 1; i >= 1; --i) {
- I32 j = PL_scopestack_ix - i;
- origin[depth - i] = PL_scopestack[j];
+ base = PL_scopestack_ix - depth;
+ origin[0] = PL_scopestack[base];
+ PL_scopestack[base] += size;
+ for (i = 1; i < depth; ++i) {
+ I32 j = i + base;
+ origin[i] = PL_scopestack[j];
PL_scopestack[j] += offset;
}
origin[depth] = PL_savestack_ix;
#if SU_HAS_PERL(5, 10, 0)
if (cxix > 0) {
PERL_CONTEXT *prev = cx - 1;
- U8 type = CxTYPE(prev);
- if ((type == CXt_GIVEN || type == CXt_WHEN)
+ U8 prev_type = CxTYPE(prev);
+ if ((prev_type == CXt_GIVEN || prev_type == CXt_WHEN)
&& (prev->blk_oldcop == cx->blk_oldcop)) {
cxix--;
cx = prev;
- if (type == CXt_GIVEN)
+ if (prev_type == CXt_GIVEN)
goto cxt_given;
else
goto cxt_when;
return sud;
}
+#if SU_HAS_PERL(5, 13, 7)
+
static void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) {
#define su_uplevel_storage_delete(S) su_uplevel_storage_delete(aTHX_ (S))
dMY_CXT;
}
}
+#endif
+
static int su_uplevel_goto_static(const OP *o) {
for (; o; o = OpSIBLING(o)) {
/* goto ops are unops with kids. */
return G_VOID;
}
+/* --- Global setup/teardown ----------------------------------------------- */
+
+static VOL U32 su_initialized = 0;
+
+static void su_global_teardown(pTHX_ void *root) {
+ if (!su_initialized)
+ return;
+
+#if SU_MULTIPLICITY
+ if (aTHX != root)
+ return;
+#endif
+
+ SU_LOCK(&su_uid_seq_counter_mutex);
+ PerlMemShared_free(su_uid_seq_counter.seqs);
+ su_uid_seq_counter.size = 0;
+ SU_UNLOCK(&su_uid_seq_counter_mutex);
+
+ MUTEX_DESTROY(&su_uid_seq_counter_mutex);
+
+ su_initialized = 0;
+
+ return;
+}
+
+XS(XS_Scope__Upper_unwind);
+XS(XS_Scope__Upper_yield);
+XS(XS_Scope__Upper_leave);
+
+#if SU_HAS_PERL(5, 9, 0)
+# define SU_XS_FILE_TYPE const char
+#else
+# define SU_XS_FILE_TYPE char
+#endif
+
+static void su_global_setup(pTHX_ SU_XS_FILE_TYPE *file) {
+#define su_global_setup(F) su_global_setup(aTHX_ (F))
+ HV *stash;
+
+ if (su_initialized)
+ return;
+
+ MUTEX_INIT(&su_uid_seq_counter_mutex);
+
+ SU_LOCK(&su_uid_seq_counter_mutex);
+ su_uid_seq_counter.seqs = NULL;
+ su_uid_seq_counter.size = 0;
+ SU_UNLOCK(&su_uid_seq_counter_mutex);
+
+ stash = gv_stashpv(__PACKAGE__, 1);
+ newCONSTSUB(stash, "TOP", newSViv(0));
+ newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE));
+
+ 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);
+
+#if SU_MULTIPLICITY
+ call_atexit(su_global_teardown, aTHX);
+#else
+ call_atexit(su_global_teardown, NULL);
+#endif
+
+ su_initialized = 1;
+
+ return;
+}
+
/* --- Interpreter setup/teardown ------------------------------------------ */
-static void su_teardown(pTHX_ void *param) {
+static void su_local_teardown(pTHX_ void *param) {
su_uplevel_ud *cur;
su_uid **map;
dMY_CXT;
return;
}
-static void su_setup(pTHX) {
-#define su_setup() su_setup(aTHX)
+static void su_local_setup(pTHX) {
+#define su_local_setup() su_local_setup(aTHX)
MY_CXT_INIT;
MY_CXT.stack_placeholder = NULL;
MY_CXT.uid_storage.used = 0;
MY_CXT.uid_storage.alloc = 0;
- call_atexit(su_teardown, NULL);
+ call_atexit(su_local_teardown, NULL);
return;
}
# define SU_INFO_COUNT 10
#endif
-XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */
-
XS(XS_Scope__Upper_unwind) {
#ifdef dVAR
dVAR; dXSARGS;
static const char su_yield_name[] = "yield";
-XS(XS_Scope__Upper_yield); /* prototype to pass -Wmissing-prototypes */
-
XS(XS_Scope__Upper_yield) {
#ifdef dVAR
dVAR; dXSARGS;
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;
BOOT:
{
- HV *stash;
-
- MUTEX_INIT(&su_uid_seq_counter_mutex);
-
- su_uid_seq_counter.seqs = NULL;
- su_uid_seq_counter.size = 0;
-
- stash = gv_stashpv(__PACKAGE__, 1);
- newCONSTSUB(stash, "TOP", newSViv(0));
- newCONSTSUB(stash, "SU_THREADSAFE", newSVuv(SU_THREADSAFE));
-
- 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();
+ su_global_setup(file);
+ su_local_setup();
}
#if SU_THREADSAFE
goto context_info_warnings_off;
#endif
} else if (old_warnings == pWARN_NONE) {
+#if !SU_HAS_PERL(5, 17, 4)
context_info_warnings_off:
+#endif
mask = su_newmortal_pvn(WARN_NONEstring, WARNsize);
} else if (old_warnings == pWARN_ALL) {
HV *bits;
projects / perl / modules / Scope-Upper.git / blobdiff