[PATCH pad.c,h] move all pad-related code to its own src file

[Dave Mitchell]

[ this patch requires 'make regen_headers' ]

This patch moves (nearly) all pad-related code from the various core src
files to the two new files pad.c and pad.h, and attempts to create
something approaching an API for pads.

It has the following things of note:

* There are now no direct references outside of pad.[ch] to the various
pad-related variables such as PL_curpad, PL_padix etc etc. These are now
handled via functions or macros.

* Actually I haven't *quite* finished moving everything yet -
PL_pad_reset_pending is still loose, and some of the extensions and
/(??...)/ still know about pads. I plan to revisit these soon.

* There are two new types, PAD and PADLIST - currently just typedef'ed
to SV** and AV.

* The lexical deugging output with -DX is more comprehensive, and using the
new verbose flag (-DXv), is more verbose too.

* Some non-public functions have had their signatures changed:
Perl_pad_leavemy() has lost its only arg
Perl_pad_swipe() has gained an arg
Perl_pad_allocmy() has been renamed Perl_allocmy()

* the frequently-occuring sv=PL_cupad[po], and PL_curpad[po]=sv have
bee replaced with sv=PAD_SVl[po], and PAD_SVl[po]=sv.
The new PAD_SVl macro is like PAD_SV, but it can act as an lvalue, and is
'lite' -it doesn't produce any output under -DX.

* In principle we can now change the internal implementation of pads
by only modifying code in pad.[ch].

* pad.c currently has quite a few notes marked with 'XXX DAPM'
where I've spotted potential problems or room for improvement, and
I intend to revisit these soon too. The whole API can be considered a first
cut, and can probably be simplified. I've tried very hard to make this
initial move functionally change as little as possible - subsequent
patches that I will sumbit that just affect pad.c may be more daring. In
the few places where I've done something that might just conceivably break
something, I've put temporary asserts in the code.

* I've also made a couple of tiny mods to autodoc.pl to make it better
handle extraneous spaces in apidoc and embed.fnc declarations.

Dave.

# This is a patch for 17914.ORIG to update it to 17914.pad
#
# To apply this patch:
# STEP 1: Chdir to the source directory.
# STEP 2: Run the 'applypatch' program with this patch file as input.
#
# If you do not have 'applypatch', it is part of the 'makepatch' package
# that you can fetch from the Comprehensive Perl Archive Network:
# http://www.perl.com/CPAN/authors/Johan_Vromans/makepatch-x.y.tar.gz
# In the above URL, 'x' should be 2 or higher.
#
# To apply this patch without the use of 'applypatch':
# STEP 1: Chdir to the source directory.
# If you have a decent Bourne-type shell:
# STEP 2: Run the shell with this file as input.
# If you don't have such a shell, you may need to manually create
# the files as shown below.
# STEP 3: Run the 'patch' program with this file as input.
#
# These are the commands needed to create/delete files/directories:
#
touch 'pad.c'
chmod 0664 'pad.c'
touch 'pad.h'
chmod 0664 'pad.h'
#
# This command terminates the shell and need not be executed manually.
exit
#
#### End of Preamble ####

#### Patch data follows ####
diff -up '17914.ORIG/MANIFEST' '17914.pad/MANIFEST'
Index: ./MANIFEST
--- ./MANIFEST Tue Sep 24 00:27:20 2002
+++ ./MANIFEST Tue Sep 24 01:15:19 2002
@@ -2104,6 +2104,8 @@ os2/os2_base.t Additional tests for bu
os2/perl2cmd.pl Corrects installed binaries under OS/2
os2/perlrexx.c Support perl interpreter embedded in REXX
patchlevel.h The current patch level of perl
+pad.c Scratchpad functions
+pad.h Scratchpad headers
perl.c main()
perl.h Global declarations
perlapi.c Perl API functions
diff -up '17914.ORIG/Makefile.SH' '17914.pad/Makefile.SH'
Index: ./Makefile.SH
--- ./Makefile.SH Tue Sep 24 00:27:20 2002
+++ ./Makefile.SH Tue Sep 24 01:15:19 2002
@@ -299,20 +299,20 @@ plextract = pod/pod2html pod/pod2latex p
addedbyconf = UU $(shextract) $(plextract) lib/lib.pm pstruct

h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h
-h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h
-h3 = opcode.h patchlevel.h perl.h perlapi.h perly.h pp.h proto.h regcomp.h
+h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h opcode.h
+h3 = pad.h patchlevel.h perl.h perlapi.h perly.h pp.h proto.h regcomp.h
h4 = regexp.h scope.h sv.h unixish.h util.h iperlsys.h thread.h
h5 = utf8.h warnings.h
h = $(h1) $(h2) $(h3) $(h4) $(h5)

c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c reentr.c
c2 = perl.c perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c
-c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c universal.c xsutils.c
+c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c universal.c xsutils.c pad.c
c4 = globals.c perlio.c perlapi.c numeric.c locale.c pp_pack.c pp_sort.c

c = $(c1) $(c2) $(c3) $(c4) miniperlmain.c perlmain.c

-obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT)
+obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT)
obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT)
obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) pp_sort$(OBJ_EXT)

diff -up '17914.ORIG/Makefile.micro' '17914.pad/Makefile.micro'
Index: ./Makefile.micro
--- ./Makefile.micro Tue Sep 24 00:27:20 2002
+++ ./Makefile.micro Tue Sep 24 01:15:19 2002
@@ -9,7 +9,7 @@ all: microperl

O = uav$(_O) udeb$(_O) udoio$(_O) udoop$(_O) udump$(_O) \
uglobals$(_O) ugv$(_O) uhv$(_O) \
- umg$(_O) uperlmain$(_O) uop$(_O) ureentr$(_O) \
+ umg$(_O) uperlmain$(_O) uop$(_O) upad$(_O) ureentr$(_O) \
uperl$(_O) uperlio$(_O) uperly$(_O) upp$(_O) \
upp_ctl$(_O) upp_hot$(_O) upp_sys$(_O) upp_pack$(_O) upp_sort$(_O) \
uregcomp$(_O) uregexec$(_O) urun$(_O) \
@@ -21,10 +21,10 @@ microperl: $(O)
$(LD) -o $@ $(O) $(LIBS)

H = av.h uconfig.h cop.h cv.h embed.h embedvar.h form.h gv.h handy.h \
- hv.h intrpvar.h iperlsys.h mg.h op.h opcode.h opnames.h patchlevel.h \
- perl.h perlsdio.h perlvars.h perly.h pp.h pp_proto.h proto.h reentr.h \
- regexp.h scope.h sv.h thrdvar.h thread.h unixish.h utf8.h util.h \
- warnings.h
+ hv.h intrpvar.h iperlsys.h mg.h op.h opcode.h opnames.h pad.h \
+ patchlevel.h perl.h perlsdio.h perlvars.h perly.h pp.h \
+ pp_proto.h proto.h reentr.h regexp.h scope.h sv.h thrdvar.h \
+ thread.h unixish.h utf8.h util.h warnings.h

HE = $(H) EXTERN.h

@@ -82,6 +82,9 @@ uperlmain$(_O): $(HE) miniperlmain.c
uop$(_O): $(HE) op.c keywords.h
$(CC) -c -o $@ $(CFLAGS) op.c

+upad$(_O): $(HE) pad.c
+ $(CC) -c -o $@ $(CFLAGS) pad.c
+
ureentr$(_O): $(HE) reentr.c
$(CC) -c -o $@ $(CFLAGS) reentr.c

diff -up '17914.ORIG/autodoc.pl' '17914.pad/autodoc.pl'
Index: ./autodoc.pl
--- ./autodoc.pl Tue Sep 24 00:27:26 2002
+++ ./autodoc.pl Tue Sep 24 01:15:25 2002
@@ -36,7 +36,7 @@ sub walk_table (&@) {
while (<IN>) {
chomp;
next if /^:/;
- while (s|\\$||) {
+ while (s|\\\s*$||) {
$_ .= <IN>;
chomp;
}
@@ -69,7 +69,7 @@ FUNC:
next FUNC;
}
$line++;
- if ($in =~ /^=for\s+apidoc\s+(.*)\n/) {
+ if ($in =~ /^=for\s+apidoc\s+(.*?)\s*\n/) {
my $proto = $1;
$proto = "||$proto" unless $proto =~ /\|/;
my($flags, $ret, $name, @args) = split /\|/, $proto;
@@ -155,16 +155,20 @@ walk_table { # load documented functions
return "" unless $flags =~ /d/;
$func =~ s/\t//g; $flags =~ s/p//; # clean up fields from embed.pl
$retval =~ s/\t//;
- if ($flags =~ /A/) {
- my $docref = delete $docfuncs{$func};
+ my $docref = delete $docfuncs{$func};
+ if ($docref and @$docref) {
+ if ($flags =~ /A/) {
+ $docref->[0].="x" if $flags =~ /M/;
+ $apidocs{$docref->[4]}{$func} =
+ [$docref->[0] . 'A', $docref->[1], $retval,
+ $docref->[3], @args];
+ } else {
+ $gutsdocs{$docref->[4]}{$func} =
+ [$docref->[0], $docref->[1], $retval, $docref->[3], @args];
+ }
+ }
+ else {
warn "no docs for $func\n" unless $docref and @$docref;
- $docref->[0].="x" if $flags =~ /M/;
- $apidocs{$docref->[4]}{$func} =
- [$docref->[0] . 'A', $docref->[1], $retval, $docref->[3], @args];
- } else {
- my $docref = delete $docfuncs{$func};
- $gutsdocs{$docref->[4]}{$func} =
- [$docref->[0], $docref->[1], $retval, $docref->[3], @args];
}
}
return "";
diff -up '17914.ORIG/cop.h' '17914.pad/cop.h'
Index: ./cop.h
--- ./cop.h Tue Sep 24 00:27:26 2002
+++ ./cop.h Tue Sep 24 01:15:25 2002
@@ -114,7 +114,7 @@ struct block_sub {
long olddepth;
U8 hasargs;
U8 lval; /* XXX merge lval and hasargs? */
- SV ** oldcurpad;
+ PAD oldcurpad;
};

#define PUSHSUB(cx) \
@@ -161,7 +161,7 @@ struct block_sub {
cx->blk_sub.argarray = newAV(); \
av_extend(cx->blk_sub.argarray, fill); \
AvFLAGS(cx->blk_sub.argarray) = AVf_REIFY; \
- cx->blk_sub.oldcurpad[0] = (SV*)cx->blk_sub.argarray; \
+ CX_CURPAD_SV(cx->blk_sub, 0) = (SV*)cx->blk_sub.argarray; \
} \
else { \
CLEAR_ARGARRAY(cx->blk_sub.argarray); \
@@ -220,7 +220,7 @@ struct block_loop {
OP * last_op;
#ifdef USE_ITHREADS
void * iterdata;
- SV ** oldcurpad;
+ PAD oldcurpad;
#else
SV ** itervar;
#endif
@@ -235,11 +235,12 @@ struct block_loop {
# define CxITERVAR(c) \
((c)->blk_loop.iterdata \
? (CxPADLOOP(cx) \
- ? &((c)->blk_loop.oldcurpad)[INT2PTR(PADOFFSET, (c)->blk_loop.iterdata)] \
+ ? &CX_CURPAD_SV( (c)->blk_loop, \
+ INT2PTR(PADOFFSET, (c)->blk_loop.iterdata)) \
: &GvSV((GV*)(c)->blk_loop.iterdata)) \
: (SV**)NULL)
# define CX_ITERDATA_SET(cx,idata) \
- cx->blk_loop.oldcurpad = PL_curpad; \
+ CX_CURPAD_SAVE(cx->blk_loop); \
if ((cx->blk_loop.iterdata = (idata))) \
cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx)); \
else \
diff -up '17914.ORIG/cv.h' '17914.pad/cv.h'
Index: ./cv.h
--- ./cv.h Tue Sep 24 00:27:26 2002
+++ ./cv.h Tue Sep 24 01:15:25 2002
@@ -27,7 +27,7 @@ struct xpvcv {
GV * xcv_gv;
char * xcv_file;
long xcv_depth; /* >= 2 indicates recursive call */
- AV * xcv_padlist;
+ PADLIST * xcv_padlist;
CV * xcv_outside;
#ifdef USE_5005THREADS
perl_mutex *xcv_mutexp;
@@ -139,61 +139,3 @@ Returns the stash of the CV.
#define CvCONST_on(cv) (CvFLAGS(cv) |= CVf_CONST)
#define CvCONST_off(cv) (CvFLAGS(cv) &= ~CVf_CONST)

-/*
-=head1 Pad Data Structures
-
-=for apidoc m|AV *|CvPADLIST|CV *cv
-CV's can have CvPADLIST(cv) set to point to an AV.
-
-For these purposes "forms" are a kind-of CV, eval""s are too (except they're
-not callable at will and are always thrown away after the eval"" is done
-executing).
-
-XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
-but that is really the callers pad (a slot of which is allocated by
-every entersub).
-
-The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
-is managed "manual" (mostly in op.c) rather than normal av.c rules.
-The items in the AV are not SVs as for a normal AV, but other AVs:
-
-0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
-the "static type information" for lexicals.
-
-The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
-depth of recursion into the CV.
-The 0'th slot of a frame AV is an AV which is @_.
-other entries are storage for variables and op targets.
-
-During compilation:
-C<PL_comppad_name> is set the the the names AV.
-C<PL_comppad> is set the the frame AV for the frame CvDEPTH == 1.
-C<PL_curpad> is set the body of the frame AV (i.e. AvARRAY(PL_comppad)).
-
-Itterating over the names AV itterates over all possible pad
-items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
-&PL_sv_undef "names" (see pad_alloc()).
-
-Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
-The rest are op targets/GVs/constants which are statically allocated
-or resolved at compile time. These don't have names by which they
-can be looked up from Perl code at run time through eval"" like
-my/our variables can be. Since they can't be looked up by "name"
-but only by their index allocated at compile time (which is usually
-in PL_op->op_targ), wasting a name SV for them doesn't make sense.
-
-The SVs in the names AV have their PV being the name of the variable.
-NV+1..IV inclusive is a range of cop_seq numbers for which the name is valid.
-For typed lexicals name SV is SVt_PVMG and SvSTASH points at the type.
-
-If SvFAKE is set on the name SV then slot in the frame AVs are
-a REFCNT'ed references to a lexical from "outside".
-
-If the 'name' is '&' the the corresponding entry in frame AV
-is a CV representing a possible closure.
-(SvFAKE and name of '&' is not a meaningful combination currently but could
-become so if C<my sub foo {}> is implemented.)
-
-=cut
-*/
-
diff -up '17914.ORIG/dump.c' '17914.pad/dump.c'
Index: ./dump.c
--- ./dump.c Tue Sep 24 00:27:26 2002
+++ ./dump.c Tue Sep 24 01:15:26 2002
@@ -1294,26 +1294,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO
if (type == SVt_PVFM)
Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
- if (nest < maxnest && CvPADLIST(sv)) {
- AV* padlist = CvPADLIST(sv);
- AV* pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
- AV* pad = (AV*)*av_fetch(padlist, 1, FALSE);
- SV** pname = AvARRAY(pad_name);
- SV** ppad = AvARRAY(pad);
- I32 ix;
-
- for (ix = 1; ix <= AvFILL(pad_name); ix++) {
- if (SvPOK(pname[ix]))
- Perl_dump_indent(aTHX_ level,
- /* %5d below is enough whitespace. */
- file,
- "%5d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
- (int)ix, PTR2UV(ppad[ix]),
- SvFAKE(pname[ix]) ? "FAKE " : "",
- SvPVX(pname[ix]),
- (IV)SvNVX(pname[ix]),
- (IV)SvIVX(pname[ix]));
- }
+ if (nest < maxnest) {
+ do_dump_pad(level+1, file, CvPADLIST(sv), 0);
}
{
CV *outside = CvOUTSIDE(sv);
diff -up '17914.ORIG/embed.fnc' '17914.pad/embed.fnc'
Index: ./embed.fnc
--- ./embed.fnc Tue Sep 24 00:27:40 2002
+++ ./embed.fnc Tue Sep 24 01:15:26 2002
@@ -130,7 +130,7 @@ Afnp |int |fprintf_nocontext|PerlIO* str
Afnp |int |printf_nocontext|const char* fmt|...
#endif
p |void |cv_ckproto |CV* cv|GV* gv|char* p
-p |CV* |cv_clone |CV* proto
+pd |CV* |cv_clone |CV* proto
Apd |SV* |cv_const_sv |CV* cv
p |SV* |op_const_sv |OP* o|CV* cv
Ap |void |cv_undef |CV* cv
@@ -294,7 +294,7 @@ p |void |init_argv_symbols|int|char **
p |void |init_debugger
Ap |void |init_stacks
Ap |void |init_tm |struct tm *ptm
-p |U32 |intro_my
+pd |U32 |intro_my
Ap |char* |instr |const char* big|const char* little
p |bool |io_close |IO* io|bool not_implicit
p |OP* |invert |OP* cmd
@@ -546,16 +546,16 @@ Ap |char* |ninstr |const char* big|cons
p |OP* |oopsCV |OP* o
Ap |void |op_free |OP* arg
p |void |package |OP* o
-p |PADOFFSET|pad_alloc |I32 optype|U32 tmptype
-p |PADOFFSET|pad_allocmy |char* name
-p |PADOFFSET|pad_findmy |char* name
+pd |PADOFFSET|pad_alloc |I32 optype|U32 tmptype
+p |PADOFFSET|allocmy |char* name
+pd |PADOFFSET|pad_findmy |char* name
p |OP* |oopsAV |OP* o
p |OP* |oopsHV |OP* o
-p |void |pad_leavemy |I32 fill
-Ap |SV* |pad_sv |PADOFFSET po
-p |void |pad_free |PADOFFSET po
-p |void |pad_reset
-p |void |pad_swipe |PADOFFSET po
+pd |void |pad_leavemy
+Apd |SV* |pad_sv |PADOFFSET po
+pd |void |pad_free |PADOFFSET po
+pd |void |pad_reset
+pd |void |pad_swipe |PADOFFSET po|bool refadjust
p |void |peep |OP* o
dopM |PerlIO*|start_glob |SV* pattern|IO *io
#if defined(USE_5005THREADS)
@@ -1016,18 +1016,11 @@ s |OP* |no_fh_allowed |OP *o
s |OP* |scalarboolean |OP *o
s |OP* |too_few_arguments|OP *o|char* name
s |OP* |too_many_arguments|OP *o|char* name
-s |PADOFFSET|pad_addlex |SV* name
-s |PADOFFSET|pad_findlex |char* name|PADOFFSET newoff|U32 seq \
- |CV* startcv|I32 cx_ix|I32 saweval|U32 flags
s |OP* |newDEFSVOP
s |OP* |new_logop |I32 type|I32 flags|OP **firstp|OP **otherp
s |void |simplify_sort |OP *o
s |bool |is_handle_constructor |OP *o|I32 argnum
s |char* |gv_ename |GV *gv
-# if defined(DEBUG_CLOSURES)
-s |void |cv_dump |CV *cv
-# endif
-s |CV* |cv_clone2 |CV *proto|CV *outside
s |bool |scalar_mod_type|OP *o|I32 type
s |OP * |my_kid |OP *o|OP *attrs|OP **imopsp
s |OP * |dup_attrlist |OP *o
@@ -1364,6 +1357,34 @@ s |void |deb_stack_n |SV** stack_base|I3
|I32 stack_max|I32 mark_min|I32 mark_max
#endif

+pd |PADLIST*|pad_new |padnew_flags flags
+pd |void |pad_undef |CV* cv|CV* outercv
+pd |PADOFFSET|pad_add_name |char *name\
+ |HV* typestash|HV* ourstash \
+ |bool clone
+pd |PADOFFSET|pad_add_anon |SV* sv|OPCODE op_type
+pd |void |pad_check_dup |char* name|bool is_our|HV* ourstash
+#ifdef DEBUGGING
+pd |void |pad_setsv |PADOFFSET po|SV* sv
+#endif
+pd |void |pad_block_start|int full
+pd |void |pad_tidy |padtidy_type type
+pd |void |do_dump_pad |I32 level|PerlIO *file \
+ |PADLIST *padlist|int full
+pd |void |pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
+
+pd |void |pad_push |PADLIST *padlist|int depth|int has_args
+
+#if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+sd |PADOFFSET|pad_findlex |char* name|PADOFFSET newoff|U32 seq \
+ |CV* startcv|I32 cx_ix|I32 saweval|U32 flags
+# if defined(DEBUGGING)
+sd |void |cv_dump |CV *cv|char *title
+# endif
+s |CV* |cv_clone2 |CV *proto|CV *outside
+#endif
+
+

END_EXTERN_C

diff -up '17914.ORIG/ext/B/B.xs' '17914.pad/ext/B/B.xs'
Index: ./ext/B/B.xs
--- ./ext/B/B.xs Tue Sep 24 00:27:20 2002
+++ ./ext/B/B.xs Tue Sep 24 01:15:27 2002
@@ -826,10 +826,10 @@ SVOP_gv(o)
B::SVOP o

#define PADOP_padix(o) o->op_padix
-#define PADOP_sv(o) (o->op_padix ? PL_curpad[o->op_padix] : Nullsv)
+#define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
#define PADOP_gv(o) ((o->op_padix \
- && SvTYPE(PL_curpad[o->op_padix]) == SVt_PVGV) \
- ? (GV*)PL_curpad[o->op_padix] : Nullgv)
+ && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
+ ? (GV*)PAD_SVl(o->op_padix) : Nullgv)

MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_

diff -up '17914.ORIG/ext/Devel/Peek/Peek.t' '17914.pad/ext/Devel/Peek/Peek.t'
Index: ./ext/Devel/Peek/Peek.t
--- ./ext/Devel/Peek/Peek.t Tue Sep 24 00:27:20 2002
+++ ./ext/Devel/Peek/Peek.t Tue Sep 24 01:15:31 2002
@@ -222,6 +222,7 @@ do_test(13,
OWNER = $ADDR
)? FLAGS = 0x4
PADLIST = $ADDR
+ PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
OUTSIDE = $ADDR \\(MAIN\\)');

do_test(14,
@@ -247,9 +248,10 @@ do_test(14,
OWNER = $ADDR
)? FLAGS = 0x0
PADLIST = $ADDR
- \\d+\\. $ADDR \\("\\$pattern" \\d+-\\d+\\)
- \\d+\\. $ADDR \\(FAKE "\\$DEBUG" 0-\\d+\\)
- \\d+\\. $ADDR \\("\\$dump" \\d+-\\d+\\)
+ PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
+ \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
+ \\d+\\. $ADDR<\\d+> FAKE \\(\\d+,\\d+\\) "\\$DEBUG"
+ \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
OUTSIDE = $ADDR \\(MAIN\\)');

do_test(15,
diff -up '17914.ORIG/op.c' '17914.pad/op.c'
Index: ./op.c
--- ./op.c Tue Sep 24 00:27:26 2002
+++ ./op.c Wed Sep 25 01:07:07 2002
@@ -108,7 +108,6 @@ S_Slab_Free(pTHX_ void *op)
Nullop ) \
: CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))

-#define PAD_MAX 999999999
#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)

STATIC char*
@@ -160,11 +159,11 @@ S_no_bareword_allowed(pTHX_ OP *o)
/* "register" allocation */

PADOFFSET
-Perl_pad_allocmy(pTHX_ char *name)
+Perl_allocmy(pTHX_ char *name)
{
PADOFFSET off;
- SV *sv;

+ /* complain about "my $_" etc etc */
if (!(PL_in_my == KEY_our ||
isALPHA(name[1]) ||
(USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
@@ -191,491 +190,32 @@ Perl_pad_allocmy(pTHX_ char *name)
}
yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
}
- if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
- SV **svp = AvARRAY(PL_comppad_name);
- HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
- PADOFFSET top = AvFILLp(PL_comppad_name);
- for (off = top; (I32)off > PL_comppad_name_floor; off--) {
- if ((sv = svp[off])
- && sv != &PL_sv_undef
- && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
- && (PL_in_my != KEY_our
- || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
- && strEQ(name, SvPVX(sv)))
- {
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "\"%s\" variable %s masks earlier declaration in same %s",
- (PL_in_my == KEY_our ? "our" : "my"),
- name,
- (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
- --off;
- break;
- }
- }
- if (PL_in_my == KEY_our) {
- do {
- if ((sv = svp[off])
- && sv != &PL_sv_undef
- && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
- && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
- && strEQ(name, SvPVX(sv)))
- {
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "\"our\" variable %s redeclared", name);
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "\t(Did you mean \"local\" instead of \"our\"?)\n");
- break;
- }
- } while ( off-- > 0 );
- }
- }
- off = pad_alloc(OP_PADSV, SVs_PADMY);
- sv = NEWSV(1102,0);
- sv_upgrade(sv, SVt_PVNV);
- sv_setpv(sv, name);
- if (PL_in_my_stash) {
- if (*name != '$')
- yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
- name, PL_in_my == KEY_our ? "our" : "my"));
- SvFLAGS(sv) |= SVpad_TYPED;
- (void)SvUPGRADE(sv, SVt_PVMG);
- SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
- }
- if (PL_in_my == KEY_our) {
- (void)SvUPGRADE(sv, SVt_PVGV);
- GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
- SvFLAGS(sv) |= SVpad_OUR;
- }
- av_store(PL_comppad_name, off, sv);
- SvNVX(sv) = (NV)PAD_MAX;
- SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
- if (!PL_min_intro_pending)
- PL_min_intro_pending = off;
- PL_max_intro_pending = off;
- if (*name == '@')
- av_store(PL_comppad, off, (SV*)newAV());
- else if (*name == '%')
- av_store(PL_comppad, off, (SV*)newHV());
- SvPADMY_on(PL_curpad[off]);
- return off;
-}
-
-STATIC PADOFFSET
-S_pad_addlex(pTHX_ SV *proto_namesv)
-{
- SV *namesv = NEWSV(1103,0);
- PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
- sv_upgrade(namesv, SVt_PVNV);
- sv_setpv(namesv, SvPVX(proto_namesv));
- av_store(PL_comppad_name, newoff, namesv);
- SvNVX(namesv) = (NV)PL_curcop->cop_seq;
- SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
- SvFAKE_on(namesv); /* A ref, not a real var */
- if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
- SvFLAGS(namesv) |= SVpad_OUR;
- (void)SvUPGRADE(namesv, SVt_PVGV);
- GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
- }
- if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
- SvFLAGS(namesv) |= SVpad_TYPED;
- (void)SvUPGRADE(namesv, SVt_PVMG);
- SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
- }
- return newoff;
-}
-
-#define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
-
-STATIC PADOFFSET
-S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
- I32 cx_ix, I32 saweval, U32 flags)
-{
- CV *cv;
- I32 off;
- SV *sv;
- register I32 i;
- register PERL_CONTEXT *cx;
-
- for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
- AV *curlist = CvPADLIST(cv);
- SV **svp = av_fetch(curlist, 0, FALSE);
- AV *curname;
-
- if (!svp || *svp == &PL_sv_undef)
- continue;
- curname = (AV*)*svp;
- svp = AvARRAY(curname);
- for (off = AvFILLp(curname); off > 0; off--) {
- if ((sv = svp[off]) &&
- sv != &PL_sv_undef &&
- seq <= (U32)SvIVX(sv) &&
- seq > (U32)I_32(SvNVX(sv)) &&
- strEQ(SvPVX(sv), name))
- {
- I32 depth;
- AV *oldpad;
- SV *oldsv;
-
- depth = CvDEPTH(cv);
- if (!depth) {
- if (newoff) {
- if (SvFAKE(sv))
- continue;
- return 0; /* don't clone from inactive stack frame */
- }
- depth = 1;
- }
- oldpad = (AV*)AvARRAY(curlist)[depth];
- oldsv = *av_fetch(oldpad, off, TRUE);
- if (!newoff) { /* Not a mere clone operation. */
- newoff = pad_addlex(sv);
- if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
- /* "It's closures all the way down." */
- CvCLONE_on(PL_compcv);
- if (cv == startcv) {
- if (CvANON(PL_compcv))
- oldsv = Nullsv; /* no need to keep ref */
- }
- else {
- CV *bcv;
- for (bcv = startcv;
- bcv && bcv != cv && !CvCLONE(bcv);
- bcv = CvOUTSIDE(bcv))
- {
- if (CvANON(bcv)) {
- /* install the missing pad entry in intervening
- * nested subs and mark them cloneable.
- * XXX fix pad_foo() to not use globals */
- AV *ocomppad_name = PL_comppad_name;
- AV *ocomppad = PL_comppad;
- SV **ocurpad = PL_curpad;
- AV *padlist = CvPADLIST(bcv);
- PL_comppad_name = (AV*)AvARRAY(padlist)[0];
- PL_comppad = (AV*)AvARRAY(padlist)[1];
- PL_curpad = AvARRAY(PL_comppad);
- pad_addlex(sv);
- PL_comppad_name = ocomppad_name;
- PL_comppad = ocomppad;
- PL_curpad = ocurpad;
- CvCLONE_on(bcv);
- }
- else {
- if (ckWARN(WARN_CLOSURE)
- && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
- {
- Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" may be unavailable",
- name);
- }
- break;
- }
- }
- }
- }
- else if (!CvUNIQUE(PL_compcv)) {
- if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
- && !(SvFLAGS(sv) & SVpad_OUR))
- {
- Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" will not stay shared", name);
- }
- }
- }
- av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
- return newoff;
- }
- }
- }
-
- if (flags & FINDLEX_NOSEARCH)
- return 0;
-
- /* Nothing in current lexical context--try eval's context, if any.
- * This is necessary to let the perldb get at lexically scoped variables.
- * XXX This will also probably interact badly with eval tree caching.
- */
-
- for (i = cx_ix; i >= 0; i--) {
- cx = &cxstack[i];
- switch (CxTYPE(cx)) {
- default:
- if (i == 0 && saweval) {
- return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
- }
- break;
- case CXt_EVAL:
- switch (cx->blk_eval.old_op_type) {
- case OP_ENTEREVAL:
- if (CxREALEVAL(cx)) {
- PADOFFSET off;
- saweval = i;
- seq = cxstack[i].blk_oldcop->cop_seq;
- startcv = cxstack[i].blk_eval.cv;
- if (startcv && CvOUTSIDE(startcv)) {
- off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
- i-1, saweval, 0);
- if (off) /* continue looking if not found here */
- return off;
- }
- }
- break;
- case OP_DOFILE:
- case OP_REQUIRE:
- /* require/do must have their own scope */
- return 0;
- }
- break;
- case CXt_FORMAT:
- case CXt_SUB:
- if (!saweval)
- return 0;
- cv = cx->blk_sub.cv;
- if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
- saweval = i; /* so we know where we were called from */
- seq = cxstack[i].blk_oldcop->cop_seq;
- continue;
- }
- return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
- }
- }
-
- return 0;
-}
-
-PADOFFSET
-Perl_pad_findmy(pTHX_ char *name)
-{
- I32 off;
- I32 pendoff = 0;
- SV *sv;
- SV **svp = AvARRAY(PL_comppad_name);
- U32 seq = PL_cop_seqmax;
- PERL_CONTEXT *cx;
- CV *outside;
-
-#ifdef USE_5005THREADS
- /*
- * Special case to get lexical (and hence per-thread) @_.
- * XXX I need to find out how to tell at parse-time whether use
- * of @_ should refer to a lexical (from a sub) or defgv (global
- * scope and maybe weird sub-ish things like formats). See
- * startsub in perly.y. It's possible that @_ could be lexical
- * (at least from subs) even in non-threaded perl.
- */
- if (strEQ(name, "@_"))
- return 0; /* success. (NOT_IN_PAD indicates failure) */
-#endif /* USE_5005THREADS */
-
- /* The one we're looking for is probably just before comppad_name_fill. */
- for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
- if ((sv = svp[off]) &&
- sv != &PL_sv_undef &&
- (!SvIVX(sv) ||
- (seq <= (U32)SvIVX(sv) &&
- seq > (U32)I_32(SvNVX(sv)))) &&
- strEQ(SvPVX(sv), name))
- {
- if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
- return (PADOFFSET)off;
- pendoff = off; /* this pending def. will override import */
- }
- }
-
- outside = CvOUTSIDE(PL_compcv);
-
- /* Check if if we're compiling an eval'', and adjust seq to be the
- * eval's seq number. This depends on eval'' having a non-null
- * CvOUTSIDE() while it is being compiled. The eval'' itself is
- * identified by CvEVAL being true and CvGV being null. */
- if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
- cx = &cxstack[cxstack_ix];
- if (CxREALEVAL(cx))
- seq = cx->blk_oldcop->cop_seq;
- }
-
- /* See if it's in a nested scope */
- off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
- if (off) {
- /* If there is a pending local definition, this new alias must die */
- if (pendoff)
- SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
- return off; /* pad_findlex returns 0 for failure...*/
- }
- return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
-}
-
-void
-Perl_pad_leavemy(pTHX_ I32 fill)
-{
- I32 off;
- SV **svp = AvARRAY(PL_comppad_name);
- SV *sv;
- if (PL_min_intro_pending && fill < PL_min_intro_pending) {
- for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
- if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "%s never introduced", SvPVX(sv));
- }
- }
- /* "Deintroduce" my variables that are leaving with this scope. */
- for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
- if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
- SvIVX(sv) = PL_cop_seqmax;
- }
-}
-
-PADOFFSET
-Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
-{
- SV *sv;
- I32 retval;
-
- if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_alloc");
- if (PL_pad_reset_pending)
- pad_reset();
- if (tmptype & SVs_PADMY) {
- do {
- sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
- } while (SvPADBUSY(sv)); /* need a fresh one */
- retval = AvFILLp(PL_comppad);
- }
- else {
- SV **names = AvARRAY(PL_comppad_name);
- SSize_t names_fill = AvFILLp(PL_comppad_name);
- for (;;) {
- /*
- * "foreach" index vars temporarily become aliases to non-"my"
- * values. Thus we must skip, not just pad values that are
- * marked as current pad values, but also those with names.
- */
- if (++PL_padix <= names_fill &&
- (sv = names[PL_padix]) && sv != &PL_sv_undef)
- continue;
- sv = *av_fetch(PL_comppad, PL_padix, TRUE);
- if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
- !IS_PADGV(sv) && !IS_PADCONST(sv))
- break;
- }
- retval = PL_padix;
- }
- SvFLAGS(sv) |= tmptype;
- PL_curpad = AvARRAY(PL_comppad);
-#ifdef USE_5005THREADS
- DEBUG_X(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
- PTR2UV(thr), PTR2UV(PL_curpad),
- (long) retval, PL_op_name[optype]));
-#else
- DEBUG_X(PerlIO_printf(Perl_debug_log,
- "Pad 0x%"UVxf" alloc %ld for %s\n",
- PTR2UV(PL_curpad),
- (long) retval, PL_op_name[optype]));
-#endif /* USE_5005THREADS */
- return (PADOFFSET)retval;
-}

-SV *
-Perl_pad_sv(pTHX_ PADOFFSET po)
-{
-#ifdef USE_5005THREADS
- DEBUG_X(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
- PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
-#else
- if (!po)
- Perl_croak(aTHX_ "panic: pad_sv po");
- DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
- PTR2UV(PL_curpad), (IV)po));
-#endif /* USE_5005THREADS */
- return PL_curpad[po]; /* eventually we'll turn this into a macro */
-}
-
-void
-Perl_pad_free(pTHX_ PADOFFSET po)
-{
- if (!PL_curpad)
- return;
- if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_free curpad");
- if (!po)
- Perl_croak(aTHX_ "panic: pad_free po");
-#ifdef USE_5005THREADS
- DEBUG_X(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
- PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
-#else
- DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
- PTR2UV(PL_curpad), (IV)po));
-#endif /* USE_5005THREADS */
- if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
- SvPADTMP_off(PL_curpad[po]);
-#ifdef USE_ITHREADS
-#ifdef PERL_COPY_ON_WRITE
- if (SvIsCOW(PL_curpad[po])) {
- sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
- } else
-#endif
- SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
-#endif
- }
- if ((I32)po < PL_padix)
- PL_padix = po - 1;
-}
-
-void
-Perl_pad_swipe(pTHX_ PADOFFSET po)
-{
- if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_swipe curpad");
- if (!po)
- Perl_croak(aTHX_ "panic: pad_swipe po");
-#ifdef USE_5005THREADS
- DEBUG_X(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
- PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
-#else
- DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
- PTR2UV(PL_curpad), (IV)po));
-#endif /* USE_5005THREADS */
- SvPADTMP_off(PL_curpad[po]);
- PL_curpad[po] = NEWSV(1107,0);
- SvPADTMP_on(PL_curpad[po]);
- if ((I32)po < PL_padix)
- PL_padix = po - 1;
+ /* check for duplicate declaration */
+ pad_check_dup(name,
+ PL_in_my == KEY_our,
+ (PL_curstash ? PL_curstash : PL_defstash)
+ );
+
+ if (PL_in_my_stash && *name != '$') {
+ yyerror(Perl_form(aTHX_
+ "Can't declare class for non-scalar %s in \"%s\"",
+ name, PL_in_my == KEY_our ? "our" : "my"));
+ }
+
+ /* allocate a spare slot and store the name in that slot */
+
+ off = pad_add_name(name,
+ PL_in_my_stash,
+ (PL_in_my == KEY_our
+ ? (PL_curstash ? PL_curstash : PL_defstash)
+ : Nullhv
+ ),
+ 0 /* not fake */
+ );
+ return off;
}

-/* XXX pad_reset() is currently disabled because it results in serious bugs.
- * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
- * on the stack by OPs that use them, there are several ways to get an alias
- * to a shared TARG. Such an alias will change randomly and unpredictably.
- * We avoid doing this until we can think of a Better Way.
- * GSAR 97-10-29 */
-void
-Perl_pad_reset(pTHX)
-{
-#ifdef USE_BROKEN_PAD_RESET
- register I32 po;
-
- if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_reset curpad");
-#ifdef USE_5005THREADS
- DEBUG_X(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" Pad 0x%"UVxf" reset\n",
- PTR2UV(thr), PTR2UV(PL_curpad)));
-#else
- DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
- PTR2UV(PL_curpad)));
-#endif /* USE_5005THREADS */
- if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
- for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
- if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
- SvPADTMP_off(PL_curpad[po]);
- }
- PL_padix = PL_padix_floor;
- }
-#endif
- PL_pad_reset_pending = FALSE;
-}

#ifdef USE_5005THREADS
/* find_threadsv is not reentrant */
@@ -822,13 +362,9 @@ Perl_op_clear(pTHX_ OP *o)
case OP_AELEMFAST:
#ifdef USE_ITHREADS
if (cPADOPo->op_padix > 0) {
- if (PL_curpad) {
- GV *gv = cGVOPo_gv;
- pad_swipe(cPADOPo->op_padix);
- /* No GvIN_PAD_off(gv) here, because other references may still
- * exist on the pad */
- SvREFCNT_dec(gv);
- }
+ /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
+ * may still exist on the pad */
+ pad_swipe(cPADOPo->op_padix, TRUE);
cPADOPo->op_padix = 0;
}
#else
@@ -864,13 +400,9 @@ Perl_op_clear(pTHX_ OP *o)
case OP_PUSHRE:
#ifdef USE_ITHREADS
if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
- if (PL_curpad) {
- GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
- pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
- /* No GvIN_PAD_off(gv) here, because other references may still
- * exist on the pad */
- SvREFCNT_dec(gv);
- }
+ /* No GvIN_PAD_off here, because other references may still
+ * exist on the pad */
+ pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
}
#else
SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
@@ -1423,7 +955,6 @@ OP *
Perl_mod(pTHX_ OP *o, I32 type)
{
OP *kid;
- STRLEN n_a;

if (!o || PL_error_count)
return o;
@@ -1649,8 +1180,13 @@ Perl_mod(pTHX_ OP *o, I32 type)
case OP_PADSV:
PL_modcount++;
if (!type)
+ { /* XXX DAPM 2002.08.25 tmp assert test */
+ /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE));
+ /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE));
+
Perl_croak(aTHX_ "Can't localize lexical variable %s",
- SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
+ PAD_COMPNAME_PV(o->op_targ));
+ }
break;

#ifdef USE_5005THREADS
@@ -1994,7 +1530,7 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *ta
target->op_type == OP_PADAV);

/* Ensure that attributes.pm is loaded. */
- apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
+ apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);

/* Need package name for method call. */
pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
@@ -2122,16 +1658,13 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **im
}
else if (attrs && type != OP_PUSHMARK) {
HV *stash;
- SV **namesvp;

PL_in_my = FALSE;
PL_in_my_stash = Nullhv;

/* check for C<my Dog $spot> when deciding package */
- namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
- if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
- stash = SvSTASH(*namesvp);
- else
+ stash = PAD_COMPNAME_TYPE(o->op_targ);
+ if (!stash)
stash = PL_curstash;
apply_attrs_my(stash, o, attrs, imopsp);
}
@@ -2278,19 +1811,7 @@ Perl_block_start(pTHX_ int full)
{
int retval = PL_savestack_ix;

- SAVEI32(PL_comppad_name_floor);
- PL_comppad_name_floor = AvFILLp(PL_comppad_name);
- if (full)
- PL_comppad_name_fill = PL_comppad_name_floor;
- if (PL_comppad_name_floor < 0)
- PL_comppad_name_floor = 0;
- SAVEI32(PL_min_intro_pending);
- SAVEI32(PL_max_intro_pending);
- PL_min_intro_pending = 0;
- SAVEI32(PL_comppad_name_fill);
- SAVEI32(PL_padix_floor);
- PL_padix_floor = PL_padix;
- PL_pad_reset_pending = FALSE;
+ pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
SAVESPTR(PL_compiling.cop_warnings);
@@ -2315,12 +1836,10 @@ Perl_block_end(pTHX_ I32 floor, OP *seq)
OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
LEAVE_SCOPE(floor);
- PL_pad_reset_pending = FALSE;
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
if (needblockscope)
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
- pad_leavemy(PL_comppad_name_fill);
- PL_cop_seqmax++;
+ pad_leavemy();
return retval;
}

@@ -2487,7 +2006,7 @@ Perl_fold_constants(pTHX_ register OP *o
CALLRUNOPS(aTHX);
sv = *(PL_stack_sp--);
if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
- pad_swipe(o->op_targ);
+ pad_swipe(o->op_targ, FALSE);
else if (SvTEMP(sv)) { /* grab mortal temp? */
(void)SvREFCNT_inc(sv);
SvTEMP_off(sv);
@@ -3310,8 +2829,8 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags,
padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
padop->op_padix = pad_alloc(type, SVs_PADTMP);
- SvREFCNT_dec(PL_curpad[padop->op_padix]);
- PL_curpad[padop->op_padix] = sv;
+ SvREFCNT_dec(PAD_SVl(padop->op_padix));
+ PAD_SETSV(padop->op_padix, sv);
SvPADTMP_on(sv);
padop->op_next = (OP*)padop;
padop->op_flags = (U8)flags;
@@ -3650,6 +3169,21 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *le
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
+
+ /* PL_generation sorcery:
+ * an assignment like ($a,$b) = ($c,$d) is easier than
+ * ($a,$b) = ($c,$a), since there is no need for temporary vars.
+ * To detect whether there are common vars, the global var
+ * PL_generation is incremented for each assign op we compile.
+ * Then, while compiling the assign op, we run through all the
+ * variables on both sides of the assignment, setting a spare slot
+ * in each of them to PL_generation. If any of them already have
+ * that value, we know we've got commonality. We could use a
+ * single bit marker, but then we'd have to make 2 passes, first
+ * to clear the flag, then to test and set it. To find somewhere
+ * to store these values, evil chicanery is done with SvCUR().
+ */
+
if (!(left->op_private & OPpLVAL_INTRO)) {
OP *lastop = o;
PL_generation++;
@@ -3664,12 +3198,14 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *le
else if (curop->op_type == OP_PADSV ||
curop->op_type == OP_PADAV ||
curop->op_type == OP_PADHV ||
- curop->op_type == OP_PADANY) {
- SV **svp = AvARRAY(PL_comppad_name);
- SV *sv = svp[curop->op_targ];
- if ((int)SvCUR(sv) == PL_generation)
+ curop->op_type == OP_PADANY)
+ {
+ if (PAD_COMPNAME_GEN(curop->op_targ)
+ == PL_generation)
break;
- SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
+ PAD_COMPNAME_GEN(curop->op_targ)
+ = PL_generation;
+
}
else if (curop->op_type == OP_RV2CV)
break;
@@ -3683,7 +3219,8 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *le
else if (curop->op_type == OP_PUSHRE) {
if (((PMOP*)curop)->op_pmreplroot) {
#ifdef USE_ITHREADS
- GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
+ GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
+ ((PMOP*)curop)->op_pmreplroot));
#else
GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
#endif
@@ -3826,28 +3363,6 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *l
return prepend_elem(OP_LINESEQ, (OP*)cop, o);
}

-/* "Introduce" my variables to visible status. */
-U32
-Perl_intro_my(pTHX)
-{
- SV **svp;
- SV *sv;
- I32 i;
-
- if (! PL_min_intro_pending)
- return PL_cop_seqmax;
-
- svp = AvARRAY(PL_comppad_name);
- for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
- if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
- SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
- SvNVX(sv) = (NV)PL_cop_seqmax;
- }
- }
- PL_min_intro_pending = 0;
- PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
- return PL_cop_seqmax++;
-}

OP *
Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
@@ -4337,7 +3852,6 @@ Perl_cv_undef(pTHX_ CV *cv)
{
CV *outsidecv;
CV *freecv = Nullcv;
- bool is_eval = CvEVAL(cv) && !CvGV(cv); /* is this eval"" ? */

#ifdef USE_5005THREADS
if (CvMUTEXP(cv)) {
@@ -4365,8 +3879,7 @@ Perl_cv_undef(pTHX_ CV *cv)
#endif /* USE_5005THREADS */
ENTER;

- SAVEVPTR(PL_curpad);
- PL_curpad = 0;
+ PAD_SAVE_SETNULLPAD;

op_free(CvROOT(cv));
CvROOT(cv) = Nullop;
@@ -4387,58 +3900,8 @@ Perl_cv_undef(pTHX_ CV *cv)
SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
CvCONST_off(cv);
}
- if (CvPADLIST(cv)) {
- /* may be during global destruction */
- if (SvREFCNT(CvPADLIST(cv))) {
- AV *padlist = CvPADLIST(cv);
- I32 ix;
- /* pads may be cleared out already during global destruction */
- if (is_eval && !PL_dirty) {
- /* inner references to eval's cv must be fixed up */
- AV *comppad_name = (AV*)AvARRAY(padlist)[0];
- AV *comppad = (AV*)AvARRAY(padlist)[1];
- SV **namepad = AvARRAY(comppad_name);
- SV **curpad = AvARRAY(comppad);
- for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
- SV *namesv = namepad[ix];
- if (namesv && namesv != &PL_sv_undef
- && *SvPVX(namesv) == '&'
- && ix <= AvFILLp(comppad))
- {
- CV *innercv = (CV*)curpad[ix];
- if (innercv && SvTYPE(innercv) == SVt_PVCV
- && CvOUTSIDE(innercv) == cv)
- {
- CvOUTSIDE(innercv) = outsidecv;
- if (!CvANON(innercv) || CvCLONED(innercv)) {
- (void)SvREFCNT_inc(outsidecv);
- if (SvREFCNT(cv))
- SvREFCNT_dec(cv);
- }
- }
- }
- }
- }
- if (freecv)
- SvREFCNT_dec(freecv);
- ix = AvFILLp(padlist);
- while (ix >= 0) {
- SV* sv = AvARRAY(padlist)[ix--];
- if (!sv)
- continue;
- if (sv == (SV*)PL_comppad_name)
- PL_comppad_name = Nullav;
- else if (sv == (SV*)PL_comppad) {
- PL_comppad = Nullav;
- PL_curpad = Null(SV**);
- }
- SvREFCNT_dec(sv);
- }
- SvREFCNT_dec((SV*)CvPADLIST(cv));
- }
- CvPADLIST(cv) = Nullav;
- }
- else if (freecv)
+ pad_undef(cv, outsidecv);
+ if (freecv)
SvREFCNT_dec(freecv);
if (CvXSUB(cv)) {
CvXSUB(cv) = 0;
@@ -4446,211 +3909,6 @@ Perl_cv_undef(pTHX_ CV *cv)
CvFLAGS(cv) = 0;
}

-#ifdef DEBUG_CLOSURES
-STATIC void
-S_cv_dump(pTHX_ CV *cv)
-{
-#ifdef DEBUGGING
- CV *outside = CvOUTSIDE(cv);
- AV* padlist = CvPADLIST(cv);
- AV* pad_name;
- AV* pad;
- SV** pname;
- SV** ppad;
- I32 ix;
-
- PerlIO_printf(Perl_debug_log,
- "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
- PTR2UV(cv),
- (CvANON(cv) ? "ANON"
- : (cv == PL_main_cv) ? "MAIN"
- : CvUNIQUE(cv) ? "UNIQUE"
- : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
- PTR2UV(outside),
- (!outside ? "null"
- : CvANON(outside) ? "ANON"
- : (outside == PL_main_cv) ? "MAIN"
- : CvUNIQUE(outside) ? "UNIQUE"
- : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
-
- if (!padlist)
- return;
-
- pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
- pad = (AV*)*av_fetch(padlist, 1, FALSE);
- pname = AvARRAY(pad_name);
- ppad = AvARRAY(pad);
-
- for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
- if (SvPOK(pname[ix]))
- PerlIO_printf(Perl_debug_log,
- "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
- (int)ix, PTR2UV(ppad[ix]),
- SvFAKE(pname[ix]) ? "FAKE " : "",
- SvPVX(pname[ix]),
- (IV)I_32(SvNVX(pname[ix])),
- SvIVX(pname[ix]));
- }
-#endif /* DEBUGGING */
-}
-#endif /* DEBUG_CLOSURES */
-
-STATIC CV *
-S_cv_clone2(pTHX_ CV *proto, CV *outside)
-{
- AV* av;
- I32 ix;
- AV* protopadlist = CvPADLIST(proto);
- AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
- AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
- SV** pname = AvARRAY(protopad_name);
- SV** ppad = AvARRAY(protopad);
- I32 fname = AvFILLp(protopad_name);
- I32 fpad = AvFILLp(protopad);
- AV* comppadlist;
- CV* cv;
-
- assert(!CvUNIQUE(proto));
-
- ENTER;
- SAVECOMPPAD();
- SAVESPTR(PL_comppad_name);
- SAVESPTR(PL_compcv);
-
- cv = PL_compcv = (CV*)NEWSV(1104,0);
- sv_upgrade((SV *)cv, SvTYPE(proto));
- CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
- CvCLONED_on(cv);
-
-#ifdef USE_5005THREADS
- New(666, CvMUTEXP(cv), 1, perl_mutex);
- MUTEX_INIT(CvMUTEXP(cv));
- CvOWNER(cv) = 0;
-#endif /* USE_5005THREADS */
-#ifdef USE_ITHREADS
- CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
- : savepv(CvFILE(proto));
-#else
- CvFILE(cv) = CvFILE(proto);
-#endif
- CvGV(cv) = CvGV(proto);
- CvSTASH(cv) = CvSTASH(proto);
- CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
- CvSTART(cv) = CvSTART(proto);
- if (outside)
- CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
-
- if (SvPOK(proto))
- sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
-
- PL_comppad_name = newAV();
- for (ix = fname; ix >= 0; ix--)
- av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
-
- PL_comppad = newAV();
-
- comppadlist = newAV();
- AvREAL_off(comppadlist);
- av_store(comppadlist, 0, (SV*)PL_comppad_name);
- av_store(comppadlist, 1, (SV*)PL_comppad);
- CvPADLIST(cv) = comppadlist;
- av_fill(PL_comppad, AvFILLp(protopad));
- PL_curpad = AvARRAY(PL_comppad);
-
- av = newAV(); /* will be @_ */
- av_extend(av, 0);
- av_store(PL_comppad, 0, (SV*)av);
- AvFLAGS(av) = AVf_REIFY;
-
- for (ix = fpad; ix > 0; ix--) {
- SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
- if (namesv && namesv != &PL_sv_undef) {
- char *name = SvPVX(namesv); /* XXX */
- if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
- I32 off = pad_findlex(name, ix, SvIVX(namesv),
- CvOUTSIDE(cv), cxstack_ix, 0, 0);
- if (!off)
- PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
- else if (off != ix)
- Perl_croak(aTHX_ "panic: cv_clone: %s", name);
- }
- else { /* our own lexical */
- SV* sv;
- if (*name == '&') {
- /* anon code -- we'll come back for it */
- sv = SvREFCNT_inc(ppad[ix]);
- }
- else if (*name == '@')
- sv = (SV*)newAV();
- else if (*name == '%')
- sv = (SV*)newHV();
- else
- sv = NEWSV(0,0);
- if (!SvPADBUSY(sv))
- SvPADMY_on(sv);
- PL_curpad[ix] = sv;
- }
- }
- else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
- PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
- }
- else {
- SV* sv = NEWSV(0,0);
- SvPADTMP_on(sv);
- PL_curpad[ix] = sv;
- }
- }
-
- /* Now that vars are all in place, clone nested closures. */
-
- for (ix = fpad; ix > 0; ix--) {
- SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
- if (namesv
- && namesv != &PL_sv_undef
- && !(SvFLAGS(namesv) & SVf_FAKE)
- && *SvPVX(namesv) == '&'
- && CvCLONE(ppad[ix]))
- {
- CV *kid = cv_clone2((CV*)ppad[ix], cv);
- SvREFCNT_dec(ppad[ix]);
- CvCLONE_on(kid);
- SvPADMY_on(kid);
- PL_curpad[ix] = (SV*)kid;
- }
- }
-
-#ifdef DEBUG_CLOSURES
- PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
- cv_dump(outside);
- PerlIO_printf(Perl_debug_log, " from:\n");
- cv_dump(proto);
- PerlIO_printf(Perl_debug_log, " to:\n");
- cv_dump(cv);
-#endif
-
- LEAVE;
-
- if (CvCONST(cv)) {
- SV* const_sv = op_const_sv(CvSTART(cv), cv);
- assert(const_sv);
- /* constant sub () { $x } closing over $x - see lib/constant.pm */
- SvREFCNT_dec(cv);
- cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
- }
-
- return cv;
-}
-
-CV *
-Perl_cv_clone(pTHX_ CV *proto)
-{
- CV *cv;
- LOCK_CRED_MUTEX; /* XXX create separate mutex */
- cv = cv_clone2(proto, CvOUTSIDE(proto));
- UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
- return cv;
-}
-
void
Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
{
@@ -4727,8 +3985,7 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv)
if (type == OP_CONST && cSVOPo->op_sv)
sv = cSVOPo->op_sv;
else if ((type == OP_PADSV || type == OP_CONST) && cv) {
- AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
- sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
+ sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
if (!sv)
return Nullsv;
if (CvCONST(cv)) {
@@ -4779,7 +4036,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o,
GV *gv;
char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
register CV *cv=0;
- I32 ix;
SV *const_sv;

name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
@@ -4944,28 +4200,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o,
CvPADLIST(cv) = CvPADLIST(PL_compcv);
CvPADLIST(PL_compcv) = 0;
/* inner references to PL_compcv must be fixed up ... */
- {
- AV *padlist = CvPADLIST(cv);
- AV *comppad_name = (AV*)AvARRAY(padlist)[0];
- AV *comppad = (AV*)AvARRAY(padlist)[1];
- SV **namepad = AvARRAY(comppad_name);
- SV **curpad = AvARRAY(comppad);
- for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
- SV *namesv = namepad[ix];
- if (namesv && namesv != &PL_sv_undef
- && *SvPVX(namesv) == '&')
- {
- CV *innercv = (CV*)curpad[ix];
- if (CvOUTSIDE(innercv) == PL_compcv) {
- CvOUTSIDE(innercv) = cv;
- if (!CvANON(innercv) || CvCLONED(innercv)) {
- (void)SvREFCNT_inc(cv);
- SvREFCNT_dec(PL_compcv);
- }
- }
- }
- }
- }
+ pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
/* ... before we throw it away */
SvREFCNT_dec(PL_compcv);
if (PERLDB_INTER)/* Advice debugger on the new sub. */
@@ -5015,9 +4250,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o,
if (!block)
goto done;

- if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
- av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
-
if (CvLVALUE(cv)) {
CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
mod(scalarseq(block), OP_LEAVESUBLV));
@@ -5032,44 +4264,14 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o,
CALL_PEEP(CvSTART(cv));

/* now that optimizer has done its work, adjust pad values */
- if (CvCLONE(cv)) {
- SV **namep = AvARRAY(PL_comppad_name);
- for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
- SV *namesv;

- if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
- continue;
- /*
- * The only things that a clonable function needs in its
- * pad are references to outer lexicals and anonymous subs.
- * The rest are created anew during cloning.
- */
- if (!((namesv = namep[ix]) != Nullsv &&
- namesv != &PL_sv_undef &&
- (SvFAKE(namesv) ||
- *SvPVX(namesv) == '&')))
- {
- SvREFCNT_dec(PL_curpad[ix]);
- PL_curpad[ix] = Nullsv;
- }
- }
+ pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+
+ if (CvCLONE(cv)) {
assert(!CvCONST(cv));
if (ps && !*ps && op_const_sv(block, cv))
CvCONST_on(cv);
}
- else {
- AV *av = newAV(); /* Will be @_ */
- av_extend(av, 0);
- av_store(PL_comppad, 0, (SV*)av);
- AvFLAGS(av) = AVf_REIFY;
-
- for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
- if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
- continue;
- if (!SvPADMY(PL_curpad[ix]))
- SvPADTMP_on(PL_curpad[ix]);
- }
- }

/* If a potential closure prototype, don't keep a refcount on outer CV.
* This is okay as the lifetime of the prototype is tied to the
@@ -5325,7 +4527,6 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP
register CV *cv;
char *name;
GV *gv;
- I32 ix;
STRLEN n_a;

if (o)
@@ -5354,11 +4555,8 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP
CvGV(cv) = gv;
CvFILE_set_from_cop(cv, PL_curcop);

- for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
- if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
- SvPADTMP_on(PL_curpad[ix]);
- }

+ pad_tidy(padtidy_FORMAT);
CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
@@ -5520,20 +4718,8 @@ Perl_newSVREF(pTHX_ OP *o)
OP *
Perl_ck_anoncode(pTHX_ OP *o)
{
- PADOFFSET ix;
- SV* name;
-
- name = NEWSV(1106,0);
- sv_upgrade(name, SVt_PVNV);
- sv_setpvn(name, "&", 1);
- SvIVX(name) = -1;
- SvNVX(name) = 1;
- ix = pad_alloc(o->op_type, SVs_PADMY);
- av_store(PL_comppad_name, ix, name);
- av_store(PL_comppad, ix, cSVOPo->op_sv);
- SvPADMY_on(cSVOPo->op_sv);
+ cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
cSVOPo->op_sv = Nullsv;
- cSVOPo->op_targ = ix;
return o;
}

@@ -5825,9 +5011,9 @@ Perl_ck_rvconst(pTHX_ register OP *o)
#ifdef USE_ITHREADS
/* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
- SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
+ SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
GvIN_PAD_on(gv);
- PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
+ PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
#else
kid->op_sv = SvREFCNT_inc(gv);
#endif
@@ -6002,7 +5188,7 @@ Perl_ck_fun(pTHX_ OP *o)
/* is this op a FH constructor? */
if (is_handle_constructor(o,numargs)) {
char *name = Nullch;
- STRLEN len;
+ STRLEN len = 0;

flags = 0;
/* Set a flag to tell rv2gv to vivify
@@ -6011,10 +5197,17 @@ Perl_ck_fun(pTHX_ OP *o)
*/
priv = OPpDEREF;
if (kid->op_type == OP_PADSV) {
- SV **namep = av_fetch(PL_comppad_name,
- kid->op_targ, 4);
- if (namep && *namep)
- name = SvPV(*namep, len);
+ /*XXX DAPM 2002.08.25 tmp assert test */
+ /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
+ /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
+
+ name = PAD_COMPNAME_PV(kid->op_targ);
+ /* SvCUR of a pad namesv can't be trusted
+ * (see PL_generation), so calc its length
+ * manually */
+ if (name)
+ len = strlen(name);
+
}
else if (kid->op_type == OP_RV2SV
&& kUNOP->op_first->op_type == OP_GV)
@@ -6033,7 +5226,7 @@ Perl_ck_fun(pTHX_ OP *o)
if (name) {
SV *namesv;
targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
- namesv = PL_curpad[targ];
+ namesv = PAD_SVl(targ);
(void)SvUPGRADE(namesv, SVt_PV);
if (*name != '$')
sv_setpvn(namesv, "$", 1);
@@ -6489,7 +5682,7 @@ Perl_ck_shift(pTHX_ OP *o)
#ifdef USE_5005THREADS
if (!CvUNIQUE(PL_compcv)) {
argop = newOP(OP_PADAV, OPf_REF);
- argop->op_targ = 0; /* PL_curpad[0] is @_ */
+ argop->op_targ = 0; /* PAD_SV(0) is @_ */
}
else {
argop = newUNOP(OP_RV2AV, 0,
@@ -7001,16 +6194,16 @@ Perl_peep(pTHX_ register OP *o)
if (SvPADTMP(cSVOPo->op_sv)) {
/* If op_sv is already a PADTMP then it is being used by
* some pad, so make a copy. */
- sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
- SvREADONLY_on(PL_curpad[ix]);
+ sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
+ SvREADONLY_on(PAD_SVl(ix));
SvREFCNT_dec(cSVOPo->op_sv);
}
else {
- SvREFCNT_dec(PL_curpad[ix]);
+ SvREFCNT_dec(PAD_SVl(ix));
SvPADTMP_on(cSVOPo->op_sv);
- PL_curpad[ix] = cSVOPo->op_sv;
+ PAD_SETSV(ix, cSVOPo->op_sv);
/* XXX I don't know how this isn't readonly already. */
- SvREADONLY_on(PL_curpad[ix]);
+ SvREADONLY_on(PAD_SVl(ix));
}
cSVOPo->op_sv = Nullsv;
o->op_targ = ix;
diff -up '17914.ORIG/op.h' '17914.pad/op.h'
Index: ./op.h
--- ./op.h Tue Sep 24 00:27:26 2002
+++ ./op.h Tue Sep 24 21:59:28 2002
@@ -23,15 +23,6 @@
* which may or may not check number of children).
*/

-#if PTRSIZE == 4
-typedef U32TYPE PADOFFSET;
-#else
-# if PTRSIZE == 8
-typedef U64TYPE PADOFFSET;
-# endif
-#endif
-#define NOT_IN_PAD ((PADOFFSET) -1)
-
#ifdef DEBUGGING_OPS
#define OPCODE opcode
#else
@@ -387,13 +378,13 @@ struct loop {


#ifdef USE_ITHREADS
-# define cGVOPx_gv(o) ((GV*)PL_curpad[cPADOPx(o)->op_padix])
+# define cGVOPx_gv(o) ((GV*)PAD_SVl(cPADOPx(o)->op_padix))
# define IS_PADGV(v) (v && SvTYPE(v) == SVt_PVGV && GvIN_PAD(v))
# define IS_PADCONST(v) (v && SvREADONLY(v))
# define cSVOPx_sv(v) (cSVOPx(v)->op_sv \
- ? cSVOPx(v)->op_sv : PL_curpad[(v)->op_targ])
+ ? cSVOPx(v)->op_sv : PAD_SVl((v)->op_targ))
# define cSVOPx_svp(v) (cSVOPx(v)->op_sv \
- ? &cSVOPx(v)->op_sv : &PL_curpad[(v)->op_targ])
+ ? &cSVOPx(v)->op_sv : &PAD_SVl((v)->op_targ))
#else
# define cGVOPx_gv(o) ((GV*)cSVOPx(o)->op_sv)
# define IS_PADGV(v) FALSE
diff -up /dev/null '17914.pad/pad.c'
Index: ./pad.c
--- ./pad.c Thu Jan 1 01:00:00 1970
+++ ./pad.c Wed Sep 25 20:34:16 2002
@@ -0,0 +1,1520 @@
+/* pad.c
+ *
+ * Copyright (c) 2002, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * "Anyway: there was this Mr Frodo left an orphan and stranded, as you
+ * might say, among those queer Bucklanders, being brought up anyhow in
+ * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
+ * never had fewer than a couple of hundred relations in the place. Mr
+ * Bilbo never did a kinder deed than when he brought the lad back to
+ * live among decent folk." --the Gaffer
+ */
+
+/* XXX DAPM
+ * As of Sept 2002, this file is new and may be in a state of flux for
+ * a while. I've marked things I intent to come back and look at further
+ * with an 'XXX DAPM' comment.
+ */
+
+/*
+=head1 Pad Data Structures
+
+=for apidoc m|AV *|CvPADLIST|CV *cv
+CV's can have CvPADLIST(cv) set to point to an AV.
+
+For these purposes "forms" are a kind-of CV, eval""s are too (except they're
+not callable at will and are always thrown away after the eval"" is done
+executing).
+
+XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
+but that is really the callers pad (a slot of which is allocated by
+every entersub).
+
+The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
+is managed "manual" (mostly in op.c) rather than normal av.c rules.
+The items in the AV are not SVs as for a normal AV, but other AVs:
+
+0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
+the "static type information" for lexicals.
+
+The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
+depth of recursion into the CV.
+The 0'th slot of a frame AV is an AV which is @_.
+other entries are storage for variables and op targets.
+
+During compilation:
+C<PL_comppad_name> is set the the the names AV.
+C<PL_comppad> is set the the frame AV for the frame CvDEPTH == 1.
+C<PL_curpad> is set the body of the frame AV (i.e. AvARRAY(PL_comppad)).
+
+Itterating over the names AV itterates over all possible pad
+items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
+&PL_sv_undef "names" (see pad_alloc()).
+
+Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
+The rest are op targets/GVs/constants which are statically allocated
+or resolved at compile time. These don't have names by which they
+can be looked up from Perl code at run time through eval"" like
+my/our variables can be. Since they can't be looked up by "name"
+but only by their index allocated at compile time (which is usually
+in PL_op->op_targ), wasting a name SV for them doesn't make sense.
+
+The SVs in the names AV have their PV being the name of the variable.
+NV+1..IV inclusive is a range of cop_seq numbers for which the name is
+valid. For typed lexicals name SV is SVt_PVMG and SvSTASH points at the
+type. For C<our> lexicals, the type is SVt_PVGV, and GvSTASH points at the
+stash of the associated global (so that duplicate C<our> delarations in the
+same package can be detected). SvCUR is sometimes hijacked to
+store the generation number during compilation.
+
+If SvFAKE is set on the name SV then slot in the frame AVs are
+a REFCNT'ed references to a lexical from "outside".
+
+If the 'name' is '&' the the corresponding entry in frame AV
+is a CV representing a possible closure.
+(SvFAKE and name of '&' is not a meaningful combination currently but could
+become so if C<my sub foo {}> is implemented.)
+
+=cut
+*/
+
+
+
+#include "EXTERN.h"
+#define PERL_IN_PAD_C
+#include "perl.h"
+
+
+#define PAD_MAX 999999999
+
+
+
+/*
+=for apidoc pad_new
+
+Create a new comnpiling padlist, saving and updating the various global
+vars at the same time as creating the pad itself. The following flags
+can be OR'ed together:
+
+ padnew_CLONE this pad is for a cloned CV
+ padnew_SAVE save old globals
+ padnew_SAVESUB also save extra stuff for start of sub
+
+=cut
+*/
+
+PADLIST *
+Perl_pad_new(pTHX_ padnew_flags flags)
+{
+ AV *padlist, *padname, *pad, *a0;
+
+ /* XXX DAPM really need a new SAVEt_PAD which restores all or most
+ * vars (based on flags) rather than storing vals + addresses for
+ * each individually. Also see pad_block_start.
+ * XXX DAPM Try to see whether all these conditionals are required
+ */
+
+ /* save existing state, ... */
+
+ if (flags & padnew_SAVE) {
+ SAVEVPTR(PL_curpad);
+ SAVESPTR(PL_comppad);
+ SAVESPTR(PL_comppad_name);
+ if (! (flags & padnew_CLONE)) {
+ SAVEI32(PL_padix);
+ SAVEI32(PL_comppad_name_fill);
+ SAVEI32(PL_min_intro_pending);
+ SAVEI32(PL_max_intro_pending);
+ if (flags & padnew_SAVESUB) {
+ SAVEI32(PL_pad_reset_pending);
+ }
+ }
+ }
+ /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
+ * saved - check at some pt that this is okay */
+
+ /* ... create new pad ... */
+
+ padlist = newAV();
+ padname = newAV();
+ pad = newAV();
+
+ if (flags & padnew_CLONE) {
+ /* XXX DAPM I dont know why cv_clone needs it
+ * doing differently yet - perhaps this separate branch can be
+ * dispensed with eventually ???
+ */
+
+ a0 = newAV(); /* will be @_ */
+ av_extend(a0,0);
+ av_store(pad, 0, (SV*)a0);
+ AvFLAGS(a0) = AVf_REIFY;
+ }
+ else {
+#ifdef USE_5005THREADS
+ av_store(padname, 0, newSVpvn("@_", 2));
+ a0 = newAV();
+ SvPADMY_on((SV*)a0); /* XXX Needed? */
+ av_store(pad, 0, (SV*)a0);
+#else
+ av_store(pad, 0, Nullsv);
+#endif /* USE_THREADS */
+ }
+
+ AvREAL_off(padlist);
+ av_store(padlist, 0, (SV*)padname);
+ av_store(padlist, 1, (SV*)pad);
+
+ /* ... then update state variables */
+
+ PL_comppad_name = (AV*)(*av_fetch(padlist, 0, FALSE));
+ PL_comppad = (AV*)(*av_fetch(padlist, 1, FALSE));
+ PL_curpad = AvARRAY(PL_comppad);
+
+ if (! (flags & padnew_CLONE)) {
+ PL_comppad_name_fill = 0;
+ PL_min_intro_pending = 0;
+ PL_padix = 0;
+ }
+
+ DEBUG_X(PerlIO_printf(Perl_debug_log,
+ "Pad 0x%"UVxf"[0x%"UVxf"] new: padlist=0x%"UVxf
+ " name=0x%"UVxf" flags=0x%"UVxf"\n",
+ PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(padlist),
+ PTR2UV(padname), (UV)flags
+ )
+ );
+
+ return (PADLIST*)padlist;
+}
+
+/*
+=for apidoc pad_undef
+
+Free the padlist associated with a CV.
+If parts of it happen to be current, we null the relevant
+PL_*pad* global vars so that we don't have any dangling references left.
+We also repoint the CvOUTSIDE of any about-to-be-orphaned
+inner subs to outercv.
+
+=cut
+*/
+
+void
+Perl_pad_undef(pTHX_ CV* cv, CV* outercv)
+{
+ I32 ix;
+ PADLIST *padlist = CvPADLIST(cv);
+
+ if (!padlist)
+ return;
+ if (!SvREFCNT(CvPADLIST(cv))) /* may be during global destruction */
+ return;
+
+ DEBUG_X(PerlIO_printf(Perl_debug_log,
+ "Pad undef: padlist=0x%"UVxf"\n" , PTR2UV(padlist))
+ );
+
+ /* pads may be cleared out already during global destruction */
+ if (CvEVAL(cv) && !CvGV(cv) /* is this eval"" ? */
+ && !PL_dirty)
+ {
+ /* XXX DAPM the following code is very similar to
+ * pad_fixup_inner_anons(). Merge??? */
+
+ /* inner references to eval's cv must be fixed up */
+ AV *comppad_name = (AV*)AvARRAY(padlist)[0];
+ SV **namepad = AvARRAY(comppad_name);
+ AV *comppad = (AV*)AvARRAY(padlist)[1];
+ SV **curpad = AvARRAY(comppad);
+ for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
+ SV *namesv = namepad[ix];
+ if (namesv && namesv != &PL_sv_undef
+ && *SvPVX(namesv) == '&'
+ && ix <= AvFILLp(comppad))
+ {
+ CV *innercv = (CV*)curpad[ix];
+ if (innercv && SvTYPE(innercv) == SVt_PVCV
+ && CvOUTSIDE(innercv) == cv)
+ {
+ CvOUTSIDE(innercv) = outercv;
+ if (!CvANON(innercv) || CvCLONED(innercv)) {
+ (void)SvREFCNT_inc(outercv);
+ if (SvREFCNT(cv))
+ SvREFCNT_dec(cv);
+ }
+ }
+ }
+ }
+ }
+ ix = AvFILLp(padlist);
+ while (ix >= 0) {
+ SV* sv = AvARRAY(padlist)[ix--];
+ if (!sv)
+ continue;
+ if (sv == (SV*)PL_comppad_name)
+ PL_comppad_name = Nullav;
+ else if (sv == (SV*)PL_comppad) {
+ PL_comppad = Nullav;
+ PL_curpad = Null(SV**);
+ }
+ SvREFCNT_dec(sv);
+ }
+ SvREFCNT_dec((SV*)CvPADLIST(cv));
+ CvPADLIST(cv) = Null(PADLIST*);
+}
+
+
+
+
+/*
+=for apidoc pad_add_name
+
+Create a new name in the current pad at the specified offset.
+If C<typestash> is valid, the name is for a typed lexical; set the
+name's stash to that value.
+If C<ourstash> is valid, it's an our lexical, set the name's
+GvSTASH to that value
+
+Also, if the name is @.. or %.., create a new array or hash for that slot
+
+If fake, it means we're cloning an existing entry
+
+=cut
+*/
+
+/*
+ * XXX DAPM this doesn't seem the right place to create a new array/hash.
+ * Whatever we do, we should be consistent - create scalars too, and
+ * create even if fake. Really need to integrate better the whole entry
+ * creation business - when + where does the name and value get created?
+ */
+
+PADOFFSET
+Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
+{
+
+ PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
+ SV* namesv = NEWSV(1102,0);
+ U32 min, max;
+
+ if (fake) {
+ min = PL_curcop->cop_seq;
+ max = PAD_MAX;
+ }
+ else {
+ /* not yet introduced */
+ min = PAD_MAX;
+ max = 0;
+ }
+
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad addname: %ld \"%s\", (%lu,%lu)%s\n",
+ (long)offset, name, (unsigned long)min, (unsigned long)max,
+ (fake ? " FAKE" : "")
+ )
+ );
+
+ sv_upgrade(namesv, ourstash ? SVt_PVGV : typestash ? SVt_PVMG : SVt_PVNV);
+ sv_setpv(namesv, name);
+
+ if (typestash) {
+ SvFLAGS(namesv) |= SVpad_TYPED;
+ SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) typestash);
+ }
+ if (ourstash) {
+ SvFLAGS(namesv) |= SVpad_OUR;
+ GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) ourstash);
+ }
+
+ av_store(PL_comppad_name, offset, namesv);
+ SvNVX(namesv) = (NV)min;
+ SvIVX(namesv) = max;
+ if (fake)
+ SvFAKE_on(namesv);
+ else {
+ if (!PL_min_intro_pending)
+ PL_min_intro_pending = offset;
+ PL_max_intro_pending = offset;
+ if (*name == '@')
+ av_store(PL_comppad, offset, (SV*)newAV());
+ else if (*name == '%')
+ av_store(PL_comppad, offset, (SV*)newHV());
+ SvPADMY_on(PL_curpad[offset]);
+ }
+
+ return offset;
+}
+
+
+
+
+/*
+=for apidoc pad_alloc
+
+Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
+the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
+for a slot which has no name and and no active value.
+
+=cut
+*/
+
+/* XXX DAPM integrate alloc(), add_name() and add_anon(),
+ * or at least rationalise ??? */
+
+
+PADOFFSET
+Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
+{
+ SV *sv;
+ I32 retval;
+
+ if (AvARRAY(PL_comppad) != PL_curpad)
+ Perl_croak(aTHX_ "panic: pad_alloc");
+ if (PL_pad_reset_pending)
+ pad_reset();
+ if (tmptype & SVs_PADMY) {
+ do {
+ sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
+ } while (SvPADBUSY(sv)); /* need a fresh one */
+ retval = AvFILLp(PL_comppad);
+ }
+ else {
+ SV **names = AvARRAY(PL_comppad_name);
+ SSize_t names_fill = AvFILLp(PL_comppad_name);
+ for (;;) {
+ /*
+ * "foreach" index vars temporarily become aliases to non-"my"
+ * values. Thus we must skip, not just pad values that are
+ * marked as current pad values, but also those with names.
+ */
+ if (++PL_padix <= names_fill &&
+ (sv = names[PL_padix]) && sv != &PL_sv_undef)
+ continue;
+ sv = *av_fetch(PL_comppad, PL_padix, TRUE);
+ if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
+ !IS_PADGV(sv) && !IS_PADCONST(sv))
+ break;
+ }
+ retval = PL_padix;
+ }
+ SvFLAGS(sv) |= tmptype;
+ PL_curpad = AvARRAY(PL_comppad);
+
+ DEBUG_X(PerlIO_printf(Perl_debug_log,
+ "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
+ PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
+ PL_op_name[optype]));
+ return (PADOFFSET)retval;
+}
+
+/*
+=for apidoc pad_add_anon
+
+Add an anon code entry to the current compiling pad
+
+=cut
+*/
+
+PADOFFSET
+Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
+{
+ PADOFFSET ix;
+ SV* name;
+
+ name = NEWSV(1106,0);
+ sv_upgrade(name, SVt_PVNV);
+ sv_setpvn(name, "&", 1);
+ SvIVX(name) = -1;
+ SvNVX(name) = 1;
+ ix = pad_alloc(op_type, SVs_PADMY);
+ av_store(PL_comppad_name, ix, name);
+ av_store(PL_comppad, ix, sv);
+ SvPADMY_on(sv);
+ return ix;
+}
+
+
+
+/*
+=for apidoc pad_check_dup
+
+Check for duplicate declarations: report any of:
+ * a my in the current scope with the same name;
+ * an our (anywhere in the pad) with the same name and the same stash
+ as C<ourstash>
+C<is_our> indicates that the name to check is an 'our' declaration
+
+
+=cut
+*/
+
+/* XXX DAPM integrate this into pad_add_name ??? */
+
+void
+Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
+{
+ SV **svp, *sv;
+ PADOFFSET top, off;
+
+ if (!ckWARN(WARN_MISC) || AvFILLp(PL_comppad_name) < 0)
+ return; /* nothing to check */
+
+ svp = AvARRAY(PL_comppad_name);
+ top = AvFILLp(PL_comppad_name);
+ /* check the current scope */
+ /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
+ * type ? */
+ for (off = top; (I32)off > PL_comppad_name_floor; off--) {
+ if ((sv = svp[off])
+ && sv != &PL_sv_undef
+ && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
+ && (!is_our
+ || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
+ && strEQ(name, SvPVX(sv)))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "\"%s\" variable %s masks earlier declaration in same %s",
+ (is_our ? "our" : "my"),
+ name,
+ (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
+ --off;
+ break;
+ }
+ }
+ /* check the rest of the pad */
+ if (is_our) {
+ do {
+ if ((sv = svp[off])
+ && sv != &PL_sv_undef
+ && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
+ && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
+ && strEQ(name, SvPVX(sv)))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "\"our\" variable %s redeclared", name);
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "\t(Did you mean \"local\" instead of \"our\"?)\n");
+ break;
+ }
+ } while ( off-- > 0 );
+ }
+}
+
+
+
+/*
+=for apidoc pad_findmy
+
+Given a lexical name, try to find it's offset, first in the current pad,
+or failing that, in the pads of any lexically enclosing subs (including
+the complications introduced by eval). If the name is found in an outer pad, then a fake entry is added to the current pad.
+Returns the offset in the current pad, or NOT_IN_PAD on failure.
+
+=cut
+*/
+
+PADOFFSET
+Perl_pad_findmy(pTHX_ char *name)
+{
+ I32 off;
+ I32 pendoff = 0;
+ SV *sv;
+ SV **svp = AvARRAY(PL_comppad_name);
+ U32 seq = PL_cop_seqmax;
+ PERL_CONTEXT *cx;
+ CV *outside;
+
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findmy: \"%s\"\n", name));
+
+#ifdef USE_5005THREADS
+ /*
+ * Special case to get lexical (and hence per-thread) @_.
+ * XXX I need to find out how to tell at parse-time whether use
+ * of @_ should refer to a lexical (from a sub) or defgv (global
+ * scope and maybe weird sub-ish things like formats). See
+ * startsub in perly.y. It's possible that @_ could be lexical
+ * (at least from subs) even in non-threaded perl.
+ */
+ if (strEQ(name, "@_"))
+ return 0; /* success. (NOT_IN_PAD indicates failure) */
+#endif /* USE_5005THREADS */
+
+ /* The one we're looking for is probably just before comppad_name_fill. */
+ for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
+ if ((sv = svp[off]) &&
+ sv != &PL_sv_undef &&
+ (!SvIVX(sv) ||
+ (seq <= (U32)SvIVX(sv) &&
+ seq > (U32)I_32(SvNVX(sv)))) &&
+ strEQ(SvPVX(sv), name))
+ {
+ if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
+ return (PADOFFSET)off;
+ pendoff = off; /* this pending def. will override import */
+ }
+ }
+
+ outside = CvOUTSIDE(PL_compcv);
+
+ /* Check if if we're compiling an eval'', and adjust seq to be the
+ * eval's seq number. This depends on eval'' having a non-null
+ * CvOUTSIDE() while it is being compiled. The eval'' itself is
+ * identified by CvEVAL being true and CvGV being null. */
+ if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
+ cx = &cxstack[cxstack_ix];
+ if (CxREALEVAL(cx))
+ seq = cx->blk_oldcop->cop_seq;
+ }
+
+ /* See if it's in a nested scope */
+ off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
+ if (!off) /* pad_findlex returns 0 for failure...*/
+ return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
+
+ /* If there is a pending local definition, this new alias must die */
+ if (pendoff)
+ SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
+ return off;
+}
+
+
+
+/*
+=for apidoc pad_findlex
+
+Find a named lexical anywhere in a chain of nested pads. Add fake entries
+in the inner pads if its found in an outer one.
+
+If flags == FINDLEX_NOSEARCH we don't bother searching outer contexts.
+
+=cut
+*/
+
+#define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
+
+STATIC PADOFFSET
+S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
+ I32 cx_ix, I32 saweval, U32 flags)
+{
+ CV *cv;
+ I32 off;
+ SV *sv;
+ register I32 i;
+ register PERL_CONTEXT *cx;
+
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad findlex: \"%s\" off=%ld seq=%lu cv=0x%"UVxf
+ " ix=%ld saweval=%d flags=%lu\n",
+ name, (long)newoff, (unsigned long)seq, PTR2UV(startcv),
+ (long)cx_ix, (int)saweval, (unsigned long)flags
+ )
+ );
+
+ for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
+ AV *curlist = CvPADLIST(cv);
+ SV **svp = av_fetch(curlist, 0, FALSE);
+ AV *curname;
+
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ " searching: cv=0x%"UVxf"\n", PTR2UV(cv))
+ );
+
+ if (!svp || *svp == &PL_sv_undef)
+ continue;
+ curname = (AV*)*svp;
+ svp = AvARRAY(curname);
+ for (off = AvFILLp(curname); off > 0; off--) {
+ I32 depth;
+ AV *oldpad;
+ SV *oldsv;
+
+
+ if ( ! (
+ (sv = svp[off]) &&
+ sv != &PL_sv_undef &&
+ seq <= (U32)SvIVX(sv) &&
+ seq > (U32)I_32(SvNVX(sv)) &&
+ strEQ(SvPVX(sv), name))
+ )
+ continue;
+
+ depth = CvDEPTH(cv);
+ if (!depth) {
+ if (newoff) {
+ if (SvFAKE(sv))
+ continue;
+ return 0; /* don't clone from inactive stack frame */
+ }
+ depth = 1;
+ }
+
+ oldpad = (AV*)AvARRAY(curlist)[depth];
+ oldsv = *av_fetch(oldpad, off, TRUE);
+
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ " matched: offset %ld"
+ " %s(%lu,%lu), sv=0x%"UVxf"\n",
+ (long)off,
+ SvFAKE(sv) ? "FAKE " : "",
+ (unsigned long)I_32(SvNVX(sv)),
+ (unsigned long)SvIVX(sv),
+ PTR2UV(oldsv)
+ )
+ );
+
+ if (!newoff) { /* Not a mere clone operation. */
+ newoff = pad_add_name(
+ SvPVX(sv),
+ (SvFLAGS(sv) & SVpad_TYPED) ? SvSTASH(sv) : Nullhv,
+ (SvFLAGS(sv) & SVpad_OUR) ? GvSTASH(sv) : Nullhv,
+ 1 /* fake */
+ );
+
+ if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
+ /* "It's closures all the way down." */
+ CvCLONE_on(PL_compcv);
+ if (cv == startcv) {
+ if (CvANON(PL_compcv))
+ oldsv = Nullsv; /* no need to keep ref */
+ }
+ else {
+ CV *bcv;
+ for (bcv = startcv;
+ bcv && bcv != cv && !CvCLONE(bcv);
+ bcv = CvOUTSIDE(bcv))
+ {
+ if (CvANON(bcv)) {
+ /* install the missing pad entry in intervening
+ * nested subs and mark them cloneable. */
+ AV *ocomppad_name = PL_comppad_name;
+ AV *ocomppad = PL_comppad;
+ SV **ocurpad = PL_curpad;
+ AV *padlist = CvPADLIST(bcv);
+ PL_comppad_name = (AV*)AvARRAY(padlist)[0];
+ PL_comppad = (AV*)AvARRAY(padlist)[1];
+ PL_curpad = AvARRAY(PL_comppad);
+ pad_add_name(
+ SvPVX(sv),
+ (SvFLAGS(sv) & SVpad_TYPED)
+ ? SvSTASH(sv) : Nullhv,
+ (SvFLAGS(sv) & SVpad_OUR)
+ ? GvSTASH(sv) : Nullhv,
+ 1 /* fake */
+ );
+
+ PL_comppad_name = ocomppad_name;
+ PL_comppad = ocomppad;
+ PL_curpad = ocurpad;
+ CvCLONE_on(bcv);
+ }
+ else {
+ if (ckWARN(WARN_CLOSURE)
+ && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
+ "Variable \"%s\" may be unavailable",
+ name);
+ }
+ break;
+ }
+ }
+ }
+ }
+ else if (!CvUNIQUE(PL_compcv)) {
+ if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
+ && !(SvFLAGS(sv) & SVpad_OUR))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
+ "Variable \"%s\" will not stay shared", name);
+ }
+ }
+ }
+ av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad findlex: set offset %ld to sv 0x%"UVxf"\n",
+ (long)newoff, PTR2UV(oldsv)
+ )
+ );
+ return newoff;
+ }
+ }
+
+ if (flags & FINDLEX_NOSEARCH)
+ return 0;
+
+ /* Nothing in current lexical context--try eval's context, if any.
+ * This is necessary to let the perldb get at lexically scoped variables.
+ * XXX This will also probably interact badly with eval tree caching.
+ */
+
+ for (i = cx_ix; i >= 0; i--) {
+ cx = &cxstack[i];
+ switch (CxTYPE(cx)) {
+ default:
+ if (i == 0 && saweval) {
+ return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
+ }
+ break;
+ case CXt_EVAL:
+ switch (cx->blk_eval.old_op_type) {
+ case OP_ENTEREVAL:
+ if (CxREALEVAL(cx)) {
+ PADOFFSET off;
+ saweval = i;
+ seq = cxstack[i].blk_oldcop->cop_seq;
+ startcv = cxstack[i].blk_eval.cv;
+ if (startcv && CvOUTSIDE(startcv)) {
+ off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
+ i-1, saweval, 0);
+ if (off) /* continue looking if not found here */
+ return off;
+ }
+ }
+ break;
+ case OP_DOFILE:
+ case OP_REQUIRE:
+ /* require/do must have their own scope */
+ return 0;
+ }
+ break;
+ case CXt_FORMAT:
+ case CXt_SUB:
+ if (!saweval)
+ return 0;
+ cv = cx->blk_sub.cv;
+ if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
+ saweval = i; /* so we know where we were called from */
+ seq = cxstack[i].blk_oldcop->cop_seq;
+ continue;
+ }
+ return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
+ }
+ }
+
+ return 0;
+}
+
+
+/*
+=for apidoc pad_sv
+
+Get the value at offset po in the current pad.
+Use macro PAD_SV instead of calling this function directly.
+
+=cut
+*/
+
+
+SV *
+Perl_pad_sv(pTHX_ PADOFFSET po)
+{
+
+#ifdef DEBUGGING
+ /* for display purposes, try to guess the AV corresponding to
+ * Pl_curpad */
+ AV *cp = PL_comppad;
+ if (cp && AvARRAY(cp) != PL_curpad)
+ cp = Nullav;
+#endif
+
+#ifndef USE_5005THREADS
+ if (!po)
+ Perl_croak(aTHX_ "panic: pad_sv po");
+#endif
+ DEBUG_X(PerlIO_printf(Perl_debug_log,
+ "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
+ PTR2UV(cp), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
+ );
+ return PL_curpad[po];
+}
+
+
+/*
+=for apidoc pad_setsv
+
+Set the entry at offset po in the current pad to sv.
+Use the macro PAD_SETSV() rather than calling this function directly.
+
+=cut
+*/
+
+#ifdef DEBUGGING
+void
+Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
+{
+
+ /* for display purposes, try to guess the AV corresponding to
+ * Pl_curpad */
+ AV *cp = PL_comppad;
+ if (cp && AvARRAY(cp) != PL_curpad)
+ cp = Nullav;
+
+ DEBUG_X(PerlIO_printf(Perl_debug_log,
+ "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
+ PTR2UV(cp), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
+ );
+ PL_curpad[po] = sv;
+}
+#endif
+
+
+
+/*
+=for apidoc pad_block_start
+
+Update the pad compilation state variables on entry to a new block
+
+=cut
+*/
+
+/* XXX DAPM perhaps:
+ * - integrate this in general state-saving routine ???
+ * - combine with the state-saving going on in pad_new ???
+ * - introduce a new SAVE type that does all this in one go ?
+ */
+
+void
+Perl_pad_block_start(pTHX_ int full)
+{
+ SAVEI32(PL_comppad_name_floor);
+ PL_comppad_name_floor = AvFILLp(PL_comppad_name);
+ if (full)
+ PL_comppad_name_fill = PL_comppad_name_floor;
+ if (PL_comppad_name_floor < 0)
+ PL_comppad_name_floor = 0;
+ SAVEI32(PL_min_intro_pending);
+ SAVEI32(PL_max_intro_pending);
+ PL_min_intro_pending = 0;
+ SAVEI32(PL_comppad_name_fill);
+ SAVEI32(PL_padix_floor);
+ PL_padix_floor = PL_padix;
+ PL_pad_reset_pending = FALSE;
+}
+
+
+/*
+=for apidoc intro_my
+
+"Introduce" my variables to visible status.
+
+=cut
+*/
+
+U32
+Perl_intro_my(pTHX)
+{
+ SV **svp;
+ SV *sv;
+ I32 i;
+
+ if (! PL_min_intro_pending)
+ return PL_cop_seqmax;
+
+ svp = AvARRAY(PL_comppad_name);
+ for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
+ if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
+ SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
+ SvNVX(sv) = (NV)PL_cop_seqmax;
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
+ (long)i, SvPVX(sv),
+ (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
+ );
+ }
+ }
+ PL_min_intro_pending = 0;
+ PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
+
+ return PL_cop_seqmax++;
+}
+
+/*
+=for apidoc pad_leavemy
+
+Cleanup at end of scope during compilation: set the max seq number for
+lexicals in this scope and warn of any lexicals that never got introduced.
+
+=cut
+*/
+
+void
+Perl_pad_leavemy(pTHX)
+{
+ I32 off;
+ SV **svp = AvARRAY(PL_comppad_name);
+ SV *sv;
+
+ PL_pad_reset_pending = FALSE;
+
+ if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
+ for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
+ if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ "%s never introduced", SvPVX(sv));
+ }
+ }
+ /* "Deintroduce" my variables that are leaving with this scope. */
+ for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
+ if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX) {
+ SvIVX(sv) = PL_cop_seqmax;
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
+ (long)off, SvPVX(sv),
+ (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
+ );
+ }
+ }
+ PL_cop_seqmax++;
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
+
+}
+
+
+/*
+=for apidoc pad_swipe
+
+Abandon the tmp in the current pad at offset po and replace with a
+new one.
+
+=cut
+*/
+
+void
+Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
+{
+ if (!PL_curpad)
+ return;
+ if (AvARRAY(PL_comppad) != PL_curpad)
+ Perl_croak(aTHX_ "panic: pad_swipe curpad");
+ if (!po)
+ Perl_croak(aTHX_ "panic: pad_swipe po");
+
+ DEBUG_X(PerlIO_printf(Perl_debug_log,
+ "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
+ PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
+
+ SvPADTMP_off(PL_curpad[po]);
+ if (refadjust)
+ SvREFCNT_dec(PL_curpad[po]);
+
+ PL_curpad[po] = NEWSV(1107,0);
+ SvPADTMP_on(PL_curpad[po]);
+ if ((I32)po < PL_padix)
+ PL_padix = po - 1;
+}
+
+
+/*
+=for apidoc pad_reset
+
+Mark all the current temporaries for reuse
+
+=cut
+*/
+
+/* XXX pad_reset() is currently disabled because it results in serious bugs.
+ * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
+ * on the stack by OPs that use them, there are several ways to get an alias
+ * to a shared TARG. Such an alias will change randomly and unpredictably.
+ * We avoid doing this until we can think of a Better Way.
+ * GSAR 97-10-29 */
+void
+Perl_pad_reset(pTHX)
+{
+#ifdef USE_BROKEN_PAD_RESET
+ register I32 po;
+
+ if (AvARRAY(PL_comppad) != PL_curpad)
+ Perl_croak(aTHX_ "panic: pad_reset curpad");
+
+ DEBUG_X(PerlIO_printf(Perl_debug_log,
+ "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
+ PTR2UV(PL_comppad), PTR2UV(PL_curpad),
+ (long)PL_padix, (long)PL_padix_floor
+ )
+ );
+
+ if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
+ for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
+ if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
+ SvPADTMP_off(PL_curpad[po]);
+ }
+ PL_padix = PL_padix_floor;
+ }
+#endif
+ PL_pad_reset_pending = FALSE;
+}
+
+
+/*
+=for apidoc pad_tidy
+
+Tidy up a pad after we've finished compiling it:
+ * remove most stuff from the pads of anonsub prototypes;
+ * give it a @_;
+ * mark tmps as such.
+
+=cut
+*/
+
+/* XXX DAPM surely most of this stuff should be done properly
+ * at the right time beforehand, rather than going around afterwards
+ * cleaning up our mistakes ???
+ */
+
+void
+Perl_pad_tidy(pTHX_ padtidy_type type)
+{
+ PADOFFSET ix;
+ /* extend curpad to match namepad */
+ if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
+ av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
+
+ if (type == padtidy_SUBCLONE) {
+ SV **namep = AvARRAY(PL_comppad_name);
+ for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
+ SV *namesv;
+
+ if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
+ continue;
+ /*
+ * The only things that a clonable function needs in its
+ * pad are references to outer lexicals and anonymous subs.
+ * The rest are created anew during cloning.
+ */
+ if (!((namesv = namep[ix]) != Nullsv &&
+ namesv != &PL_sv_undef &&
+ (SvFAKE(namesv) ||
+ *SvPVX(namesv) == '&')))
+ {
+ SvREFCNT_dec(PL_curpad[ix]);
+ PL_curpad[ix] = Nullsv;
+ }
+ }
+ }
+ else if (type == padtidy_SUB) {
+ /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
+ AV *av = newAV(); /* Will be @_ */
+ av_extend(av, 0);
+ av_store(PL_comppad, 0, (SV*)av);
+ AvFLAGS(av) = AVf_REIFY;
+ }
+
+ /* XXX DAPM rationalise these two similar branches */
+
+ if (type == padtidy_SUB) {
+ for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
+ if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
+ continue;
+ if (!SvPADMY(PL_curpad[ix]))
+ SvPADTMP_on(PL_curpad[ix]);
+ }
+ }
+ else if (type == padtidy_FORMAT) {
+ for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
+ if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
+ SvPADTMP_on(PL_curpad[ix]);
+ }
+ }
+}
+
+
+/*
+=for apidoc pad_free
+
+Free the SV at offet po in the current pad.
+
+=cut
+*/
+
+/* XXX DAPM integrate with pad_swipe ???? */
+void
+Perl_pad_free(pTHX_ PADOFFSET po)
+{
+ if (!PL_curpad)
+ return;
+ if (AvARRAY(PL_comppad) != PL_curpad)
+ Perl_croak(aTHX_ "panic: pad_free curpad");
+ if (!po)
+ Perl_croak(aTHX_ "panic: pad_free po");
+
+ DEBUG_X(PerlIO_printf(Perl_debug_log,
+ "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
+ PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
+ );
+
+ if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
+ SvPADTMP_off(PL_curpad[po]);
+#ifdef USE_ITHREADS
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(PL_curpad[po])) {
+ sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
+ } else
+#endif
+ SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
+
+#endif
+ }
+ if ((I32)po < PL_padix)
+ PL_padix = po - 1;
+}
+
+
+
+/*
+=for apidoc do_dump_pad
+
+Dump the contents of a padlist
+
+=cut
+*/
+
+void
+Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
+{
+ AV *pad_name;
+ AV *pad;
+ SV **pname;
+ SV **ppad;
+ SV *namesv;
+ I32 ix;
+
+ if (!padlist) {
+ return;
+ }
+ pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
+ pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
+ pname = AvARRAY(pad_name);
+ ppad = AvARRAY(pad);
+ Perl_dump_indent(aTHX_ level, file,
+ "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
+ PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
+ );
+
+ for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
+ namesv = pname[ix];
+ if (namesv && namesv == &PL_sv_undef) {
+ namesv = Nullsv;
+ }
+ if (namesv) {
+ Perl_dump_indent(aTHX_ level+1, file,
+ "%2d. 0x%"UVxf"<%lu> %s (%lu,%lu) \"%s\"\n",
+ (int) ix,
+ PTR2UV(ppad[ix]),
+ (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
+ SvFAKE(namesv) ? "FAKE" : " ",
+ (unsigned long)I_32(SvNVX(namesv)),
+ (unsigned long)SvIVX(namesv),
+ SvPVX(namesv)
+ );
+ }
+ else if (full) {
+ Perl_dump_indent(aTHX_ level+1, file,
+ "%2d. 0x%"UVxf"<%lu>\n",
+ (int) ix,
+ PTR2UV(ppad[ix]),
+ (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
+ );
+ }
+ }
+}
+
+
+
+/*
+=for apidoc cv_dump
+
+dump the contents of a CV
+
+=cut
+*/
+
+#ifdef DEBUGGING
+STATIC void
+S_cv_dump(pTHX_ CV *cv, char *title)
+{
+ CV *outside = CvOUTSIDE(cv);
+ AV* padlist = CvPADLIST(cv);
+
+ PerlIO_printf(Perl_debug_log,
+ " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
+ title,
+ PTR2UV(cv),
+ (CvANON(cv) ? "ANON"
+ : (cv == PL_main_cv) ? "MAIN"
+ : CvUNIQUE(cv) ? "UNIQUE"
+ : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
+ PTR2UV(outside),
+ (!outside ? "null"
+ : CvANON(outside) ? "ANON"
+ : (outside == PL_main_cv) ? "MAIN"
+ : CvUNIQUE(outside) ? "UNIQUE"
+ : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
+
+ PerlIO_printf(Perl_debug_log,
+ " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
+ do_dump_pad(1, Perl_debug_log, padlist, 1);
+}
+#endif /* DEBUGGING */
+
+
+
+
+
+/*
+=for apidoc cv_clone
+
+Clone a CV: make a new CV which points to the same code etc, but which
+has a newly-created pad done by copying the prototype pad and capturing
+any outer lexicals.
+
+=cut
+*/
+
+CV *
+Perl_cv_clone(pTHX_ CV *proto)
+{
+ CV *cv;
+ LOCK_CRED_MUTEX; /* XXX create separate mutex */
+ cv = cv_clone2(proto, CvOUTSIDE(proto));
+ UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
+ return cv;
+}
+
+
+/* XXX DAPM separate out cv and paddish bits ???
+ * ideally the CV-related stuff shouldn't be in pad.c - how about
+ * a cv.c? */
+
+STATIC CV *
+S_cv_clone2(pTHX_ CV *proto, CV *outside)
+{
+ I32 ix;
+ AV* protopadlist = CvPADLIST(proto);
+ AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
+ AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
+ SV** pname = AvARRAY(protopad_name);
+ SV** ppad = AvARRAY(protopad);
+ I32 fname = AvFILLp(protopad_name);
+ I32 fpad = AvFILLp(protopad);
+ AV* comppadlist;
+ CV* cv;
+
+ assert(!CvUNIQUE(proto));
+
+ ENTER;
+ SAVESPTR(PL_compcv);
+
+ cv = PL_compcv = (CV*)NEWSV(1104,0);
+ sv_upgrade((SV *)cv, SvTYPE(proto));
+ CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
+ CvCLONED_on(cv);
+
+#ifdef USE_5005THREADS
+ New(666, CvMUTEXP(cv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(cv));
+ CvOWNER(cv) = 0;
+#endif /* USE_5005THREADS */
+#ifdef USE_ITHREADS
+ CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
+ : savepv(CvFILE(proto));
+#else
+ CvFILE(cv) = CvFILE(proto);
+#endif
+ CvGV(cv) = CvGV(proto);
+ CvSTASH(cv) = CvSTASH(proto);
+ CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
+ CvSTART(cv) = CvSTART(proto);
+ if (outside)
+ CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
+
+ if (SvPOK(proto))
+ sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
+
+ CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
+
+ for (ix = fname; ix >= 0; ix--)
+ av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
+
+ av_fill(PL_comppad, fpad);
+ PL_curpad = AvARRAY(PL_comppad);
+
+ for (ix = fpad; ix > 0; ix--) {
+ SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
+ if (namesv && namesv != &PL_sv_undef) {
+ char *name = SvPVX(namesv); /* XXX */
+ if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
+ I32 off = pad_findlex(name, ix, SvIVX(namesv),
+ CvOUTSIDE(cv), cxstack_ix, 0, 0);
+ if (!off)
+ PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
+ else if (off != ix)
+ Perl_croak(aTHX_ "panic: cv_clone: %s", name);
+ }
+ else { /* our own lexical */
+ SV* sv;
+ if (*name == '&') {
+ /* anon code -- we'll come back for it */
+ sv = SvREFCNT_inc(ppad[ix]);
+ }
+ else if (*name == '@')
+ sv = (SV*)newAV();
+ else if (*name == '%')
+ sv = (SV*)newHV();
+ else
+ sv = NEWSV(0,0);
+ if (!SvPADBUSY(sv))
+ SvPADMY_on(sv);
+ PL_curpad[ix] = sv;
+ }
+ }
+ else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
+ PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
+ }
+ else {
+ SV* sv = NEWSV(0,0);
+ SvPADTMP_on(sv);
+ PL_curpad[ix] = sv;
+ }
+ }
+
+ /* Now that vars are all in place, clone nested closures. */
+
+ for (ix = fpad; ix > 0; ix--) {
+ SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
+ if (namesv
+ && namesv != &PL_sv_undef
+ && !(SvFLAGS(namesv) & SVf_FAKE)
+ && *SvPVX(namesv) == '&'
+ && CvCLONE(ppad[ix]))
+ {
+ CV *kid = cv_clone2((CV*)ppad[ix], cv);
+ SvREFCNT_dec(ppad[ix]);
+ CvCLONE_on(kid);
+ SvPADMY_on(kid);
+ PL_curpad[ix] = (SV*)kid;
+ }
+ }
+
+ DEBUG_Xv(
+ PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
+ cv_dump(outside, "Outside");
+ cv_dump(proto, "Proto");
+ cv_dump(cv, "To");
+ );
+
+ LEAVE;
+
+ if (CvCONST(cv)) {
+ SV* const_sv = op_const_sv(CvSTART(cv), cv);
+ assert(const_sv);
+ /* constant sub () { $x } closing over $x - see lib/constant.pm */
+ SvREFCNT_dec(cv);
+ cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
+ }
+
+ return cv;
+}
+
+
+/*
+=for apidoc pad_fixup_inner_anons
+
+For any anon CVs in the pad, change CvOUTSIDE of that CV from
+old_cv to new_cv if necessary.
+
+=cut
+*/
+
+void
+Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
+{
+ I32 ix;
+ AV *comppad_name = (AV*)AvARRAY(padlist)[0];
+ AV *comppad = (AV*)AvARRAY(padlist)[1];
+ SV **namepad = AvARRAY(comppad_name);
+ SV **curpad = AvARRAY(comppad);
+ for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
+ SV *namesv = namepad[ix];
+ if (namesv && namesv != &PL_sv_undef
+ && *SvPVX(namesv) == '&')
+ {
+ CV *innercv = (CV*)curpad[ix];
+ if (CvOUTSIDE(innercv) == old_cv) {
+ CvOUTSIDE(innercv) = new_cv;
+ if (!CvANON(innercv) || CvCLONED(innercv)) {
+ (void)SvREFCNT_inc(new_cv);
+ SvREFCNT_dec(old_cv);
+ }
+ }
+ }
+ }
+}
+
+/*
+=for apidoc pad_push
+
+Push a new pad frame onto the padlist, unless there's already a pad at
+this depth, in which case don't bother creating a new one.
+If has_args is true, give the new pad an @_ in slot zero.
+
+=cut
+*/
+
+void
+Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
+{
+ if (depth <= AvFILLp(padlist))
+ return;
+
+ {
+ SV** svp = AvARRAY(padlist);
+ AV *newpad = newAV();
+ SV **oldpad = AvARRAY(svp[depth-1]);
+ I32 ix = AvFILLp((AV*)svp[1]);
+ I32 names_fill = AvFILLp((AV*)svp[0]);
+ SV** names = AvARRAY(svp[0]);
+ SV* sv;
+ for ( ;ix > 0; ix--) {
+ if (names_fill >= ix && names[ix] != &PL_sv_undef) {
+ char *name = SvPVX(names[ix]);
+ if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
+ /* outer lexical or anon code */
+ av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]) );
+ }
+ else { /* our own lexical */
+ if (*name == '@')
+ av_store(newpad, ix, sv = (SV*)newAV());
+ else if (*name == '%')
+ av_store(newpad, ix, sv = (SV*)newHV());
+ else
+ av_store(newpad, ix, sv = NEWSV(0,0));
+ SvPADMY_on(sv);
+ }
+ }
+ else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+ av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
+ }
+ else {
+ /* save temporaries on recursion? */
+ av_store(newpad, ix, sv = NEWSV(0,0));
+ SvPADTMP_on(sv);
+ }
+ }
+ if (has_args) {
+ AV* av = newAV();
+ av_extend(av, 0);
+ av_store(newpad, 0, (SV*)av);
+ AvFLAGS(av) = AVf_REIFY;
+ }
+ av_store(padlist, depth, (SV*)newpad);
+ AvFILLp(padlist) = depth;
+ }
+}
diff -up /dev/null '17914.pad/pad.h'
Index: ./pad.h
--- ./pad.h Thu Jan 1 01:00:00 1970
+++ ./pad.h Wed Sep 25 22:53:51 2002
@@ -0,0 +1,214 @@
+/* pad.h
+ *
+ * Copyright (c) 2002, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * This file defines the types and macros associated with the API for
+ * manipulating scratchpads, which are used by perl to store lexical
+ * variables, op targets and constants.
+ */
+
+
+
+
+/* a padlist is currently just an AV; but that might change,
+ * so hide the type. Ditto a pad. */
+
+typedef AV PADLIST;
+typedef SV** PAD;
+
+
+/* offsets within a pad */
+
+#if PTRSIZE == 4
+typedef U32TYPE PADOFFSET;
+#else
+# if PTRSIZE == 8
+typedef U64TYPE PADOFFSET;
+# endif
+#endif
+#define NOT_IN_PAD ((PADOFFSET) -1)
+
+
+/* flags for the pad_new() function */
+
+typedef enum {
+ padnew_CLONE = 1, /* this pad is for a cloned CV */
+ padnew_SAVE = 2, /* save old globals */
+ padnew_SAVESUB = 4, /* also save extra stuff for start of sub */
+} padnew_flags;
+
+/* values for the pad_tidy() function */
+
+typedef enum {
+ padtidy_SUB, /* tidy up a pad for a sub, */
+ padtidy_SUBCLONE, /* a cloned sub, */
+ padtidy_FORMAT /* or a format */
+} padtidy_type;
+
+
+/* Note: the following four macros are actually defined in scope.h, but
+ * they are documented here for completeness, since they directly or
+ * indirectly affect pads.
+
+=for apidoc m|void|SAVEPADSV |PADOFFSET po
+Save a pad slot (used to restore after an iteration)
+
+=for apidoc m|void|SAVECLEARSV |SV **svp
+Clear the pointed to pad value on scope exit. (ie the runtime action of 'my')
+
+=for apidoc m|void|SAVECOMPPAD
+save PL_comppad and PL_curpad
+
+=for apidoc m|void|SAVEFREEOP |OP *o
+Free the op on scope exit. At the same time, reset PL_curpad
+
+
+
+
+=for apidoc m|SV *|PAD_SETSV |PADOFFSET po|SV* sv
+Set the slot at offset C<po> in the current pad to C<sv>
+
+=for apidoc m|void|PAD_SV |PADOFFSET po
+Get the value at offset C<po> in the current pad
+
+=for apidoc m|SV *|PAD_SVl |PADOFFSET po
+Lightweight and lvalue version of C<PAD_SV>.
+Get or set the value at offset C<po> in the current pad.
+Unlike C<PAD_SV>, does not print diagnostics with -DX.
+For internal use only.
+
+=for apidoc m|SV *|PAD_BASE_SV |PADLIST padlist|PADOFFSET po
+Get the value from slot C<po> in the base (DEPTH=1) pad of a padlist
+
+=for apidoc m|void|PAD_SET_CUR |PADLIST padlist|I32 n
+Set the current pad to be pad C<n> in the padlist, saving
+the previous current pad.
+
+=for apidoc m|void|PAD_SAVE_SETNULLPAD
+Save the current pad then set it to null.
+
+=for apidoc m|void|PAD_UPDATE_CURPAD
+Set PL_curpad from the value of PL_comppad.
+
+=cut
+*/
+
+#ifdef DEBUGGING
+# define PAD_SV(po) pad_sv(po)
+# define PAD_SETSV(po,sv) pad_setsv(po,sv)
+#else
+# define PAD_SV(po) (PL_curpad[po])
+# define PAD_SETSV(po,sv) PL_curpad[po] = (sv)
+#endif
+
+#define PAD_SVl(po) (PL_curpad[po])
+
+#define PAD_BASE_SV(padlist, po) \
+ (AvARRAY(padlist)[1]) \
+ ? AvARRAY((AV*)(AvARRAY(padlist)[1]))[po] : Nullsv;
+
+
+#define PAD_SET_CUR(padlist,n) \
+ SAVEVPTR(PL_curpad); \
+ PL_curpad = AvARRAY((AV*)*av_fetch((padlist),(n),FALSE))
+
+#define PAD_SAVE_SETNULLPAD SAVEVPTR(PL_curpad); PL_curpad = 0;
+
+#define PAD_UPDATE_CURPAD \
+ PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : Null(PAD)
+
+
+/*
+=for apidoc m|void|CX_CURPAD_SAVE|struct context
+Save the current pad in the given context block structure.
+
+=for apidoc m|PAD *|CX_CURPAD_SV|struct context|PADOFFSET po
+Access the SV at offset po in the saved current pad in the given
+context block structure (can be used as an lvalue).
+
+=cut
+*/
+
+#define CX_CURPAD_SAVE(block) (block).oldcurpad = PL_curpad
+#define CX_CURPAD_SV(block,po) ((block).oldcurpad[po])
+
+
+/*
+=for apidoc m|U32|PAD_COMPNAME_FLAGS|PADOFFSET po
+Return the flags for the current compiling pad name
+at offset C<po>. Assumes a valid slot entry.
+
+=for apidoc m|char *|PAD_COMPNAME_PV|PADOFFSET po
+Return the name of the current compiling pad name
+at offset C<po>. Assumes a valid slot entry.
+
+=for apidoc m|HV *|PAD_COMPNAME_TYPE|PADOFFSET po
+Return the type (stash) of the current compiling pad name at offset
+C<po>. Must be a valid name. Returns null if not typed.
+
+=for apidoc m|HV *|PAD_COMPNAME_OURSTASH|PADOFFSET po
+Return the stash associated with an C<our> variable.
+Assumes the slot entry is a valid C<our> lexical.
+
+=for apidoc m|STRLEN|PAD_COMPNAME_GEN|PADOFFSET po
+The generation number of the name at offset C<po> in the current
+compiling pad (lvalue). Note that C<SvCUR> is hijacked for this purpose.
+
+=cut
+*/
+
+#define PAD_COMPNAME_FLAGS(po) SvFLAGS(*av_fetch(PL_comppad_name, (po), FALSE))
+#define PAD_COMPNAME_PV(po) SvPV_nolen(*av_fetch(PL_comppad_name, (po), FALSE))
+
+/* XXX DAPM yuk - using av_fetch twice. Is there a better way? */
+#define PAD_COMPNAME_TYPE(po) \
+ ((SvFLAGS(*av_fetch(PL_comppad_name, (po), FALSE)) & SVpad_TYPED) \
+ ? (SvSTASH(*av_fetch(PL_comppad_name, (po), FALSE))) : Nullhv)
+
+#define PAD_COMPNAME_OURSTASH(po) \
+ (GvSTASH(*av_fetch(PL_comppad_name, (po), FALSE)))
+
+#define PAD_COMPNAME_GEN(po) SvCUR(AvARRAY(PL_comppad_name)[po])
+
+
+
+
+/*
+=for apidoc m|void|PAD_DUP|PADLIST dstpad|PADLIST srcpad|CLONE_PARAMS* param
+Clone a padlist.
+
+=for apidoc m|void|PAD_CLONE_VARS|PerlInterpreter *proto_perl \
+|CLONE_PARAMS* param
+Clone the state variables associated with running and compiling pads.
+
+=cut
+*/
+
+
+#define PAD_DUP(dstpad, srcpad, param) \
+ if ((srcpad) && !AvREAL(srcpad)) { \
+ /* XXX padlists are real, but pretend to be not */ \
+ AvREAL_on(srcpad); \
+ (dstpad) = av_dup_inc((srcpad), param); \
+ AvREAL_off(srcpad); \
+ AvREAL_off(dstpad); \
+ } \
+ else \
+ (dstpad) = av_dup_inc((srcpad), param);
+
+#define PAD_CLONE_VARS(proto_perl, param) \
+ PL_comppad = av_dup(proto_perl->Icomppad, param); \
+ PL_comppad_name = av_dup(proto_perl->Icomppad_name, param); \
+ PL_comppad_name_fill = proto_perl->Icomppad_name_fill; \
+ PL_comppad_name_floor = proto_perl->Icomppad_name_floor; \
+ PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table, \
+ proto_perl->Tcurpad); \
+ PL_min_intro_pending = proto_perl->Imin_intro_pending; \
+ PL_max_intro_pending = proto_perl->Imax_intro_pending; \
+ PL_padix = proto_perl->Ipadix; \
+ PL_padix_floor = proto_perl->Ipadix_floor; \
+ PL_pad_reset_pending = proto_perl->Ipad_reset_pending; \
+ PL_cop_seqmax = proto_perl->Icop_seqmax;
diff -up '17914.ORIG/perl.c' '17914.pad/perl.c'
Index: ./perl.c
--- ./perl.c Tue Sep 24 00:27:26 2002
+++ ./perl.c Tue Sep 24 01:16:58 2002
@@ -462,8 +462,7 @@ perl_destruct(pTHXx)

/* Destroy the main CV and syntax tree */
if (PL_main_root) {
- /* If running under -d may not have PL_comppad. */
- PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL;
+ PAD_UPDATE_CURPAD;
op_free(PL_main_root);
PL_main_root = Nullop;
}
@@ -1040,7 +1039,7 @@ setuid perl scripts securely.\n");
}

if (PL_main_root) {
- PL_curpad = AvARRAY(PL_comppad);
+ PAD_UPDATE_CURPAD;
op_free(PL_main_root);
PL_main_root = Nullop;
}
@@ -1108,7 +1107,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t
int fdscript = -1;
VOL bool dosearch = FALSE;
char *validarg = "";
- AV* comppadlist;
register SV *sv;
register char *s;
char *cddir = Nullch;
@@ -1450,28 +1448,13 @@ print \" \\@INC:\\n @INC\\n\";");
sv_upgrade((SV *)PL_compcv, SVt_PVCV);
CvUNIQUE_on(PL_compcv);

- PL_comppad = newAV();
- av_push(PL_comppad, Nullsv);
- PL_curpad = AvARRAY(PL_comppad);
- PL_comppad_name = newAV();
- PL_comppad_name_fill = 0;
- PL_min_intro_pending = 0;
- PL_padix = 0;
+ CvPADLIST(PL_compcv) = pad_new(0);
#ifdef USE_5005THREADS
- av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
- PL_curpad[0] = (SV*)newAV();
- SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
CvOWNER(PL_compcv) = 0;
New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(PL_compcv));
#endif /* USE_5005THREADS */

- comppadlist = newAV();
- AvREAL_off(comppadlist);
- av_store(comppadlist, 0, (SV*)PL_comppad_name);
- av_store(comppadlist, 1, (SV*)PL_comppad);
- CvPADLIST(PL_compcv) = comppadlist;
-
boot_core_PerlIO();
boot_core_UNIVERSAL();
#ifndef PERL_MICRO
diff -up '17914.ORIG/perl.h' '17914.pad/perl.h'
Index: ./perl.h
--- ./perl.h Tue Sep 24 00:27:26 2002
+++ ./perl.h Tue Sep 24 01:45:39 2002
@@ -2240,6 +2240,7 @@ typedef struct crypt_data { /
#include "util.h"
#include "form.h"
#include "gv.h"
+#include "pad.h"
#include "cv.h"
#include "opnames.h"
#include "op.h"
@@ -2490,34 +2491,36 @@ Gid_t getegid (void);
# define DEBUG_J_TEST_ (PL_debug & DEBUG_J_FLAG)
# define DEBUG_v_TEST_ (PL_debug & DEBUG_v_FLAG)
# define DEBUG_C_TEST_ (PL_debug & DEBUG_C_FLAG)
+# define DEBUG_Xv_TEST_ (DEBUG_X_TEST_ && DEBUG_v_TEST_)

#ifdef DEBUGGING

# undef YYDEBUG
# define YYDEBUG 1

-# define DEBUG_p_TEST DEBUG_p_TEST_
-# define DEBUG_s_TEST DEBUG_s_TEST_
-# define DEBUG_l_TEST DEBUG_l_TEST_
-# define DEBUG_t_TEST DEBUG_t_TEST_
-# define DEBUG_o_TEST DEBUG_o_TEST_
-# define DEBUG_c_TEST DEBUG_c_TEST_
-# define DEBUG_P_TEST DEBUG_P_TEST_
-# define DEBUG_m_TEST DEBUG_m_TEST_
-# define DEBUG_f_TEST DEBUG_f_TEST_
-# define DEBUG_r_TEST DEBUG_r_TEST_
-# define DEBUG_x_TEST DEBUG_x_TEST_
-# define DEBUG_u_TEST DEBUG_u_TEST_
-# define DEBUG_L_TEST DEBUG_L_TEST_
-# define DEBUG_H_TEST DEBUG_H_TEST_
-# define DEBUG_X_TEST DEBUG_X_TEST_
-# define DEBUG_D_TEST DEBUG_D_TEST_
-# define DEBUG_S_TEST DEBUG_S_TEST_
-# define DEBUG_T_TEST DEBUG_T_TEST_
-# define DEBUG_R_TEST DEBUG_R_TEST_
-# define DEBUG_J_TEST DEBUG_J_TEST_
-# define DEBUG_v_TEST DEBUG_v_TEST_
-# define DEBUG_C_TEST DEBUG_C_TEST_
+# define DEBUG_p_TEST DEBUG_p_TEST_
+# define DEBUG_s_TEST DEBUG_s_TEST_
+# define DEBUG_l_TEST DEBUG_l_TEST_
+# define DEBUG_t_TEST DEBUG_t_TEST_
+# define DEBUG_o_TEST DEBUG_o_TEST_
+# define DEBUG_c_TEST DEBUG_c_TEST_
+# define DEBUG_P_TEST DEBUG_P_TEST_
+# define DEBUG_m_TEST DEBUG_m_TEST_
+# define DEBUG_f_TEST DEBUG_f_TEST_
+# define DEBUG_r_TEST DEBUG_r_TEST_
+# define DEBUG_x_TEST DEBUG_x_TEST_
+# define DEBUG_u_TEST DEBUG_u_TEST_
+# define DEBUG_L_TEST DEBUG_L_TEST_
+# define DEBUG_H_TEST DEBUG_H_TEST_
+# define DEBUG_X_TEST DEBUG_X_TEST_
+# define DEBUG_Xv_TEST DEBUG_Xv_TEST_
+# define DEBUG_D_TEST DEBUG_D_TEST_
+# define DEBUG_S_TEST DEBUG_S_TEST_
+# define DEBUG_T_TEST DEBUG_T_TEST_
+# define DEBUG_R_TEST DEBUG_R_TEST_
+# define DEBUG_J_TEST DEBUG_J_TEST_
+# define DEBUG_v_TEST DEBUG_v_TEST_
+# define DEBUG_C_TEST DEBUG_C_TEST_

# define DEB(a) a
# define DEBUG(a) if (PL_debug) a
@@ -2541,14 +2544,15 @@ Gid_t getegid (void);
if (t) STMT_START {a;} STMT_END; \
} STMT_END

-# define DEBUG_f(a) DEBUG__(DEBUG_f_TEST, a)
-# define DEBUG_r(a) DEBUG__(DEBUG_r_TEST, a)
-# define DEBUG_x(a) DEBUG__(DEBUG_x_TEST, a)
-# define DEBUG_u(a) DEBUG__(DEBUG_u_TEST, a)
-# define DEBUG_L(a) DEBUG__(DEBUG_L_TEST, a)
-# define DEBUG_H(a) DEBUG__(DEBUG_H_TEST, a)
-# define DEBUG_X(a) DEBUG__(DEBUG_X_TEST, a)
-# define DEBUG_D(a) DEBUG__(DEBUG_D_TEST, a)
+# define DEBUG_f(a) DEBUG__(DEBUG_f_TEST, a)
+# define DEBUG_r(a) DEBUG__(DEBUG_r_TEST, a)
+# define DEBUG_x(a) DEBUG__(DEBUG_x_TEST, a)
+# define DEBUG_u(a) DEBUG__(DEBUG_u_TEST, a)
+# define DEBUG_L(a) DEBUG__(DEBUG_L_TEST, a)
+# define DEBUG_H(a) DEBUG__(DEBUG_H_TEST, a)
+# define DEBUG_X(a) DEBUG__(DEBUG_X_TEST, a)
+# define DEBUG_Xv(a) DEBUG__(DEBUG_Xv_TEST, a)
+# define DEBUG_D(a) DEBUG__(DEBUG_D_TEST, a)

# ifdef USE_5005THREADS
# define DEBUG_S(a) DEBUG__(DEBUG_S_TEST, a)
@@ -2563,28 +2567,29 @@ Gid_t getegid (void);

#else /* DEBUGGING */

-# define DEBUG_p_TEST (0)
-# define DEBUG_s_TEST (0)
-# define DEBUG_l_TEST (0)
-# define DEBUG_t_TEST (0)
-# define DEBUG_o_TEST (0)
-# define DEBUG_c_TEST (0)
-# define DEBUG_P_TEST (0)
-# define DEBUG_m_TEST (0)
-# define DEBUG_f_TEST (0)
-# define DEBUG_r_TEST (0)
-# define DEBUG_x_TEST (0)
-# define DEBUG_u_TEST (0)
-# define DEBUG_L_TEST (0)
-# define DEBUG_H_TEST (0)
-# define DEBUG_X_TEST (0)
-# define DEBUG_D_TEST (0)
-# define DEBUG_S_TEST (0)
-# define DEBUG_T_TEST (0)
-# define DEBUG_R_TEST (0)
-# define DEBUG_J_TEST (0)
-# define DEBUG_v_TEST (0)
-# define DEBUG_C_TEST (0)
+# define DEBUG_p_TEST (0)
+# define DEBUG_s_TEST (0)
+# define DEBUG_l_TEST (0)
+# define DEBUG_t_TEST (0)
+# define DEBUG_o_TEST (0)
+# define DEBUG_c_TEST (0)
+# define DEBUG_P_TEST (0)
+# define DEBUG_m_TEST (0)
+# define DEBUG_f_TEST (0)
+# define DEBUG_r_TEST (0)
+# define DEBUG_x_TEST (0)
+# define DEBUG_u_TEST (0)
+# define DEBUG_L_TEST (0)
+# define DEBUG_H_TEST (0)
+# define DEBUG_X_TEST (0)
+# define DEBUG_Xv_TEST (0)
+# define DEBUG_D_TEST (0)
+# define DEBUG_S_TEST (0)
+# define DEBUG_T_TEST (0)
+# define DEBUG_R_TEST (0)
+# define DEBUG_J_TEST (0)
+# define DEBUG_v_TEST (0)
+# define DEBUG_C_TEST (0)

# define DEB(a)
# define DEBUG(a)
@@ -2603,6 +2608,7 @@ Gid_t getegid (void);
# define DEBUG_L(a)
# define DEBUG_H(a)
# define DEBUG_X(a)
+# define DEBUG_Xv(a)
# define DEBUG_D(a)
# define DEBUG_S(a)
# define DEBUG_T(a)
@@ -2871,10 +2877,8 @@ typedef Sighandler_t Sigsave_t;
# ifndef register
# define register
# endif
-# define PAD_SV(po) pad_sv(po)
# define RUNOPS_DEFAULT Perl_runops_debug
#else
-# define PAD_SV(po) PL_curpad[po]
# define RUNOPS_DEFAULT Perl_runops_standard
#endif

diff -up '17914.ORIG/pp.c' '17914.pad/pp.c'
Index: ./pp.c
--- ./pp.c Tue Sep 24 00:27:26 2002
+++ ./pp.c Tue Sep 24 01:17:07 2002
@@ -48,7 +48,7 @@ PP(pp_padav)
{
dSP; dTARGET;
if (PL_op->op_private & OPpLVAL_INTRO)
- SAVECLEARSV(PL_curpad[PL_op->op_targ]);
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
EXTEND(SP, 1);
if (PL_op->op_flags & OPf_REF) {
PUSHs(TARG);
@@ -90,7 +90,7 @@ PP(pp_padhv)

XPUSHs(TARG);
if (PL_op->op_private & OPpLVAL_INTRO)
- SAVECLEARSV(PL_curpad[PL_op->op_targ]);
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
if (PL_op->op_flags & OPf_REF)
RETURN;
else if (LVRET) {
@@ -159,7 +159,7 @@ PP(pp_rv2gv)
GV *gv;
if (cUNOP->op_targ) {
STRLEN len;
- SV *namesv = PL_curpad[cUNOP->op_targ];
+ SV *namesv = PAD_SV(cUNOP->op_targ);
name = SvPV(namesv, len);
gv = (GV*)NEWSV(0,0);
gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
@@ -420,7 +420,7 @@ PP(pp_prototype)
PP(pp_anoncode)
{
dSP;
- CV* cv = (CV*)PL_curpad[PL_op->op_targ];
+ CV* cv = (CV*)PAD_SV(PL_op->op_targ);
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
EXTEND(SP,1);
@@ -4372,14 +4372,14 @@ PP(pp_split)

if (pm->op_pmreplroot) {
#ifdef USE_ITHREADS
- ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
+ ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
#else
ary = GvAVn((GV*)pm->op_pmreplroot);
#endif
}
else if (gimme != G_ARRAY)
#ifdef USE_5005THREADS
- ary = (AV*)PL_curpad[0];
+ ary = (AV*)PAD_SVl(0);
#else
ary = GvAVn(PL_defgv);
#endif /* USE_5005THREADS */
diff -up '17914.ORIG/pp_ctl.c' '17914.pad/pp_ctl.c'
Index: ./pp_ctl.c
--- ./pp_ctl.c Tue Sep 24 00:27:26 2002
+++ ./pp_ctl.c Tue Sep 24 01:17:07 2002
@@ -1587,6 +1587,8 @@ PP(pp_lineseq)
return NORMAL;
}

+/* like pp_nextstate, but used instead when the debugger is active */
+
PP(pp_dbstate)
{
PL_curcop = (COP*)PL_op;
@@ -1626,8 +1628,7 @@ PP(pp_dbstate)
PUSHSUB(cx);
CvDEPTH(cv)++;
(void)SvREFCNT_inc(cv);
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
+ PAD_SET_CUR(CvPADLIST(cv),1);
RETURNOP(CvSTART(cv));
}
else
@@ -1663,7 +1664,7 @@ PP(pp_enteriter)
#endif /* USE_5005THREADS */
if (PL_op->op_targ) {
#ifndef USE_ITHREADS
- svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
+ svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
SAVESPTR(*svp);
#else
SAVEPADSV(PL_op->op_targ);
@@ -2145,13 +2146,13 @@ PP(pp_goto)
av = newAV();
av_extend(av, items-1);
AvFLAGS(av) = AVf_REIFY;
- PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
+ PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
}
}
else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
AV* av;
#ifdef USE_5005THREADS
- av = (AV*)PL_curpad[0];
+ av = (AV*)PAD_SVl(0);
#else
av = GvAV(PL_defgv);
#endif
@@ -2202,7 +2203,6 @@ PP(pp_goto)
}
else {
AV* padlist = CvPADLIST(cv);
- SV** svp = AvARRAY(padlist);
if (CxTYPE(cx) == CXt_EVAL) {
PL_in_eval = cx->blk_eval.old_in_eval;
PL_eval_root = cx->blk_eval.old_eval_root;
@@ -2211,60 +2211,18 @@ PP(pp_goto)
}
cx->blk_sub.cv = cv;
cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
+
CvDEPTH(cv)++;
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
- else { /* save temporaries on recursion? */
+ else {
if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
sub_crush_depth(cv);
- if (CvDEPTH(cv) > AvFILLp(padlist)) {
- AV *newpad = newAV();
- SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
- I32 ix = AvFILLp((AV*)svp[1]);
- I32 names_fill = AvFILLp((AV*)svp[0]);
- svp = AvARRAY(svp[0]);
- for ( ;ix > 0; ix--) {
- if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
- char *name = SvPVX(svp[ix]);
- if ((SvFLAGS(svp[ix]) & SVf_FAKE)
- || *name == '&')
- {
- /* outer lexical or anon code */
- av_store(newpad, ix,
- SvREFCNT_inc(oldpad[ix]) );
- }
- else { /* our own lexical */
- if (*name == '@')
- av_store(newpad, ix, sv = (SV*)newAV());
- else if (*name == '%')
- av_store(newpad, ix, sv = (SV*)newHV());
- else
- av_store(newpad, ix, sv = NEWSV(0,0));
- SvPADMY_on(sv);
- }
- }
- else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
- av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
- }
- else {
- av_store(newpad, ix, sv = NEWSV(0,0));
- SvPADTMP_on(sv);
- }
- }
- if (cx->blk_sub.hasargs) {
- AV* av = newAV();
- av_extend(av, 0);
- av_store(newpad, 0, (SV*)av);
- AvFLAGS(av) = AVf_REIFY;
- }
- av_store(padlist, CvDEPTH(cv), (SV*)newpad);
- AvFILLp(padlist) = CvDEPTH(cv);
- svp = AvARRAY(padlist);
- }
+ pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
}
#ifdef USE_5005THREADS
if (!cx->blk_sub.hasargs) {
- AV* av = (AV*)PL_curpad[0];
+ AV* av = (AV*)PAD_SVl(0);

items = AvFILLp(av) + 1;
if (items) {
@@ -2275,21 +2233,20 @@ PP(pp_goto)
PUTBACK ;
}
}
-#endif /* USE_5005THREADS */
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
+#endif /* USE_5005THREADS */
+ PAD_SET_CUR(padlist, CvDEPTH(cv));
#ifndef USE_5005THREADS
if (cx->blk_sub.hasargs)
#endif /* USE_5005THREADS */
{
- AV* av = (AV*)PL_curpad[0];
+ AV* av = (AV*)PAD_SVl(0);
SV** ary;

#ifndef USE_5005THREADS
cx->blk_sub.savearray = GvAV(PL_defgv);
GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
#endif /* USE_5005THREADS */
- cx->blk_sub.oldcurpad = PL_curpad;
+ CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
++mark;

@@ -2710,7 +2667,6 @@ S_doeval(pTHX_ int gimme, OP** startop)
dSP;
OP *saveop = PL_op;
CV *caller;
- AV* comppadlist;
I32 i;

PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
@@ -2719,16 +2675,6 @@ S_doeval(pTHX_ int gimme, OP** startop)

PUSHMARK(SP);

- /* set up a scratch pad */
-
- SAVEI32(PL_padix);
- SAVEVPTR(PL_curpad);
- SAVESPTR(PL_comppad);
- SAVESPTR(PL_comppad_name);
- SAVEI32(PL_comppad_name_fill);
- SAVEI32(PL_min_intro_pending);
- SAVEI32(PL_max_intro_pending);
-
caller = PL_compcv;
for (i = cxstack_ix - 1; i >= 0; i--) {
PERL_CONTEXT *cx = &cxstack[i];
@@ -2753,24 +2699,9 @@ S_doeval(pTHX_ int gimme, OP** startop)
MUTEX_INIT(CvMUTEXP(PL_compcv));
#endif /* USE_5005THREADS */

- PL_comppad = newAV();
- av_push(PL_comppad, Nullsv);
- PL_curpad = AvARRAY(PL_comppad);
- PL_comppad_name = newAV();
- PL_comppad_name_fill = 0;
- PL_min_intro_pending = 0;
- PL_padix = 0;
-#ifdef USE_5005THREADS
- av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
- PL_curpad[0] = (SV*)newAV();
- SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
-#endif /* USE_5005THREADS */
+ /* set up a scratch pad */

- comppadlist = newAV();
- AvREAL_off(comppadlist);
- av_store(comppadlist, 0, (SV*)PL_comppad_name);
- av_store(comppadlist, 1, (SV*)PL_comppad);
- CvPADLIST(PL_compcv) = comppadlist;
+ CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);

if (!saveop ||
(saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
diff -up '17914.ORIG/pp_hot.c' '17914.pad/pp_hot.c'
Index: ./pp_hot.c
--- ./pp_hot.c Tue Sep 24 00:27:26 2002
+++ ./pp_hot.c Tue Sep 24 01:17:07 2002
@@ -197,10 +197,10 @@ PP(pp_padsv)
XPUSHs(TARG);
if (PL_op->op_flags & OPf_MOD) {
if (PL_op->op_private & OPpLVAL_INTRO)
- SAVECLEARSV(PL_curpad[PL_op->op_targ]);
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
else if (PL_op->op_private & OPpDEREF) {
PUTBACK;
- vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
+ vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
SPAGAIN;
}
}
@@ -2572,7 +2572,7 @@ try_autoload:
if (SP > PL_stack_base + TOPMARK)
sv = *(PL_stack_base + TOPMARK + 1);
else {
- AV *av = (AV*)PL_curpad[0];
+ AV *av = (AV*)PAD_SVl(0);
if (hasargs || !av || AvFILLp(av) < 0
|| !(sv = AvARRAY(av)[0]))
{
@@ -2723,7 +2723,7 @@ try_autoload:
AV* av;
I32 items;
#ifdef USE_5005THREADS
- av = (AV*)PL_curpad[0];
+ av = (AV*)PAD_SVl(0);
#else
av = GvAV(PL_defgv);
#endif /* USE_5005THREADS */
@@ -2762,7 +2762,6 @@ try_autoload:
dMARK;
register I32 items = SP - MARK;
AV* padlist = CvPADLIST(cv);
- SV** svp = AvARRAY(padlist);
push_return(PL_op->op_next);
PUSHBLOCK(cx, CXt_SUB, MARK);
PUSHSUB(cx);
@@ -2774,53 +2773,13 @@ try_autoload:
*/
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
- else { /* save temporaries on recursion? */
+ else {
PERL_STACK_OVERFLOW_CHECK();
- if (CvDEPTH(cv) > AvFILLp(padlist)) {
- AV *av;
- AV *newpad = newAV();
- SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
- I32 ix = AvFILLp((AV*)svp[1]);
- I32 names_fill = AvFILLp((AV*)svp[0]);
- svp = AvARRAY(svp[0]);
- for ( ;ix > 0; ix--) {
- if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
- char *name = SvPVX(svp[ix]);
- if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
- || *name == '&') /* anonymous code? */
- {
- av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
- }
- else { /* our own lexical */
- if (*name == '@')
- av_store(newpad, ix, sv = (SV*)newAV());
- else if (*name == '%')
- av_store(newpad, ix, sv = (SV*)newHV());
- else
- av_store(newpad, ix, sv = NEWSV(0,0));
- SvPADMY_on(sv);
- }
- }
- else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
- av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
- }
- else {
- av_store(newpad, ix, sv = NEWSV(0,0));
- SvPADTMP_on(sv);
- }
- }
- av = newAV(); /* will be @_ */
- av_extend(av, 0);
- av_store(newpad, 0, (SV*)av);
- AvFLAGS(av) = AVf_REIFY;
- av_store(padlist, CvDEPTH(cv), (SV*)newpad);
- AvFILLp(padlist) = CvDEPTH(cv);
- svp = AvARRAY(padlist);
- }
+ pad_push(padlist, CvDEPTH(cv), 1);
}
#ifdef USE_5005THREADS
if (!hasargs) {
- AV* av = (AV*)PL_curpad[0];
+ AV* av = (AV*)PAD_SVl(0);

items = AvFILLp(av) + 1;
if (items) {
@@ -2832,8 +2791,7 @@ try_autoload:
}
}
#endif /* USE_5005THREADS */
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
+ PAD_SET_CUR(padlist, CvDEPTH(cv));
#ifndef USE_5005THREADS
if (hasargs)
#endif /* USE_5005THREADS */
@@ -2845,7 +2803,7 @@ try_autoload:
DEBUG_S(PerlIO_printf(Perl_debug_log,
"%p entersub preparing @_\n", thr));
#endif
- av = (AV*)PL_curpad[0];
+ av = (AV*)PAD_SVl(0);
if (AvREAL(av)) {
/* @_ is normally not REAL--this should only ever
* happen when DB::sub() calls things that modify @_ */
@@ -2857,7 +2815,7 @@ try_autoload:
cx->blk_sub.savearray = GvAV(PL_defgv);
GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
#endif /* USE_5005THREADS */
- cx->blk_sub.oldcurpad = PL_curpad;
+ CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
++MARK;

diff -up '17914.ORIG/pp_sort.c' '17914.pad/pp_sort.c'
Index: ./pp_sort.c
--- ./pp_sort.c Tue Sep 24 00:27:40 2002
+++ ./pp_sort.c Tue Sep 24 01:17:07 2002
@@ -1470,8 +1470,7 @@ PP(pp_sort)
SAVEVPTR(CvROOT(cv)->op_ppaddr);
CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];

- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+ PAD_SET_CUR(CvPADLIST(cv), 1);
}
}
}
@@ -1535,13 +1534,13 @@ PP(pp_sort)

if (hasargs && !is_xsub) {
/* This is mostly copied from pp_entersub */
- AV *av = (AV*)PL_curpad[0];
+ AV *av = (AV*)PAD_SVl(0);

#ifndef USE_5005THREADS
cx->blk_sub.savearray = GvAV(PL_defgv);
GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
#endif /* USE_5005THREADS */
- cx->blk_sub.oldcurpad = PL_curpad;
+ CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
}
sortsv((myorigmark+1), max,
@@ -1614,7 +1613,7 @@ sortcv_stacked(pTHX_ SV *a, SV *b)
AV *av;

#ifdef USE_5005THREADS
- av = (AV*)PL_curpad[0];
+ av = (AV*)PAD_SVl(0);
#else
av = GvAV(PL_defgv);
#endif
diff -up '17914.ORIG/pp_sys.c' '17914.pad/pp_sys.c'
Index: ./pp_sys.c
--- ./pp_sys.c Tue Sep 24 00:27:26 2002
+++ ./pp_sys.c Tue Sep 24 01:17:07 2002
@@ -1206,8 +1206,6 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop
{
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
- AV* padlist = CvPADLIST(cv);
- SV** svp = AvARRAY(padlist);

ENTER;
SAVETMPS;
@@ -1215,8 +1213,7 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop
push_return(retop);
PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
PUSHFORMAT(cx);
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)svp[1]);
+ PAD_SET_CUR(CvPADLIST(cv), 1);

setdefout(gv); /* locally select filehandle so $% et al work */
return CvSTART(cv);
diff -up '17914.ORIG/scope.c' '17914.pad/scope.c'
Index: ./scope.c
--- ./scope.c Tue Sep 24 00:27:27 2002
+++ ./scope.c Tue Sep 24 01:17:08 2002
@@ -868,6 +868,15 @@ Perl_leave_scope(pTHX_ I32 base)
case SAVEt_CLEARSV:
ptr = (void*)&PL_curpad[SSPOPLONG];
sv = *(SV**)ptr;
+
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad [0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n",
+ PTR2UV(PL_curpad), (long)((SV **)ptr-PL_curpad),
+ PTR2UV(sv),
+ (IV)SvREFCNT(sv),
+ (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
+ ));
+
/* Can clear pad variable in place? */
if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
/*
@@ -1000,7 +1009,7 @@ Perl_leave_scope(pTHX_ I32 base)
PADOFFSET off = (PADOFFSET)SSPOPLONG;
ptr = SSPOPPTR;
if (ptr)
- ((SV**)ptr)[off] = (SV*)SSPOPPTR;
+ ((PAD)ptr)[off] = (SV*)SSPOPPTR;
}
break;
default:
diff -up '17914.ORIG/sv.c' '17914.pad/sv.c'
Index: ./sv.c
--- ./sv.c Tue Sep 24 00:27:27 2002
+++ ./sv.c Wed Sep 25 00:26:24 2002
@@ -9573,15 +9573,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS
} else {
CvDEPTH(dstr) = 0;
}
- if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
- /* XXX padlists are real, but pretend to be not */
- AvREAL_on(CvPADLIST(sstr));
- CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
- AvREAL_off(CvPADLIST(sstr));
- AvREAL_off(CvPADLIST(dstr));
- }
- else
- CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
+ PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
if (!CvANON(sstr) || CvCLONED(sstr))
CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
else
@@ -10391,12 +10383,8 @@ perl_clone_using(PerlInterpreter *proto_
PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);

PL_compcv = cv_dup(proto_perl->Icompcv, param);
- PL_comppad = av_dup(proto_perl->Icomppad, param);
- PL_comppad_name = av_dup(proto_perl->Icomppad_name, param);
- PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
- PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
- PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
- proto_perl->Tcurpad);
+
+ PAD_CLONE_VARS(proto_perl, param);

#ifdef HAVE_INTERP_INTERN
sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
@@ -10415,7 +10403,6 @@ perl_clone_using(PerlInterpreter *proto_
PL_egid = proto_perl->Iegid;
PL_nomemok = proto_perl->Inomemok;
PL_an = proto_perl->Ian;
- PL_cop_seqmax = proto_perl->Icop_seqmax;
PL_op_seqmax = proto_perl->Iop_seqmax;
PL_evalseq = proto_perl->Ievalseq;
PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
@@ -10494,12 +10481,6 @@ perl_clone_using(PerlInterpreter *proto_
PL_subline = proto_perl->Isubline;
PL_subname = sv_dup_inc(proto_perl->Isubname, param);

- PL_min_intro_pending = proto_perl->Imin_intro_pending;
- PL_max_intro_pending = proto_perl->Imax_intro_pending;
- PL_padix = proto_perl->Ipadix;
- PL_padix_floor = proto_perl->Ipadix_floor;
- PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
-
/* XXX See comment on SvANY(proto_perl->Ilinestr) above */
if (SvANY(proto_perl->Ilinestr)) {
i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
diff -up '17914.ORIG/toke.c' '17914.pad/toke.c'
Index: ./toke.c
--- ./toke.c Tue Sep 24 00:27:27 2002
+++ ./toke.c Tue Sep 24 01:17:21 2002
@@ -5257,14 +5257,14 @@ S_pending_ident(pTHX)
yyerror(Perl_form(aTHX_ "No package name allowed for "
"variable %s in \"our\"",
PL_tokenbuf));
- tmp = pad_allocmy(PL_tokenbuf);
+ tmp = allocmy(PL_tokenbuf);
}
else {
if (strchr(PL_tokenbuf,':'))
yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));

yylval.opval = newOP(OP_PADANY, 0);
- yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
+ yylval.opval->op_targ = allocmy(PL_tokenbuf);
return PRIVATEREF;
}
}
@@ -5294,11 +5294,10 @@ S_pending_ident(pTHX)
}
#endif /* USE_5005THREADS */
if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
- SV *namesv = AvARRAY(PL_comppad_name)[tmp];
/* might be an "our" variable" */
- if (SvFLAGS(namesv) & SVpad_OUR) {
+ if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
/* build ops for a bareword */
- SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
+ SV *sym = newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)), 0);
sv_catpvn(sym, "::", 2);
sv_catpv(sym, PL_tokenbuf+1);
yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
@@ -6777,9 +6776,9 @@ S_scan_inputsymbol(pTHX_ char *start)
add symbol table ops
*/
if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
- SV *namesv = AvARRAY(PL_comppad_name)[tmp];
- if (SvFLAGS(namesv) & SVpad_OUR) {
- SV *sym = sv_2mortal(newSVpv(HvNAME(GvSTASH(namesv)),0));
+ if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
+ SV *sym = sv_2mortal(
+ newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)),0));
sv_catpvn(sym, "::", 2);
sv_catpv(sym, d+1);
d = SvPVX(sym);
@@ -7557,46 +7556,20 @@ Perl_start_subparse(pTHX_ I32 is_format,
{
I32 oldsavestack_ix = PL_savestack_ix;
CV* outsidecv = PL_compcv;
- AV* comppadlist;

if (PL_compcv) {
assert(SvTYPE(PL_compcv) == SVt_PVCV);
}
SAVEI32(PL_subline);
save_item(PL_subname);
- SAVEI32(PL_padix);
- SAVECOMPPAD();
- SAVESPTR(PL_comppad_name);
SAVESPTR(PL_compcv);
- SAVEI32(PL_comppad_name_fill);
- SAVEI32(PL_min_intro_pending);
- SAVEI32(PL_max_intro_pending);
- SAVEI32(PL_pad_reset_pending);

PL_compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
CvFLAGS(PL_compcv) |= flags;

- PL_comppad = newAV();
- av_push(PL_comppad, Nullsv);
- PL_curpad = AvARRAY(PL_comppad);
- PL_comppad_name = newAV();
- PL_comppad_name_fill = 0;
- PL_min_intro_pending = 0;
- PL_padix = 0;
PL_subline = CopLINE(PL_curcop);
-#ifdef USE_5005THREADS
- av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
- PL_curpad[0] = (SV*)newAV();
- SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
-#endif /* USE_5005THREADS */
-
- comppadlist = newAV();
- AvREAL_off(comppadlist);
- av_store(comppadlist, 0, (SV*)PL_comppad_name);
- av_store(comppadlist, 1, (SV*)PL_comppad);
-
- CvPADLIST(PL_compcv) = comppadlist;
+ CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
#ifdef USE_5005THREADS
CvOWNER(PL_compcv) = 0;
#### End of Patch data ####

#### ApplyPatch data follows ####
# Data version : 1.0
# Date generated : Wed Sep 25 22:55:06 2002
# Generated by : makepatch 2.00_05
# Recurse directories : Yes
# Excluded files : keywords\.h|warnings\.h|regnodes\.h|perlapi\.c|perlapi\.h|global\.sym|embedvar\.h|embed\.h|pod\/perlapi\.pod|pod\/perlintern\.pod|proto\.h
# v 'patchlevel.h' 3261 1032826618 33188
# p 'MANIFEST' 138881 1032826519 0100644
# p 'Makefile.SH' 39016 1032826519 0100644
# p 'Makefile.micro' 3495 1032826519 0100644
# p 'autodoc.pl' 7413 1032826525 0100644
# p 'cop.h' 17389 1032826525 0100644
# p 'cv.h' 7301 1032826525 0100644
# p 'dump.c' 46101 1032826526 0100644
# p 'embed.fnc' 49837 1032826526 0100644
# p 'ext/B/B.xs' 25449 1032826527 0100644
# p 'ext/Devel/Peek/Peek.t' 8166 1032826531 0100644
# p 'op.c' 181842 1032912427 0100644
# p 'op.h' 14848 1032901168 0100644
# c 'pad.c' 0 1032982456 0100664
# c 'pad.h' 0 1032990831 0100664
# p 'perl.c' 108639 1032826618 0100644
# p 'perl.h' 121129 1032828339 0100644
# p 'pp.c' 101344 1032826627 0100644
# p 'pp_ctl.c' 87260 1032826627 0100644
# p 'pp_hot.c' 75350 1032826627 0100644
# p 'pp_sort.c' 60619 1032826627 0100644
# p 'pp_sys.c' 122132 1032826627 0100644
# p 'scope.c' 26570 1032826628 0100644
# p 'sv.c' 275193 1032909984 0100644
# p 'toke.c' 202543 1032826641 0100644
#### End of ApplyPatch data ####

#### End of Patch kit [created: Wed Sep 25 22:55:06 2002] ####
#### Patch checksum: 4389 132553 50240 ####
#### Checksum: 4421 133638 9545 ####

[h...@crypt.org]

Dave Mitchell <da...@fdgroup.com> wrote:
:This patch moves (nearly) all pad-related code from the various core src

:files to the two new files pad.c and pad.h, and attempts to create
:something approaching an API for pads.

Great work, thanks very much.

:* Actually I haven't *quite* finished moving everything yet -

:PL_pad_reset_pending is still loose, and some of the extensions and
:/(??...)/ still know about pads. I plan to revisit these soon.

For what it's worth, I suspect that some of what /(??...)/ thinks
it knows about pads is wrong - use of lexicals, particularly with
recursive patterns, has led to a lot of bug reports that I vaguely
hoped to fix some day. I suspect the main problem is the lack of
definition as to whether the deferred evals should have their
variables bound at (regexp) compile time or run time.

:* I've also made a couple of tiny mods to autodoc.pl to make it better

:handle extraneous spaces in apidoc and embed.fnc declarations.

Thanks, I'll try to apply this separately - is autodoc.pl the only
file that changed to achieve that? In general it's likely to make
debugging and archive-digging easier if each patch (and particularly
the larger example) concentrates on doing one thing.

I'll be aiming to integrate this sometime tomorrow.

Hugo

[Dave Mitchell]

On Thu, Sep 26, 2002 at 01:18:32AM +0100, h...@crypt.org wrote:
> Dave Mitchell <da...@fdgroup.com> wrote:
> :* Actually I haven't *quite* finished moving everything yet -
> :PL_pad_reset_pending is still loose, and some of the extensions and
> :/(??...)/ still know about pads. I plan to revisit these soon.
>
> For what it's worth, I suspect that some of what /(??...)/ thinks
> it knows about pads is wrong - use of lexicals, particularly with
> recursive patterns, has led to a lot of bug reports that I vaguely
> hoped to fix some day. I suspect the main problem is the lack of
> definition as to whether the deferred evals should have their
> variables bound at (regexp) compile time or run time.

If you or someone could point me towards some of the bug reports, I might
have a go at this myself.

> :* I've also made a couple of tiny mods to autodoc.pl to make it better
> :handle extraneous spaces in apidoc and embed.fnc declarations.
>
> Thanks, I'll try to apply this separately - is autodoc.pl the only
> file that changed to achieve that? In general it's likely to make
> debugging and archive-digging easier if each patch (and particularly
> the larger example) concentrates on doing one thing.

Yeah, its just the one file, and yeah, I should have included it
separately. I'd recommend applying it first - the main patch may well
reply on it.

--
"I do not resent critisism, even when, for the sake of emphasis,
it parts for the time with reality".
Winston Churchill, House of Commons, 22nd Jan 1941.

[h...@crypt.org]

Dave Mitchell <da...@fdgroup.com> wrote:
:This patch moves (nearly) all pad-related code from the various core src

:files to the two new files pad.c and pad.h, and attempts to create
:something approaching an API for pads.

Thanks, applied as #17953.

:* I've also made a couple of tiny mods to autodoc.pl to make it better

:handle extraneous spaces in apidoc and embed.fnc declarations.

This applied separately as #17952.

The main patch applied with some fuzz; I spotted two changes that needed
to be carried over into the new versions of the code, but I may have
missed others: #17950 added a protection to pad_swipe(), and an earlier
patch (I think from Rafael) added the CvSPECIAL(cv) check in pad_undef().

The perl.h fragments were quite difficult to apply because the LEAKTEST
debug option had been removed in the intervening period. In general,
I'd prefer it if patches did not add whitespace to line things up -
it tends to make patches much larger than otherwise necessary, and it
can often make scanning the code _more_ difficult.

I noticed that there were many examples in the code extracted to pad.c
of assignments done inside a complex if() test to save one test; here's
one example:

if ((sv = svp[off])
&& sv != &PL_sv_undef

&& (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)

&& (!is_our

|| ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))

&& strEQ(name, SvPVX(sv)))
{
I find such code much clearer if the assignment is separated out, and
the variable then tested explicitly:
sv = svp[off];
if (sv
&& sv != &PL_sv_undef

&& (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)

&& (!is_our

|| ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))

&& strEQ(name, SvPVX(sv)))
{
Is there any (currently relevant) compiler known that won't optimise
the latter to be equivalent to the former?

Thanks Dave for your sterling work on this; I like forward to the
additional improvements this will make possible.

Hugo

[H.Merijn Brand]

On Wed 02 Oct 2002 16:16, h...@crypt.org wrote:
> Dave Mitchell <da...@fdgroup.com> wrote:
> :This patch moves (nearly) all pad-related code from the various core src
> :files to the two new files pad.c and pad.h, and attempts to create
> :something approaching an API for pads.
>
> Thanks, applied as #17953.
>
> :* I've also made a couple of tiny mods to autodoc.pl to make it better
> :handle extraneous spaces in apidoc and embed.fnc declarations.
>
> This applied separately as #17952.

Any chance on a snapshot before I go for the thr5005 removal?

--
H.Merijn Brand Amsterdam Perl Mongers (http://amsterdam.pm.org/)
using perl-5.6.1, 5.8.0 & 633 on HP-UX 10.20 & 11.00, AIX 4.2, AIX 4.3,
WinNT 4, Win2K pro & WinCE 2.11. Smoking perl CORE: smo...@perl.org
http://archives.develooper.com/daily...@perl.org/ per...@perl.org
send smoke reports to: smokers...@perl.org, QA: http://qa.perl.org