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