This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Allow CVs to point to HEKs rather than GVs
[perl5.git] / pad.c
1 /*    pad.c
2  *
3  *    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
4  *    by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  */
9
10 /*
11  *  'Anyway: there was this Mr. Frodo left an orphan and stranded, as you
12  *   might say, among those queer Bucklanders, being brought up anyhow in
13  *   Brandy Hall.  A regular warren, by all accounts.  Old Master Gorbadoc
14  *   never had fewer than a couple of hundred relations in the place.
15  *   Mr. Bilbo never did a kinder deed than when he brought the lad back
16  *   to live among decent folk.'                           --the Gaffer
17  *
18  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
19  */
20
21 /* XXX DAPM
22  * As of Sept 2002, this file is new and may be in a state of flux for
23  * a while. I've marked things I intent to come back and look at further
24  * with an 'XXX DAPM' comment.
25  */
26
27 /*
28 =head1 Pad Data Structures
29
30 =for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
31
32 CV's can have CvPADLIST(cv) set to point to a PADLIST.  This is the CV's
33 scratchpad, which stores lexical variables and opcode temporary and
34 per-thread values.
35
36 For these purposes "formats" are a kind-of CV; eval""s are too (except they're
37 not callable at will and are always thrown away after the eval"" is done
38 executing).  Require'd files are simply evals without any outer lexical
39 scope.
40
41 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
42 but that is really the callers pad (a slot of which is allocated by
43 every entersub).
44
45 The PADLIST has a C array where pads are stored.
46
47 The 0th entry of the PADLIST is a PADNAMELIST (which is actually just an
48 AV, but that may change) which represents the "names" or rather
49 the "static type information" for lexicals.  The individual elements of a
50 PADNAMELIST are PADNAMEs (just SVs; but, again, that may change).  Future
51 refactorings might stop the PADNAMELIST from being stored in the PADLIST's
52 array, so don't rely on it.  See L</PadlistNAMES>.
53
54 The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
55 at that depth of recursion into the CV.  The 0th slot of a frame AV is an
56 AV which is @_.  Other entries are storage for variables and op targets.
57
58 Iterating over the PADNAMELIST iterates over all possible pad
59 items.  Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
60 &PL_sv_undef "names" (see pad_alloc()).
61
62 Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
63 The rest are op targets/GVs/constants which are statically allocated
64 or resolved at compile time.  These don't have names by which they
65 can be looked up from Perl code at run time through eval"" the way
66 my/our variables can be.  Since they can't be looked up by "name"
67 but only by their index allocated at compile time (which is usually
68 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
69
70 The SVs in the names AV have their PV being the name of the variable.
71 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
72 which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
73 _HIGH).  During compilation, these fields may hold the special value
74 PERL_PADSEQ_INTRO to indicate various stages:
75
76    COP_SEQ_RANGE_LOW        _HIGH
77    -----------------        -----
78    PERL_PADSEQ_INTRO            0   variable not yet introduced:   { my ($x
79    valid-seq#   PERL_PADSEQ_INTRO   variable in scope:             { my ($x)
80    valid-seq#          valid-seq#   compilation of scope complete: { my ($x) }
81
82 For typed lexicals name SV is SVt_PVMG and SvSTASH
83 points at the type.  For C<our> lexicals, the type is also SVt_PVMG, with the
84 SvOURSTASH slot pointing at the stash of the associated global (so that
85 duplicate C<our> declarations in the same package can be detected).  SvUVX is
86 sometimes hijacked to store the generation number during compilation.
87
88 If PADNAME_OUTER (SvFAKE) is set on the
89 name SV, then that slot in the frame AV is
90 a REFCNT'ed reference to a lexical from "outside". In this case,
91 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
92 in scope throughout. Instead xhigh stores some flags containing info about
93 the real lexical (is it declared in an anon, and is it capable of being
94 instantiated multiple times?), and for fake ANONs, xlow contains the index
95 within the parent's pad where the lexical's value is stored, to make
96 cloning quicker.
97
98 If the 'name' is '&' the corresponding entry in the PAD
99 is a CV representing a possible closure.
100 (PADNAME_OUTER and name of '&' is not a
101 meaningful combination currently but could
102 become so if C<my sub foo {}> is implemented.)
103
104 Note that formats are treated as anon subs, and are cloned each time
105 write is called (if necessary).
106
107 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
108 and set on scope exit.  This allows the
109 'Variable $x is not available' warning
110 to be generated in evals, such as 
111
112     { my $x = 1; sub f { eval '$x'} } f();
113
114 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
115
116 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
117
118 During compilation, this points to the array containing the names part
119 of the pad for the currently-compiling code.
120
121 =for apidoc AmxU|PAD *|PL_comppad
122
123 During compilation, this points to the array containing the values
124 part of the pad for the currently-compiling code.  (At runtime a CV may
125 have many such value arrays; at compile time just one is constructed.)
126 At runtime, this points to the array containing the currently-relevant
127 values for the pad for the currently-executing code.
128
129 =for apidoc AmxU|SV **|PL_curpad
130
131 Points directly to the body of the L</PL_comppad> array.
132 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
133
134 =cut
135 */
136
137
138 #include "EXTERN.h"
139 #define PERL_IN_PAD_C
140 #include "perl.h"
141 #include "keywords.h"
142
143 #define COP_SEQ_RANGE_LOW_set(sv,val)           \
144   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
145 #define COP_SEQ_RANGE_HIGH_set(sv,val)          \
146   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
147
148 #define PARENT_PAD_INDEX_set(sv,val)            \
149   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
150 #define PARENT_FAKELEX_FLAGS_set(sv,val)        \
151   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
152
153 /*
154 =for apidoc mx|void|pad_peg|const char *s
155
156 When PERL_MAD is enabled, this is a small no-op function that gets called
157 at the start of each pad-related function.  It can be breakpointed to
158 track all pad operations.  The parameter is a string indicating the type
159 of pad operation being performed.
160
161 =cut
162 */
163
164 #ifdef PERL_MAD
165 void pad_peg(const char* s) {
166     static int pegcnt; /* XXX not threadsafe */
167     PERL_UNUSED_ARG(s);
168
169     PERL_ARGS_ASSERT_PAD_PEG;
170
171     pegcnt++;
172 }
173 #endif
174
175 /*
176 This is basically sv_eq_flags() in sv.c, but we avoid the magic
177 and bytes checking.
178 */
179
180 static bool
181 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
182     if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
183         const char *pv1 = SvPVX_const(sv);
184         STRLEN cur1     = SvCUR(sv);
185         const char *pv2 = pv;
186         STRLEN cur2     = pvlen;
187         if (PL_encoding) {
188               SV* svrecode = NULL;
189               if (SvUTF8(sv)) {
190                    svrecode = newSVpvn(pv2, cur2);
191                    sv_recode_to_utf8(svrecode, PL_encoding);
192                    pv2      = SvPV_const(svrecode, cur2);
193               }
194               else {
195                    svrecode = newSVpvn(pv1, cur1);
196                    sv_recode_to_utf8(svrecode, PL_encoding);
197                    pv1      = SvPV_const(svrecode, cur1);
198               }
199               SvREFCNT_dec(svrecode);
200         }
201         if (flags & SVf_UTF8)
202             return (bytes_cmp_utf8(
203                         (const U8*)pv1, cur1,
204                         (const U8*)pv2, cur2) == 0);
205         else
206             return (bytes_cmp_utf8(
207                         (const U8*)pv2, cur2,
208                         (const U8*)pv1, cur1) == 0);
209     }
210     else
211         return ((SvPVX_const(sv) == pv)
212                     || memEQ(SvPVX_const(sv), pv, pvlen));
213 }
214
215
216 /*
217 =for apidoc Am|PADLIST *|pad_new|int flags
218
219 Create a new padlist, updating the global variables for the
220 currently-compiling padlist to point to the new padlist.  The following
221 flags can be OR'ed together:
222
223     padnew_CLONE        this pad is for a cloned CV
224     padnew_SAVE         save old globals on the save stack
225     padnew_SAVESUB      also save extra stuff for start of sub
226
227 =cut
228 */
229
230 PADLIST *
231 Perl_pad_new(pTHX_ int flags)
232 {
233     dVAR;
234     PADLIST *padlist;
235     PAD *padname, *pad;
236     PAD **ary;
237
238     ASSERT_CURPAD_LEGAL("pad_new");
239
240     /* XXX DAPM really need a new SAVEt_PAD which restores all or most
241      * vars (based on flags) rather than storing vals + addresses for
242      * each individually. Also see pad_block_start.
243      * XXX DAPM Try to see whether all these conditionals are required
244      */
245
246     /* save existing state, ... */
247
248     if (flags & padnew_SAVE) {
249         SAVECOMPPAD();
250         if (! (flags & padnew_CLONE)) {
251             SAVESPTR(PL_comppad_name);
252             SAVEI32(PL_padix);
253             SAVEI32(PL_comppad_name_fill);
254             SAVEI32(PL_min_intro_pending);
255             SAVEI32(PL_max_intro_pending);
256             SAVEBOOL(PL_cv_has_eval);
257             if (flags & padnew_SAVESUB) {
258                 SAVEBOOL(PL_pad_reset_pending);
259             }
260         }
261     }
262     /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
263      * saved - check at some pt that this is okay */
264
265     /* ... create new pad ... */
266
267     Newxz(padlist, 1, PADLIST);
268     pad         = newAV();
269
270     if (flags & padnew_CLONE) {
271         /* XXX DAPM  I dont know why cv_clone needs it
272          * doing differently yet - perhaps this separate branch can be
273          * dispensed with eventually ???
274          */
275
276         AV * const a0 = newAV();                        /* will be @_ */
277         av_store(pad, 0, MUTABLE_SV(a0));
278         AvREIFY_only(a0);
279
280         padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
281     }
282     else {
283         padlist->xpadl_id = PL_padlist_generation++;
284         av_store(pad, 0, NULL);
285         padname = newAV();
286     }
287
288     /* Most subroutines never recurse, hence only need 2 entries in the padlist
289        array - names, and depth=1.  The default for av_store() is to allocate
290        0..3, and even an explicit call to av_extend() with <3 will be rounded
291        up, so we inline the allocation of the array here.  */
292     Newx(ary, 2, PAD *);
293     PadlistMAX(padlist) = 1;
294     PadlistARRAY(padlist) = ary;
295     ary[0] = padname;
296     ary[1] = pad;
297
298     /* ... then update state variables */
299
300     PL_comppad          = pad;
301     PL_curpad           = AvARRAY(pad);
302
303     if (! (flags & padnew_CLONE)) {
304         PL_comppad_name      = padname;
305         PL_comppad_name_fill = 0;
306         PL_min_intro_pending = 0;
307         PL_padix             = 0;
308         PL_cv_has_eval       = 0;
309     }
310
311     DEBUG_X(PerlIO_printf(Perl_debug_log,
312           "Pad 0x%"UVxf"[0x%"UVxf"] new:       compcv=0x%"UVxf
313               " name=0x%"UVxf" flags=0x%"UVxf"\n",
314           PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
315               PTR2UV(padname), (UV)flags
316         )
317     );
318
319     return (PADLIST*)padlist;
320 }
321
322
323 /*
324 =head1 Embedding Functions
325
326 =for apidoc cv_undef
327
328 Clear out all the active components of a CV. This can happen either
329 by an explicit C<undef &foo>, or by the reference count going to zero.
330 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
331 children can still follow the full lexical scope chain.
332
333 =cut
334 */
335
336 void
337 Perl_cv_undef(pTHX_ CV *cv)
338 {
339     dVAR;
340     const PADLIST *padlist = CvPADLIST(cv);
341     bool const slabbed = !!CvSLABBED(cv);
342
343     PERL_ARGS_ASSERT_CV_UNDEF;
344
345     DEBUG_X(PerlIO_printf(Perl_debug_log,
346           "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
347             PTR2UV(cv), PTR2UV(PL_comppad))
348     );
349
350     if (CvFILE(cv) && CvDYNFILE(cv)) {
351         Safefree(CvFILE(cv));
352     }
353     CvFILE(cv) = NULL;
354
355     CvSLABBED_off(cv);
356     if (!CvISXSUB(cv) && CvROOT(cv)) {
357         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
358             Perl_croak(aTHX_ "Can't undef active subroutine");
359         ENTER;
360
361         PAD_SAVE_SETNULLPAD();
362
363         if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
364         op_free(CvROOT(cv));
365         CvROOT(cv) = NULL;
366         CvSTART(cv) = NULL;
367         LEAVE;
368     }
369     else if (slabbed && CvSTART(cv)) {
370         ENTER;
371         PAD_SAVE_SETNULLPAD();
372
373         /* discard any leaked ops */
374         opslab_force_free((OPSLAB *)CvSTART(cv));
375         CvSTART(cv) = NULL;
376
377         LEAVE;
378     }
379 #ifdef DEBUGGING
380     else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
381 #endif
382     SvPOK_off(MUTABLE_SV(cv));          /* forget prototype */
383     sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
384     if (CvNAMED(cv)) unshare_hek(CvNAME_HEK(cv));
385     else             CvGV_set(cv, NULL);
386
387     /* This statement and the subsequence if block was pad_undef().  */
388     pad_peg("pad_undef");
389
390     if (padlist) {
391         I32 ix;
392
393         /* Free the padlist associated with a CV.
394            If parts of it happen to be current, we null the relevant PL_*pad*
395            global vars so that we don't have any dangling references left.
396            We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
397            subs to the outer of this cv.  */
398
399         DEBUG_X(PerlIO_printf(Perl_debug_log,
400                               "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
401                               PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
402                 );
403
404         /* detach any '&' anon children in the pad; if afterwards they
405          * are still live, fix up their CvOUTSIDEs to point to our outside,
406          * bypassing us. */
407         /* XXX DAPM for efficiency, we should only do this if we know we have
408          * children, or integrate this loop with general cleanup */
409
410         if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
411             CV * const outercv = CvOUTSIDE(cv);
412             const U32 seq = CvOUTSIDE_SEQ(cv);
413             PAD * const comppad_name = PadlistARRAY(padlist)[0];
414             SV ** const namepad = AvARRAY(comppad_name);
415             PAD * const comppad = PadlistARRAY(padlist)[1];
416             SV ** const curpad = AvARRAY(comppad);
417             for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
418                 SV * const namesv = namepad[ix];
419                 if (namesv && namesv != &PL_sv_undef
420                     && *SvPVX_const(namesv) == '&')
421                     {
422                         CV * const innercv = MUTABLE_CV(curpad[ix]);
423                         U32 inner_rc = SvREFCNT(innercv);
424                         assert(inner_rc);
425                         assert(SvTYPE(innercv) != SVt_PVFM);
426
427                         if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/  */
428                             curpad[ix] = NULL;
429                             SvREFCNT_dec(innercv);
430                             inner_rc--;
431                         }
432
433                         /* in use, not just a prototype */
434                         if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
435                             assert(CvWEAKOUTSIDE(innercv));
436                             /* don't relink to grandfather if he's being freed */
437                             if (outercv && SvREFCNT(outercv)) {
438                                 CvWEAKOUTSIDE_off(innercv);
439                                 CvOUTSIDE(innercv) = outercv;
440                                 CvOUTSIDE_SEQ(innercv) = seq;
441                                 SvREFCNT_inc_simple_void_NN(outercv);
442                             }
443                             else {
444                                 CvOUTSIDE(innercv) = NULL;
445                             }
446                         }
447                     }
448             }
449         }
450
451         ix = PadlistMAX(padlist);
452         while (ix > 0) {
453             PAD * const sv = PadlistARRAY(padlist)[ix--];
454             if (sv) {
455                 if (sv == PL_comppad) {
456                     PL_comppad = NULL;
457                     PL_curpad = NULL;
458                 }
459                 SvREFCNT_dec(sv);
460             }
461         }
462         {
463             PAD * const sv = PadlistARRAY(padlist)[0];
464             if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
465                 PL_comppad_name = NULL;
466             SvREFCNT_dec(sv);
467         }
468         if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
469         Safefree(padlist);
470         CvPADLIST(cv) = NULL;
471     }
472
473
474     /* remove CvOUTSIDE unless this is an undef rather than a free */
475     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
476         if (!CvWEAKOUTSIDE(cv))
477             SvREFCNT_dec(CvOUTSIDE(cv));
478         CvOUTSIDE(cv) = NULL;
479     }
480     if (CvCONST(cv)) {
481         SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
482         CvCONST_off(cv);
483     }
484     if (CvISXSUB(cv) && CvXSUB(cv)) {
485         CvXSUB(cv) = NULL;
486     }
487     /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
488      * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
489      * to choose an error message */
490     CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
491 }
492
493 /*
494 =for apidoc cv_forget_slab
495
496 When a CV has a reference count on its slab (CvSLABBED), it is responsible
497 for making sure it is freed.  (Hence, no two CVs should ever have a
498 reference count on the same slab.)  The CV only needs to reference the slab
499 during compilation.  Once it is compiled and CvROOT attached, it has
500 finished its job, so it can forget the slab.
501
502 =cut
503 */
504
505 void
506 Perl_cv_forget_slab(pTHX_ CV *cv)
507 {
508     const bool slabbed = !!CvSLABBED(cv);
509     OPSLAB *slab = NULL;
510
511     PERL_ARGS_ASSERT_CV_FORGET_SLAB;
512
513     if (!slabbed) return;
514
515     CvSLABBED_off(cv);
516
517     if      (CvROOT(cv))  slab = OpSLAB(CvROOT(cv));
518     else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
519 #ifdef DEBUGGING
520     else if (slabbed)     Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
521 #endif
522
523     if (slab) {
524 #ifdef PERL_DEBUG_READONLY_OPS
525         const size_t refcnt = slab->opslab_refcnt;
526 #endif
527         OpslabREFCNT_dec(slab);
528 #ifdef PERL_DEBUG_READONLY_OPS
529         if (refcnt > 1) Slab_to_ro(slab);
530 #endif
531     }
532 }
533
534 /*
535 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
536
537 Allocates a place in the currently-compiling
538 pad (via L<perlapi/pad_alloc>) and
539 then stores a name for that entry.  I<namesv> is adopted and becomes the
540 name entry; it must already contain the name string and be sufficiently
541 upgraded.  I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
542 added to I<namesv>.  None of the other
543 processing of L<perlapi/pad_add_name_pvn>
544 is done.  Returns the offset of the allocated pad slot.
545
546 =cut
547 */
548
549 static PADOFFSET
550 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
551 {
552     dVAR;
553     const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
554
555     PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
556
557     ASSERT_CURPAD_ACTIVE("pad_alloc_name");
558
559     if (typestash) {
560         assert(SvTYPE(namesv) == SVt_PVMG);
561         SvPAD_TYPED_on(namesv);
562         SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
563     }
564     if (ourstash) {
565         SvPAD_OUR_on(namesv);
566         SvOURSTASH_set(namesv, ourstash);
567         SvREFCNT_inc_simple_void_NN(ourstash);
568     }
569     else if (flags & padadd_STATE) {
570         SvPAD_STATE_on(namesv);
571     }
572
573     av_store(PL_comppad_name, offset, namesv);
574     return offset;
575 }
576
577 /*
578 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
579
580 Allocates a place in the currently-compiling pad for a named lexical
581 variable.  Stores the name and other metadata in the name part of the
582 pad, and makes preparations to manage the variable's lexical scoping.
583 Returns the offset of the allocated pad slot.
584
585 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
586 If I<typestash> is non-null, the name is for a typed lexical, and this
587 identifies the type.  If I<ourstash> is non-null, it's a lexical reference
588 to a package variable, and this identifies the package.  The following
589 flags can be OR'ed together:
590
591     padadd_OUR          redundantly specifies if it's a package var
592     padadd_STATE        variable will retain value persistently
593     padadd_NO_DUP_CHECK skip check for lexical shadowing
594
595 =cut
596 */
597
598 PADOFFSET
599 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
600                 U32 flags, HV *typestash, HV *ourstash)
601 {
602     dVAR;
603     PADOFFSET offset;
604     SV *namesv;
605     bool is_utf8;
606
607     PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
608
609     if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
610         Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
611                    (UV)flags);
612
613     namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
614     
615     if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
616         namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
617     }
618
619     sv_setpvn(namesv, namepv, namelen);
620
621     if (is_utf8) {
622         flags |= padadd_UTF8_NAME;
623         SvUTF8_on(namesv);
624     }
625     else
626         flags &= ~padadd_UTF8_NAME;
627
628     if ((flags & padadd_NO_DUP_CHECK) == 0) {
629         /* check for duplicate declaration */
630         pad_check_dup(namesv, flags & padadd_OUR, ourstash);
631     }
632
633     offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
634
635     /* not yet introduced */
636     COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
637     COP_SEQ_RANGE_HIGH_set(namesv, 0);
638
639     if (!PL_min_intro_pending)
640         PL_min_intro_pending = offset;
641     PL_max_intro_pending = offset;
642     /* if it's not a simple scalar, replace with an AV or HV */
643     assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
644     assert(SvREFCNT(PL_curpad[offset]) == 1);
645     if (namelen != 0 && *namepv == '@')
646         sv_upgrade(PL_curpad[offset], SVt_PVAV);
647     else if (namelen != 0 && *namepv == '%')
648         sv_upgrade(PL_curpad[offset], SVt_PVHV);
649     assert(SvPADMY(PL_curpad[offset]));
650     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
651                            "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
652                            (long)offset, SvPVX(namesv),
653                            PTR2UV(PL_curpad[offset])));
654
655     return offset;
656 }
657
658 /*
659 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
660
661 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
662 instead of a string/length pair.
663
664 =cut
665 */
666
667 PADOFFSET
668 Perl_pad_add_name_pv(pTHX_ const char *name,
669                      const U32 flags, HV *typestash, HV *ourstash)
670 {
671     PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
672     return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
673 }
674
675 /*
676 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
677
678 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
679 of an SV instead of a string/length pair.
680
681 =cut
682 */
683
684 PADOFFSET
685 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
686 {
687     char *namepv;
688     STRLEN namelen;
689     PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
690     namepv = SvPV(name, namelen);
691     if (SvUTF8(name))
692         flags |= padadd_UTF8_NAME;
693     return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
694 }
695
696 /*
697 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
698
699 Allocates a place in the currently-compiling pad,
700 returning the offset of the allocated pad slot.
701 No name is initially attached to the pad slot.
702 I<tmptype> is a set of flags indicating the kind of pad entry required,
703 which will be set in the value SV for the allocated pad entry:
704
705     SVs_PADMY    named lexical variable ("my", "our", "state")
706     SVs_PADTMP   unnamed temporary store
707
708 I<optype> should be an opcode indicating the type of operation that the
709 pad entry is to support.  This doesn't affect operational semantics,
710 but is used for debugging.
711
712 =cut
713 */
714
715 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
716  * or at least rationalise ??? */
717
718 PADOFFSET
719 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
720 {
721     dVAR;
722     SV *sv;
723     I32 retval;
724
725     PERL_UNUSED_ARG(optype);
726     ASSERT_CURPAD_ACTIVE("pad_alloc");
727
728     if (AvARRAY(PL_comppad) != PL_curpad)
729         Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
730                    AvARRAY(PL_comppad), PL_curpad);
731     if (PL_pad_reset_pending)
732         pad_reset();
733     if (tmptype & SVs_PADMY) {
734         /* For a my, simply push a null SV onto the end of PL_comppad. */
735         sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
736         retval = AvFILLp(PL_comppad);
737     }
738     else {
739         /* For a tmp, scan the pad from PL_padix upwards
740          * for a slot which has no name and no active value.
741          */
742         SV * const * const names = AvARRAY(PL_comppad_name);
743         const SSize_t names_fill = AvFILLp(PL_comppad_name);
744         for (;;) {
745             /*
746              * "foreach" index vars temporarily become aliases to non-"my"
747              * values.  Thus we must skip, not just pad values that are
748              * marked as current pad values, but also those with names.
749              */
750             /* HVDS why copy to sv here? we don't seem to use it */
751             if (++PL_padix <= names_fill &&
752                    (sv = names[PL_padix]) && sv != &PL_sv_undef)
753                 continue;
754             sv = *av_fetch(PL_comppad, PL_padix, TRUE);
755             if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
756                 !IS_PADGV(sv) && !IS_PADCONST(sv))
757                 break;
758         }
759         retval = PL_padix;
760     }
761     SvFLAGS(sv) |= tmptype;
762     PL_curpad = AvARRAY(PL_comppad);
763
764     DEBUG_X(PerlIO_printf(Perl_debug_log,
765           "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
766           PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
767           PL_op_name[optype]));
768 #ifdef DEBUG_LEAKING_SCALARS
769     sv->sv_debug_optype = optype;
770     sv->sv_debug_inpad = 1;
771 #endif
772     return (PADOFFSET)retval;
773 }
774
775 /*
776 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
777
778 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
779 for an anonymous function that is lexically scoped inside the
780 currently-compiling function.
781 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
782 to the outer scope is weakened to avoid a reference loop.
783
784 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
785
786 I<optype> should be an opcode indicating the type of operation that the
787 pad entry is to support.  This doesn't affect operational semantics,
788 but is used for debugging.
789
790 =cut
791 */
792
793 PADOFFSET
794 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
795 {
796     dVAR;
797     PADOFFSET ix;
798     SV* const name = newSV_type(SVt_PVNV);
799
800     PERL_ARGS_ASSERT_PAD_ADD_ANON;
801
802     pad_peg("add_anon");
803     sv_setpvs(name, "&");
804     /* These two aren't used; just make sure they're not equal to
805      * PERL_PADSEQ_INTRO */
806     COP_SEQ_RANGE_LOW_set(name, 0);
807     COP_SEQ_RANGE_HIGH_set(name, 0);
808     ix = pad_alloc(optype, SVs_PADMY);
809     av_store(PL_comppad_name, ix, name);
810     /* XXX DAPM use PL_curpad[] ? */
811     if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
812         av_store(PL_comppad, ix, (SV*)func);
813     else {
814         SV *rv = newRV_noinc((SV *)func);
815         sv_rvweaken(rv);
816         assert (SvTYPE(func) == SVt_PVFM);
817         av_store(PL_comppad, ix, rv);
818     }
819     SvPADMY_on((SV*)func);
820
821     /* to avoid ref loops, we never have parent + child referencing each
822      * other simultaneously */
823     if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
824         assert(!CvWEAKOUTSIDE(func));
825         CvWEAKOUTSIDE_on(func);
826         SvREFCNT_dec(CvOUTSIDE(func));
827     }
828     return ix;
829 }
830
831 /*
832 =for apidoc pad_check_dup
833
834 Check for duplicate declarations: report any of:
835
836      * a my in the current scope with the same name;
837      * an our (anywhere in the pad) with the same name and the
838        same stash as C<ourstash>
839
840 C<is_our> indicates that the name to check is an 'our' declaration.
841
842 =cut
843 */
844
845 STATIC void
846 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
847 {
848     dVAR;
849     SV          **svp;
850     PADOFFSET   top, off;
851     const U32   is_our = flags & padadd_OUR;
852
853     PERL_ARGS_ASSERT_PAD_CHECK_DUP;
854
855     ASSERT_CURPAD_ACTIVE("pad_check_dup");
856
857     assert((flags & ~padadd_OUR) == 0);
858
859     if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
860         return; /* nothing to check */
861
862     svp = AvARRAY(PL_comppad_name);
863     top = AvFILLp(PL_comppad_name);
864     /* check the current scope */
865     /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
866      * type ? */
867     for (off = top; (I32)off > PL_comppad_name_floor; off--) {
868         SV * const sv = svp[off];
869         if (sv
870             && sv != &PL_sv_undef
871             && !SvFAKE(sv)
872             && (   COP_SEQ_RANGE_LOW(sv)  == PERL_PADSEQ_INTRO
873                 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
874             && sv_eq(name, sv))
875         {
876             if (is_our && (SvPAD_OUR(sv)))
877                 break; /* "our" masking "our" */
878             Perl_warner(aTHX_ packWARN(WARN_MISC),
879                 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
880                 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
881                 sv,
882                 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
883                     ? "scope" : "statement"));
884             --off;
885             break;
886         }
887     }
888     /* check the rest of the pad */
889     if (is_our) {
890         while (off > 0) {
891             SV * const sv = svp[off];
892             if (sv
893                 && sv != &PL_sv_undef
894                 && !SvFAKE(sv)
895                 && (   COP_SEQ_RANGE_LOW(sv)  == PERL_PADSEQ_INTRO
896                     || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
897                 && SvOURSTASH(sv) == ourstash
898                 && sv_eq(name, sv))
899             {
900                 Perl_warner(aTHX_ packWARN(WARN_MISC),
901                     "\"our\" variable %"SVf" redeclared", sv);
902                 if ((I32)off <= PL_comppad_name_floor)
903                     Perl_warner(aTHX_ packWARN(WARN_MISC),
904                         "\t(Did you mean \"local\" instead of \"our\"?)\n");
905                 break;
906             }
907             --off;
908         }
909     }
910 }
911
912
913 /*
914 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
915
916 Given the name of a lexical variable, find its position in the
917 currently-compiling pad.
918 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
919 I<flags> is reserved and must be zero.
920 If it is not in the current pad but appears in the pad of any lexically
921 enclosing scope, then a pseudo-entry for it is added in the current pad.
922 Returns the offset in the current pad,
923 or C<NOT_IN_PAD> if no such lexical is in scope.
924
925 =cut
926 */
927
928 PADOFFSET
929 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
930 {
931     dVAR;
932     SV *out_sv;
933     int out_flags;
934     I32 offset;
935     const AV *nameav;
936     SV **name_svp;
937
938     PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
939
940     pad_peg("pad_findmy_pvn");
941
942     if (flags & ~padadd_UTF8_NAME)
943         Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
944                    (UV)flags);
945
946     if (flags & padadd_UTF8_NAME) {
947         bool is_utf8 = TRUE;
948         namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
949
950         if (is_utf8)
951             flags |= padadd_UTF8_NAME;
952         else
953             flags &= ~padadd_UTF8_NAME;
954     }
955
956     offset = pad_findlex(namepv, namelen, flags,
957                 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
958     if ((PADOFFSET)offset != NOT_IN_PAD) 
959         return offset;
960
961     /* look for an our that's being introduced; this allows
962      *    our $foo = 0 unless defined $foo;
963      * to not give a warning. (Yes, this is a hack) */
964
965     nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
966     name_svp = AvARRAY(nameav);
967     for (offset = AvFILLp(nameav); offset > 0; offset--) {
968         const SV * const namesv = name_svp[offset];
969         if (namesv && namesv != &PL_sv_undef
970             && !SvFAKE(namesv)
971             && (SvPAD_OUR(namesv))
972             && SvCUR(namesv) == namelen
973             && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
974                                 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
975             && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
976         )
977             return offset;
978     }
979     return NOT_IN_PAD;
980 }
981
982 /*
983 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
984
985 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
986 instead of a string/length pair.
987
988 =cut
989 */
990
991 PADOFFSET
992 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
993 {
994     PERL_ARGS_ASSERT_PAD_FINDMY_PV;
995     return pad_findmy_pvn(name, strlen(name), flags);
996 }
997
998 /*
999 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1000
1001 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1002 of an SV instead of a string/length pair.
1003
1004 =cut
1005 */
1006
1007 PADOFFSET
1008 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1009 {
1010     char *namepv;
1011     STRLEN namelen;
1012     PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1013     namepv = SvPV(name, namelen);
1014     if (SvUTF8(name))
1015         flags |= padadd_UTF8_NAME;
1016     return pad_findmy_pvn(namepv, namelen, flags);
1017 }
1018
1019 /*
1020 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1021
1022 Find the position of the lexical C<$_> in the pad of the
1023 currently-executing function.  Returns the offset in the current pad,
1024 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1025 the global one should be used instead).
1026 L</find_rundefsv> is likely to be more convenient.
1027
1028 =cut
1029 */
1030
1031 PADOFFSET
1032 Perl_find_rundefsvoffset(pTHX)
1033 {
1034     dVAR;
1035     SV *out_sv;
1036     int out_flags;
1037     return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1038             NULL, &out_sv, &out_flags);
1039 }
1040
1041 /*
1042 =for apidoc Am|SV *|find_rundefsv
1043
1044 Find and return the variable that is named C<$_> in the lexical scope
1045 of the currently-executing function.  This may be a lexical C<$_>,
1046 or will otherwise be the global one.
1047
1048 =cut
1049 */
1050
1051 SV *
1052 Perl_find_rundefsv(pTHX)
1053 {
1054     SV *namesv;
1055     int flags;
1056     PADOFFSET po;
1057
1058     po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1059             NULL, &namesv, &flags);
1060
1061     if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1062         return DEFSV;
1063
1064     return PAD_SVl(po);
1065 }
1066
1067 SV *
1068 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1069 {
1070     SV *namesv;
1071     int flags;
1072     PADOFFSET po;
1073
1074     PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1075
1076     po = pad_findlex("$_", 2, 0, cv, seq, 1,
1077             NULL, &namesv, &flags);
1078
1079     if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1080         return DEFSV;
1081
1082     return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1083 }
1084
1085 /*
1086 =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
1087
1088 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1089 in the inner pads if it's found in an outer one.
1090
1091 Returns the offset in the bottom pad of the lex or the fake lex.
1092 cv is the CV in which to start the search, and seq is the current cop_seq
1093 to match against. If warn is true, print appropriate warnings.  The out_*
1094 vars return values, and so are pointers to where the returned values
1095 should be stored. out_capture, if non-null, requests that the innermost
1096 instance of the lexical is captured; out_name_sv is set to the innermost
1097 matched namesv or fake namesv; out_flags returns the flags normally
1098 associated with the IVX field of a fake namesv.
1099
1100 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1101 then comes back down, adding fake entries as it goes. It has to be this way
1102 because fake namesvs in anon protoypes have to store in xlow the index into
1103 the parent pad.
1104
1105 =cut
1106 */
1107
1108 /* the CV has finished being compiled. This is not a sufficient test for
1109  * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1110 #define CvCOMPILED(cv)  CvROOT(cv)
1111
1112 /* the CV does late binding of its lexicals */
1113 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
1114
1115
1116 STATIC PADOFFSET
1117 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1118         int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1119 {
1120     dVAR;
1121     I32 offset, new_offset;
1122     SV *new_capture;
1123     SV **new_capturep;
1124     const PADLIST * const padlist = CvPADLIST(cv);
1125     const bool staleok = !!(flags & padadd_STALEOK);
1126
1127     PERL_ARGS_ASSERT_PAD_FINDLEX;
1128
1129     if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1130         Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1131                    (UV)flags);
1132     flags &= ~ padadd_STALEOK; /* one-shot flag */
1133
1134     *out_flags = 0;
1135
1136     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1137         "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1138                            PTR2UV(cv), (int)namelen, namepv, (int)seq,
1139         out_capture ? " capturing" : "" ));
1140
1141     /* first, search this pad */
1142
1143     if (padlist) { /* not an undef CV */
1144         I32 fake_offset = 0;
1145         const AV * const nameav = PadlistARRAY(padlist)[0];
1146         SV * const * const name_svp = AvARRAY(nameav);
1147
1148         for (offset = AvFILLp(nameav); offset > 0; offset--) {
1149             const SV * const namesv = name_svp[offset];
1150             if (namesv && namesv != &PL_sv_undef
1151                     && SvCUR(namesv) == namelen
1152                     && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1153                                     flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1154             {
1155                 if (SvFAKE(namesv)) {
1156                     fake_offset = offset; /* in case we don't find a real one */
1157                     continue;
1158                 }
1159                 /* is seq within the range _LOW to _HIGH ?
1160                  * This is complicated by the fact that PL_cop_seqmax
1161                  * may have wrapped around at some point */
1162                 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1163                     continue; /* not yet introduced */
1164
1165                 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1166                     /* in compiling scope */
1167                     if (
1168                         (seq >  COP_SEQ_RANGE_LOW(namesv))
1169                         ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1170                         : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1171                     )
1172                        break;
1173                 }
1174                 else if (
1175                     (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1176                     ?
1177                         (  seq >  COP_SEQ_RANGE_LOW(namesv)
1178                         || seq <= COP_SEQ_RANGE_HIGH(namesv))
1179
1180                     :    (  seq >  COP_SEQ_RANGE_LOW(namesv)
1181                          && seq <= COP_SEQ_RANGE_HIGH(namesv))
1182                 )
1183                 break;
1184             }
1185         }
1186
1187         if (offset > 0 || fake_offset > 0 ) { /* a match! */
1188             if (offset > 0) { /* not fake */
1189                 fake_offset = 0;
1190                 *out_name_sv = name_svp[offset]; /* return the namesv */
1191
1192                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1193                  * instances. For now, we just test !CvUNIQUE(cv), but
1194                  * ideally, we should detect my's declared within loops
1195                  * etc - this would allow a wider range of 'not stayed
1196                  * shared' warnings. We also treated already-compiled
1197                  * lexes as not multi as viewed from evals. */
1198
1199                 *out_flags = CvANON(cv) ?
1200                         PAD_FAKELEX_ANON :
1201                             (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1202                                 ? PAD_FAKELEX_MULTI : 0;
1203
1204                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1205                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1206                     PTR2UV(cv), (long)offset,
1207                     (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1208                     (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1209             }
1210             else { /* fake match */
1211                 offset = fake_offset;
1212                 *out_name_sv = name_svp[offset]; /* return the namesv */
1213                 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1214                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1215                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1216                     PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1217                     (unsigned long) PARENT_PAD_INDEX(*out_name_sv) 
1218                 ));
1219             }
1220
1221             /* return the lex? */
1222
1223             if (out_capture) {
1224
1225                 /* our ? */
1226                 if (SvPAD_OUR(*out_name_sv)) {
1227                     *out_capture = NULL;
1228                     return offset;
1229                 }
1230
1231                 /* trying to capture from an anon prototype? */
1232                 if (CvCOMPILED(cv)
1233                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1234                         : *out_flags & PAD_FAKELEX_ANON)
1235                 {
1236                     if (warn)
1237                         Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1238                                        "Variable \"%"SVf"\" is not available",
1239                                        newSVpvn_flags(namepv, namelen,
1240                                            SVs_TEMP |
1241                                            (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1242
1243                     *out_capture = NULL;
1244                 }
1245
1246                 /* real value */
1247                 else {
1248                     int newwarn = warn;
1249                     if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1250                          && !SvPAD_STATE(name_svp[offset])
1251                          && warn && ckWARN(WARN_CLOSURE)) {
1252                         newwarn = 0;
1253                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1254                             "Variable \"%"SVf"\" will not stay shared",
1255                             newSVpvn_flags(namepv, namelen,
1256                                 SVs_TEMP |
1257                                 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1258                     }
1259
1260                     if (fake_offset && CvANON(cv)
1261                             && CvCLONE(cv) &&!CvCLONED(cv))
1262                     {
1263                         SV *n;
1264                         /* not yet caught - look further up */
1265                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1266                             "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1267                             PTR2UV(cv)));
1268                         n = *out_name_sv;
1269                         (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1270                             CvOUTSIDE_SEQ(cv),
1271                             newwarn, out_capture, out_name_sv, out_flags);
1272                         *out_name_sv = n;
1273                         return offset;
1274                     }
1275
1276                     *out_capture = AvARRAY(PadlistARRAY(padlist)[
1277                                     CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1278                     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1279                         "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1280                         PTR2UV(cv), PTR2UV(*out_capture)));
1281
1282                     if (SvPADSTALE(*out_capture)
1283                         && (!CvDEPTH(cv) || !staleok)
1284                         && !SvPAD_STATE(name_svp[offset]))
1285                     {
1286                         Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1287                                        "Variable \"%"SVf"\" is not available",
1288                                        newSVpvn_flags(namepv, namelen,
1289                                            SVs_TEMP |
1290                                            (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1291                         *out_capture = NULL;
1292                     }
1293                 }
1294                 if (!*out_capture) {
1295                     if (namelen != 0 && *namepv == '@')
1296                         *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1297                     else if (namelen != 0 && *namepv == '%')
1298                         *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1299                     else
1300                         *out_capture = sv_newmortal();
1301                 }
1302             }
1303
1304             return offset;
1305         }
1306     }
1307
1308     /* it's not in this pad - try above */
1309
1310     if (!CvOUTSIDE(cv))
1311         return NOT_IN_PAD;
1312
1313     /* out_capture non-null means caller wants us to capture lex; in
1314      * addition we capture ourselves unless it's an ANON/format */
1315     new_capturep = out_capture ? out_capture :
1316                 CvLATE(cv) ? NULL : &new_capture;
1317
1318     offset = pad_findlex(namepv, namelen,
1319                 flags | padadd_STALEOK*(new_capturep == &new_capture),
1320                 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1321                 new_capturep, out_name_sv, out_flags);
1322     if ((PADOFFSET)offset == NOT_IN_PAD)
1323         return NOT_IN_PAD;
1324
1325     /* found in an outer CV. Add appropriate fake entry to this pad */
1326
1327     /* don't add new fake entries (via eval) to CVs that we have already
1328      * finished compiling, or to undef CVs */
1329     if (CvCOMPILED(cv) || !padlist)
1330         return 0; /* this dummy (and invalid) value isnt used by the caller */
1331
1332     {
1333         /* This relies on sv_setsv_flags() upgrading the destination to the same
1334            type as the source, independent of the flags set, and on it being
1335            "good" and only copying flag bits and pointers that it understands.
1336         */
1337         SV *new_namesv = newSVsv(*out_name_sv);
1338         AV *  const ocomppad_name = PL_comppad_name;
1339         PAD * const ocomppad = PL_comppad;
1340         PL_comppad_name = PadlistARRAY(padlist)[0];
1341         PL_comppad = PadlistARRAY(padlist)[1];
1342         PL_curpad = AvARRAY(PL_comppad);
1343
1344         new_offset
1345             = pad_alloc_name(new_namesv,
1346                               (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1347                               SvPAD_TYPED(*out_name_sv)
1348                               ? SvSTASH(*out_name_sv) : NULL,
1349                               SvOURSTASH(*out_name_sv)
1350                               );
1351
1352         SvFAKE_on(new_namesv);
1353         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1354                                "Pad addname: %ld \"%.*s\" FAKE\n",
1355                                (long)new_offset,
1356                                (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1357         PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1358
1359         PARENT_PAD_INDEX_set(new_namesv, 0);
1360         if (SvPAD_OUR(new_namesv)) {
1361             NOOP;   /* do nothing */
1362         }
1363         else if (CvLATE(cv)) {
1364             /* delayed creation - just note the offset within parent pad */
1365             PARENT_PAD_INDEX_set(new_namesv, offset);
1366             CvCLONE_on(cv);
1367         }
1368         else {
1369             /* immediate creation - capture outer value right now */
1370             av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1371             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1372                 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1373                 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1374         }
1375         *out_name_sv = new_namesv;
1376         *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1377
1378         PL_comppad_name = ocomppad_name;
1379         PL_comppad = ocomppad;
1380         PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1381     }
1382     return new_offset;
1383 }
1384
1385 #ifdef DEBUGGING
1386
1387 /*
1388 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1389
1390 Get the value at offset I<po> in the current (compiling or executing) pad.
1391 Use macro PAD_SV instead of calling this function directly.
1392
1393 =cut
1394 */
1395
1396 SV *
1397 Perl_pad_sv(pTHX_ PADOFFSET po)
1398 {
1399     dVAR;
1400     ASSERT_CURPAD_ACTIVE("pad_sv");
1401
1402     if (!po)
1403         Perl_croak(aTHX_ "panic: pad_sv po");
1404     DEBUG_X(PerlIO_printf(Perl_debug_log,
1405         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
1406         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1407     );
1408     return PL_curpad[po];
1409 }
1410
1411 /*
1412 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1413
1414 Set the value at offset I<po> in the current (compiling or executing) pad.
1415 Use the macro PAD_SETSV() rather than calling this function directly.
1416
1417 =cut
1418 */
1419
1420 void
1421 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1422 {
1423     dVAR;
1424
1425     PERL_ARGS_ASSERT_PAD_SETSV;
1426
1427     ASSERT_CURPAD_ACTIVE("pad_setsv");
1428
1429     DEBUG_X(PerlIO_printf(Perl_debug_log,
1430         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
1431         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1432     );
1433     PL_curpad[po] = sv;
1434 }
1435
1436 #endif /* DEBUGGING */
1437
1438 /*
1439 =for apidoc m|void|pad_block_start|int full
1440
1441 Update the pad compilation state variables on entry to a new block.
1442
1443 =cut
1444 */
1445
1446 /* XXX DAPM perhaps:
1447  *      - integrate this in general state-saving routine ???
1448  *      - combine with the state-saving going on in pad_new ???
1449  *      - introduce a new SAVE type that does all this in one go ?
1450  */
1451
1452 void
1453 Perl_pad_block_start(pTHX_ int full)
1454 {
1455     dVAR;
1456     ASSERT_CURPAD_ACTIVE("pad_block_start");
1457     SAVEI32(PL_comppad_name_floor);
1458     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1459     if (full)
1460         PL_comppad_name_fill = PL_comppad_name_floor;
1461     if (PL_comppad_name_floor < 0)
1462         PL_comppad_name_floor = 0;
1463     SAVEI32(PL_min_intro_pending);
1464     SAVEI32(PL_max_intro_pending);
1465     PL_min_intro_pending = 0;
1466     SAVEI32(PL_comppad_name_fill);
1467     SAVEI32(PL_padix_floor);
1468     PL_padix_floor = PL_padix;
1469     PL_pad_reset_pending = FALSE;
1470 }
1471
1472 /*
1473 =for apidoc m|U32|intro_my
1474
1475 "Introduce" my variables to visible status.  This is called during parsing
1476 at the end of each statement to make lexical variables visible to
1477 subsequent statements.
1478
1479 =cut
1480 */
1481
1482 U32
1483 Perl_intro_my(pTHX)
1484 {
1485     dVAR;
1486     SV **svp;
1487     I32 i;
1488     U32 seq;
1489
1490     ASSERT_CURPAD_ACTIVE("intro_my");
1491     if (! PL_min_intro_pending)
1492         return PL_cop_seqmax;
1493
1494     svp = AvARRAY(PL_comppad_name);
1495     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1496         SV * const sv = svp[i];
1497
1498         if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1499             && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1500         {
1501             COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1502             COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1503             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1504                 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1505                 (long)i, SvPVX_const(sv),
1506                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1507                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1508             );
1509         }
1510     }
1511     seq = PL_cop_seqmax;
1512     PL_cop_seqmax++;
1513     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1514         PL_cop_seqmax++;
1515     PL_min_intro_pending = 0;
1516     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1517     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1518                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1519
1520     return seq;
1521 }
1522
1523 /*
1524 =for apidoc m|void|pad_leavemy
1525
1526 Cleanup at end of scope during compilation: set the max seq number for
1527 lexicals in this scope and warn of any lexicals that never got introduced.
1528
1529 =cut
1530 */
1531
1532 void
1533 Perl_pad_leavemy(pTHX)
1534 {
1535     dVAR;
1536     I32 off;
1537     SV * const * const svp = AvARRAY(PL_comppad_name);
1538
1539     PL_pad_reset_pending = FALSE;
1540
1541     ASSERT_CURPAD_ACTIVE("pad_leavemy");
1542     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1543         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1544             const SV * const sv = svp[off];
1545             if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1546                 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1547                                  "%"SVf" never introduced",
1548                                  SVfARG(sv));
1549         }
1550     }
1551     /* "Deintroduce" my variables that are leaving with this scope. */
1552     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1553         const SV * const sv = svp[off];
1554         if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1555             && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1556         {
1557             COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1558             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1559                 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1560                 (long)off, SvPVX_const(sv),
1561                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1562                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1563             );
1564         }
1565     }
1566     PL_cop_seqmax++;
1567     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1568         PL_cop_seqmax++;
1569     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1570             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1571 }
1572
1573 /*
1574 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1575
1576 Abandon the tmp in the current pad at offset po and replace with a
1577 new one.
1578
1579 =cut
1580 */
1581
1582 void
1583 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1584 {
1585     dVAR;
1586     ASSERT_CURPAD_LEGAL("pad_swipe");
1587     if (!PL_curpad)
1588         return;
1589     if (AvARRAY(PL_comppad) != PL_curpad)
1590         Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1591                    AvARRAY(PL_comppad), PL_curpad);
1592     if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1593         Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1594                    (long)po, (long)AvFILLp(PL_comppad));
1595
1596     DEBUG_X(PerlIO_printf(Perl_debug_log,
1597                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
1598                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1599
1600     if (PL_curpad[po])
1601         SvPADTMP_off(PL_curpad[po]);
1602     if (refadjust)
1603         SvREFCNT_dec(PL_curpad[po]);
1604
1605
1606     /* if pad tmps aren't shared between ops, then there's no need to
1607      * create a new tmp when an existing op is freed */
1608 #ifdef USE_BROKEN_PAD_RESET
1609     PL_curpad[po] = newSV(0);
1610     SvPADTMP_on(PL_curpad[po]);
1611 #else
1612     PL_curpad[po] = &PL_sv_undef;
1613 #endif
1614     if ((I32)po < PL_padix)
1615         PL_padix = po - 1;
1616 }
1617
1618 /*
1619 =for apidoc m|void|pad_reset
1620
1621 Mark all the current temporaries for reuse
1622
1623 =cut
1624 */
1625
1626 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1627  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1628  * on the stack by OPs that use them, there are several ways to get an alias
1629  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
1630  * We avoid doing this until we can think of a Better Way.
1631  * GSAR 97-10-29 */
1632 static void
1633 S_pad_reset(pTHX)
1634 {
1635     dVAR;
1636 #ifdef USE_BROKEN_PAD_RESET
1637     if (AvARRAY(PL_comppad) != PL_curpad)
1638         Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1639                    AvARRAY(PL_comppad), PL_curpad);
1640
1641     DEBUG_X(PerlIO_printf(Perl_debug_log,
1642             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1643             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1644                 (long)PL_padix, (long)PL_padix_floor
1645             )
1646     );
1647
1648     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1649         I32 po;
1650         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1651             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1652                 SvPADTMP_off(PL_curpad[po]);
1653         }
1654         PL_padix = PL_padix_floor;
1655     }
1656 #endif
1657     PL_pad_reset_pending = FALSE;
1658 }
1659
1660 /*
1661 =for apidoc Amx|void|pad_tidy|padtidy_type type
1662
1663 Tidy up a pad at the end of compilation of the code to which it belongs.
1664 Jobs performed here are: remove most stuff from the pads of anonsub
1665 prototypes; give it a @_; mark temporaries as such.  I<type> indicates
1666 the kind of subroutine:
1667
1668     padtidy_SUB        ordinary subroutine
1669     padtidy_SUBCLONE   prototype for lexical closure
1670     padtidy_FORMAT     format
1671
1672 =cut
1673 */
1674
1675 /* XXX DAPM surely most of this stuff should be done properly
1676  * at the right time beforehand, rather than going around afterwards
1677  * cleaning up our mistakes ???
1678  */
1679
1680 void
1681 Perl_pad_tidy(pTHX_ padtidy_type type)
1682 {
1683     dVAR;
1684
1685     ASSERT_CURPAD_ACTIVE("pad_tidy");
1686
1687     /* If this CV has had any 'eval-capable' ops planted in it
1688      * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1689      * anon prototypes in the chain of CVs should be marked as cloneable,
1690      * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1691      * the right CvOUTSIDE.
1692      * If running with -d, *any* sub may potentially have an eval
1693      * executed within it.
1694      */
1695
1696     if (PL_cv_has_eval || PL_perldb) {
1697         const CV *cv;
1698         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1699             if (cv != PL_compcv && CvCOMPILED(cv))
1700                 break; /* no need to mark already-compiled code */
1701             if (CvANON(cv)) {
1702                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1703                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1704                 CvCLONE_on(cv);
1705                 CvHASEVAL_on(cv);
1706             }
1707         }
1708     }
1709
1710     /* extend curpad to match namepad */
1711     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1712         av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1713
1714     if (type == padtidy_SUBCLONE) {
1715         SV * const * const namep = AvARRAY(PL_comppad_name);
1716         PADOFFSET ix;
1717
1718         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1719             SV *namesv;
1720
1721             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1722                 continue;
1723             /*
1724              * The only things that a clonable function needs in its
1725              * pad are anonymous subs.
1726              * The rest are created anew during cloning.
1727              */
1728             if (!((namesv = namep[ix]) != NULL &&
1729                   namesv != &PL_sv_undef &&
1730                    *SvPVX_const(namesv) == '&'))
1731             {
1732                 SvREFCNT_dec(PL_curpad[ix]);
1733                 PL_curpad[ix] = NULL;
1734             }
1735         }
1736     }
1737     else if (type == padtidy_SUB) {
1738         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1739         AV * const av = newAV();                        /* Will be @_ */
1740         av_store(PL_comppad, 0, MUTABLE_SV(av));
1741         AvREIFY_only(av);
1742     }
1743
1744     if (type == padtidy_SUB || type == padtidy_FORMAT) {
1745         SV * const * const namep = AvARRAY(PL_comppad_name);
1746         PADOFFSET ix;
1747         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1748             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1749                 continue;
1750             if (!SvPADMY(PL_curpad[ix])) {
1751                 SvPADTMP_on(PL_curpad[ix]);
1752             } else if (!SvFAKE(namep[ix])) {
1753                 /* This is a work around for how the current implementation of
1754                    ?{ } blocks in regexps interacts with lexicals.
1755
1756                    One of our lexicals.
1757                    Can't do this on all lexicals, otherwise sub baz() won't
1758                    compile in
1759
1760                    my $foo;
1761
1762                    sub bar { ++$foo; }
1763
1764                    sub baz { ++$foo; }
1765
1766                    because completion of compiling &bar calling pad_tidy()
1767                    would cause (top level) $foo to be marked as stale, and
1768                    "no longer available".  */
1769                 SvPADSTALE_on(PL_curpad[ix]);
1770             }
1771         }
1772     }
1773     PL_curpad = AvARRAY(PL_comppad);
1774 }
1775
1776 /*
1777 =for apidoc m|void|pad_free|PADOFFSET po
1778
1779 Free the SV at offset po in the current pad.
1780
1781 =cut
1782 */
1783
1784 /* XXX DAPM integrate with pad_swipe ???? */
1785 void
1786 Perl_pad_free(pTHX_ PADOFFSET po)
1787 {
1788     dVAR;
1789     ASSERT_CURPAD_LEGAL("pad_free");
1790     if (!PL_curpad)
1791         return;
1792     if (AvARRAY(PL_comppad) != PL_curpad)
1793         Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1794                    AvARRAY(PL_comppad), PL_curpad);
1795     if (!po)
1796         Perl_croak(aTHX_ "panic: pad_free po");
1797
1798     DEBUG_X(PerlIO_printf(Perl_debug_log,
1799             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1800             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1801     );
1802
1803     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1804         SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
1805     }
1806     if ((I32)po < PL_padix)
1807         PL_padix = po - 1;
1808 }
1809
1810 /*
1811 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1812
1813 Dump the contents of a padlist
1814
1815 =cut
1816 */
1817
1818 void
1819 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1820 {
1821     dVAR;
1822     const AV *pad_name;
1823     const AV *pad;
1824     SV **pname;
1825     SV **ppad;
1826     I32 ix;
1827
1828     PERL_ARGS_ASSERT_DO_DUMP_PAD;
1829
1830     if (!padlist) {
1831         return;
1832     }
1833     pad_name = *PadlistARRAY(padlist);
1834     pad = PadlistARRAY(padlist)[1];
1835     pname = AvARRAY(pad_name);
1836     ppad = AvARRAY(pad);
1837     Perl_dump_indent(aTHX_ level, file,
1838             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1839             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1840     );
1841
1842     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1843         const SV *namesv = pname[ix];
1844         if (namesv && namesv == &PL_sv_undef) {
1845             namesv = NULL;
1846         }
1847         if (namesv) {
1848             if (SvFAKE(namesv))
1849                 Perl_dump_indent(aTHX_ level+1, file,
1850                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1851                     (int) ix,
1852                     PTR2UV(ppad[ix]),
1853                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1854                     SvPVX_const(namesv),
1855                     (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1856                     (unsigned long)PARENT_PAD_INDEX(namesv)
1857
1858                 );
1859             else
1860                 Perl_dump_indent(aTHX_ level+1, file,
1861                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1862                     (int) ix,
1863                     PTR2UV(ppad[ix]),
1864                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1865                     (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1866                     (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1867                     SvPVX_const(namesv)
1868                 );
1869         }
1870         else if (full) {
1871             Perl_dump_indent(aTHX_ level+1, file,
1872                 "%2d. 0x%"UVxf"<%lu>\n",
1873                 (int) ix,
1874                 PTR2UV(ppad[ix]),
1875                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1876             );
1877         }
1878     }
1879 }
1880
1881 #ifdef DEBUGGING
1882
1883 /*
1884 =for apidoc m|void|cv_dump|CV *cv|const char *title
1885
1886 dump the contents of a CV
1887
1888 =cut
1889 */
1890
1891 STATIC void
1892 S_cv_dump(pTHX_ const CV *cv, const char *title)
1893 {
1894     dVAR;
1895     const CV * const outside = CvOUTSIDE(cv);
1896     PADLIST* const padlist = CvPADLIST(cv);
1897
1898     PERL_ARGS_ASSERT_CV_DUMP;
1899
1900     PerlIO_printf(Perl_debug_log,
1901                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1902                   title,
1903                   PTR2UV(cv),
1904                   (CvANON(cv) ? "ANON"
1905                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1906                    : (cv == PL_main_cv) ? "MAIN"
1907                    : CvUNIQUE(cv) ? "UNIQUE"
1908                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1909                   PTR2UV(outside),
1910                   (!outside ? "null"
1911                    : CvANON(outside) ? "ANON"
1912                    : (outside == PL_main_cv) ? "MAIN"
1913                    : CvUNIQUE(outside) ? "UNIQUE"
1914                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1915
1916     PerlIO_printf(Perl_debug_log,
1917                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1918     do_dump_pad(1, Perl_debug_log, padlist, 1);
1919 }
1920
1921 #endif /* DEBUGGING */
1922
1923 /*
1924 =for apidoc Am|CV *|cv_clone|CV *proto
1925
1926 Clone a CV, making a lexical closure.  I<proto> supplies the prototype
1927 of the function: its code, pad structure, and other attributes.
1928 The prototype is combined with a capture of outer lexicals to which the
1929 code refers, which are taken from the currently-executing instance of
1930 the immediately surrounding code.
1931
1932 =cut
1933 */
1934
1935 CV *
1936 Perl_cv_clone(pTHX_ CV *proto)
1937 {
1938     dVAR;
1939     I32 ix;
1940     PADLIST* const protopadlist = CvPADLIST(proto);
1941     PAD *const protopad_name = *PadlistARRAY(protopadlist);
1942     const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1943     SV** const pname = AvARRAY(protopad_name);
1944     SV** const ppad = AvARRAY(protopad);
1945     const I32 fname = AvFILLp(protopad_name);
1946     const I32 fpad = AvFILLp(protopad);
1947     CV* cv;
1948     SV** outpad;
1949     CV* outside;
1950     long depth;
1951
1952     PERL_ARGS_ASSERT_CV_CLONE;
1953
1954     assert(!CvUNIQUE(proto));
1955
1956     /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1957      * reliable.  The currently-running sub is always the one we need to
1958      * close over.
1959      * Note that in general for formats, CvOUTSIDE != find_runcv.
1960      * Since formats may be nested inside closures, CvOUTSIDE may point
1961      * to a prototype; we instead want the cloned parent who called us.
1962      */
1963
1964     if (SvTYPE(proto) == SVt_PVCV)
1965         outside = find_runcv(NULL);
1966     else {
1967         outside = CvOUTSIDE(proto);
1968         if ((CvCLONE(outside) && ! CvCLONED(outside))
1969             || !CvPADLIST(outside)
1970             || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1971             outside = find_runcv_where(
1972                 FIND_RUNCV_padid_eq, (IV)protopadlist->xpadl_outid, NULL
1973             );
1974             /* outside could be null */
1975         }
1976     }
1977     depth = outside ? CvDEPTH(outside) : 0;
1978     assert(depth || SvTYPE(proto) == SVt_PVFM);
1979     if (!depth)
1980         depth = 1;
1981     assert(SvTYPE(proto) == SVt_PVFM || CvPADLIST(outside));
1982
1983     ENTER;
1984     SAVESPTR(PL_compcv);
1985
1986     cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1987     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
1988                                     |CVf_SLABBED);
1989     CvCLONED_on(cv);
1990
1991     CvFILE(cv)          = CvDYNFILE(proto) ? savepv(CvFILE(proto))
1992                                            : CvFILE(proto);
1993     if (CvNAMED(proto))
1994          SvANY(cv)->xcv_gv_u.xcv_hek = share_hek_hek(CvNAME_HEK(proto));
1995     else CvGV_set(cv,CvGV(proto));
1996     CvSTASH_set(cv, CvSTASH(proto));
1997     OP_REFCNT_LOCK;
1998     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1999     OP_REFCNT_UNLOCK;
2000     CvSTART(cv)         = CvSTART(proto);
2001     if (CvHASEVAL(cv))
2002         CvOUTSIDE(cv)   = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2003     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2004
2005     if (SvPOK(proto))
2006         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2007     if (SvMAGIC(proto))
2008         mg_copy((SV *)proto, (SV *)cv, 0, 0);
2009
2010     SAVESPTR(PL_comppad_name);
2011     PL_comppad_name = protopad_name;
2012     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2013     CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
2014
2015     av_fill(PL_comppad, fpad);
2016
2017     PL_curpad = AvARRAY(PL_comppad);
2018
2019     outpad = outside && CvPADLIST(outside)
2020         ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2021         : NULL;
2022     assert(outpad || SvTYPE(cv) == SVt_PVFM);
2023     if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
2024
2025     for (ix = fpad; ix > 0; ix--) {
2026         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2027         SV *sv = NULL;
2028         if (namesv && namesv != &PL_sv_undef) { /* lexical */
2029             if (SvFAKE(namesv)) {   /* lexical from outside? */
2030                 /* formats may have an inactive, or even undefined, parent;
2031                    but state vars are always available. */
2032                 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2033                  || (  SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2034                     && (!outside || !CvDEPTH(outside)))  ) {
2035                     assert(SvTYPE(cv) == SVt_PVFM);
2036                     Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
2037                                    "Variable \"%"SVf"\" is not available", namesv);
2038                     sv = NULL;
2039                 }
2040                 else 
2041                     SvREFCNT_inc_simple_void_NN(sv);
2042             }
2043             if (!sv) {
2044                 const char sigil = SvPVX_const(namesv)[0];
2045                 if (sigil == '&')
2046                     sv = SvREFCNT_inc(ppad[ix]);
2047                 else if (sigil == '@')
2048                     sv = MUTABLE_SV(newAV());
2049                 else if (sigil == '%')
2050                     sv = MUTABLE_SV(newHV());
2051                 else
2052                     sv = newSV(0);
2053                 SvPADMY_on(sv);
2054                 /* reset the 'assign only once' flag on each state var */
2055                 if (SvPAD_STATE(namesv))
2056                     SvPADSTALE_on(sv);
2057             }
2058         }
2059         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
2060             sv = SvREFCNT_inc_NN(ppad[ix]);
2061         }
2062         else {
2063             sv = newSV(0);
2064             SvPADTMP_on(sv);
2065         }
2066         PL_curpad[ix] = sv;
2067     }
2068
2069     DEBUG_Xv(
2070         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2071         if (outside) cv_dump(outside, "Outside");
2072         cv_dump(proto,   "Proto");
2073         cv_dump(cv,      "To");
2074     );
2075
2076     LEAVE;
2077
2078     if (CvCONST(cv)) {
2079         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2080          * The prototype was marked as a candiate for const-ization,
2081          * so try to grab the current const value, and if successful,
2082          * turn into a const sub:
2083          */
2084         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2085         if (const_sv) {
2086             SvREFCNT_dec(cv);
2087             /* For this calling case, op_const_sv returns a *copy*, which we
2088                donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2089                Need to fix how lib/constant.pm works to eliminate this.  */
2090             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2091         }
2092         else {
2093             CvCONST_off(cv);
2094         }
2095     }
2096
2097     return cv;
2098 }
2099
2100 /*
2101 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2102
2103 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2104 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2105 moved to a pre-existing CV struct.
2106
2107 =cut
2108 */
2109
2110 void
2111 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2112 {
2113     dVAR;
2114     I32 ix;
2115     AV * const comppad_name = PadlistARRAY(padlist)[0];
2116     AV * const comppad = PadlistARRAY(padlist)[1];
2117     SV ** const namepad = AvARRAY(comppad_name);
2118     SV ** const curpad = AvARRAY(comppad);
2119
2120     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2121     PERL_UNUSED_ARG(old_cv);
2122
2123     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2124         const SV * const namesv = namepad[ix];
2125         if (namesv && namesv != &PL_sv_undef
2126             && *SvPVX_const(namesv) == '&')
2127         {
2128           if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2129             CV * const innercv = MUTABLE_CV(curpad[ix]);
2130             assert(CvWEAKOUTSIDE(innercv));
2131             assert(CvOUTSIDE(innercv) == old_cv);
2132             CvOUTSIDE(innercv) = new_cv;
2133           }
2134           else { /* format reference */
2135             SV * const rv = curpad[ix];
2136             CV *innercv;
2137             if (!SvOK(rv)) continue;
2138             assert(SvROK(rv));
2139             assert(SvWEAKREF(rv));
2140             innercv = (CV *)SvRV(rv);
2141             assert(!CvWEAKOUTSIDE(innercv));
2142             SvREFCNT_dec(CvOUTSIDE(innercv));
2143             CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2144           }
2145         }
2146     }
2147 }
2148
2149 /*
2150 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2151
2152 Push a new pad frame onto the padlist, unless there's already a pad at
2153 this depth, in which case don't bother creating a new one.  Then give
2154 the new pad an @_ in slot zero.
2155
2156 =cut
2157 */
2158
2159 void
2160 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2161 {
2162     dVAR;
2163
2164     PERL_ARGS_ASSERT_PAD_PUSH;
2165
2166     if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2167         PAD** const svp = PadlistARRAY(padlist);
2168         AV* const newpad = newAV();
2169         SV** const oldpad = AvARRAY(svp[depth-1]);
2170         I32 ix = AvFILLp((const AV *)svp[1]);
2171         const I32 names_fill = AvFILLp((const AV *)svp[0]);
2172         SV** const names = AvARRAY(svp[0]);
2173         AV *av;
2174
2175         for ( ;ix > 0; ix--) {
2176             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2177                 const char sigil = SvPVX_const(names[ix])[0];
2178                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2179                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2180                         || sigil == '&')
2181                 {
2182                     /* outer lexical or anon code */
2183                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2184                 }
2185                 else {          /* our own lexical */
2186                     SV *sv; 
2187                     if (sigil == '@')
2188                         sv = MUTABLE_SV(newAV());
2189                     else if (sigil == '%')
2190                         sv = MUTABLE_SV(newHV());
2191                     else
2192                         sv = newSV(0);
2193                     av_store(newpad, ix, sv);
2194                     SvPADMY_on(sv);
2195                 }
2196             }
2197             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2198                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2199             }
2200             else {
2201                 /* save temporaries on recursion? */
2202                 SV * const sv = newSV(0);
2203                 av_store(newpad, ix, sv);
2204                 SvPADTMP_on(sv);
2205             }
2206         }
2207         av = newAV();
2208         av_store(newpad, 0, MUTABLE_SV(av));
2209         AvREIFY_only(av);
2210
2211         padlist_store(padlist, depth, newpad);
2212     }
2213 }
2214
2215 /*
2216 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2217
2218 Looks up the type of the lexical variable at position I<po> in the
2219 currently-compiling pad.  If the variable is typed, the stash of the
2220 class to which it is typed is returned.  If not, C<NULL> is returned.
2221
2222 =cut
2223 */
2224
2225 HV *
2226 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2227 {
2228     dVAR;
2229     SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2230     if ( SvPAD_TYPED(*av) ) {
2231         return SvSTASH(*av);
2232     }
2233     return NULL;
2234 }
2235
2236 #if defined(USE_ITHREADS)
2237
2238 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2239
2240 /*
2241 =for apidoc padlist_dup
2242
2243 Duplicates a pad.
2244
2245 =cut
2246 */
2247
2248 PADLIST *
2249 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2250 {
2251     PADLIST *dstpad;
2252     bool cloneall;
2253     PADOFFSET max;
2254
2255     PERL_ARGS_ASSERT_PADLIST_DUP;
2256
2257     if (!srcpad)
2258         return NULL;
2259
2260     cloneall = param->flags & CLONEf_COPY_STACKS
2261         || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2262     assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2263
2264     max = cloneall ? PadlistMAX(srcpad) : 1;
2265
2266     Newx(dstpad, 1, PADLIST);
2267     ptr_table_store(PL_ptr_table, srcpad, dstpad);
2268     PadlistMAX(dstpad) = max;
2269     Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2270
2271     if (cloneall) {
2272         PADOFFSET depth;
2273         for (depth = 0; depth <= max; ++depth)
2274             PadlistARRAY(dstpad)[depth] =
2275                 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2276     } else {
2277         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2278            to build anything other than the first level of pads.  */
2279         I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2280         AV *pad1;
2281         const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2282         const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2283         SV **oldpad = AvARRAY(srcpad1);
2284         SV **names;
2285         SV **pad1a;
2286         AV *args;
2287
2288         PadlistARRAY(dstpad)[0] =
2289             av_dup_inc(PadlistARRAY(srcpad)[0], param);
2290         names = AvARRAY(PadlistARRAY(dstpad)[0]);
2291
2292         pad1 = newAV();
2293
2294         av_extend(pad1, ix);
2295         PadlistARRAY(dstpad)[1] = pad1;
2296         pad1a = AvARRAY(pad1);
2297
2298         if (ix > -1) {
2299             AvFILLp(pad1) = ix;
2300
2301             for ( ;ix > 0; ix--) {
2302                 if (!oldpad[ix]) {
2303                     pad1a[ix] = NULL;
2304                 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2305                     const char sigil = SvPVX_const(names[ix])[0];
2306                     if ((SvFLAGS(names[ix]) & SVf_FAKE)
2307                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2308                         || sigil == '&')
2309                         {
2310                             /* outer lexical or anon code */
2311                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2312                         }
2313                     else {              /* our own lexical */
2314                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2315                             /* This is a work around for how the current
2316                                implementation of ?{ } blocks in regexps
2317                                interacts with lexicals.  */
2318                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2319                         } else {
2320                             SV *sv; 
2321                             
2322                             if (sigil == '@')
2323                                 sv = MUTABLE_SV(newAV());
2324                             else if (sigil == '%')
2325                                 sv = MUTABLE_SV(newHV());
2326                             else
2327                                 sv = newSV(0);
2328                             pad1a[ix] = sv;
2329                             SvPADMY_on(sv);
2330                         }
2331                     }
2332                 }
2333                 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2334                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2335                 }
2336                 else {
2337                     /* save temporaries on recursion? */
2338                     SV * const sv = newSV(0);
2339                     pad1a[ix] = sv;
2340
2341                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2342                        FIXTHAT before merging this branch.
2343                        (And I know how to) */
2344                     if (SvPADMY(oldpad[ix]))
2345                         SvPADMY_on(sv);
2346                     else
2347                         SvPADTMP_on(sv);
2348                 }
2349             }
2350
2351             if (oldpad[0]) {
2352                 args = newAV();                 /* Will be @_ */
2353                 AvREIFY_only(args);
2354                 pad1a[0] = (SV *)args;
2355             }
2356         }
2357     }
2358
2359     return dstpad;
2360 }
2361
2362 #endif /* USE_ITHREADS */
2363
2364 PAD **
2365 Perl_padlist_store(pTHX_ register PADLIST *padlist, I32 key, PAD *val)
2366 {
2367     dVAR;
2368     PAD **ary;
2369     SSize_t const oldmax = PadlistMAX(padlist);
2370
2371     PERL_ARGS_ASSERT_PADLIST_STORE;
2372
2373     assert(key >= 0);
2374
2375     if (key > PadlistMAX(padlist)) {
2376         av_extend_guts(NULL,key,&PadlistMAX(padlist),
2377                        (SV ***)&PadlistARRAY(padlist),
2378                        (SV ***)&PadlistARRAY(padlist));
2379         Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2380              PAD *);
2381     }
2382     ary = PadlistARRAY(padlist);
2383     SvREFCNT_dec(ary[key]);
2384     ary[key] = val;
2385     return &ary[key];
2386 }
2387
2388 /*
2389  * Local variables:
2390  * c-indentation-style: bsd
2391  * c-basic-offset: 4
2392  * indent-tabs-mode: nil
2393  * End:
2394  *
2395  * ex: set ts=8 sts=4 sw=4 et:
2396  */