/* pad.c
*
- * Copyright (C) 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ * 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.
+ */
+
+/*
+ * 'Anyway: there was this Mr. Frodo left an orphan and stranded, as you
+ * might say, among those queer Bucklanders, being brought up anyhow in
+ * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
+ * never had fewer than a couple of hundred relations in the place.
+ * Mr. Bilbo never did a kinder deed than when he brought the lad back
+ * to live among decent folk.' --the Gaffer
*
- * "Anyway: there was this Mr Frodo left an orphan and stranded, as you
- * might say, among those queer Bucklanders, being brought up anyhow in
- * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
- * never had fewer than a couple of hundred relations in the place. Mr
- * Bilbo never did a kinder deed than when he brought the lad back to
- * live among decent folk." --the Gaffer
+ * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
*/
/* XXX DAPM
{ my $x = 1; sub f { eval '$x'} } f();
+For state vars, SVf_PADSTALE is overloaded to mean 'not yet initialised'
+
=cut
*/
#ifdef PERL_MAD
void pad_peg(const char* s) {
static int pegcnt;
+
+ PERL_ARGS_ASSERT_PAD_PEG;
+
pegcnt++;
}
#endif
SAVEI32(PL_comppad_name_fill);
SAVEI32(PL_min_intro_pending);
SAVEI32(PL_max_intro_pending);
- SAVEI32(PL_cv_has_eval);
+ SAVEBOOL(PL_cv_has_eval);
if (flags & padnew_SAVESUB) {
- SAVEI32(PL_pad_reset_pending);
+ SAVEBOOL(PL_pad_reset_pending);
}
}
}
AV * const a0 = newAV(); /* will be @_ */
av_extend(a0, 0);
- av_store(pad, 0, (SV*)a0);
+ av_store(pad, 0, MUTABLE_SV(a0));
AvREIFY_only(a0);
}
else {
}
AvREAL_off(padlist);
- av_store(padlist, 0, (SV*)padname);
- av_store(padlist, 1, (SV*)pad);
+ av_store(padlist, 0, MUTABLE_SV(padname));
+ av_store(padlist, 1, MUTABLE_SV(pad));
/* ... then update state variables */
- PL_comppad_name = (AV*)(*av_fetch(padlist, 0, FALSE));
- PL_comppad = (AV*)(*av_fetch(padlist, 1, FALSE));
+ PL_comppad_name = MUTABLE_AV((*av_fetch(padlist, 0, FALSE)));
+ PL_comppad = MUTABLE_AV((*av_fetch(padlist, 1, FALSE)));
PL_curpad = AvARRAY(PL_comppad);
if (! (flags & padnew_CLONE)) {
I32 ix;
const PADLIST * const padlist = CvPADLIST(cv);
+ PERL_ARGS_ASSERT_PAD_UNDEF;
+
pad_peg("pad_undef");
if (!padlist)
return;
return;
DEBUG_X(PerlIO_printf(Perl_debug_log,
- "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf"\n",
- PTR2UV(cv), PTR2UV(padlist))
+ "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
+ PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
);
/* detach any '&' anon children in the pad; if afterwards they
if (!PL_dirty) { /* don't bother during global destruction */
CV * const outercv = CvOUTSIDE(cv);
const U32 seq = CvOUTSIDE_SEQ(cv);
- AV * const comppad_name = (AV*)AvARRAY(padlist)[0];
+ AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
SV ** const namepad = AvARRAY(comppad_name);
- AV * const comppad = (AV*)AvARRAY(padlist)[1];
+ AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
SV ** const curpad = AvARRAY(comppad);
for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
SV * const namesv = namepad[ix];
if (namesv && namesv != &PL_sv_undef
&& *SvPVX_const(namesv) == '&')
{
- CV * const innercv = (CV*)curpad[ix];
+ CV * const innercv = MUTABLE_CV(curpad[ix]);
U32 inner_rc = SvREFCNT(innercv);
assert(inner_rc);
namepad[ix] = NULL;
ix = AvFILLp(padlist);
while (ix >= 0) {
- const SV* const sv = AvARRAY(padlist)[ix--];
+ SV* const sv = AvARRAY(padlist)[ix--];
if (sv) {
- if (sv == (SV*)PL_comppad_name)
+ if (sv == (const SV *)PL_comppad_name)
PL_comppad_name = NULL;
- else if (sv == (SV*)PL_comppad) {
+ else if (sv == (const SV *)PL_comppad) {
PL_comppad = NULL;
PL_curpad = NULL;
}
}
SvREFCNT_dec(sv);
}
- SvREFCNT_dec((SV*)CvPADLIST(cv));
+ SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
CvPADLIST(cv) = NULL;
}
{
dVAR;
const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
- SV* const namesv = newSV(0);
+ SV* const namesv
+ = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
- ASSERT_CURPAD_ACTIVE("pad_add_name");
+ PERL_ARGS_ASSERT_PAD_ADD_NAME;
+ ASSERT_CURPAD_ACTIVE("pad_add_name");
- sv_upgrade(namesv, (ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
sv_setpv(namesv, name);
if (typestash) {
assert(SvTYPE(namesv) == SVt_PVMG);
SvPAD_TYPED_on(namesv);
- SvSTASH_set(namesv, (HV*)SvREFCNT_inc_simple_NN((SV*)typestash));
+ SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
}
if (ourstash) {
SvPAD_OUR_on(namesv);
/* XXX DAPM since slot has been allocated, replace
* av_store with PL_curpad[offset] ? */
if (*name == '@')
- av_store(PL_comppad, offset, (SV*)newAV());
+ av_store(PL_comppad, offset, MUTABLE_SV(newAV()));
else if (*name == '%')
- av_store(PL_comppad, offset, (SV*)newHV());
+ av_store(PL_comppad, offset, MUTABLE_SV(newHV()));
SvPADMY_on(PL_curpad[offset]);
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
{
dVAR;
PADOFFSET ix;
- SV* const name = newSV(0);
+ SV* const name = newSV_type(SVt_PVNV);
+
+ PERL_ARGS_ASSERT_PAD_ADD_ANON;
+
pad_peg("add_anon");
- sv_upgrade(name, SVt_PVNV);
- sv_setpvn(name, "&", 1);
+ sv_setpvs(name, "&");
/* Are these two actually ever read? */
COP_SEQ_RANGE_HIGH_set(name, ~0);
COP_SEQ_RANGE_LOW_set(name, 1);
/* to avoid ref loops, we never have parent + child referencing each
* other simultaneously */
- if (CvOUTSIDE((CV*)sv)) {
- assert(!CvWEAKOUTSIDE((CV*)sv));
- CvWEAKOUTSIDE_on((CV*)sv);
- SvREFCNT_dec(CvOUTSIDE((CV*)sv));
+ if (CvOUTSIDE((const CV *)sv)) {
+ assert(!CvWEAKOUTSIDE((const CV *)sv));
+ CvWEAKOUTSIDE_on(MUTABLE_CV(sv));
+ SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv)));
}
return ix;
}
SV **svp;
PADOFFSET top, off;
+ PERL_ARGS_ASSERT_PAD_CHECK_DUP;
+
ASSERT_CURPAD_ACTIVE("pad_check_dup");
if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
return; /* nothing to check */
break; /* "our" masking "our" */
Perl_warner(aTHX_ packWARN(WARN_MISC),
"\"%s\" variable %s masks earlier declaration in same %s",
- (is_our ? "our" : PL_in_my == KEY_my ? "my" : "state"),
+ (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
name,
(COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement"));
--off;
const AV *nameav;
SV **name_svp;
+ PERL_ARGS_ASSERT_PAD_FINDMY;
+
pad_peg("pad_findmy");
offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
NULL, &out_sv, &out_flags);
* our $foo = 0 unless defined $foo;
* to not give a warning. (Yes, this is a hack) */
- nameav = (AV*)AvARRAY(CvPADLIST(PL_compcv))[0];
+ nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
name_svp = AvARRAY(nameav);
for (offset = AvFILLp(nameav); offset > 0; offset--) {
const SV * const namesv = name_svp[offset];
SV **new_capturep;
const AV * const padlist = CvPADLIST(cv);
+ PERL_ARGS_ASSERT_PAD_FINDLEX;
+
*out_flags = 0;
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
if (padlist) { /* not an undef CV */
I32 fake_offset = 0;
- const AV * const nameav = (AV*)AvARRAY(padlist)[0];
+ const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
SV * const * const name_svp = AvARRAY(nameav);
for (offset = AvFILLp(nameav); offset > 0; offset--) {
else {
int newwarn = warn;
if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
+ && !SvPAD_STATE(name_svp[offset])
&& warn && ckWARN(WARN_CLOSURE)) {
newwarn = 0;
Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
return offset;
}
- *out_capture = AvARRAY((AV*)AvARRAY(padlist)[
- CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
+ *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
+ CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
PTR2UV(cv), PTR2UV(*out_capture)));
- if (SvPADSTALE(*out_capture)) {
+ if (SvPADSTALE(*out_capture)
+ && !SvPAD_STATE(name_svp[offset]))
+ {
if (ckWARN(WARN_CLOSURE))
Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%s\" is not available", name);
}
if (!*out_capture) {
if (*name == '@')
- *out_capture = sv_2mortal((SV*)newAV());
+ *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
else if (*name == '%')
- *out_capture = sv_2mortal((SV*)newHV());
+ *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
else
*out_capture = sv_newmortal();
}
SV *new_namesv;
AV * const ocomppad_name = PL_comppad_name;
PAD * const ocomppad = PL_comppad;
- PL_comppad_name = (AV*)AvARRAY(padlist)[0];
- PL_comppad = (AV*)AvARRAY(padlist)[1];
+ PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
+ PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
PL_curpad = AvARRAY(PL_comppad);
new_offset = pad_add_name(
? SvSTASH(*out_name_sv) : NULL,
SvOURSTASH(*out_name_sv),
1, /* fake */
- 0 /* not a state variable */
+ SvPAD_STATE(*out_name_sv) ? 1 : 0 /* state variable ? */
);
new_namesv = AvARRAY(PL_comppad_name)[new_offset];
Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
{
dVAR;
+
+ PERL_ARGS_ASSERT_PAD_SETSV;
+
ASSERT_CURPAD_ACTIVE("pad_setsv");
DEBUG_X(PerlIO_printf(Perl_debug_log,
* to a shared TARG. Such an alias will change randomly and unpredictably.
* We avoid doing this until we can think of a Better Way.
* GSAR 97-10-29 */
-void
-Perl_pad_reset(pTHX)
+static void
+S_pad_reset(pTHX)
{
dVAR;
#ifdef USE_BROKEN_PAD_RESET
/* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
AV * const av = newAV(); /* Will be @_ */
av_extend(av, 0);
- av_store(PL_comppad, 0, (SV*)av);
+ av_store(PL_comppad, 0, MUTABLE_SV(av));
AvREIFY_only(av);
}
SvPADTMP_off(PL_curpad[po]);
#ifdef USE_ITHREADS
/* SV could be a shared hash key (eg bugid #19022) */
- if (
-#ifdef PERL_OLD_COPY_ON_WRITE
- !SvIsCOW(PL_curpad[po])
-#else
- !SvFAKE(PL_curpad[po])
-#endif
- )
+ if (!SvIsCOW(PL_curpad[po]))
SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
#endif
}
SV **ppad;
I32 ix;
+ PERL_ARGS_ASSERT_DO_DUMP_PAD;
+
if (!padlist) {
return;
}
- pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
- pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
+ pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
+ pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
pname = AvARRAY(pad_name);
ppad = AvARRAY(pad);
Perl_dump_indent(aTHX_ level, file,
const CV * const outside = CvOUTSIDE(cv);
AV* const padlist = CvPADLIST(cv);
+ PERL_ARGS_ASSERT_CV_DUMP;
+
PerlIO_printf(Perl_debug_log,
" %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
title,
dVAR;
I32 ix;
AV* const protopadlist = CvPADLIST(proto);
- const AV* const protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
- const AV* const protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
+ const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
+ const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
SV** const pname = AvARRAY(protopad_name);
SV** const ppad = AvARRAY(protopad);
const I32 fname = AvFILLp(protopad_name);
CV* outside;
long depth;
+ PERL_ARGS_ASSERT_CV_CLONE;
+
assert(!CvUNIQUE(proto));
/* Since cloneable anon subs can be nested, CvOUTSIDE may point
ENTER;
SAVESPTR(PL_compcv);
- cv = PL_compcv = (CV*)newSV(0);
- sv_upgrade((SV *)cv, SvTYPE(proto));
+ cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
CvCLONED_on(cv);
CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
OP_REFCNT_UNLOCK;
CvSTART(cv) = CvSTART(proto);
- CvOUTSIDE(cv) = (CV*)SvREFCNT_inc_simple(outside);
+ CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
if (SvPOK(proto))
- sv_setpvn((SV*)cv, SvPVX_const(proto), SvCUR(proto));
+ sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
if (SvFAKE(namesv)) { /* lexical from outside? */
sv = outpad[PARENT_PAD_INDEX(namesv)];
assert(sv);
- /* formats may have an inactive parent */
- if (SvTYPE(proto) == SVt_PVFM && SvPADSTALE(sv)) {
+ /* formats may have an inactive parent,
+ while my $x if $false can leave an active var marked as
+ stale. And state vars are always available */
+ if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
if (ckWARN(WARN_CLOSURE))
Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%s\" is not available", SvPVX_const(namesv));
sv = NULL;
}
- else {
- assert(!SvPADSTALE(sv));
+ else
SvREFCNT_inc_simple_void_NN(sv);
- }
}
if (!sv) {
const char sigil = SvPVX_const(namesv)[0];
if (sigil == '&')
sv = SvREFCNT_inc(ppad[ix]);
else if (sigil == '@')
- sv = (SV*)newAV();
+ sv = MUTABLE_SV(newAV());
else if (sigil == '%')
- sv = (SV*)newHV();
+ sv = MUTABLE_SV(newHV());
else
sv = newSV(0);
SvPADMY_on(sv);
+ /* reset the 'assign only once' flag on each state var */
+ if (SvPAD_STATE(namesv))
+ SvPADSTALE_on(sv);
}
}
else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
{
dVAR;
I32 ix;
- AV * const comppad_name = (AV*)AvARRAY(padlist)[0];
- AV * const comppad = (AV*)AvARRAY(padlist)[1];
+ AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
+ AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
SV ** const namepad = AvARRAY(comppad_name);
SV ** const curpad = AvARRAY(comppad);
+
+ PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
PERL_UNUSED_ARG(old_cv);
for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
if (namesv && namesv != &PL_sv_undef
&& *SvPVX_const(namesv) == '&')
{
- CV * const innercv = (CV*)curpad[ix];
+ CV * const innercv = MUTABLE_CV(curpad[ix]);
assert(CvWEAKOUTSIDE(innercv));
assert(CvOUTSIDE(innercv) == old_cv);
CvOUTSIDE(innercv) = new_cv;
Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
{
dVAR;
+
+ PERL_ARGS_ASSERT_PAD_PUSH;
+
if (depth > AvFILLp(padlist)) {
SV** const svp = AvARRAY(padlist);
AV* const newpad = newAV();
SV** const oldpad = AvARRAY(svp[depth-1]);
- I32 ix = AvFILLp((AV*)svp[1]);
- const I32 names_fill = AvFILLp((AV*)svp[0]);
+ I32 ix = AvFILLp((const AV *)svp[1]);
+ const I32 names_fill = AvFILLp((const AV *)svp[0]);
SV** const names = AvARRAY(svp[0]);
AV *av;
for ( ;ix > 0; ix--) {
if (names_fill >= ix && names[ix] != &PL_sv_undef) {
const char sigil = SvPVX_const(names[ix])[0];
- if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') {
+ if ((SvFLAGS(names[ix]) & SVf_FAKE)
+ || (SvFLAGS(names[ix]) & SVpad_STATE)
+ || sigil == '&')
+ {
/* outer lexical or anon code */
av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
}
else { /* our own lexical */
SV *sv;
if (sigil == '@')
- sv = (SV*)newAV();
+ sv = MUTABLE_SV(newAV());
else if (sigil == '%')
- sv = (SV*)newHV();
+ sv = MUTABLE_SV(newHV());
else
sv = newSV(0);
av_store(newpad, ix, sv);
}
av = newAV();
av_extend(av, 0);
- av_store(newpad, 0, (SV*)av);
+ av_store(newpad, 0, MUTABLE_SV(av));
AvREIFY_only(av);
- av_store(padlist, depth, (SV*)newpad);
+ av_store(padlist, depth, MUTABLE_SV(newpad));
AvFILLp(padlist) = depth;
}
}
https://perl5.git.perl.org / perl5.git / blobdiff