X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Upper.xs;h=92f9e65b4f0e09573b28c7dd9e8ab6bf54b44607;hb=a06eb7aacdd80daabe3b1565c15b37096ea2b57c;hp=20fa5d662013c10dc685bd656fee919a9753c3b9;hpb=44bbbdcdafa5707a753abb9de5c5d01cd7388880;p=perl%2Fmodules%2FScope-Upper.git diff --git a/Upper.xs b/Upper.xs index 20fa5d6..92f9e65 100644 --- a/Upper.xs +++ b/Upper.xs @@ -114,8 +114,25 @@ # define MY_CXT_CLONE NOOP #endif +/* --- Global data --------------------------------------------------------- */ + +#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION + +typedef struct { + int stack_placeholder; + I32 cxix; + I32 items; + SV **savesp; + OP fakeop; +} my_cxt_t; + +START_MY_CXT + /* --- Stack manipulations ------------------------------------------------- */ +#define SU_SAVE_DESTRUCTOR_SIZE 3 +#define SU_SAVE_INT_SIZE 3 + #ifndef SvCANEXISTDELETE # define SvCANEXISTDELETE(sv) \ (!SvRMAGICAL(sv) \ @@ -259,11 +276,13 @@ STATIC void su_save_helem(pTHX_ HV *hv, SV *keysv, SV *val) { typedef struct { I32 depth; + I32 pad; I32 *origin; void (*handler)(pTHX_ void *); } su_ud_common; #define SU_UD_DEPTH(U) (((su_ud_common *) (U))->depth) +#define SU_UD_PAD(U) (((su_ud_common *) (U))->pad) #define SU_UD_ORIGIN(U) (((su_ud_common *) (U))->origin) #define SU_UD_HANDLER(U) (((su_ud_common *) (U))->handler) @@ -361,6 +380,9 @@ STATIC void su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *e t = SvTYPE(SvRV(val)); deref = 1; } + } else if (SvROK(sv)) { + croak("Invalid %s reference as the localization target", + sv_reftype(SvRV(sv), 0)); } else { STRLEN len, l; const char *p = SvPV_const(sv, len), *s; @@ -518,30 +540,22 @@ STATIC void su_pop(pTHX_ void *ud) { SU_UD_DEPTH(ud) = --depth; if (depth > 0) { - I32 i = 1; - - SAVEDESTRUCTOR_X(su_pop, ud); - - /* Skip depths corresponding to scopes for which leave_scope() might not be - * called. */ - while (depth > 1 && PL_scopestack_ix >= i) { - I32 j = PL_scopestack[PL_scopestack_ix - i]; - - if (j < PL_savestack_ix) - break; - - SU_D(PerlIO_printf(Perl_debug_log, - "%p: skip scope%*cat depth=%2d scope_ix=%2d new_top=%2d >= cur_base=%2d\n", - ud, 6, ' ', depth, PL_scopestack_ix - i, j, PL_savestack_ix)); - - SU_UD_DEPTH(ud) = --depth; - - ++i; + I32 pad; + + if ((pad = SU_UD_PAD(ud))) { + dMY_CXT; + do { + SU_D(PerlIO_printf(Perl_debug_log, + "%p: push a pad slot at depth=%2d scope_ix=%2d save_ix=%2d\n", + ud, depth, PL_scopestack_ix, PL_savestack_ix)); + save_int(&MY_CXT.stack_placeholder); + } while (--pad); } SU_D(PerlIO_printf(Perl_debug_log, - "%p: set destructor at depth=%2d scope_ix=%2d save_ix=%2d\n", - ud, depth, PL_scopestack_ix, PL_savestack_ix)); + "%p: push destructor at depth=%2d scope_ix=%2d save_ix=%2d\n", + ud, depth, PL_scopestack_ix, PL_savestack_ix)); + SAVEDESTRUCTOR_X(su_pop, ud); } else { SU_UD_HANDLER(ud)(aTHX_ ud); } @@ -551,28 +565,25 @@ STATIC void su_pop(pTHX_ void *ud) { ud, PL_savestack_ix, PL_scopestack[PL_scopestack_ix])); } -/* --- Global data --------------------------------------------------------- */ - -#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION - -typedef struct { - int stack_placeholder; - I32 cxix; - I32 items; - SV **savesp; - OP fakeop; -} my_cxt_t; - -START_MY_CXT - /* --- Initialize the stack and the action userdata ------------------------ */ 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 = 1, *origin; + I32 i, depth = 1, pad, offset, *origin; SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for cx %d\n", ud, cxix)); + if (size <= SU_SAVE_DESTRUCTOR_SIZE) + pad = 0; + else { + I32 extra = size - SU_SAVE_DESTRUCTOR_SIZE; + pad = extra / SU_SAVE_INT_SIZE + ((extra % SU_SAVE_INT_SIZE) ? 1 : 0); + } + offset = SU_SAVE_DESTRUCTOR_SIZE + SU_SAVE_INT_SIZE * pad; + + 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)) { @@ -606,7 +617,7 @@ STATIC I32 su_init(pTHX_ I32 cxix, void *ud, I32 size) { break; } } - SU_D(PerlIO_printf(Perl_debug_log, "%p: depth is %d\n", ud, depth)); + 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]; @@ -614,26 +625,30 @@ STATIC I32 su_init(pTHX_ I32 cxix, void *ud, I32 size) { for (i = depth - 1; i >= 1; --i) { I32 j = PL_scopestack_ix - i; origin[depth - i] = PL_scopestack[j]; - PL_scopestack[j] += 3; + PL_scopestack[j] += offset; } origin[depth] = PL_savestack_ix; SU_UD_ORIGIN(ud) = origin; SU_UD_DEPTH(ud) = depth; - - SU_D(PerlIO_printf(Perl_debug_log, - "%p: set original destructor at depth=%2d scope_ix=%2d save_ix=%2d\n", - ud, depth, PL_scopestack_ix - 1, PL_savestack_ix)); + SU_UD_PAD(ud) = pad; /* Make sure the first destructor fires by pushing enough fake slots on the * stack. */ - if (PL_savestack_ix + 3 <= PL_scopestack[PL_scopestack_ix - 1]) { + if (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE + <= PL_scopestack[PL_scopestack_ix - 1]) { dMY_CXT; do { + SU_D(PerlIO_printf(Perl_debug_log, + "%p: push a fake slot at scope_ix=%2d save_ix=%2d\n", + ud, PL_scopestack_ix, PL_savestack_ix)); save_int(&MY_CXT.stack_placeholder); - } while (PL_savestack_ix + 3 <= PL_scopestack[PL_scopestack_ix - 1]); + } while (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE + <= PL_scopestack[PL_scopestack_ix - 1]); } - + SU_D(PerlIO_printf(Perl_debug_log, + "%p: push first destructor at scope_ix=%2d save_ix=%2d\n", + ud, PL_scopestack_ix, PL_savestack_ix)); SAVEDESTRUCTOR_X(su_pop, ud); SU_D({ @@ -1005,11 +1020,17 @@ PREINIT: I32 cxix; su_ud_localize *ud; CODE: + if (SvTYPE(sv) >= SVt_PVGV) + 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); SU_UD_ORIGIN(ud) = NULL; SU_UD_HANDLER(ud) = su_localize; su_ud_localize_init(ud, sv, val, elem); + if (ud->type != SVt_PVAV && ud->type != SVt_PVHV) { + Safefree(ud); + croak("Can't localize an element of something that isn't an array or a hash"); + } su_init(cxix, ud, 4); void