/* --- Compatibility ------------------------------------------------------- */
/* perl 5.23.8 onwards has a revamped context system */
-#if XSH_HAS_PERL(5, 23, 8)
-# define SU_HAS_NEW_CXT
-#endif
-
+#define SU_HAS_NEW_CXT XSH_HAS_PERL(5, 23, 8)
#ifndef dVAR
# define dVAR dNOOP
CV *callback;
CV *renamed;
-#ifdef SU_HAS_NEW_CXT
- U8 *cxtypes; /* array of saved context types */
- I32 gap; /* how many contexts have temporarily CXt_NULLed out */
- AV* argarray; /* the PL_curpad[0] of the uplevel sub */
+#if SU_HAS_NEW_CXT
+ U8 *cxtypes; /* array of saved context types */
+ I32 gap; /* how many contexts have temporarily CXt_NULLed out*/
+ AV* argarray; /* the PL_curpad[0] of the uplevel sub */
#else
I32 target_depth;
CV *target;
#endif
} su_uplevel_ud;
-#ifdef SU_HAS_NEW_CXT
+#if SU_HAS_NEW_CXT
/* used to flag a context stack entry whose type has been temporarily
* set to CXt_NULL. It relies on perl not using this value for real
* CXt_NULL entries.
sud->tmp_uid_storage.used = 0;
sud->tmp_uid_storage.alloc = 0;
- #ifndef SU_HAS_NEW_CXT
+#if !SU_HAS_NEW_CXT
Newx(si, 1, PERL_SI);
si->si_stack = newAV();
AvREAL_off(si->si_stack);
static void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) {
#define su_uplevel_ud_delete(S) su_uplevel_ud_delete(aTHX_ (S))
-#ifndef SU_HAS_NEW_CXT
+#if !SU_HAS_NEW_CXT
PERL_SI *si = sud->si;
Safefree(si->si_cxstack);
# define SU_SAVE_HELEM_OR_HDELETE_SIZE SU_SAVE_HELEM_SIZE
#endif
-
#ifndef SvCANEXISTDELETE
# define SvCANEXISTDELETE(sv) \
(!SvRMAGICAL(sv) \
return;
}
- if (preeminent)
+ if (preeminent) {
save_helem(hv, keysv, svp);
- else {
+ } else {
STRLEN keylen;
const char * const key = SvPV_const(keysv, keylen);
SAVEDELETE(hv, savepvn(key, keylen),
/* --- Actions ------------------------------------------------------------- */
typedef struct {
- I32 orig_ix; /* original savestack_ix */
- I32 offset; /* how much we bumped this savestack index */
+ I32 orig_ix; /* original savestack_ix */
+ I32 offset; /* how much we bumped this savestack index */
} su_ud_origin_elem;
typedef struct {
- U8 type;
- U8 private;
+ U8 type;
+ U8 private;
/* spare */
- I32 depth;
+ I32 depth;
su_ud_origin_elem *origin;
} su_ud_common;
-
#define SU_UD_TYPE(U) (((su_ud_common *) (U))->type)
#define SU_UD_PRIVATE(U) (((su_ud_common *) (U))->private)
#define SU_UD_DEPTH(U) (((su_ud_common *) (U))->depth)
if (SvTYPE(sv) >= SVt_PVGV) {
gv = (GV *) sv;
} else {
-
/* new perl context implementation frees savestack *before* restoring
* PL_curcop. Temporarily restore it prematurely to make gv_fetch*
* looks up unqualified var names in the caller's package */
-#ifdef SU_HAS_NEW_CXT
+#if SU_HAS_NEW_CXT
COP *old_cop = PL_curcop;
- PL_curcop = CX_CUR()->blk_oldcop;
+ PL_curcop = CX_CUR()->blk_oldcop;
#endif
#ifdef gv_fetchsv
gv = gv_fetchsv(sv, GV_ADDMULTI, t);
#else
- STRLEN len;
- const char *name = SvPV_const(sv, len);
- gv = gv_fetchpvn_flags(name, len, GV_ADDMULTI, t);
+ {
+ STRLEN len;
+ const char *name = SvPV_const(sv, len);
+ gv = gv_fetchpvn_flags(name, len, GV_ADDMULTI, t);
+ }
#endif
-#ifdef SU_HAS_NEW_CXT
- CX_CUR()->blk_oldcop = PL_curcop;
+
+#if SU_HAS_NEW_CXT
+ CX_CUR()->blk_oldcop = old_cop;
#endif
}
if (elem) {
su_save_aelem(GvAV(gv), elem, val);
return;
- } else
+ } else {
save_ary(gv);
+ }
break;
case SVt_PVHV:
if (elem) {
su_save_helem(GvHV(gv), elem, val);
return;
- } else
+ } else {
save_hash(gv);
+ }
break;
case SVt_PVGV:
save_gp(gv, 1); /* hide previous entry in symtab */
#define SU_CXNAME(C) SU_CX_TYPENAME(CxTYPE(C))
+#if XSH_DEBUG
+
/* for debugging. These indicate how many ENTERs each context type
* does before the PUSHBLOCK */
# endif
};
-
+#endif /* XSH_DEBUG */
/* push at least 'size' slots worth of padding onto the savestack */
static void su_ss_push_padding(pTHX_ void *ud, I32 size) {
+#define su_ss_push_padding(U, S) su_ss_push_padding(aTHX_ (U), (S))
if (size <= 0)
return;
if (size < SU_SAVE_ALLOC_SIZE + 1) /* minimum possible SAVEt_ALLOC */
save_alloc((size - SU_SAVE_ALLOC_SIZE)*sizeof(*PL_savestack), 0);
}
-
static void su_pop(pTHX_ void *ud);
-
-
/* push an su_pop destructor onto the savestack with suitable padding.
* first indicates that this is the first push of a destructor */
static void su_ss_push_destructor(pTHX_ void *ud, I32 depth, bool first) {
+#define su_ss_push_destructor(U, D, F) su_ss_push_destructor(aTHX_ (U), (D), (F))
su_ud_origin_elem *origin = SU_UD_ORIGIN(ud);
- I32 pad;
assert(first || origin[depth+1].orig_ix == PL_savestack_ix);
- su_ss_push_padding(aTHX_ ud,
+ su_ss_push_padding(ud,
(origin[depth].orig_ix + origin[depth].offset) - PL_savestack_ix);
XSH_D(su_debug_log(
"%p: push destructor at save_ix=%d depth=%d scope_ix=%d\n",
PL_savestack_ix <= origin[depth+1].orig_ix + origin[depth+1].offset);
}
-
/* this is called during each leave_scope() via SAVEDESTRUCTOR_X */
static void su_pop(pTHX_ void *ud) {
SU_UD_DEPTH(ud) = depth;
if (depth > 0) {
- su_ss_push_destructor(aTHX_ ud, depth-1, 0);
+ su_ss_push_destructor(ud, depth-1, 0);
} else {
I32 offset = origin[0].offset; /* grab value before origin is freed */
switch (SU_UD_TYPE(ud)) {
if (PL_savestack_ix < base + offset) {
I32 gap = (base + offset) - PL_savestack_ix;
assert(gap >= SU_SAVE_ALLOC_SIZE + 1);
- su_ss_push_padding(aTHX_ ud, gap);
+ su_ss_push_padding(ud, gap);
}
assert(PL_savestack_ix == base + offset);
}
XSH_D(su_debug_log("%p: end pop: ss_ix=%d\n", ud, PL_savestack_ix));
}
-
/* --- Initialize the stack and the action userdata ------------------------ */
static void su_init(pTHX_ void *ud, I32 cxix, I32 size) {
#define su_init(U, C, S) su_init(aTHX_ (U), (C), (S))
- I32 i, depth, base;
+ I32 i, depth;
su_ud_origin_elem *origin;
I32 cur_cx_ix;
I32 cur_scope_ix;
XSH_D(su_debug_log("%p: ### su_init(cxix=%d, size=%d)\n", ud, cxix, size));
depth = PL_scopestack_ix - cxstack[cxix].blk_oldscopesp;
-#ifdef SU_HAS_NEW_CXT
+#if SU_HAS_NEW_CXT
depth += (cxstack_ix - cxix); /* each context frame holds 1 scope */
#endif
XSH_D(su_debug_log(
*
* The passed cxix argument represents the scope we wish to inject into;
* we have to adjust all the savestack frame boundaries above (but not
- * including) that context.
+ * including) that context.
*/
Newx(origin, depth, su_ud_origin_elem);
cur_cx_ix = cxix;
cur_scope_ix = cxstack[cxix].blk_oldscopesp;
-#ifdef SU_HAS_NEW_CXT
+#if SU_HAS_NEW_CXT
XSH_D(su_debug_log("%p: cx=%-2d %-11s\n",
ud, cur_cx_ix, SU_CXNAME(cxstack+cur_cx_ix)));
cur_cx_ix++;
I32 *ixp;
I32 offset;
-#ifdef SU_HAS_NEW_CXT
+#if SU_HAS_NEW_CXT
if ( cur_cx_ix <= cxstack_ix
&& cur_scope_ix == cxstack[cur_cx_ix].blk_oldscopesp
#endif
- if (i == 0)
+ if (i == 0) {
offset = size;
- else {
+ } else {
/* we have three constraints to satisfy:
* 1) Each adjusted offset must be at least SU_SAVE_DESTRUCTOR_SIZE
* above its unadjusted boundary, so that there is space to inject a
origin[i].orig_ix = *ixp;
*ixp += offset;
-#ifdef SU_HAS_NEW_CXT
+#if SU_HAS_NEW_CXT
XSH_D({
if (ixp == &PL_scopestack[cur_scope_ix-1])
su_debug_log(
SU_UD_DEPTH(ud) = depth;
SU_UD_ORIGIN(ud) = origin;
- su_ss_push_destructor(aTHX_ ud, depth-1, 1);
+ su_ss_push_destructor(ud, depth-1, 1);
}
-
/* --- Unwind stack -------------------------------------------------------- */
static void su_unwind(pTHX_ void *ud_) {
U8 flags = 0;
OP *next;
- PERL_UNUSED_VAR(ud_);
-
cx = cxstack + cxix;
switch (CxTYPE(cx)) {
case CXt_BLOCK: {
return 0;
}
-#if !defined(SU_HAS_NEW_CXT) && SU_UPLEVEL_HIJACKS_RUNOPS
+#if !SU_HAS_NEW_CXT && SU_UPLEVEL_HIJACKS_RUNOPS
static int su_uplevel_goto_runops(pTHX) {
#define su_uplevel_goto_runops() su_uplevel_goto_runops(aTHX)
#define su_at_underscore(C) PadARRAY(PadlistARRAY(CvPADLIST(C))[CvDEPTH(C)])[0]
-#ifdef SU_HAS_NEW_CXT
+#if SU_HAS_NEW_CXT
static void su_uplevel_restore_new(pTHX_ void *sus_) {
su_uplevel_ud *sud = sus_;
return cv;
}
-
-
-#ifdef SU_HAS_NEW_CXT
+#if SU_HAS_NEW_CXT
/* this one-shot runops "loop" is designed to be called just before
* execution of the first op following an uplevel()'s entersub. It gets a
return 0;
}
-
-
static I32 su_uplevel_new(pTHX_ CV *callback, I32 cxix, I32 args) {
+#define su_uplevel_new(CB, CX, A) su_uplevel_new(aTHX_ (CB), (CX), (A))
su_uplevel_ud *sud;
U8 *saved_cxtypes;
I32 i, ret;
sud->gap = cxstack_ix - cxix + 1;
sud->argarray = NULL;
-
Newx(saved_cxtypes, sud->gap, U8);
sud->cxtypes = saved_cxtypes;
sud->renamed = su_cv_clone(callback, CvGV(base_cv));
sud->old_runops = PL_runops;
-
if (!CvISXSUB(sud->renamed) && CxHASARGS(&cxstack[cxix])) {
sud->argarray = (AV*)su_at_underscore(base_cv);
assert(PL_runops != su_uplevel_runops_hook_entersub);
#else
static I32 su_uplevel_old(pTHX_ CV *callback, I32 cxix, I32 args) {
+#define su_uplevel_old(CB, CX, A) su_uplevel_old(aTHX_ (CB), (CX), (A))
su_uplevel_ud *sud;
const PERL_CONTEXT *cx = cxstack + cxix;
PERL_SI *si;
return cxix;
}
-
-#ifdef SU_HAS_NEW_CXT
+#if SU_HAS_NEW_CXT
/* convert a physical context stack index into the logical equivalent:
* one that ignores all the context frames hidden by uplevel().
# define su_context_logical2real(C) (C)
#endif
-
static I32 su_context_normalize_up(pTHX_ I32 cxix) {
#define su_context_normalize_up(C) su_context_normalize_up(aTHX_ (C))
PERL_CONTEXT *cx;
args = items - 2;
}
/* su_uplevel() takes care of extending the stack if needed. */
-#ifdef SU_HAS_NEW_CXT
- ret = su_uplevel_new(aTHX_ (CV *) code, cxix, args);
+#if SU_HAS_NEW_CXT
+ ret = su_uplevel_new((CV *) code, cxix, args);
#else
- ret = su_uplevel_old(aTHX_ (CV *) code, cxix, args);
+ ret = su_uplevel_old((CV *) code, cxix, args);
#endif
XSRETURN(ret);
default:
projects / perl / modules / Scope-Upper.git / blobdiff