/* pad.c
*
- * Copyright (C) 2002,2003 by Larry Wall and others
+ * Copyright (C) 2002, 2003, 2004, 2005 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.
/*
=head1 Pad Data Structures
+This file contains the functions that create and manipulate scratchpads,
+which are array-of-array data structures attached to a CV (ie a sub)
+and which store lexical variables and opcode temporary and per-thread
+values.
+
=for apidoc m|AV *|CvPADLIST|CV *cv
CV's can have CvPADLIST(cv) set to point to an AV.
PADLIST *
Perl_pad_new(pTHX_ int flags)
{
- AV *padlist, *padname, *pad, *a0;
+ AV *padlist, *padname, *pad;
ASSERT_CURPAD_LEGAL("pad_new");
* dispensed with eventually ???
*/
- a0 = newAV(); /* will be @_ */
+ AV * const a0 = newAV(); /* will be @_ */
av_extend(a0, 0);
av_store(pad, 0, (SV*)a0);
AvFLAGS(a0) = AVf_REIFY;
Perl_pad_undef(pTHX_ CV* cv)
{
I32 ix;
- PADLIST *padlist = CvPADLIST(cv);
+ const PADLIST *padlist = CvPADLIST(cv);
if (!padlist)
return;
if (!PL_dirty) { /* don't bother during global destruction */
CV *outercv = CvOUTSIDE(cv);
- U32 seq = CvOUTSIDE_SEQ(cv);
+ const U32 seq = CvOUTSIDE_SEQ(cv);
AV *comppad_name = (AV*)AvARRAY(padlist)[0];
SV **namepad = AvARRAY(comppad_name);
AV *comppad = (AV*)AvARRAY(padlist)[1];
if (namesv && namesv != &PL_sv_undef
&& *SvPVX(namesv) == '&')
{
- CV *innercv = (CV*)curpad[ix];
+ CV * const innercv = (CV*)curpad[ix];
+ U32 inner_rc = SvREFCNT(innercv);
+ assert(inner_rc);
namepad[ix] = Nullsv;
SvREFCNT_dec(namesv);
if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
curpad[ix] = Nullsv;
SvREFCNT_dec(innercv);
+ inner_rc--;
}
- if (SvREFCNT(innercv) /* in use, not just a prototype */
+ if (inner_rc /* in use, not just a prototype */
&& CvOUTSIDE(innercv) == cv)
{
assert(CvWEAKOUTSIDE(innercv));
CvWEAKOUTSIDE_off(innercv);
CvOUTSIDE(innercv) = outercv;
CvOUTSIDE_SEQ(innercv) = seq;
- SvREFCNT_inc(outercv);
+ (void)SvREFCNT_inc(outercv);
}
else {
CvOUTSIDE(innercv) = Nullcv;
*/
PADOFFSET
-Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
+Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake)
{
PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
SV* namesv = NEWSV(1102, 0);
if (typestash) {
SvFLAGS(namesv) |= SVpad_TYPED;
- SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) typestash);
+ SvSTASH_set(namesv, (HV*)SvREFCNT_inc((SV*) typestash));
}
if (ourstash) {
SvFLAGS(namesv) |= SVpad_OUR;
}
else {
/* not yet introduced */
- SvNVX(namesv) = (NV)PAD_MAX; /* min */
- SvIVX(namesv) = 0; /* max */
+ SvNV_set(namesv, (NV)PAD_MAX); /* min */
+ SvIV_set(namesv, 0); /* max */
if (!PL_min_intro_pending)
PL_min_intro_pending = offset;
}
else {
SV **names = AvARRAY(PL_comppad_name);
- SSize_t names_fill = AvFILLp(PL_comppad_name);
+ const SSize_t names_fill = AvFILLp(PL_comppad_name);
for (;;) {
/*
* "foreach" index vars temporarily become aliases to non-"my"
"Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
PL_op_name[optype]));
+#ifdef DEBUG_LEAKING_SCALARS
+ sv->sv_debug_optype = optype;
+ sv->sv_debug_inpad = 1;
+#endif
return (PADOFFSET)retval;
}
name = NEWSV(1106, 0);
sv_upgrade(name, SVt_PVNV);
sv_setpvn(name, "&", 1);
- SvIVX(name) = -1;
- SvNVX(name) = 1;
+ SvIV_set(name, -1);
+ SvNV_set(name, 1);
ix = pad_alloc(op_type, SVs_PADMY);
av_store(PL_comppad_name, ix, name);
/* XXX DAPM use PL_curpad[] ? */
/* XXX DAPM integrate this into pad_add_name ??? */
void
-Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
+Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash)
{
SV **svp, *sv;
PADOFFSET top, off;
*/
PADOFFSET
-Perl_pad_findmy(pTHX_ char *name)
+Perl_pad_findmy(pTHX_ const char *name)
{
SV *out_sv;
int out_flags;
I32 offset;
- AV *nameav;
+ const AV *nameav;
SV **name_svp;
offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
nameav = (AV*)AvARRAY(CvPADLIST(PL_compcv))[0];
name_svp = AvARRAY(nameav);
for (offset = AvFILLp(nameav); offset > 0; offset--) {
- SV *namesv = name_svp[offset];
+ const SV *namesv = name_svp[offset];
if (namesv && namesv != &PL_sv_undef
&& !SvFAKE(namesv)
&& (SvFLAGS(namesv) & SVpad_OUR)
return NOT_IN_PAD;
}
+/*
+ * Returns the offset of a lexical $_, if there is one, at run time.
+ * Used by the UNDERBAR XS macro.
+ */
+
+PADOFFSET
+Perl_find_rundefsvoffset(pTHX)
+{
+ SV *out_sv;
+ int out_flags;
+ return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
+ Null(SV**), &out_sv, &out_flags);
+}
/*
=for apidoc pad_findlex
STATIC PADOFFSET
-S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn,
+S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
SV** out_capture, SV** out_name_sv, int *out_flags)
{
I32 offset, new_offset;
SV *new_capture;
SV **new_capturep;
- AV *padlist = CvPADLIST(cv);
+ const AV *padlist = CvPADLIST(cv);
*out_flags = 0;
if (padlist) { /* not an undef CV */
I32 fake_offset = 0;
- AV *nameav = (AV*)AvARRAY(padlist)[0];
+ const AV *nameav = (AV*)AvARRAY(padlist)[0];
SV **name_svp = AvARRAY(nameav);
for (offset = AvFILLp(nameav); offset > 0; offset--) {
- SV *namesv = name_svp[offset];
+ const SV *namesv = name_svp[offset];
if (namesv && namesv != &PL_sv_undef
&& strEQ(SvPVX(namesv), name))
{
);
new_namesv = AvARRAY(PL_comppad_name)[new_offset];
- SvIVX(new_namesv) = *out_flags;
+ SvIV_set(new_namesv, *out_flags);
- SvNVX(new_namesv) = (NV)0;
+ SvNV_set(new_namesv, (NV)0);
if (SvFLAGS(new_namesv) & SVpad_OUR) {
/* do nothing */
}
else if (CvLATE(cv)) {
/* delayed creation - just note the offset within parent pad */
- SvNVX(new_namesv) = (NV)offset;
+ SvNV_set(new_namesv, (NV)offset);
CvCLONE_on(cv);
}
else {
if ((sv = svp[i]) && sv != &PL_sv_undef
&& !SvFAKE(sv) && !SvIVX(sv))
{
- SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
- SvNVX(sv) = (NV)PL_cop_seqmax;
+ SvIV_set(sv, PAD_MAX); /* Don't know scope end yet. */
+ SvNV_set(sv, (NV)PL_cop_seqmax);
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad intromy: %ld \"%s\", (%ld,%ld)\n",
(long)i, SvPVX(sv),
{
I32 off;
SV **svp = AvARRAY(PL_comppad_name);
- SV *sv;
PL_pad_reset_pending = FALSE;
ASSERT_CURPAD_ACTIVE("pad_leavemy");
if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
+ const SV *sv;
if ((sv = svp[off]) && sv != &PL_sv_undef
&& !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
}
/* "Deintroduce" my variables that are leaving with this scope. */
for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
+ const SV *sv;
if ((sv = svp[off]) && sv != &PL_sv_undef
&& !SvFAKE(sv) && SvIVX(sv) == PAD_MAX)
{
- SvIVX(sv) = PL_cop_seqmax;
+ SvIV_set(sv, PL_cop_seqmax);
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad leavemy: %ld \"%s\", (%ld,%ld)\n",
(long)off, SvPVX(sv),
Perl_pad_reset(pTHX)
{
#ifdef USE_BROKEN_PAD_RESET
- register I32 po;
-
if (AvARRAY(PL_comppad) != PL_curpad)
Perl_croak(aTHX_ "panic: pad_reset curpad");
);
if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
+ register I32 po;
for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
SvPADTMP_off(PL_curpad[po]);
void
Perl_pad_tidy(pTHX_ padtidy_type type)
{
+ dVAR;
PADOFFSET ix;
- CV *cv;
ASSERT_CURPAD_ACTIVE("pad_tidy");
*/
if (PL_cv_has_eval || PL_perldb) {
+ const CV *cv;
for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
if (cv != PL_compcv && CvCOMPILED(cv))
break; /* no need to mark already-compiled code */
void
Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
{
- AV *pad_name;
- AV *pad;
+ const AV *pad_name;
+ const AV *pad;
SV **pname;
SV **ppad;
- SV *namesv;
I32 ix;
if (!padlist) {
);
for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
- namesv = pname[ix];
+ const SV *namesv = pname[ix];
if (namesv && namesv == &PL_sv_undef) {
namesv = Nullsv;
}
if (namesv) {
if (SvFAKE(namesv))
Perl_dump_indent(aTHX_ level+1, file,
- "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%x index=%lu\n",
+ "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
(int) ix,
PTR2UV(ppad[ix]),
(unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
#ifdef DEBUGGING
STATIC void
-S_cv_dump(pTHX_ CV *cv, char *title)
+S_cv_dump(pTHX_ const CV *cv, const char *title)
{
- CV *outside = CvOUTSIDE(cv);
+ const CV *outside = CvOUTSIDE(cv);
AV* padlist = CvPADLIST(cv);
PerlIO_printf(Perl_debug_log,
CV *
Perl_cv_clone(pTHX_ CV *proto)
{
+ dVAR;
I32 ix;
AV* protopadlist = CvPADLIST(proto);
- AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
- AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
+ const AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
+ const AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
SV** pname = AvARRAY(protopad_name);
SV** ppad = AvARRAY(protopad);
- I32 fname = AvFILLp(protopad_name);
- I32 fpad = AvFILLp(protopad);
- AV* comppadlist;
+ const I32 fname = AvFILLp(protopad_name);
+ const I32 fpad = AvFILLp(protopad);
CV* cv;
SV** outpad;
CV* outside;
#endif
CvGV(cv) = CvGV(proto);
CvSTASH(cv) = CvSTASH(proto);
+ OP_REFCNT_LOCK;
CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
+ OP_REFCNT_UNLOCK;
CvSTART(cv) = CvSTART(proto);
CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
if (SvPOK(proto))
sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
- CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
+ CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
av_fill(PL_comppad, fpad);
for (ix = fname; ix >= 0; ix--)
}
}
if (!sv) {
- char *name = SvPVX(namesv);
- if (*name == '&')
+ const char sigil = SvPVX(namesv)[0];
+ if (sigil == '&')
sv = SvREFCNT_inc(ppad[ix]);
- else if (*name == '@')
+ else if (sigil == '@')
sv = (SV*)newAV();
- else if (*name == '%')
+ else if (sigil == '%')
sv = (SV*)newHV();
else
sv = NEWSV(0, 0);
SV **namepad = AvARRAY(comppad_name);
SV **curpad = AvARRAY(comppad);
for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
- SV *namesv = namepad[ix];
+ const SV *namesv = namepad[ix];
if (namesv && namesv != &PL_sv_undef
&& *SvPVX(namesv) == '&')
{
=for apidoc pad_push
Push a new pad frame onto the padlist, unless there's already a pad at
-this depth, in which case don't bother creating a new one.
-If has_args is true, give the new pad an @_ in slot zero.
+this depth, in which case don't bother creating a new one. Then give
+the new pad an @_ in slot zero.
=cut
*/
void
-Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
+Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
{
if (depth <= AvFILLp(padlist))
return;
AV *newpad = newAV();
SV **oldpad = AvARRAY(svp[depth-1]);
I32 ix = AvFILLp((AV*)svp[1]);
- I32 names_fill = AvFILLp((AV*)svp[0]);
+ const I32 names_fill = AvFILLp((AV*)svp[0]);
SV** names = AvARRAY(svp[0]);
- SV* sv;
+ AV *av;
+
for ( ;ix > 0; ix--) {
if (names_fill >= ix && names[ix] != &PL_sv_undef) {
- char *name = SvPVX(names[ix]);
- if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
+ const char sigil = SvPVX(names[ix])[0];
+ if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') {
/* outer lexical or anon code */
av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
}
else { /* our own lexical */
- if (*name == '@')
- av_store(newpad, ix, sv = (SV*)newAV());
- else if (*name == '%')
- av_store(newpad, ix, sv = (SV*)newHV());
+ SV *sv;
+ if (sigil == '@')
+ sv = (SV*)newAV();
+ else if (sigil == '%')
+ sv = (SV*)newHV();
else
- av_store(newpad, ix, sv = NEWSV(0, 0));
+ sv = NEWSV(0, 0);
+ av_store(newpad, ix, sv);
SvPADMY_on(sv);
}
}
else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
- av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
+ av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
}
else {
/* save temporaries on recursion? */
- av_store(newpad, ix, sv = NEWSV(0, 0));
+ SV *sv = NEWSV(0, 0);
+ av_store(newpad, ix, sv);
SvPADTMP_on(sv);
}
}
- if (has_args) {
- AV* av = newAV();
- av_extend(av, 0);
- av_store(newpad, 0, (SV*)av);
- AvFLAGS(av) = AVf_REIFY;
- }
+ av = newAV();
+ av_extend(av, 0);
+ av_store(newpad, 0, (SV*)av);
+ AvFLAGS(av) = AVf_REIFY;
+
av_store(padlist, depth, (SV*)newpad);
AvFILLp(padlist) = depth;
}
}
+
+
+HV *
+Perl_pad_compname_type(pTHX_ const PADOFFSET po)
+{
+ SV** const av = av_fetch(PL_comppad_name, po, FALSE);
+ if ( SvFLAGS(*av) & SVpad_TYPED ) {
+ return SvSTASH(*av);
+ }
+ return Nullhv;
+}
https://perl5.git.perl.org / perl5.git / blobdiff