dSP;
ENTER;
SAVETMPS;
+ PUSHSTACK(SI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,2);
PUSHs(mg->mg_obj);
PUSHs(sv_2mortal(newSViv(key+1)));
PUTBACK;
perl_call_method("EXTEND", G_SCALAR|G_DISCARD);
+ POPSTACK();
FREETMPS;
LEAVE;
return;
if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
dSP;
+ PUSHSTACK(SI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,2);
PUSHs(mg->mg_obj);
ENTER;
perl_call_method("PUSH", G_SCALAR|G_DISCARD);
LEAVE;
+ POPSTACK();
return;
}
av_store(av,AvFILLp(av)+1,val);
croak(no_modify);
if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
dSP;
+ PUSHSTACK(SI_MAGIC);
PUSHMARK(SP);
XPUSHs(mg->mg_obj);
PUTBACK;
retval = &sv_undef;
}
LEAVE;
+ POPSTACK();
return retval;
}
retval = AvARRAY(av)[AvFILLp(av)];
if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
dSP;
+ PUSHSTACK(SI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,1+num);
PUSHs(mg->mg_obj);
ENTER;
perl_call_method("UNSHIFT", G_SCALAR|G_DISCARD);
LEAVE;
+ POPSTACK();
return;
}
croak(no_modify);
if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
dSP;
+ PUSHSTACK(SI_MAGIC);
PUSHMARK(SP);
XPUSHs(mg->mg_obj);
PUTBACK;
retval = &sv_undef;
}
LEAVE;
+ POPSTACK();
return retval;
}
retval = *AvARRAY(av);
dSP;
ENTER;
SAVETMPS;
+ PUSHSTACK(SI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,2);
PUSHs(mg->mg_obj);
PUSHs(sv_2mortal(newSViv(fill+1)));
PUTBACK;
perl_call_method("STORESIZE", G_SCALAR|G_DISCARD);
+ POPSTACK();
FREETMPS;
LEAVE;
return;
#define G_EVAL 4 /* Assume eval {} around subroutine call. */
#define G_NOARGS 8 /* Don't construct a @_ array. */
#define G_KEEPERR 16 /* Append errors to $@, don't overwrite it */
+
+/* Support for switching (stack and block) contexts.
+ * This ensures magic doesn't invalidate local stack and cx pointers.
+ */
+
+#define SI_UNDEF 0
+#define SI_MAIN 1
+#define SI_MAGIC 2
+#define SI_SORT 3
+#define SI_SIGNAL 4
+#define SI_OVERLOAD 5
+#define SI_DESTROY 6
+/* XXX todo
+#define SI_WARNHOOK 7
+#define SI_DIEHOOK 8
+*/
+
+struct stackinfo {
+ AV * si_stack; /* stack for current runlevel */
+ PERL_CONTEXT * si_cxstack; /* context stack for runlevel */
+ I32 si_cxix; /* current context index */
+ I32 si_cxmax; /* maximum allocated index */
+ I32 si_type; /* type of runlevel */
+ struct stackinfo * si_prev;
+ struct stackinfo * si_next;
+ I32 * si_markbase; /* where markstack begins for us.
+ * currently used only with DEBUGGING,
+ * but not #ifdef-ed for bincompat */
+};
+
+typedef struct stackinfo PERL_SI;
+
+#define cxstack (curstackinfo->si_cxstack)
+#define cxstack_ix (curstackinfo->si_cxix)
+#define cxstack_max (curstackinfo->si_cxmax)
+
+#ifdef DEBUGGING
+# define SET_MARKBASE curstackinfo->si_markbase = markstack_ptr
+#else
+# define SET_MARKBASE NOOP
+#endif
+
+#define PUSHSTACK(type) \
+ STMT_START { \
+ PERL_SI *next = curstackinfo->si_next; \
+ if (!next) { \
+ next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1); \
+ next->si_prev = curstackinfo; \
+ curstackinfo->si_next = next; \
+ } \
+ next->si_type = type; \
+ next->si_cxix = -1; \
+ AvFILLp(next->si_stack) = 0; \
+ SWITCHSTACK(curstack,next->si_stack); \
+ curstackinfo = next; \
+ SET_MARKBASE; \
+ } STMT_END
+
+#define POPSTACK() \
+ STMT_START { \
+ PERL_SI *prev = curstackinfo->si_prev; \
+ if (!prev) { \
+ PerlIO_printf(PerlIO_stderr(), "panic: POPSTACK\n"); \
+ my_exit(1); \
+ } \
+ SWITCHSTACK(curstack,prev->si_stack); \
+ /* don't free prev here, free them all at the END{} */ \
+ curstackinfo = prev; \
+ } STMT_END
+
+#define POPSTACK_TO(s) \
+ STMT_START { \
+ while (curstack != s) \
+ POPSTACK(); \
+ } STMT_END
dTHR;
I32 top = stack_sp - stack_base;
register I32 i = top - 30;
- I32 *markscan = markstack;
+ I32 *markscan = curstackinfo->si_markbase;
if (i < 0)
i = 0;
#define newWHILEOP Perl_newWHILEOP
#define newXS Perl_newXS
#define newXSUB Perl_newXSUB
+#define new_stackinfo Perl_new_stackinfo
#define new_struct_thread Perl_new_struct_thread
#define nextargv Perl_nextargv
#define ninstr Perl_ninstr
#define curpad (curinterp->Tcurpad)
#define curpm (curinterp->Tcurpm)
#define curstack (curinterp->Tcurstack)
+#define curstackinfo (curinterp->Tcurstackinfo)
#define curstash (curinterp->Tcurstash)
-#define cxstack (curinterp->Tcxstack)
-#define cxstack_ix (curinterp->Tcxstack_ix)
-#define cxstack_max (curinterp->Tcxstack_max)
#define defoutgv (curinterp->Tdefoutgv)
#define defstash (curinterp->Tdefstash)
#define delaymagic (curinterp->Tdelaymagic)
#define screamnext (curinterp->Iscreamnext)
#define secondgv (curinterp->Isecondgv)
#define siggv (curinterp->Isiggv)
-#define signalstack (curinterp->Isignalstack)
#define sortcop (curinterp->Isortcop)
-#define sortstack (curinterp->Isortstack)
#define sortstash (curinterp->Isortstash)
#define splitstr (curinterp->Isplitstr)
#define statcache (curinterp->Istatcache)
#define Iscreamnext screamnext
#define Isecondgv secondgv
#define Isiggv siggv
-#define Isignalstack signalstack
#define Isortcop sortcop
-#define Isortstack sortstack
#define Isortstash sortstash
#define Isplitstr splitstr
#define Istatcache statcache
#define Tcurpad curpad
#define Tcurpm curpm
#define Tcurstack curstack
+#define Tcurstackinfo curstackinfo
#define Tcurstash curstash
-#define Tcxstack cxstack
-#define Tcxstack_ix cxstack_ix
-#define Tcxstack_max cxstack_max
#define Tdefoutgv defoutgv
#define Tdefstash defstash
#define Tdelaymagic delaymagic
#define screamnext Perl_screamnext
#define secondgv Perl_secondgv
#define siggv Perl_siggv
-#define signalstack Perl_signalstack
#define sortcop Perl_sortcop
-#define sortstack Perl_sortstack
#define sortstash Perl_sortstash
#define splitstr Perl_splitstr
#define statcache Perl_statcache
#define curpad Perl_curpad
#define curpm Perl_curpm
#define curstack Perl_curstack
+#define curstackinfo Perl_curstackinfo
#define curstash Perl_curstash
-#define cxstack Perl_cxstack
-#define cxstack_ix Perl_cxstack_ix
-#define cxstack_max Perl_cxstack_max
#define defoutgv Perl_defoutgv
#define defstash Perl_defstash
#define delaymagic Perl_delaymagic
#define curpad (thr->Tcurpad)
#define curpm (thr->Tcurpm)
#define curstack (thr->Tcurstack)
+#define curstackinfo (thr->Tcurstackinfo)
#define curstash (thr->Tcurstash)
-#define cxstack (thr->Tcxstack)
-#define cxstack_ix (thr->Tcxstack_ix)
-#define cxstack_max (thr->Tcxstack_max)
#define defoutgv (thr->Tdefoutgv)
#define defstash (thr->Tdefstash)
#define delaymagic (thr->Tdelaymagic)
ne_amg
neg_amg
new_struct_thread
+new_stackinfo
no_aelem
no_dir_func
no_func
psig_ptr[i] = 0;
psig_name[i] = 0;
}
- /* initialize signal stack */
- signalstack = newAV();
- AvREAL_off(signalstack);
- av_extend(signalstack, 30);
- av_fill(signalstack, 0);
}
break;
return FALSE;
}
-/* During call to this subroutine stack can be reallocated. It is
- * advised to call SPAGAIN macro in your code after call */
-
SV*
amagic_call(SV *left, SV *right, int method, int flags)
{
myop.op_next = Nullop;
myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
+ PUSHSTACK(SI_OVERLOAD);
ENTER;
SAVEOP();
op = (OP *) &myop;
SPAGAIN;
res=POPs;
- PUTBACK;
+ POPSTACK();
CATCH_SET(oldcatch);
if (postpr) {
curstack
curstash
curstname
-cxstack
-cxstack_ix
-cxstack_max
dbargs
debdelim
debname
screamnext
secondgv
siggv
-signalstack
sortcop
-sortstack
sortstash
splitstr
start_env
PERLVAR(Isortstash, HV *) /* which is in some package or other */
PERLVAR(Ifirstgv, GV *) /* $a */
PERLVAR(Isecondgv, GV *) /* $b */
-PERLVAR(Isortstack, AV *) /* temp stack during pp_sort() */
-PERLVAR(Isignalstack, AV *) /* temp stack during sighandler() */
PERLVAR(Imystrk, SV *) /* temp key string for do_each() */
PERLVAR(Idumplvl, I32) /* indentation level on syntax tree dump */
PERLVAR(Ioldlastpm, PMOP *) /* for saving regexp context during debugger */
return 0;
}
+/* caller is responsible for stack switching/cleanup */
static int
magic_methcall(MAGIC *mg, char *meth, I32 flags, int n, SV *val)
{
ENTER;
SAVETMPS;
+ PUSHSTACK(SI_MAGIC);
if (magic_methcall(mg, meth, G_SCALAR, 2, NULL)) {
sv_setsv(sv, *stack_sp--);
}
+ POPSTACK();
FREETMPS;
LEAVE;
return 0;
int
magic_setpack(SV *sv, MAGIC *mg)
-{
+{
+ dSP;
ENTER;
+ PUSHSTACK(SI_MAGIC);
magic_methcall(mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
+ POPSTACK();
LEAVE;
return 0;
}
U32
magic_sizepack(SV *sv, MAGIC *mg)
{
- dTHR;
+ dSP;
U32 retval = 0;
ENTER;
SAVETMPS;
+ PUSHSTACK(SI_MAGIC);
if (magic_methcall(mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
sv = *stack_sp--;
retval = (U32) SvIV(sv)-1;
}
+ POPSTACK();
FREETMPS;
LEAVE;
return retval;
{
dSP;
+ ENTER;
+ PUSHSTACK(SI_MAGIC);
PUSHMARK(SP);
XPUSHs(mg->mg_obj);
PUTBACK;
- ENTER;
perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
+ POPSTACK();
LEAVE;
return 0;
}
ENTER;
SAVETMPS;
+ PUSHSTACK(SI_MAGIC);
PUSHMARK(SP);
EXTEND(SP, 2);
PUSHs(mg->mg_obj);
if (perl_call_method(meth, G_SCALAR))
sv_setsv(key, *stack_sp--);
+ POPSTACK();
FREETMPS;
LEAVE;
return 0;
HV *st;
SV *sv, *tSv = Sv;
CV *cv = Nullcv;
- AV *oldstack;
OP *myop = op;
U32 flags = 0;
I32 o_save_i = savestack_ix, type;
- PERL_CONTEXT *cx;
XPV *tXpv = Xpv;
if (savestack_ix + 15 <= savestack_max)
flags |= 1;
- if (cxstack_ix < cxstack_max - 2)
- flags |= 2;
if (markstack_ptr < markstack_max - 2)
flags |= 4;
if (retstack_ix < retstack_max - 2)
if (scopestack_ix < scopestack_max - 3)
flags |= 16;
- if (flags & 2) { /* POPBLOCK may decrease cxstack too early. */
- cxstack_ix++; /* Protect from overwrite. */
- cx = &cxstack[cxstack_ix];
- type = cx->cx_type; /* Can be during partial write. */
- cx->cx_type = CXt_NULL; /* Make it safe for unwind. */
- }
if (!psig_ptr[sig])
die("Signal SIG%s received, but no signal handler set.\n",
sig_name[sig]);
goto cleanup;
}
- oldstack = curstack;
- if (curstack != signalstack)
- AvFILLp(signalstack) = 0;
- SWITCHSTACK(curstack, signalstack);
-
if(psig_name[sig]) {
sv = SvREFCNT_inc(psig_name[sig]);
flags |= 64;
sv = sv_newmortal();
sv_setpv(sv,sig_name[sig]);
}
+
+ PUSHSTACK(SI_SIGNAL);
PUSHMARK(SP);
PUSHs(sv);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
- SWITCHSTACK(signalstack, oldstack);
+ POPSTACK();
cleanup:
if (flags & 1)
savestack_ix -= 8; /* Unprotect save in progress. */
- if (flags & 2) {
- cxstack[cxstack_ix].cx_type = type;
- cxstack_ix -= 1;
- }
if (flags & 4)
markstack_ptr--;
if (flags & 8)
goto done;
}
/* ahem, death to those who redefine active sort subs */
- if (curstack == sortstack && sortcop == CvSTART(cv))
+ if (curstackinfo->si_type == SI_SORT && sortcop == CvSTART(cv))
croak("Can't redefine active sort subroutine %s", name);
const_sv = cv_const_sv(cv);
if (const_sv || dowarn && !(CvGV(cv) && GvSTASH(CvGV(cv))
endav = Nullav;
initav = Nullav;
- /* temp stack during pp_sort() */
- SvREFCNT_dec(sortstack);
- sortstack = Nullav;
-
/* shortcuts just get cleared */
envgv = Nullgv;
siggv = Nullgv;
int
perl_run(PerlInterpreter *sv_interp)
{
- dTHR;
+ dSP;
I32 oldscope;
dJMPENV;
int ret;
JMPENV_POP;
return 1;
}
- if (curstack != mainstack) {
- dSP;
- SWITCHSTACK(curstack, mainstack);
- }
+ POPSTACK_TO(mainstack);
break;
}
void
init_stacks(ARGSproto)
{
- curstack = newAV();
+ /* start with 128-item stack and 8K cxstack */
+ curstackinfo = new_stackinfo(REASONABLE(128),
+ REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
+ curstackinfo->si_type = SI_MAIN;
+ curstack = curstackinfo->si_stack;
mainstack = curstack; /* remember in case we switch stacks */
- AvREAL_off(curstack); /* not a real array */
- av_extend(curstack,REASONABLE(127));
stack_base = AvARRAY(curstack);
stack_sp = stack_base;
- stack_max = stack_base + REASONABLE(127);
-
- /* Use most of 8K. */
- cxstack_max = REASONABLE(8192 / sizeof(PERL_CONTEXT) - 2);
- New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
- cxstack_ix = -1;
+ stack_max = stack_base + AvMAX(curstack);
New(50,tmps_stack,REASONABLE(128),SV*);
tmps_floor = -1;
markstack_max = markstack + REASONABLE(32);
}
+ SET_MARKBASE;
+
if (scopestack) {
scopestack_ix = 0;
} else {
nuke_stacks(void)
{
dTHR;
- Safefree(cxstack);
+ while (curstackinfo->si_next)
+ curstackinfo = curstackinfo->si_next;
+ while (curstackinfo) {
+ PERL_SI *p = curstackinfo->si_prev;
+ SvREFCNT_dec(curstackinfo->si_stack);
+ Safefree(curstackinfo->si_cxstack);
+ Safefree(curstackinfo);
+ curstackinfo = p;
+ }
Safefree(tmps_stack);
DEBUG( {
Safefree(debname);
#define ARGTARG op->op_targ
#define MAXARG op->op_private
-#define SWITCHSTACK(f,t) AvFILLp(f) = sp - stack_base; \
- stack_base = AvARRAY(t); \
- stack_max = stack_base + AvMAX(t); \
- sp = stack_sp = stack_base + AvFILLp(t); \
- curstack = t;
+#define SWITCHSTACK(f,t) \
+ STMT_START { \
+ AvFILLp(f) = sp - stack_base; \
+ stack_base = AvARRAY(t); \
+ stack_max = stack_base + AvMAX(t); \
+ sp = stack_sp = stack_base + AvFILLp(t); \
+ curstack = t; \
+ } STMT_END
#define EXTEND_MORTAL(n) \
STMT_START { \
max = --up - myorigmark;
if (sortcop) {
if (max > 1) {
- AV *oldstack;
PERL_CONTEXT *cx;
SV** newsp;
bool oldcatch = CATCH_GET;
SAVETMPS;
SAVEOP();
- oldstack = curstack;
- if (!sortstack) {
- sortstack = newAV();
- AvREAL_off(sortstack);
- av_extend(sortstack, 32);
- }
CATCH_SET(TRUE);
- SWITCHSTACK(curstack, sortstack);
+ PUSHSTACK(SI_SORT);
if (sortstash != stash) {
firstgv = gv_fetchpv("a", TRUE, SVt_PV);
secondgv = gv_fetchpv("b", TRUE, SVt_PV);
qsortsv(myorigmark+1, max, sortcv);
POPBLOCK(cx,curpm);
- SWITCHSTACK(sortstack, oldstack);
+ POPSTACK();
CATCH_SET(oldcatch);
}
LEAVE;
OP *
die_where(char *message)
{
- dTHR;
+ dSP;
if (in_eval) {
I32 cxix;
register PERL_CONTEXT *cx;
else
sv_setpv(ERRSV, message);
- cxix = dopoptoeval(cxstack_ix);
+ while ((cxix = dopoptoeval(cxstack_ix)) < 0 && curstackinfo->si_prev)
+ POPSTACK();
+
if (cxix >= 0) {
I32 optype;
PMOP *newpm;
I32 optype = 0;
- if (curstack == sortstack) {
+ if (curstackinfo->si_type == SI_SORT) {
if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
if (cxstack_ix > sortcxix)
dounwind(sortcxix);
do_undump = FALSE;
}
- if (curstack == signalstack) {
+ if (top_env->je_prev) {
restartop = retop;
JMPENV_JUMP(3);
}
PP(pp_tie)
{
djSP;
+ dMARK;
SV *varsv;
HV* stash;
GV *gv;
SV *sv;
- SV **mark = stack_base + ++*markstack_ptr; /* reuse in entersub */
- I32 markoff = mark - stack_base - 1;
+ I32 markoff = MARK - stack_base;
char *methname;
int how = 'P';
+ U32 items;
- varsv = mark[0];
+ varsv = *++MARK;
switch(SvTYPE(varsv)) {
case SVt_PVHV:
methname = "TIEHASH";
how = 'q';
break;
}
-
- if (sv_isobject(mark[1])) {
+ items = SP - MARK++;
+ if (sv_isobject(*MARK)) {
ENTER;
+ PUSHSTACK(SI_MAGIC);
+ PUSHMARK(SP);
+ EXTEND(SP,items);
+ while (items--)
+ PUSHs(*MARK++);
+ PUTBACK;
perl_call_method(methname, G_SCALAR);
}
else {
/* Not clear why we don't call perl_call_method here too.
* perhaps to get different error message ?
*/
- stash = gv_stashsv(mark[1], FALSE);
+ stash = gv_stashsv(*MARK, FALSE);
if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
DIE("Can't locate object method \"%s\" via package \"%s\"",
- methname, SvPV(mark[1],na));
+ methname, SvPV(*MARK,na));
}
ENTER;
+ PUSHSTACK(SI_MAGIC);
+ PUSHMARK(SP);
+ EXTEND(SP,items);
+ while (items--)
+ PUSHs(*MARK++);
+ PUTBACK;
perl_call_sv((SV*)GvCV(gv), G_SCALAR);
}
SPAGAIN;
sv = TOPs;
+ POPSTACK();
if (sv_isobject(sv)) {
sv_unmagic(varsv, how);
sv_magic(varsv, sv, how, Nullch, 0);
#ifdef USE_THREADS
struct perl_thread * new_struct_thread _((struct perl_thread *t));
#endif
+PERL_SI * new_stackinfo _((I32 stitems, I32 cxitems));
PerlIO* nextargv _((GV* gv));
char* ninstr _((char* big, char* bigend, char* little, char* lend));
OP* oopsCV _((OP* o));
#define GROW(old) ((old) + 1)
#endif
+PERL_SI *
+new_stackinfo(I32 stitems, I32 cxitems)
+{
+ PERL_SI *si;
+ PERL_CONTEXT *cxt;
+ New(56, si, 1, PERL_SI);
+ si->si_stack = newAV();
+ AvREAL_off(si->si_stack);
+ av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
+ AvALLOC(si->si_stack)[0] = &sv_undef;
+ AvFILLp(si->si_stack) = 0;
+ si->si_prev = 0;
+ si->si_next = 0;
+ si->si_cxmax = cxitems - 1;
+ si->si_cxix = -1;
+ si->si_type = SI_UNDEF;
+ New(56, si->si_cxstack, cxitems, PERL_CONTEXT);
+ return si;
+}
+
I32
cxinc(void)
{
SvFAKE_on(dstr); /* can coerce to non-glob */
}
/* ahem, death to those who redefine active sort subs */
- else if (curstack == sortstack
+ else if (curstackinfo->si_type == SI_SORT
&& GvCV(dstr) && sortcop == CvSTART(GvCV(dstr)))
croak("Can't redefine active sort subroutine %s",
GvNAME(dstr));
{
/* ahem, death to those who redefine
* active sort subs */
- if (curstack == sortstack &&
+ if (curstackinfo->si_type == SI_SORT &&
sortcop == CvSTART(cv))
croak(
"Can't redefine active sort subroutine %s",
destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
if (destructor) {
ENTER;
+ PUSHSTACK(SI_DESTROY);
SvRV(&ref) = SvREFCNT_inc(sv);
EXTEND(SP, 2);
PUSHMARK(SP);
perl_call_sv((SV*)GvCV(destructor),
G_DISCARD|G_EVAL|G_KEEPERR);
SvREFCNT(sv)--;
+ POPSTACK();
LEAVE;
}
} while (SvOBJECT(sv) && SvSTASH(sv) != stash);
#!./perl
##
-## all of these tests are from Michael Schroeder
+## Many of these tests are originally from Michael Schroeder
## <Michael.Schroeder@informatik.uni-erlangen.de>
-##
-## The more esoteric failure modes require Michael's
-## stack-of-stacks patch (so we don't test them here,
-## and they are commented out before the __END__).
-##
-## The remaining tests pass with a simpler fix
-## intended for 5.004
-##
-## Gurusamy Sarathy <gsar@umich.edu> 97-02-24
+## Adapted and expanded by Gurusamy Sarathy <gsar@umich.edu>
##
chdir 't' if -d 't';
print "ok ", ++$i, "\n";
}
-=head2 stay out of here (the real tests are after __END__)
-
-##
-## these tests don't pass yet (need the full stack-of-stacks patch)
-## GSAR 97-02-24
-##
-
-########
-# sort within sort
-sub sortfn {
- (split(/./, 'x'x10000))[0];
- my (@y) = ( 4, 6, 5);
- @y = sort { $a <=> $b } @y;
- print "sortfn ".join(', ', @y)."\n";
- return $_[0] <=> $_[1];
-}
-@x = ( 3, 2, 1 );
-@x = sort { &sortfn($a, $b) } @x;
-print "---- ".join(', ', @x)."\n";
-EXPECT
-sortfn 4, 5, 6
----- 1, 2, 3
-########
-# trapping eval within sort (doesn't work currently because
-# die does a SWITCHSTACK())
-@a = (3, 2, 1);
-@a = sort { eval('die("no way")') , $a <=> $b} @a;
-print join(", ", @a)."\n";
-EXPECT
-1, 2, 3
-########
-# this actually works fine, but results in a poor error message
-@a = (1, 2, 3);
-foo:
-{
- @a = sort { last foo; } @a;
-}
-EXPECT
-cannot reach destination block at - line 2.
-########
-package TEST;
-
-sub TIESCALAR {
- my $foo;
- return bless \$foo;
-}
-sub FETCH {
- next;
- return "ZZZ";
-}
-sub STORE {
-}
-
-package main;
-
-tie $bar, TEST;
-{
- print "- $bar\n";
-}
-print "OK\n";
-EXPECT
-cannot reach destination block at - line 8.
-########
-package TEST;
-
-sub TIESCALAR {
- my $foo;
- return bless \$foo;
-}
-sub FETCH {
- goto bbb;
- return "ZZZ";
-}
-
-package main;
-
-tie $bar, TEST;
-print "- $bar\n";
-exit;
-bbb:
-print "bbb\n";
-EXPECT
-bbb
-########
-# trapping eval within sort (doesn't work currently because
-# die does a SWITCHSTACK())
-sub foo {
- $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
-}
-@a = (3, 2, 0, 1);
-@a = sort foo @a;
-print join(', ', @a)."\n";
-EXPECT
-0, 1, 2, 3
-########
-package TEST;
-sub TIESCALAR {
- my $foo;
- next;
- return bless \$foo;
-}
-package main;
-{
-tie $bar, TEST;
-}
-EXPECT
-cannot reach destination block at - line 4.
-########
-# large stack extension causes realloc, and segfault
-package TEST;
-sub TIESCALAR {
- my $foo;
- return bless \$foo;
-}
-sub FETCH {
- return "fetch";
-}
-sub STORE {
-(split(/./, 'x'x10000))[0];
-}
-package main;
-tie $bar, TEST;
-$bar = "x";
-
-=cut
-
-##
-##
-## The real tests begin here
-##
-##
-
__END__
@a = (1, 2, 3);
{
print "bar reached\n";
EXPECT
Can't "goto" outside a block at - line 2.
+########
+sub sortfn {
+ (split(/./, 'x'x10000))[0];
+ my (@y) = ( 4, 6, 5);
+ @y = sort { $a <=> $b } @y;
+ print "sortfn ".join(', ', @y)."\n";
+ return $_[0] <=> $_[1];
+}
+@x = ( 3, 2, 1 );
+@x = sort { &sortfn($a, $b) } @x;
+print "---- ".join(', ', @x)."\n";
+EXPECT
+sortfn 4, 5, 6
+---- 1, 2, 3
+########
+@a = (3, 2, 1);
+@a = sort { eval('die("no way")') , $a <=> $b} @a;
+print join(", ", @a)."\n";
+EXPECT
+1, 2, 3
+########
+@a = (1, 2, 3);
+foo:
+{
+ @a = sort { last foo; } @a;
+}
+EXPECT
+Label not found for "last foo" at - line 2.
+########
+package TEST;
+
+sub TIESCALAR {
+ my $foo;
+ return bless \$foo;
+}
+sub FETCH {
+ next;
+ return "ZZZ";
+}
+sub STORE {
+}
+
+package main;
+
+tie $bar, TEST;
+{
+ print "- $bar\n";
+}
+print "OK\n";
+EXPECT
+Can't "next" outside a block at - line 8.
+########
+package TEST;
+
+sub TIESCALAR {
+ my $foo;
+ return bless \$foo;
+}
+sub FETCH {
+ goto bbb;
+ return "ZZZ";
+}
+
+package main;
+
+tie $bar, TEST;
+print "- $bar\n";
+exit;
+bbb:
+print "bbb\n";
+EXPECT
+Can't find label bbb at - line 8.
+########
+sub foo {
+ $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
+}
+@a = (3, 2, 0, 1);
+@a = sort foo @a;
+print join(', ', @a)."\n";
+EXPECT
+0, 1, 2, 3
+########
+package TEST;
+sub TIESCALAR {
+ my $foo;
+ return bless \$foo;
+}
+sub FETCH {
+ return "fetch";
+}
+sub STORE {
+(split(/./, 'x'x10000))[0];
+}
+package main;
+tie $bar, TEST;
+$bar = "x";
+########
+package TEST;
+sub TIESCALAR {
+ my $foo;
+ next;
+ return bless \$foo;
+}
+package main;
+{
+tie $bar, TEST;
+}
+EXPECT
+Can't "next" outside a block at - line 4.
+########
+@a = (1, 2, 3);
+foo:
+{
+ @a = sort { exit(0) } @a;
+}
+END { print "foobar\n" }
+EXPECT
+foobar
PERLVAR(Tdirty, bool) /* In the middle of tearing things down? */
PERLVAR(Tlocalizing, int) /* are we processing a local() list? */
-PERLVAR(Tcxstack, PERL_CONTEXT *)
-PERLVARI(Tcxstack_ix, I32, -1)
-PERLVARI(Tcxstack_max, I32, 128)
-
PERLVAR(Tcurstack, AV *) /* THE STACK */
+PERLVAR(Tcurstackinfo, PERL_SI *) /* current stack + context */
PERLVAR(Tmainstack, AV *) /* the stack when nothing funny is happening */
PERLVAR(Ttop_env, JMPENV *) /* ptr. to current sigjmp() environment */
PERLVAR(Tstart_env, JMPENV) /* empty startup sigjmp() environment */
"%p: die: curstack = %p, mainstack = %p\n",
thr, curstack, mainstack));
#endif /* USE_THREADS */
- /* We have to switch back to mainstack or die_where may try to pop
- * the eval block from the wrong stack if die is being called from a
- * signal handler. - dkindred@cs.cmu.edu */
- if (curstack != mainstack) {
- dSP;
- SWITCHSTACK(curstack, mainstack);
- }
#ifdef I_STDARG
va_start(args, pat);
projects / p5sagit/p5-mst-13.2.git / commitdiff