scope.c revision 7c478bd95313f5f23a4c958a745db2134aa03244
/* scope.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
* 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
*/
/*
* "For the fashion of Minas Tirith was such that it was built on seven
* levels..."
*/
#include "EXTERN.h"
#define PERL_IN_SCOPE_C
#include "perl.h"
#if defined(PERL_FLEXIBLE_EXCEPTIONS)
void *
protect_body_t body, ...)
{
void *ret;
return ret;
}
void *
{
int ex;
void *ret;
if (ex)
else
return ret;
}
#endif
SV**
{
PL_stack_sp = sp;
#ifndef STRESS_REALLOC
#else
#endif
return PL_stack_sp;
}
#ifndef STRESS_REALLOC
#else
#endif
PERL_SI *
{
/* Without any kind of initialising PUSHSUBST()
* in pp_subst() will read uninitialised heap. */
return si;
}
{
/* Without any kind of initialising deep enough recursion
* will end up reading uninitialised PERL_CONTEXTs. */
return cxstack_ix + 1;
}
void
{
if (PL_retstack_ix == PL_retstack_max) {
}
}
OP *
{
if (PL_retstack_ix > 0)
return PL_retstack[--PL_retstack_ix];
else
return Nullop;
}
void
{
if (PL_scopestack_ix == PL_scopestack_max) {
}
}
void
{
}
void
{
}
void
{
}
void
{
}
void
{
#ifndef STRESS_REALLOC
if (n < 128)
#endif
}
void
{
/* XXX should tmps_floor live in cxstack? */
SvTEMP_off(sv);
}
}
}
{
if (SvGMAGICAL(osv)) {
bool oldtainted = PL_tainted;
if (PL_tainting && PL_tainted &&
}
}
/* XXX SvMAGIC() is *shared* between osv and sv. This can
* lead to coredumps when both SVs are destroyed without one
* of their SvMAGIC() slots being NULLed. */
PL_localizing = 1;
SvSETMAGIC(sv);
PL_localizing = 0;
}
return sv;
}
SV *
{
SSCHECK(3);
return save_scalar_at(sptr);
}
SV*
{
SSCHECK(3);
return save_scalar_at(sptr);
}
/* Like save_sptr(), but also SvREFCNT_dec()s the new value. Can be used to
* restore a global SV to its prior contents, freeing new value. */
void
{
SSCHECK(3);
}
/* Like save_pptr(), but also Safefree()s the new value if it is different
* from the old one. Can be used to restore a global char* to its prior
* contents, freeing new value. */
void
{
SSCHECK(3);
}
/* Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree().
* Can be used to restore a shared global char* to its prior
* contents, freeing new value. */
void
{
SSCHECK(3);
}
void
{
SSGROW(6);
if (empty) {
PL_sub_generation++; /* taking a method out of circulation */
}
}
else {
GvINTRO_on(gv);
}
}
AV *
{
SSCHECK(3);
PL_localizing = 1;
PL_localizing = 0;
}
return av;
}
HV *
{
SSCHECK(3);
PL_localizing = 1;
PL_localizing = 0;
}
return hv;
}
void
{
SSCHECK(3);
}
void
{
SSCHECK(3);
}
void
{
SSCHECK(3);
SSPUSHLONG(*longp);
}
void
{
SSCHECK(3);
SSPUSHBOOL(*boolp);
}
void
{
SSCHECK(3);
}
void
{
SSCHECK(3);
}
void
{
SSCHECK(3);
}
void
{
SSCHECK(3);
}
/* Cannot use save_sptr() to store a char* since the SV** cast will
* force word-alignment and we'll miss the pointer.
*/
void
{
SSCHECK(3);
}
void
{
SSCHECK(3);
}
void
{
SSCHECK(3);
}
void
{
SSCHECK(4);
ASSERT_CURPAD_ACTIVE("save_padsv");
SSPUSHLONG((long)off);
}
SV **
{
#ifdef USE_5005THREADS
return svp;
#else
return 0;
#endif /* USE_5005THREADS */
}
void
{
SSCHECK(2);
}
void
{
SSCHECK(3);
}
void
{
SSCHECK(3);
}
void
{
SSCHECK(2);
}
void
{
SSCHECK(2);
}
void
{
SSCHECK(2);
SSPUSHPTR(o);
}
void
{
SSCHECK(2);
}
void
{
ASSERT_CURPAD_ACTIVE("save_clearsv");
SSCHECK(2);
}
void
{
SSCHECK(4);
}
void
{
register I32 i;
for (i = 1; i <= maxsarg; i++) {
SSCHECK(3);
}
}
void
{
SSCHECK(3);
SSPUSHDPTR(f);
SSPUSHPTR(p);
}
void
{
SSCHECK(3);
SSPUSHDXPTR(f);
SSPUSHPTR(p);
}
void
{
SSCHECK(4);
/* if it gets reified later, the restore will have the wrong refcnt */
SvREFCNT_inc(*sptr);
/* If we're localizing a tied array element, this new sv
* won't actually be stored in the array - so it won't get
* reaped when the localize ends. Ensure it gets reaped by
* mortifying it instead. DAPM */
sv_2mortal(sv);
}
void
{
SSCHECK(4);
/* If we're localizing a tied hash element, this new sv
* won't actually be stored in the hash - so it won't get
* reaped when the localize ends. Ensure it gets reaped by
* mortifying it instead. DAPM */
sv_2mortal(sv);
}
void
{
SSCHECK(2);
}
{
- (char*)PL_savestack);
/* SSCHECK may not be good enough */
PL_savestack_ix += elems;
return start;
}
void
{
register void* ptr;
register char* str;
I32 i;
if (base < -1)
while (PL_savestack_ix > base) {
switch (SSPOPINT) {
case SAVEt_ITEM: /* normal string */
PL_localizing = 2;
SvSETMAGIC(sv);
PL_localizing = 0;
break;
case SAVEt_SV: /* scalar reference */
goto restore_sv;
case SAVEt_GENERIC_PVREF: /* generic pv */
}
break;
case SAVEt_SHARED_PVREF: /* shared pv */
#ifdef NETWARE
PerlMem_free(*(char**)ptr);
#else
PerlMemShared_free(*(char**)ptr);
#endif
}
break;
case SAVEt_GENERIC_SVREF: /* generic sv */
break;
case SAVEt_SVREF: /* scalar reference */
"restore svref: %p %p:%s -> %p:%s\n",
{
}
/* XXX This branch is pretty bogus. This code irretrievably
* clears(!) the magic on the SV (either to avoid further
* croaking that might ensue when the SvSETMAGIC() below is
* called, or to avoid two different SVs pointing at the same
* SvMAGIC()). This needs a total rethink. --GSAR */
{
/* XXX this is a leak when we get here because the
* mg_get() in save_scalar_at() croaked */
}
PL_localizing = 2;
PL_localizing = 0;
if (av) /* actually an av, hv or gv */
break;
case SAVEt_AV: /* array reference */
}
PL_localizing = 2;
PL_localizing = 0;
}
break;
case SAVEt_HV: /* hash reference */
}
PL_localizing = 2;
PL_localizing = 0;
}
break;
case SAVEt_INT: /* int reference */
break;
case SAVEt_LONG: /* long reference */
break;
case SAVEt_BOOL: /* bool reference */
break;
case SAVEt_I32: /* I32 reference */
break;
case SAVEt_I16: /* I16 reference */
break;
case SAVEt_I8: /* I8 reference */
break;
case SAVEt_IV: /* IV reference */
break;
case SAVEt_SPTR: /* SV* reference */
break;
case SAVEt_VPTR: /* random* reference */
case SAVEt_PPTR: /* char* reference */
break;
case SAVEt_HPTR: /* HV* reference */
break;
case SAVEt_APTR: /* AV* reference */
break;
case SAVEt_NSTAB:
break;
case SAVEt_GP: /* scalar reference */
}
PL_sub_generation++; /* putting a method back into circulation */
break;
case SAVEt_FREESV:
break;
case SAVEt_MORTALIZESV:
break;
case SAVEt_FREEOP:
break;
case SAVEt_FREEPV:
break;
case SAVEt_CLEARSV:
));
/* Can clear pad variable in place? */
/*
* if a my variable that was made readonly is going out of
* scope, we want to remove the readonlyness so that it can
* go out of scope quietly
*/
if (SvTHINKFIRST(sv))
case SVt_NULL:
break;
case SVt_PVAV:
break;
case SVt_PVHV:
break;
case SVt_PVCV:
case SVt_RV:
case SVt_IV:
case SVt_NV:
break;
default:
break;
}
}
else { /* Someone has a claim on this, so abandon it. */
}
}
break;
case SAVEt_DELETE:
break;
case SAVEt_DESTRUCTOR:
break;
case SAVEt_DESTRUCTOR_X:
break;
case SAVEt_REGCONTEXT:
case SAVEt_ALLOC:
i = SSPOPINT;
PL_savestack_ix -= i; /* regexp must have croaked */
break;
case SAVEt_STACK_POS: /* Position on Perl stack */
i = SSPOPINT;
PL_stack_sp = PL_stack_base + i;
break;
case SAVEt_AELEM: /* array element */
i = SSPOPINT;
if (ptr) {
(void)SvREFCNT_inc(sv);
goto restore_sv;
}
}
break;
case SAVEt_HELEM: /* hash element */
if (ptr) {
goto restore_sv;
}
}
break;
case SAVEt_OP:
break;
case SAVEt_HINTS:
}
if (PL_hints & HINT_LOCALIZE_HH) {
}
break;
case SAVEt_COMPPAD:
if (PL_comppad)
else
break;
case SAVEt_PADSV:
{
if (ptr)
}
break;
default:
}
}
}
void
{
#ifdef DEBUGGING
}
case CXt_NULL:
case CXt_BLOCK:
break;
case CXt_FORMAT:
break;
case CXt_SUB:
break;
case CXt_EVAL:
break;
case CXt_LOOP:
break;
case CXt_SUBST:
(long)cx->sb_maxiters);
break;
}
#endif /* DEBUGGING */
}