*
* 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
/*
=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 Amx|PADLIST *|CvPADLIST|CV *cv
-=for apidoc m|AV *|CvPADLIST|CV *cv
-CV's can have CvPADLIST(cv) set to point to an AV.
+CV's can have CvPADLIST(cv) set to point to an AV. This is the CV's
+scratchpad, which stores lexical variables and opcode temporary and
+per-thread values.
For these purposes "forms" are a kind-of CV, eval""s are too (except they're
not callable at will and are always thrown away after the eval"" is done
The 0'th slot of a frame AV is an AV which is @_.
other entries are storage for variables and op targets.
-During compilation:
-C<PL_comppad_name> is set to the names AV.
-C<PL_comppad> is set to the frame AV for the frame CvDEPTH == 1.
-C<PL_curpad> is set to the body of the frame AV (i.e. AvARRAY(PL_comppad)).
-
-During execution, C<PL_comppad> and C<PL_curpad> refer to the live
-frame of the currently executing sub.
-
Iterating over the names AV iterates over all possible pad
items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
&PL_sv_undef "names" (see pad_alloc()).
The SVs in the names AV have their PV being the name of the variable.
xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
-which the name is valid. For typed lexicals name SV is SVt_PVMG and SvSTASH
+which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
+_HIGH). During compilation, these fields may hold the special value
+PERL_PADSEQ_INTRO to indicate various stages:
+
+ COP_SEQ_RANGE_LOW _HIGH
+ ----------------- -----
+ PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
+ valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
+ valid-seq# valid-seq# compilation of scope complete: { my ($x) }
+
+For typed lexicals name SV is SVt_PVMG and SvSTASH
points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
SvOURSTASH slot pointing at the stash of the associated global (so that
duplicate C<our> declarations in the same package can be detected). SvUVX is
Note that formats are treated as anon subs, and are cloned each time
write is called (if necessary).
-The flag SVf_PADSTALE is cleared on lexicals each time the my() is executed,
+The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
and set on scope exit. This allows the 'Variable $x is not available' warning
to be generated in evals, such as
{ my $x = 1; sub f { eval '$x'} } f();
-For state vars, SVf_PADSTALE is overloaded to mean 'not yet initialised'
+For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'
+
+=for apidoc AmxU|AV *|PL_comppad_name
+
+During compilation, this points to the array containing the names part
+of the pad for the currently-compiling code.
+
+=for apidoc AmxU|AV *|PL_comppad
+
+During compilation, this points to the array containing the values
+part of the pad for the currently-compiling code. (At runtime a CV may
+have many such value arrays; at compile time just one is constructed.)
+At runtime, this points to the array containing the currently-relevant
+values for the pad for the currently-executing code.
+
+=for apidoc AmxU|SV **|PL_curpad
+
+Points directly to the body of the L</PL_comppad> array.
+(I.e., this is C<AvARRAY(PL_comppad)>.)
=cut
*/
#define PARENT_FAKELEX_FLAGS_set(sv,val) \
STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
-#define PAD_MAX I32_MAX
+/*
+=for apidoc mx|void|pad_peg|const char *s
+
+When PERL_MAD is enabled, this is a small no-op function that gets called
+at the start of each pad-related function. It can be breakpointed to
+track all pad operations. The parameter is a string indicating the type
+of pad operation being performed.
+
+=cut
+*/
#ifdef PERL_MAD
void pad_peg(const char* s) {
- static int pegcnt;
+ static int pegcnt; /* XXX not threadsafe */
+ PERL_UNUSED_ARG(s);
PERL_ARGS_ASSERT_PAD_PEG;
#endif
/*
-=for apidoc pad_new
+This is basically sv_eq_flags() in sv.c, but we avoid the magic
+and bytes checking.
+*/
+
+STATIC I32
+sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const I32 pvlen, const U32 flags) {
+ if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
+ const char *pv1 = SvPVX_const(sv);
+ STRLEN cur1 = SvCUR(sv);
+ const char *pv2 = pv;
+ STRLEN cur2 = pvlen;
+ if (PL_encoding) {
+ SV* svrecode = NULL;
+ if (SvUTF8(sv)) {
+ svrecode = newSVpvn(pv2, cur2);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ pv2 = SvPV_const(svrecode, cur2);
+ }
+ else {
+ svrecode = newSVpvn(pv1, cur1);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ pv1 = SvPV_const(svrecode, cur1);
+ }
+ SvREFCNT_dec(svrecode);
+ }
+ if (flags & SVf_UTF8)
+ return (bytes_cmp_utf8(
+ (const U8*)pv1, cur1,
+ (const U8*)pv2, cur2) == 0);
+ else
+ return (bytes_cmp_utf8(
+ (const U8*)pv2, cur2,
+ (const U8*)pv1, cur1) == 0);
+ }
+ else
+ return ((SvPVX_const(sv) == pv)
+ || memEQ(SvPVX_const(sv), pv, pvlen));
+}
+
+
+/*
+=for apidoc Am|PADLIST *|pad_new|int flags
-Create a new compiling padlist, saving and updating the various global
-vars at the same time as creating the pad itself. The following flags
-can be OR'ed together:
+Create a new padlist, updating the global variables for the
+currently-compiling padlist to point to the new padlist. The following
+flags can be OR'ed together:
padnew_CLONE this pad is for a cloned CV
- padnew_SAVE save old globals
+ padnew_SAVE save old globals on the save stack
padnew_SAVESUB also save extra stuff for start of sub
=cut
{
dVAR;
AV *padlist, *padname, *pad;
+ SV **ary;
ASSERT_CURPAD_LEGAL("pad_new");
SAVEI32(PL_max_intro_pending);
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);
+ /* Most subroutines never recurse, hence only need 2 entries in the padlist
+ array - names, and depth=1. The default for av_store() is to allocate
+ 0..3, and even an explicit call to av_extend() with <3 will be rounded
+ up, so we inline the allocation of the array here. */
+ Newx(ary, 2, SV*);
+ AvFILLp(padlist) = 1;
+ AvMAX(padlist) = 1;
+ AvALLOC(padlist) = ary;
+ AvARRAY(padlist) = ary;
+ ary[0] = MUTABLE_SV(padname);
+ ary[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_curpad = AvARRAY(PL_comppad);
+ PL_comppad_name = padname;
+ PL_comppad = pad;
+ PL_curpad = AvARRAY(pad);
if (! (flags & padnew_CLONE)) {
PL_comppad_name_fill = 0;
return (PADLIST*)padlist;
}
+
/*
-=for apidoc pad_undef
+=head1 Embedding Functions
-Free the padlist associated with a CV.
-If parts of it happen to be current, we null the relevant
-PL_*pad* global vars so that we don't have any dangling references left.
-We also repoint the CvOUTSIDE of any about-to-be-orphaned
-inner subs to the outer of this cv.
+=for apidoc cv_undef
-(This function should really be called pad_free, but the name was already
-taken)
+Clear out all the active components of a CV. This can happen either
+by an explicit C<undef &foo>, or by the reference count going to zero.
+In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
+children can still follow the full lexical scope chain.
=cut
*/
void
-Perl_pad_undef(pTHX_ CV* cv)
+Perl_cv_undef(pTHX_ CV *cv)
{
dVAR;
- I32 ix;
- const PADLIST * const padlist = CvPADLIST(cv);
-
- PERL_ARGS_ASSERT_PAD_UNDEF;
+ const PADLIST *padlist = CvPADLIST(cv);
- pad_peg("pad_undef");
- if (!padlist)
- return;
- if (SvIS_FREED(padlist)) /* may be during global destruction */
- return;
+ PERL_ARGS_ASSERT_CV_UNDEF;
DEBUG_X(PerlIO_printf(Perl_debug_log,
- "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
- PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
+ "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
+ PTR2UV(cv), PTR2UV(PL_comppad))
);
- /* detach any '&' anon children in the pad; if afterwards they
- * are still live, fix up their CvOUTSIDEs to point to our outside,
- * bypassing us. */
- /* XXX DAPM for efficiency, we should only do this if we know we have
- * children, or integrate this loop with general cleanup */
-
- 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];
- SV ** const namepad = AvARRAY(comppad_name);
- AV * const comppad = (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];
- U32 inner_rc = SvREFCNT(innercv);
- assert(inner_rc);
- namepad[ix] = NULL;
- SvREFCNT_dec(namesv);
-
- if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
- curpad[ix] = NULL;
- SvREFCNT_dec(innercv);
- inner_rc--;
- }
+#ifdef USE_ITHREADS
+ if (CvFILE(cv) && !CvISXSUB(cv)) {
+ /* for XSUBs CvFILE point directly to static memory; __FILE__ */
+ Safefree(CvFILE(cv));
+ }
+ CvFILE(cv) = NULL;
+#endif
- /* in use, not just a prototype */
- if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
- assert(CvWEAKOUTSIDE(innercv));
- /* don't relink to grandfather if he's being freed */
- if (outercv && SvREFCNT(outercv)) {
- CvWEAKOUTSIDE_off(innercv);
- CvOUTSIDE(innercv) = outercv;
- CvOUTSIDE_SEQ(innercv) = seq;
- SvREFCNT_inc_simple_void_NN(outercv);
- }
- else {
- CvOUTSIDE(innercv) = NULL;
+ if (!CvISXSUB(cv) && CvROOT(cv)) {
+ if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
+ Perl_croak(aTHX_ "Can't undef active subroutine");
+ ENTER;
+
+ PAD_SAVE_SETNULLPAD();
+
+ op_free(CvROOT(cv));
+ CvROOT(cv) = NULL;
+ CvSTART(cv) = NULL;
+ LEAVE;
+ }
+ SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
+ CvGV_set(cv, NULL);
+
+ /* This statement and the subsequence if block was pad_undef(). */
+ pad_peg("pad_undef");
+
+ if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */
+ ) {
+ I32 ix;
+
+ /* Free the padlist associated with a CV.
+ If parts of it happen to be current, we null the relevant PL_*pad*
+ global vars so that we don't have any dangling references left.
+ We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
+ subs to the outer of this cv. */
+
+ DEBUG_X(PerlIO_printf(Perl_debug_log,
+ "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
+ * are still live, fix up their CvOUTSIDEs to point to our outside,
+ * bypassing us. */
+ /* XXX DAPM for efficiency, we should only do this if we know we have
+ * children, or integrate this loop with general cleanup */
+
+ if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
+ CV * const outercv = CvOUTSIDE(cv);
+ const U32 seq = CvOUTSIDE_SEQ(cv);
+ AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
+ SV ** const namepad = AvARRAY(comppad_name);
+ 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 = MUTABLE_CV(curpad[ix]);
+ U32 inner_rc = SvREFCNT(innercv);
+ assert(inner_rc);
+ namepad[ix] = NULL;
+ SvREFCNT_dec(namesv);
+
+ if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
+ curpad[ix] = NULL;
+ SvREFCNT_dec(innercv);
+ inner_rc--;
+ }
+
+ /* in use, not just a prototype */
+ if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
+ assert(CvWEAKOUTSIDE(innercv));
+ /* don't relink to grandfather if he's being freed */
+ if (outercv && SvREFCNT(outercv)) {
+ CvWEAKOUTSIDE_off(innercv);
+ CvOUTSIDE(innercv) = outercv;
+ CvOUTSIDE_SEQ(innercv) = seq;
+ SvREFCNT_inc_simple_void_NN(outercv);
+ }
+ else {
+ CvOUTSIDE(innercv) = NULL;
+ }
+ }
}
- }
}
}
- }
- ix = AvFILLp(padlist);
- while (ix >= 0) {
- SV* const sv = AvARRAY(padlist)[ix--];
- if (sv) {
- if (sv == (SV*)PL_comppad_name)
- PL_comppad_name = NULL;
- else if (sv == (SV*)PL_comppad) {
- PL_comppad = NULL;
- PL_curpad = NULL;
+ ix = AvFILLp(padlist);
+ while (ix > 0) {
+ SV* const sv = AvARRAY(padlist)[ix--];
+ if (sv) {
+ if (sv == (const SV *)PL_comppad) {
+ PL_comppad = NULL;
+ PL_curpad = NULL;
+ }
+ SvREFCNT_dec(sv);
}
}
- SvREFCNT_dec(sv);
+ {
+ SV *const sv = AvARRAY(padlist)[0];
+ if (sv == (const SV *)PL_comppad_name)
+ PL_comppad_name = NULL;
+ SvREFCNT_dec(sv);
+ }
+ SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
+ CvPADLIST(cv) = NULL;
}
- SvREFCNT_dec((SV*)CvPADLIST(cv));
- CvPADLIST(cv) = NULL;
-}
-
+ /* remove CvOUTSIDE unless this is an undef rather than a free */
+ if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
+ if (!CvWEAKOUTSIDE(cv))
+ SvREFCNT_dec(CvOUTSIDE(cv));
+ CvOUTSIDE(cv) = NULL;
+ }
+ if (CvCONST(cv)) {
+ SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
+ CvCONST_off(cv);
+ }
+ if (CvISXSUB(cv) && CvXSUB(cv)) {
+ CvXSUB(cv) = NULL;
+ }
+ /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
+ * ref status of CvOUTSIDE and CvGV */
+ CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
+}
/*
-=for apidoc pad_add_name
+=for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
-Create a new name and associated PADMY SV in the current pad; return the
-offset.
-If C<typestash> is valid, the name is for a typed lexical; set the
-name's stash to that value.
-If C<ourstash> is valid, it's an our lexical, set the name's
-SvOURSTASH to that value
-
-If fake, it means we're cloning an existing entry
+Allocates a place in the currently-compiling pad (via L</pad_alloc>) and
+then stores a name for that entry. I<namesv> is adopted and becomes the
+name entry; it must already contain the name string and be sufficiently
+upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
+added to I<namesv>. None of the other processing of L</pad_add_name_pvn>
+is done. Returns the offset of the allocated pad slot.
=cut
*/
-PADOFFSET
-Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake, bool state)
+static PADOFFSET
+S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
{
dVAR;
const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
- SV* const namesv
- = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
- PERL_ARGS_ASSERT_PAD_ADD_NAME;
+ PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
- ASSERT_CURPAD_ACTIVE("pad_add_name");
-
- sv_setpv(namesv, name);
+ ASSERT_CURPAD_ACTIVE("pad_alloc_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);
SvOURSTASH_set(namesv, ourstash);
SvREFCNT_inc_simple_void_NN(ourstash);
}
- else if (state) {
+ else if (flags & padadd_STATE) {
SvPAD_STATE_on(namesv);
}
av_store(PL_comppad_name, offset, namesv);
- if (fake) {
- SvFAKE_on(namesv);
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name));
+ return offset;
+}
+
+/*
+=for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
+
+Allocates a place in the currently-compiling pad for a named lexical
+variable. Stores the name and other metadata in the name part of the
+pad, and makes preparations to manage the variable's lexical scoping.
+Returns the offset of the allocated pad slot.
+
+I<namepv>/I<namelen> specify the variable's name, including leading sigil.
+If I<typestash> is non-null, the name is for a typed lexical, and this
+identifies the type. If I<ourstash> is non-null, it's a lexical reference
+to a package variable, and this identifies the package. The following
+flags can be OR'ed together:
+
+ padadd_OUR redundantly specifies if it's a package var
+ padadd_STATE variable will retain value persistently
+ padadd_NO_DUP_CHECK skip check for lexical shadowing
+
+=cut
+*/
+
+PADOFFSET
+Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
+ U32 flags, HV *typestash, HV *ourstash)
+{
+ dVAR;
+ PADOFFSET offset;
+ SV *namesv;
+ bool is_utf8;
+
+ PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
+
+ if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
+ Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
+ (UV)flags);
+
+ namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
+
+ if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
+ namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
}
- else {
- /* not yet introduced */
- COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */
- COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */
-
- if (!PL_min_intro_pending)
- PL_min_intro_pending = offset;
- PL_max_intro_pending = offset;
- /* if it's not a simple scalar, replace with an AV or HV */
- /* XXX DAPM since slot has been allocated, replace
- * av_store with PL_curpad[offset] ? */
- if (*name == '@')
- av_store(PL_comppad, offset, (SV*)newAV());
- else if (*name == '%')
- av_store(PL_comppad, offset, (SV*)newHV());
- SvPADMY_on(PL_curpad[offset]);
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
- (long)offset, name, PTR2UV(PL_curpad[offset])));
+
+ sv_setpvn(namesv, namepv, namelen);
+
+ if (is_utf8) {
+ flags |= padadd_UTF8_NAME;
+ SvUTF8_on(namesv);
}
+ else
+ flags &= ~padadd_UTF8_NAME;
+
+ if ((flags & padadd_NO_DUP_CHECK) == 0) {
+ /* check for duplicate declaration */
+ pad_check_dup(namesv, flags & padadd_OUR, ourstash);
+ }
+
+ offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
+
+ /* not yet introduced */
+ COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
+ COP_SEQ_RANGE_HIGH_set(namesv, 0);
+
+ if (!PL_min_intro_pending)
+ PL_min_intro_pending = offset;
+ PL_max_intro_pending = offset;
+ /* if it's not a simple scalar, replace with an AV or HV */
+ assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
+ assert(SvREFCNT(PL_curpad[offset]) == 1);
+ if (namelen != 0 && *namepv == '@')
+ sv_upgrade(PL_curpad[offset], SVt_PVAV);
+ else if (namelen != 0 && *namepv == '%')
+ sv_upgrade(PL_curpad[offset], SVt_PVHV);
+ assert(SvPADMY(PL_curpad[offset]));
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
+ (long)offset, SvPVX(namesv),
+ PTR2UV(PL_curpad[offset])));
return offset;
}
+/*
+=for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
+
+Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
+instead of a string/length pair.
+
+=cut
+*/
+
+PADOFFSET
+Perl_pad_add_name_pv(pTHX_ const char *name,
+ U32 flags, HV *typestash, HV *ourstash)
+{
+ PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
+ return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
+}
+
+/*
+=for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
+
+Exactly like L</pad_add_name_pvn>, but takes the name string in the form
+of an SV instead of a string/length pair.
+=cut
+*/
+PADOFFSET
+Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
+ namepv = SvPV(name, namelen);
+ if (SvUTF8(name))
+ flags |= padadd_UTF8_NAME;
+ return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
+}
/*
-=for apidoc pad_alloc
+=for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
+
+Allocates a place in the currently-compiling pad,
+returning the offset of the allocated pad slot.
+No name is initially attached to the pad slot.
+I<tmptype> is a set of flags indicating the kind of pad entry required,
+which will be set in the value SV for the allocated pad entry:
+
+ SVs_PADMY named lexical variable ("my", "our", "state")
+ SVs_PADTMP unnamed temporary store
-Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
-the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
-for a slot which has no name and no active value.
+I<optype> should be an opcode indicating the type of operation that the
+pad entry is to support. This doesn't affect operational semantics,
+but is used for debugging.
=cut
*/
if (PL_pad_reset_pending)
pad_reset();
if (tmptype & SVs_PADMY) {
+ /* For a my, simply push a null SV onto the end of PL_comppad. */
sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
retval = AvFILLp(PL_comppad);
}
else {
+ /* For a tmp, scan the pad from PL_padix upwards
+ * for a slot which has no name and no active value.
+ */
SV * const * const names = AvARRAY(PL_comppad_name);
const SSize_t names_fill = AvFILLp(PL_comppad_name);
for (;;) {
}
/*
-=for apidoc pad_add_anon
+=for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
+
+Allocates a place in the currently-compiling pad (via L</pad_alloc>)
+for an anonymous function that is lexically scoped inside the
+currently-compiling function.
+The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
+to the outer scope is weakened to avoid a reference loop.
-Add an anon code entry to the current compiling pad
+I<optype> should be an opcode indicating the type of operation that the
+pad entry is to support. This doesn't affect operational semantics,
+but is used for debugging.
=cut
*/
PADOFFSET
-Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
+Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
{
dVAR;
PADOFFSET ix;
PERL_ARGS_ASSERT_PAD_ADD_ANON;
pad_peg("add_anon");
- sv_setpvn(name, "&", 1);
- /* Are these two actually ever read? */
- COP_SEQ_RANGE_HIGH_set(name, ~0);
- COP_SEQ_RANGE_LOW_set(name, 1);
- ix = pad_alloc(op_type, SVs_PADMY);
+ sv_setpvs(name, "&");
+ /* These two aren't used; just make sure they're not equal to
+ * PERL_PADSEQ_INTRO */
+ COP_SEQ_RANGE_LOW_set(name, 0);
+ COP_SEQ_RANGE_HIGH_set(name, 0);
+ ix = pad_alloc(optype, SVs_PADMY);
av_store(PL_comppad_name, ix, name);
/* XXX DAPM use PL_curpad[] ? */
- av_store(PL_comppad, ix, sv);
- SvPADMY_on(sv);
+ av_store(PL_comppad, ix, (SV*)func);
+ SvPADMY_on((SV*)func);
/* 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(func)) {
+ assert(!CvWEAKOUTSIDE(func));
+ CvWEAKOUTSIDE_on(func);
+ SvREFCNT_dec(CvOUTSIDE(func));
}
return ix;
}
-
-
/*
-=for apidoc pad_check_dup
+=for apidoc m|pad_check_dup|SV *name|U32 flags|const HV *ourstash
Check for duplicate declarations: report any of:
* a my in the current scope with the same name;
=cut
*/
-/* XXX DAPM integrate this into pad_add_name ??? */
-
-void
-Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash)
+STATIC void
+S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
{
dVAR;
SV **svp;
PADOFFSET top, off;
+ const U32 is_our = flags & padadd_OUR;
PERL_ARGS_ASSERT_PAD_CHECK_DUP;
ASSERT_CURPAD_ACTIVE("pad_check_dup");
+
+ assert((flags & ~padadd_OUR) == 0);
+
if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
return; /* nothing to check */
if (sv
&& sv != &PL_sv_undef
&& !SvFAKE(sv)
- && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
- && strEQ(name, SvPVX_const(sv)))
+ && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
+ || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
+ && sv_eq(name, sv))
{
if (is_our && (SvPAD_OUR(sv)))
break; /* "our" masking "our" */
Perl_warner(aTHX_ packWARN(WARN_MISC),
- "\"%s\" variable %s masks earlier declaration in same %s",
+ "\"%s\" variable %"SVf" masks earlier declaration in same %s",
(is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
- name,
- (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement"));
+ sv,
+ (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
+ ? "scope" : "statement"));
--off;
break;
}
}
/* check the rest of the pad */
if (is_our) {
- do {
+ while (off > 0) {
SV * const sv = svp[off];
if (sv
&& sv != &PL_sv_undef
&& !SvFAKE(sv)
- && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
+ && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
+ || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
&& SvOURSTASH(sv) == ourstash
- && strEQ(name, SvPVX_const(sv)))
+ && sv_eq(name, sv))
{
Perl_warner(aTHX_ packWARN(WARN_MISC),
- "\"our\" variable %s redeclared", name);
+ "\"our\" variable %"SVf" redeclared", sv);
if ((I32)off <= PL_comppad_name_floor)
Perl_warner(aTHX_ packWARN(WARN_MISC),
"\t(Did you mean \"local\" instead of \"our\"?)\n");
break;
}
- } while ( off-- > 0 );
+ --off;
+ }
}
}
/*
-=for apidoc pad_findmy
+=for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
-Given a lexical name, try to find its offset, first in the current pad,
-or failing that, in the pads of any lexically enclosing subs (including
-the complications introduced by eval). If the name is found in an outer pad,
-then a fake entry is added to the current pad.
-Returns the offset in the current pad, or NOT_IN_PAD on failure.
+Given the name of a lexical variable, find its position in the
+currently-compiling pad.
+I<namepv>/I<namelen> specify the variable's name, including leading sigil.
+I<flags> is reserved and must be zero.
+If it is not in the current pad but appears in the pad of any lexically
+enclosing scope, then a pseudo-entry for it is added in the current pad.
+Returns the offset in the current pad,
+or C<NOT_IN_PAD> if no such lexical is in scope.
=cut
*/
PADOFFSET
-Perl_pad_findmy(pTHX_ const char *name)
+Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
{
dVAR;
SV *out_sv;
const AV *nameav;
SV **name_svp;
- PERL_ARGS_ASSERT_PAD_FINDMY;
+ PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
+
+ pad_peg("pad_findmy_pvn");
- pad_peg("pad_findmy");
- offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
- NULL, &out_sv, &out_flags);
+ if (flags & ~padadd_UTF8_NAME)
+ Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
+ (UV)flags);
+
+ if (flags & padadd_UTF8_NAME) {
+ bool is_utf8 = TRUE;
+ namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
+
+ if (is_utf8)
+ flags |= padadd_UTF8_NAME;
+ else
+ flags &= ~padadd_UTF8_NAME;
+ }
+
+ offset = pad_findlex(namepv, namelen, flags,
+ PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
if ((PADOFFSET)offset != NOT_IN_PAD)
return offset;
* 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];
if (namesv && namesv != &PL_sv_undef
&& !SvFAKE(namesv)
&& (SvPAD_OUR(namesv))
- && strEQ(SvPVX_const(namesv), name)
- && COP_SEQ_RANGE_LOW(namesv) == PAD_MAX /* min */
+ && SvCUR(namesv) == namelen
+ && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
+ flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
+ && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
)
return offset;
}
}
/*
- * Returns the offset of a lexical $_, if there is one, at run time.
- * Used by the UNDERBAR XS macro.
- */
+=for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
+
+Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
+instead of a string/length pair.
+
+=cut
+*/
+
+PADOFFSET
+Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
+{
+ PERL_ARGS_ASSERT_PAD_FINDMY_PV;
+ return pad_findmy_pvn(name, strlen(name), flags);
+}
+
+/*
+=for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
+
+Exactly like L</pad_findmy_pvn>, but takes the name string in the form
+of an SV instead of a string/length pair.
+
+=cut
+*/
+
+PADOFFSET
+Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_PAD_FINDMY_SV;
+ namepv = SvPV(name, namelen);
+ if (SvUTF8(name))
+ flags |= padadd_UTF8_NAME;
+ return pad_findmy_pvn(namepv, namelen, flags);
+}
+
+/*
+=for apidoc Amp|PADOFFSET|find_rundefsvoffset
+
+Find the position of the lexical C<$_> in the pad of the
+currently-executing function. Returns the offset in the current pad,
+or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
+the global one should be used instead).
+L</find_rundefsv> is likely to be more convenient.
+
+=cut
+*/
PADOFFSET
Perl_find_rundefsvoffset(pTHX)
dVAR;
SV *out_sv;
int out_flags;
- return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
+ return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
NULL, &out_sv, &out_flags);
}
/*
-=for apidoc pad_findlex
+=for apidoc Am|SV *|find_rundefsv
+
+Find and return the variable that is named C<$_> in the lexical scope
+of the currently-executing function. This may be a lexical C<$_>,
+or will otherwise be the global one.
+
+=cut
+*/
+
+SV *
+Perl_find_rundefsv(pTHX)
+{
+ SV *namesv;
+ int flags;
+ PADOFFSET po;
+
+ po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
+ NULL, &namesv, &flags);
+
+ if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
+ return DEFSV;
+
+ return PAD_SVl(po);
+}
+
+/*
+=for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags
Find a named lexical anywhere in a chain of nested pads. Add fake entries
in the inner pads if it's found in an outer one.
STATIC PADOFFSET
-S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
- SV** out_capture, SV** out_name_sv, int *out_flags)
+S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
+ int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
{
dVAR;
I32 offset, new_offset;
PERL_ARGS_ASSERT_PAD_FINDLEX;
+ if (flags & ~padadd_UTF8_NAME)
+ Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
+ (UV)flags);
+
*out_flags = 0;
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
- PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
+ "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
+ PTR2UV(cv), namelen, namepv, (int)seq,
+ out_capture ? " capturing" : "" ));
/* first, search this pad */
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--) {
const SV * const namesv = name_svp[offset];
if (namesv && namesv != &PL_sv_undef
- && strEQ(SvPVX_const(namesv), name))
+ && SvCUR(namesv) == namelen
+ && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
+ flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
{
- if (SvFAKE(namesv))
+ if (SvFAKE(namesv)) {
fake_offset = offset; /* in case we don't find a real one */
- else if ( seq > COP_SEQ_RANGE_LOW(namesv) /* min */
- && seq <= COP_SEQ_RANGE_HIGH(namesv)) /* max */
- break;
+ continue;
+ }
+ /* is seq within the range _LOW to _HIGH ?
+ * This is complicated by the fact that PL_cop_seqmax
+ * may have wrapped around at some point */
+ if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
+ continue; /* not yet introduced */
+
+ if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
+ /* in compiling scope */
+ if (
+ (seq > COP_SEQ_RANGE_LOW(namesv))
+ ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
+ : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
+ )
+ break;
+ }
+ else if (
+ (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
+ ?
+ ( seq > COP_SEQ_RANGE_LOW(namesv)
+ || seq <= COP_SEQ_RANGE_HIGH(namesv))
+
+ : ( seq > COP_SEQ_RANGE_LOW(namesv)
+ && seq <= COP_SEQ_RANGE_HIGH(namesv))
+ )
+ break;
}
}
* instances. For now, we just test !CvUNIQUE(cv), but
* ideally, we should detect my's declared within loops
* etc - this would allow a wider range of 'not stayed
- * shared' warnings. We also treated alreadly-compiled
+ * shared' warnings. We also treated already-compiled
* lexes as not multi as viewed from evals. */
*out_flags = CvANON(cv) ?
? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
: *out_flags & PAD_FAKELEX_ANON)
{
- if (warn && ckWARN(WARN_CLOSURE))
- Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" is not available", name);
+ if (warn)
+ Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
+ "Variable \"%.*s\" is not available",
+ namelen, namepv);
*out_capture = NULL;
}
&& warn && ckWARN(WARN_CLOSURE)) {
newwarn = 0;
Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" will not stay shared", name);
+ "Variable \"%.*s\" will not stay shared",
+ namelen, namepv);
}
if (fake_offset && CvANON(cv)
"Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
PTR2UV(cv)));
n = *out_name_sv;
- (void) pad_findlex(name, CvOUTSIDE(cv),
+ (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
CvOUTSIDE_SEQ(cv),
newwarn, out_capture, out_name_sv, out_flags);
*out_name_sv = n;
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)
&& !SvPAD_STATE(name_svp[offset]))
{
- if (ckWARN(WARN_CLOSURE))
- Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" is not available", name);
+ Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
+ "Variable \"%.*s\" is not available",
+ namelen, namepv);
*out_capture = NULL;
}
}
if (!*out_capture) {
- if (*name == '@')
- *out_capture = sv_2mortal((SV*)newAV());
- else if (*name == '%')
- *out_capture = sv_2mortal((SV*)newHV());
+ if (namelen != 0 && *namepv == '@')
+ *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
+ else if (namelen != 0 && *namepv == '%')
+ *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
else
*out_capture = sv_newmortal();
}
new_capturep = out_capture ? out_capture :
CvLATE(cv) ? NULL : &new_capture;
- offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
+ offset = pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
new_capturep, out_name_sv, out_flags);
if ((PADOFFSET)offset == NOT_IN_PAD)
return NOT_IN_PAD;
return 0; /* this dummy (and invalid) value isnt used by the caller */
{
- SV *new_namesv;
+ /* This relies on sv_setsv_flags() upgrading the destination to the same
+ type as the source, independent of the flags set, and on it being
+ "good" and only copying flag bits and pointers that it understands.
+ */
+ SV *new_namesv = newSVsv(*out_name_sv);
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(
- SvPVX_const(*out_name_sv),
- SvPAD_TYPED(*out_name_sv)
- ? SvSTASH(*out_name_sv) : NULL,
- SvOURSTASH(*out_name_sv),
- 1, /* fake */
- SvPAD_STATE(*out_name_sv) ? 1 : 0 /* state variable ? */
- );
+ new_offset
+ = pad_alloc_name(new_namesv,
+ (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
+ SvPAD_TYPED(*out_name_sv)
+ ? SvSTASH(*out_name_sv) : NULL,
+ SvOURSTASH(*out_name_sv)
+ );
- new_namesv = AvARRAY(PL_comppad_name)[new_offset];
+ SvFAKE_on(new_namesv);
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad addname: %ld \"%.*s\" FAKE\n",
+ (long)new_offset,
+ (int) SvCUR(new_namesv), SvPVX(new_namesv)));
PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
PARENT_PAD_INDEX_set(new_namesv, 0);
return new_offset;
}
-
#ifdef DEBUGGING
+
/*
-=for apidoc pad_sv
+=for apidoc Am|SV *|pad_sv|PADOFFSET po
-Get the value at offset po in the current pad.
+Get the value at offset I<po> in the current (compiling or executing) pad.
Use macro PAD_SV instead of calling this function directly.
=cut
*/
-
SV *
Perl_pad_sv(pTHX_ PADOFFSET po)
{
return PL_curpad[po];
}
-
/*
-=for apidoc pad_setsv
+=for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
-Set the entry at offset po in the current pad to sv.
+Set the value at offset I<po> in the current (compiling or executing) pad.
Use the macro PAD_SETSV() rather than calling this function directly.
=cut
);
PL_curpad[po] = sv;
}
-#endif
-
+#endif /* DEBUGGING */
/*
-=for apidoc pad_block_start
+=for apidoc m|void|pad_block_start|int full
Update the pad compilation state variables on entry to a new block
PL_pad_reset_pending = FALSE;
}
-
/*
-=for apidoc intro_my
+=for apidoc m|U32|intro_my
"Introduce" my variables to visible status.
dVAR;
SV **svp;
I32 i;
+ U32 seq;
ASSERT_CURPAD_ACTIVE("intro_my");
if (! PL_min_intro_pending)
for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
SV * const sv = svp[i];
- if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !COP_SEQ_RANGE_HIGH(sv)) {
- COP_SEQ_RANGE_HIGH_set(sv, PAD_MAX); /* Don't know scope end yet. */
+ if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
+ && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
+ {
+ COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad intromy: %ld \"%s\", (%lu,%lu)\n",
);
}
}
+ seq = PL_cop_seqmax;
+ PL_cop_seqmax++;
+ if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
+ PL_cop_seqmax++;
PL_min_intro_pending = 0;
PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
+ "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
- return PL_cop_seqmax++;
+ return seq;
}
/*
-=for apidoc pad_leavemy
+=for apidoc m|void|pad_leavemy
Cleanup at end of scope during compilation: set the max seq number for
lexicals in this scope and warn of any lexicals that never got introduced.
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 * const sv = svp[off];
- if (sv && sv != &PL_sv_undef
- && !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "%"SVf" never introduced",
- SVfARG(sv));
+ if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+ "%"SVf" never introduced",
+ SVfARG(sv));
}
}
/* "Deintroduce" my variables that are leaving with this scope. */
for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
const SV * const sv = svp[off];
- if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PAD_MAX) {
+ if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
+ && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
+ {
COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
}
}
PL_cop_seqmax++;
+ if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
+ PL_cop_seqmax++;
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
}
-
/*
-=for apidoc pad_swipe
+=for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
Abandon the tmp in the current pad at offset po and replace with a
new one.
PL_padix = po - 1;
}
-
/*
-=for apidoc pad_reset
+=for apidoc m|void|pad_reset
Mark all the current temporaries for reuse
* 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
PL_pad_reset_pending = FALSE;
}
-
/*
-=for apidoc pad_tidy
+=for apidoc Amx|void|pad_tidy|padtidy_type type
+
+Tidy up a pad at the end of compilation of the code to which it belongs.
+Jobs performed here are: remove most stuff from the pads of anonsub
+prototypes; give it a @_; mark temporaries as such. I<type> indicates
+the kind of subroutine:
-Tidy up a pad after we've finished compiling it:
- * remove most stuff from the pads of anonsub prototypes;
- * give it a @_;
- * mark tmps as such.
+ padtidy_SUB ordinary subroutine
+ padtidy_SUBCLONE prototype for lexical closure
+ padtidy_FORMAT format
=cut
*/
* so that for example the eval's CV in C<< sub { eval '$x' } >> gets
* the right CvOUTSIDE.
* If running with -d, *any* sub may potentially have an eval
- * excuted within it.
+ * executed within it.
*/
if (PL_cv_has_eval || PL_perldb) {
else if (type == padtidy_SUB) {
/* 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);
}
- /* XXX DAPM rationalise these two similar branches */
-
- if (type == padtidy_SUB) {
+ if (type == padtidy_SUB || type == padtidy_FORMAT) {
+ SV * const * const namep = AvARRAY(PL_comppad_name);
PADOFFSET ix;
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
continue;
- if (!SvPADMY(PL_curpad[ix]))
- SvPADTMP_on(PL_curpad[ix]);
- }
- }
- else if (type == padtidy_FORMAT) {
- PADOFFSET ix;
- for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
- if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
+ if (!SvPADMY(PL_curpad[ix])) {
SvPADTMP_on(PL_curpad[ix]);
+ } else if (!SvFAKE(namep[ix])) {
+ /* This is a work around for how the current implementation of
+ ?{ } blocks in regexps interacts with lexicals.
+
+ One of our lexicals.
+ Can't do this on all lexicals, otherwise sub baz() won't
+ compile in
+
+ my $foo;
+
+ sub bar { ++$foo; }
+
+ sub baz { ++$foo; }
+
+ because completion of compiling &bar calling pad_tidy()
+ would cause (top level) $foo to be marked as stale, and
+ "no longer available". */
+ SvPADSTALE_on(PL_curpad[ix]);
+ }
}
}
PL_curpad = AvARRAY(PL_comppad);
}
-
/*
-=for apidoc pad_free
+=for apidoc m|void|pad_free|PADOFFSET po
Free the SV at offset po in the current pad.
if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
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
- )
- SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
-#endif
}
if ((I32)po < PL_padix)
PL_padix = po - 1;
}
-
-
/*
-=for apidoc do_dump_pad
+=for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
Dump the contents of a padlist
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,
}
}
-
+#ifdef DEBUGGING
/*
-=for apidoc cv_dump
+=for apidoc m|void|cv_dump|CV *cv|const char *title
dump the contents of a CV
=cut
*/
-#ifdef DEBUGGING
STATIC void
S_cv_dump(pTHX_ const CV *cv, const char *title)
{
" PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
do_dump_pad(1, Perl_debug_log, padlist, 1);
}
-#endif /* DEBUGGING */
-
-
-
+#endif /* DEBUGGING */
/*
-=for apidoc cv_clone
+=for apidoc Am|CV *|cv_clone|CV *proto
-Clone a CV: make a new CV which points to the same code etc, but which
-has a newly-created pad built by copying the prototype pad and capturing
-any outer lexicals.
+Clone a CV, making a lexical closure. I<proto> supplies the prototype
+of the function: its code, pad structure, and other attributes.
+The prototype is combined with a capture of outer lexicals to which the
+code refers, which are taken from the currently-executing instance of
+the immediately surrounding code.
=cut
*/
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);
ENTER;
SAVESPTR(PL_compcv);
- cv = PL_compcv = (CV*)newSV_type(SvTYPE(proto));
- CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
+ cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
+ CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
CvCLONED_on(cv);
#ifdef USE_ITHREADS
#else
CvFILE(cv) = CvFILE(proto);
#endif
- CvGV(cv) = CvGV(proto);
- CvSTASH(cv) = CvSTASH(proto);
+ CvGV_set(cv,CvGV(proto));
+ CvSTASH_set(cv, CvSTASH(proto));
OP_REFCNT_LOCK;
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);
av_fill(PL_comppad, fpad);
- for (ix = fname; ix >= 0; ix--)
+ for (ix = fname; ix > 0; ix--)
av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
PL_curpad = AvARRAY(PL_comppad);
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));
+ Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
+ "Variable \"%s\" is not available", SvPVX_const(namesv));
sv = NULL;
}
else
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);
return cv;
}
-
/*
-=for apidoc pad_fixup_inner_anons
+=for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
For any anon CVs in the pad, change CvOUTSIDE of that CV from
old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
{
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);
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;
}
}
-
/*
-=for apidoc pad_push
+=for apidoc m|void|pad_push|PADLIST *padlist|int depth
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. Then give
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;
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;
}
}
+/*
+=for apidoc Am|HV *|pad_compname_type|PADOFFSET po
+
+Looks up the type of the lexical variable at position I<po> in the
+currently-compiling pad. If the variable is typed, the stash of the
+class to which it is typed is returned. If not, C<NULL> is returned.
+
+=cut
+*/
HV *
Perl_pad_compname_type(pTHX_ const PADOFFSET po)
return NULL;
}
+#if defined(USE_ITHREADS)
+
+# define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
+
+/*
+=for apidoc m|AV *|padlist_dup|AV *srcpad|CLONE_PARAMS *param
+
+Duplicates a pad.
+
+=cut
+*/
+
+AV *
+Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
+{
+ AV *dstpad;
+ PERL_ARGS_ASSERT_PADLIST_DUP;
+
+ if (!srcpad)
+ return NULL;
+
+ assert(!AvREAL(srcpad));
+
+ if (param->flags & CLONEf_COPY_STACKS
+ || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
+ /* XXX padlists are real, but pretend to be not */
+ AvREAL_on(srcpad);
+ dstpad = av_dup_inc(srcpad, param);
+ AvREAL_off(srcpad);
+ AvREAL_off(dstpad);
+ assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
+ } else {
+ /* CvDEPTH() on our subroutine will be set to 0, so there's no need
+ to build anything other than the first level of pads. */
+
+ I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
+ AV *pad1;
+ const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
+ const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
+ SV **oldpad = AvARRAY(srcpad1);
+ SV **names;
+ SV **pad1a;
+ AV *args;
+ /* look for it in the table first.
+ I *think* that it shouldn't be possible to find it there.
+ Well, except for how Perl_sv_compile_2op() "works" :-( */
+ dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
+
+ if (dstpad)
+ return dstpad;
+
+ dstpad = newAV();
+ ptr_table_store(PL_ptr_table, srcpad, dstpad);
+ AvREAL_off(dstpad);
+ av_extend(dstpad, 1);
+ AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
+ names = AvARRAY(AvARRAY(dstpad)[0]);
+
+ pad1 = newAV();
+
+ av_extend(pad1, ix);
+ AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
+ pad1a = AvARRAY(pad1);
+ AvFILLp(dstpad) = 1;
+
+ if (ix > -1) {
+ AvFILLp(pad1) = ix;
+
+ for ( ;ix > 0; ix--) {
+ if (!oldpad[ix]) {
+ pad1a[ix] = NULL;
+ } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
+ const char sigil = SvPVX_const(names[ix])[0];
+ if ((SvFLAGS(names[ix]) & SVf_FAKE)
+ || (SvFLAGS(names[ix]) & SVpad_STATE)
+ || sigil == '&')
+ {
+ /* outer lexical or anon code */
+ pad1a[ix] = sv_dup_inc(oldpad[ix], param);
+ }
+ else { /* our own lexical */
+ if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
+ /* This is a work around for how the current
+ implementation of ?{ } blocks in regexps
+ interacts with lexicals. */
+ pad1a[ix] = sv_dup_inc(oldpad[ix], param);
+ } else {
+ SV *sv;
+
+ if (sigil == '@')
+ sv = MUTABLE_SV(newAV());
+ else if (sigil == '%')
+ sv = MUTABLE_SV(newHV());
+ else
+ sv = newSV(0);
+ pad1a[ix] = sv;
+ SvPADMY_on(sv);
+ }
+ }
+ }
+ else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+ pad1a[ix] = sv_dup_inc(oldpad[ix], param);
+ }
+ else {
+ /* save temporaries on recursion? */
+ SV * const sv = newSV(0);
+ pad1a[ix] = sv;
+
+ /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
+ FIXTHAT before merging this branch.
+ (And I know how to) */
+ if (SvPADMY(oldpad[ix]))
+ SvPADMY_on(sv);
+ else
+ SvPADTMP_on(sv);
+ }
+ }
+
+ if (oldpad[0]) {
+ args = newAV(); /* Will be @_ */
+ AvREIFY_only(args);
+ pad1a[0] = (SV *)args;
+ }
+ }
+ }
+
+ return dstpad;
+}
+
+#endif /* USE_ITHREADS */
+
/*
* Local variables:
* c-indentation-style: bsd