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