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
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)
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) \
$(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
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
long olddepth;
U8 hasargs;
U8 lval; /* XXX merge lval and hasargs? */
- SV ** oldcurpad;
+ PAD oldcurpad;
};
#define PUSHSUB(cx) \
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); \
OP * last_op;
#ifdef USE_ITHREADS
void * iterdata;
- SV ** oldcurpad;
+ PAD oldcurpad;
#else
SV ** itervar;
#endif
# 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 \
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;
#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
-*/
-
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);
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
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
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)
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
|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
#define op_free Perl_op_free
#define package Perl_package
#define pad_alloc Perl_pad_alloc
-#define pad_allocmy Perl_pad_allocmy
+#define allocmy Perl_allocmy
#define pad_findmy Perl_pad_findmy
#define oopsAV Perl_oopsAV
#define oopsHV Perl_oopsHV
#define scalarboolean S_scalarboolean
#define too_few_arguments S_too_few_arguments
#define too_many_arguments S_too_many_arguments
-#define pad_addlex S_pad_addlex
-#define pad_findlex S_pad_findlex
#define newDEFSVOP S_newDEFSVOP
#define new_logop S_new_logop
#define simplify_sort S_simplify_sort
#define is_handle_constructor S_is_handle_constructor
#define gv_ename S_gv_ename
-# if defined(DEBUG_CLOSURES)
-#define cv_dump S_cv_dump
-# endif
-#define cv_clone2 S_cv_clone2
#define scalar_mod_type S_scalar_mod_type
#define my_kid S_my_kid
#define dup_attrlist S_dup_attrlist
#ifdef PERL_IN_DEB_C
#define deb_stack_n S_deb_stack_n
#endif
+#define pad_new Perl_pad_new
+#define pad_undef Perl_pad_undef
+#define pad_add_name Perl_pad_add_name
+#define pad_add_anon Perl_pad_add_anon
+#define pad_check_dup Perl_pad_check_dup
+#ifdef DEBUGGING
+#define pad_setsv Perl_pad_setsv
+#endif
+#define pad_block_start Perl_pad_block_start
+#define pad_tidy Perl_pad_tidy
+#define do_dump_pad Perl_do_dump_pad
+#define pad_fixup_inner_anons Perl_pad_fixup_inner_anons
+#define pad_push Perl_pad_push
+#if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+#define pad_findlex S_pad_findlex
+# if defined(DEBUGGING)
+#define cv_dump S_cv_dump
+# endif
+#define cv_clone2 S_cv_clone2
+#endif
#define ck_anoncode Perl_ck_anoncode
#define ck_bitop Perl_ck_bitop
#define ck_concat Perl_ck_concat
#define op_free(a) Perl_op_free(aTHX_ a)
#define package(a) Perl_package(aTHX_ a)
#define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b)
-#define pad_allocmy(a) Perl_pad_allocmy(aTHX_ a)
+#define allocmy(a) Perl_allocmy(aTHX_ a)
#define pad_findmy(a) Perl_pad_findmy(aTHX_ a)
#define oopsAV(a) Perl_oopsAV(aTHX_ a)
#define oopsHV(a) Perl_oopsHV(aTHX_ a)
-#define pad_leavemy(a) Perl_pad_leavemy(aTHX_ a)
+#define pad_leavemy() Perl_pad_leavemy(aTHX)
#define pad_sv(a) Perl_pad_sv(aTHX_ a)
#define pad_free(a) Perl_pad_free(aTHX_ a)
#define pad_reset() Perl_pad_reset(aTHX)
-#define pad_swipe(a) Perl_pad_swipe(aTHX_ a)
+#define pad_swipe(a,b) Perl_pad_swipe(aTHX_ a,b)
#define peep(a) Perl_peep(aTHX_ a)
#if defined(USE_5005THREADS)
#define new_struct_thread(a) Perl_new_struct_thread(aTHX_ a)
#define scalarboolean(a) S_scalarboolean(aTHX_ a)
#define too_few_arguments(a,b) S_too_few_arguments(aTHX_ a,b)
#define too_many_arguments(a,b) S_too_many_arguments(aTHX_ a,b)
-#define pad_addlex(a) S_pad_addlex(aTHX_ a)
-#define pad_findlex(a,b,c,d,e,f,g) S_pad_findlex(aTHX_ a,b,c,d,e,f,g)
#define newDEFSVOP() S_newDEFSVOP(aTHX)
#define new_logop(a,b,c,d) S_new_logop(aTHX_ a,b,c,d)
#define simplify_sort(a) S_simplify_sort(aTHX_ a)
#define is_handle_constructor(a,b) S_is_handle_constructor(aTHX_ a,b)
#define gv_ename(a) S_gv_ename(aTHX_ a)
-# if defined(DEBUG_CLOSURES)
-#define cv_dump(a) S_cv_dump(aTHX_ a)
-# endif
-#define cv_clone2(a,b) S_cv_clone2(aTHX_ a,b)
#define scalar_mod_type(a,b) S_scalar_mod_type(aTHX_ a,b)
#define my_kid(a,b,c) S_my_kid(aTHX_ a,b,c)
#define dup_attrlist(a) S_dup_attrlist(aTHX_ a)
#ifdef PERL_IN_DEB_C
#define deb_stack_n(a,b,c,d,e) S_deb_stack_n(aTHX_ a,b,c,d,e)
#endif
+#define pad_new(a) Perl_pad_new(aTHX_ a)
+#define pad_undef(a,b) Perl_pad_undef(aTHX_ a,b)
+#define pad_add_name(a,b,c,d) Perl_pad_add_name(aTHX_ a,b,c,d)
+#define pad_add_anon(a,b) Perl_pad_add_anon(aTHX_ a,b)
+#define pad_check_dup(a,b,c) Perl_pad_check_dup(aTHX_ a,b,c)
+#ifdef DEBUGGING
+#define pad_setsv(a,b) Perl_pad_setsv(aTHX_ a,b)
+#endif
+#define pad_block_start(a) Perl_pad_block_start(aTHX_ a)
+#define pad_tidy(a) Perl_pad_tidy(aTHX_ a)
+#define do_dump_pad(a,b,c,d) Perl_do_dump_pad(aTHX_ a,b,c,d)
+#define pad_fixup_inner_anons(a,b,c) Perl_pad_fixup_inner_anons(aTHX_ a,b,c)
+#define pad_push(a,b,c) Perl_pad_push(aTHX_ a,b,c)
+#if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+#define pad_findlex(a,b,c,d,e,f,g) S_pad_findlex(aTHX_ a,b,c,d,e,f,g)
+# if defined(DEBUGGING)
+#define cv_dump(a,b) S_cv_dump(aTHX_ a,b)
+# endif
+#define cv_clone2(a,b) S_cv_clone2(aTHX_ a,b)
+#endif
#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
#define ck_bitop(a) Perl_ck_bitop(aTHX_ a)
#define ck_concat(a) Perl_ck_concat(aTHX_ a)
#define PL_nomemok (PERL_GET_INTERP->Inomemok)
#define PL_nthreads (PERL_GET_INTERP->Inthreads)
#define PL_nthreads_cond (PERL_GET_INTERP->Inthreads_cond)
-#define PL_nullstash (PERL_GET_INTERP->Inullstash)
#define PL_numeric_compat1 (PERL_GET_INTERP->Inumeric_compat1)
#define PL_numeric_local (PERL_GET_INTERP->Inumeric_local)
#define PL_numeric_name (PERL_GET_INTERP->Inumeric_name)
#define PL_nomemok (vTHX->Inomemok)
#define PL_nthreads (vTHX->Inthreads)
#define PL_nthreads_cond (vTHX->Inthreads_cond)
-#define PL_nullstash (vTHX->Inullstash)
#define PL_numeric_compat1 (vTHX->Inumeric_compat1)
#define PL_numeric_local (vTHX->Inumeric_local)
#define PL_numeric_name (vTHX->Inumeric_name)
#define PL_Inomemok PL_nomemok
#define PL_Inthreads PL_nthreads
#define PL_Inthreads_cond PL_nthreads_cond
-#define PL_Inullstash PL_nullstash
#define PL_Inumeric_compat1 PL_numeric_compat1
#define PL_Inumeric_local PL_numeric_local
#define PL_Inumeric_name PL_numeric_name
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_
OWNER = $ADDR
)? FLAGS = 0x4
PADLIST = $ADDR
+ PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
OUTSIDE = $ADDR \\(MAIN\\)');
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,
Nullop ) \
: CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
-#define PAD_MAX 999999999
#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
STATIC char*
/* "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])) ||
}
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.
- */
+ /* check for duplicate declaration */
+ pad_check_dup(name,
+ PL_in_my == KEY_our,
+ (PL_curstash ? PL_curstash : PL_defstash)
+ );
- 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);
- }
+ 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"));
}
- 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;
+ /* allocate a spare slot and store the name in that slot */
-#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;
+ 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;
}
-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 */
- if (PL_curpad[po])
- 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;
-}
-
-/* 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 */
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
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);
Perl_mod(pTHX_ OP *o, I32 type)
{
OP *kid;
- STRLEN n_a;
if (!o || PL_error_count)
return o;
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
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));
}
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);
}
{
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);
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;
}
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);
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);
if (sv)
SvPADTMP_on(sv);
padop->op_next = (OP*)padop;
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++;
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;
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
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)
{
CV *outsidecv;
CV *freecv = Nullcv;
- bool is_eval = CvEVAL(cv) && !CvGV(cv); /* is this eval"" ? */
#ifdef USE_5005THREADS
if (CvMUTEXP(cv)) {
#endif /* USE_5005THREADS */
ENTER;
- SAVEVPTR(PL_curpad);
- PL_curpad = 0;
+ PAD_SAVE_SETNULLPAD;
op_free(CvROOT(cv));
CvROOT(cv) = Nullop;
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) || CvSPECIAL(cv)) {
- /* 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;
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)
{
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)) {
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;
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. */
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));
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
register CV *cv;
char *name;
GV *gv;
- I32 ix;
STRLEN n_a;
if (o)
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);
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;
}
#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
/* 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
*/
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)
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);
#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,
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;
* 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
#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
--- /dev/null
+/* 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 compiling padlist, saving and updating the various global
+vars at the same time as creating the pad itself. The following flags
+can be OR'ed together:
+
+ 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) || CvSPECIAL(cv))
+ {
+ /* 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.
+ */
+ /* HVDS why copy to sv here? we don't seem to use it */
+ 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 its offset, first in the current pad,
+or failing that, in the pads of any lexically enclosing subs (including
+the complications introduced by eval). If the name is found in an outer pad,
+then a fake entry is added to the current pad.
+Returns the offset in the current pad, or NOT_IN_PAD on failure.
+
+=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));
+
+ if (PL_curpad[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 built 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;
+ }
+}
--- /dev/null
+/* 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;
/* 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;
}
}
if (PL_main_root) {
- PL_curpad = AvARRAY(PL_comppad);
+ PAD_UPDATE_CURPAD;
op_free(PL_main_root);
PL_main_root = Nullop;
}
int fdscript = -1;
VOL bool dosearch = FALSE;
char *validarg = "";
- AV* comppadlist;
register SV *sv;
register char *s;
char *cddir = Nullch;
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
#include "util.h"
#include "form.h"
#include "gv.h"
+#include "pad.h"
#include "cv.h"
#include "opnames.h"
#include "op.h"
# 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
# define DEBUG_u_TEST DEBUG_u_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_u(a) DEBUG__(DEBUG_u_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_u_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_u(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)
# 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
#define PL_nthreads (*Perl_Inthreads_ptr(aTHX))
#undef PL_nthreads_cond
#define PL_nthreads_cond (*Perl_Inthreads_cond_ptr(aTHX))
-#undef PL_nullstash
-#define PL_nullstash (*Perl_Inullstash_ptr(aTHX))
#undef PL_numeric_compat1
#define PL_numeric_compat1 (*Perl_Inumeric_compat1_ptr(aTHX))
#undef PL_numeric_local
=for hackers
Found in file hv.h
-=item Nullch
+=item Nullch
Null character pointer.
=for hackers
=back
+=head1 Pad Data Structures
+
+=over 8
+
+=item pad_sv
+
+Get the value at offset po in the current pad.
+Use macro PAD_SV instead of calling this function directly.
+
+ SV* pad_sv(PADOFFSET po)
+
+=for hackers
+Found in file pad.c
+
+
+=back
+
=head1 Stack Manipulation Macros
=over 8
B<they are not for use in extensions>!
+=head1 Functions in file pad.h
+
+
+=over 8
+
+=item CX_CURPAD_SAVE
+
+Save the current pad in the given context block structure.
+
+ void CX_CURPAD_SAVE(struct context)
+
+=for hackers
+Found in file pad.h
+
+=item CX_CURPAD_SV
+
+Access the SV at offset po in the saved current pad in the given
+context block structure (can be used as an lvalue).
+
+ PAD * CX_CURPAD_SV(struct context, PADOFFSET po)
+
+=for hackers
+Found in file pad.h
+
+=item PAD_BASE_SV
+
+Get the value from slot C<po> in the base (DEPTH=1) pad of a padlist
+
+ SV * PAD_BASE_SV (PADLIST padlist, PADOFFSET po)
+
+=for hackers
+Found in file pad.h
+
+=item PAD_CLONE_VARS
+
+|CLONE_PARAMS* param
+Clone the state variables associated with running and compiling pads.
+
+ void PAD_CLONE_VARS(PerlInterpreter *proto_perl \)
+
+=for hackers
+Found in file pad.h
+
+=item PAD_COMPNAME_FLAGS
+
+Return the flags for the current compiling pad name
+at offset C<po>. Assumes a valid slot entry.
+
+ U32 PAD_COMPNAME_FLAGS(PADOFFSET po)
+
+=for hackers
+Found in file pad.h
+
+=item PAD_COMPNAME_GEN
+
+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.
+
+ STRLEN PAD_COMPNAME_GEN(PADOFFSET po)
+
+=for hackers
+Found in file pad.h
+
+=item PAD_COMPNAME_OURSTASH
+
+Return the stash associated with an C<our> variable.
+Assumes the slot entry is a valid C<our> lexical.
+
+ HV * PAD_COMPNAME_OURSTASH(PADOFFSET po)
+
+=for hackers
+Found in file pad.h
+
+=item PAD_COMPNAME_PV
+
+Return the name of the current compiling pad name
+at offset C<po>. Assumes a valid slot entry.
+
+ char * PAD_COMPNAME_PV(PADOFFSET po)
+
+=for hackers
+Found in file pad.h
+
+=item PAD_COMPNAME_TYPE
+
+Return the type (stash) of the current compiling pad name at offset
+C<po>. Must be a valid name. Returns null if not typed.
+
+ HV * PAD_COMPNAME_TYPE(PADOFFSET po)
+
+=for hackers
+Found in file pad.h
+
+=item PAD_DUP
+
+Clone a padlist.
+
+ void PAD_DUP(PADLIST dstpad, PADLIST srcpad, CLONE_PARAMS* param)
+
+=for hackers
+Found in file pad.h
+
+=item PAD_SAVE_SETNULLPAD
+
+Save the current pad then set it to null.
+
+ void PAD_SAVE_SETNULLPAD()
+
+=for hackers
+Found in file pad.h
+
+=item PAD_SETSV
+
+Set the slot at offset C<po> in the current pad to C<sv>
+
+ SV * PAD_SETSV (PADOFFSET po, SV* sv)
+
+=for hackers
+Found in file pad.h
+
+=item PAD_SET_CUR
+
+Set the current pad to be pad C<n> in the padlist, saving
+the previous current pad.
+
+ void PAD_SET_CUR (PADLIST padlist, I32 n)
+
+=for hackers
+Found in file pad.h
+
+=item PAD_SV
+
+Get the value at offset C<po> in the current pad
+
+ void PAD_SV (PADOFFSET po)
+
+=for hackers
+Found in file pad.h
+
+=item PAD_SVl
+
+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.
+
+ SV * PAD_SVl (PADOFFSET po)
+
+=for hackers
+Found in file pad.h
+
+=item PAD_UPDATE_CURPAD
+
+Set PL_curpad from the value of PL_comppad.
+
+ void PAD_UPDATE_CURPAD()
+
+=for hackers
+Found in file pad.h
+
+=item SAVECLEARSV
+
+Clear the pointed to pad value on scope exit. (ie the runtime action of 'my')
+
+ void SAVECLEARSV (SV **svp)
+
+=for hackers
+Found in file pad.h
+
+=item SAVECOMPPAD
+
+save PL_comppad and PL_curpad
+
+ void SAVECOMPPAD()
+
+=for hackers
+Found in file pad.h
+
+=item SAVEFREEOP
+
+Free the op on scope exit. At the same time, reset PL_curpad
+
+
+
+
+ void SAVEFREEOP (OP *o)
+
+=for hackers
+Found in file pad.h
+
+=item SAVEPADSV
+
+Save a pad slot (used to restore after an iteration)
+
+ void SAVEPADSV (PADOFFSET po)
+
+=for hackers
+Found in file pad.h
+
+
+=back
+
=head1 Global Variables
=over 8
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.
+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".
AV * CvPADLIST(CV *cv)
=for hackers
-Found in file cv.h
+Found in file pad.c
+
+=item 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.
+
+ CV* cv_clone(CV* proto)
+
+=for hackers
+Found in file pad.c
+
+=item cv_dump
+
+dump the contents of a CV
+
+ void cv_dump(CV *cv, char *title)
+
+=for hackers
+Found in file pad.c
+
+=item do_dump_pad
+
+Dump the contents of a padlist
+
+ void do_dump_pad(I32 level, PerlIO *file, PADLIST *padlist, int full)
+
+=for hackers
+Found in file pad.c
+
+=item intro_my
+
+"Introduce" my variables to visible status.
+
+ U32 intro_my()
+
+=for hackers
+Found in file pad.c
+
+=item pad_add_anon
+
+Add an anon code entry to the current compiling pad
+
+ PADOFFSET pad_add_anon(SV* sv, OPCODE op_type)
+
+=for hackers
+Found in file pad.c
+
+=item 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
+
+ PADOFFSET pad_add_name(char *name, HV* typestash, HV* ourstash, bool clone)
+
+=for hackers
+Found in file pad.c
+
+=item 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.
+
+ PADOFFSET pad_alloc(I32 optype, U32 tmptype)
+
+=for hackers
+Found in file pad.c
+
+=item pad_block_start
+
+Update the pad compilation state variables on entry to a new block
+
+ void pad_block_start(int full)
+
+=for hackers
+Found in file pad.c
+
+=item 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
+
+
+ void pad_check_dup(char* name, bool is_our, HV* ourstash)
+
+=for hackers
+Found in file pad.c
+
+=item 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.
+
+ PADOFFSET pad_findlex(char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, U32 flags)
+
+=for hackers
+Found in file pad.c
+
+=item 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.
+
+ PADOFFSET pad_findmy(char* name)
+
+=for hackers
+Found in file pad.c
+
+=item pad_fixup_inner_anons
+
+For any anon CVs in the pad, change CvOUTSIDE of that CV from
+old_cv to new_cv if necessary.
+
+ void pad_fixup_inner_anons(PADLIST *padlist, CV *old_cv, CV *new_cv)
+
+=for hackers
+Found in file pad.c
+
+=item pad_free
+
+Free the SV at offet po in the current pad.
+
+ void pad_free(PADOFFSET po)
+
+=for hackers
+Found in file pad.c
+
+=item 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.
+
+ void pad_leavemy()
+
+=for hackers
+Found in file pad.c
+
+=item 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
+
+ PADLIST* pad_new(padnew_flags flags)
+
+=for hackers
+Found in file pad.c
+
+=item 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.
+
+ void pad_push(PADLIST *padlist, int depth, int has_args)
+
+=for hackers
+Found in file pad.c
+
+=item pad_reset
+
+Mark all the current temporaries for reuse
+
+ void pad_reset()
+
+=for hackers
+Found in file pad.c
+
+=item 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.
+
+ void pad_setsv(PADOFFSET po, SV* sv)
+
+=for hackers
+Found in file pad.c
+
+=item pad_swipe
+
+Abandon the tmp in the current pad at offset po and replace with a
+new one.
+
+ void pad_swipe(PADOFFSET po, bool refadjust)
+
+=for hackers
+Found in file pad.c
+
+=item 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.
+
+ void pad_tidy(padtidy_type type)
+
+=for hackers
+Found in file pad.c
+
+=item 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.
+
+ void pad_undef(CV* cv, CV* outercv)
+
+=for hackers
+Found in file pad.c
=back
{
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);
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) {
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);
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);
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 */
return NORMAL;
}
+/* like pp_nextstate, but used instead when the debugger is active */
+
PP(pp_dbstate)
{
PL_curcop = (COP*)PL_op;
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
#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);
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
}
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;
}
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) {
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;
dSP;
OP *saveop = PL_op;
CV *caller;
- AV* comppadlist;
I32 i;
PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
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];
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))
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;
}
}
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]))
{
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 */
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);
*/
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) {
}
}
#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 */
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 @_ */
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;
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);
}
}
}
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,
AV *av;
#ifdef USE_5005THREADS
- av = (AV*)PL_curpad[0];
+ av = (AV*)PAD_SVl(0);
#else
av = GvAV(PL_defgv);
#endif
{
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
- AV* padlist = CvPADLIST(cv);
- SV** svp = AvARRAY(padlist);
ENTER;
SAVETMPS;
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);
PERL_CALLCONV void Perl_op_free(pTHX_ OP* arg);
PERL_CALLCONV void Perl_package(pTHX_ OP* o);
PERL_CALLCONV PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype);
-PERL_CALLCONV PADOFFSET Perl_pad_allocmy(pTHX_ char* name);
+PERL_CALLCONV PADOFFSET Perl_allocmy(pTHX_ char* name);
PERL_CALLCONV PADOFFSET Perl_pad_findmy(pTHX_ char* name);
PERL_CALLCONV OP* Perl_oopsAV(pTHX_ OP* o);
PERL_CALLCONV OP* Perl_oopsHV(pTHX_ OP* o);
-PERL_CALLCONV void Perl_pad_leavemy(pTHX_ I32 fill);
+PERL_CALLCONV void Perl_pad_leavemy(pTHX);
PERL_CALLCONV SV* Perl_pad_sv(pTHX_ PADOFFSET po);
PERL_CALLCONV void Perl_pad_free(pTHX_ PADOFFSET po);
PERL_CALLCONV void Perl_pad_reset(pTHX);
-PERL_CALLCONV void Perl_pad_swipe(pTHX_ PADOFFSET po);
+PERL_CALLCONV void Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust);
PERL_CALLCONV void Perl_peep(pTHX_ OP* o);
PERL_CALLCONV PerlIO* Perl_start_glob(pTHX_ SV* pattern, IO *io);
#if defined(USE_5005THREADS)
STATIC OP* S_scalarboolean(pTHX_ OP *o);
STATIC OP* S_too_few_arguments(pTHX_ OP *o, char* name);
STATIC OP* S_too_many_arguments(pTHX_ OP *o, char* name);
-STATIC PADOFFSET S_pad_addlex(pTHX_ SV* name);
-STATIC PADOFFSET S_pad_findlex(pTHX_ char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, U32 flags);
STATIC OP* S_newDEFSVOP(pTHX);
STATIC OP* S_new_logop(pTHX_ I32 type, I32 flags, OP **firstp, OP **otherp);
STATIC void S_simplify_sort(pTHX_ OP *o);
STATIC bool S_is_handle_constructor(pTHX_ OP *o, I32 argnum);
STATIC char* S_gv_ename(pTHX_ GV *gv);
-# if defined(DEBUG_CLOSURES)
-STATIC void S_cv_dump(pTHX_ CV *cv);
-# endif
-STATIC CV* S_cv_clone2(pTHX_ CV *proto, CV *outside);
STATIC bool S_scalar_mod_type(pTHX_ OP *o, I32 type);
STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp);
STATIC OP * S_dup_attrlist(pTHX_ OP *o);
STATIC void S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, I32 mark_min, I32 mark_max);
#endif
+PERL_CALLCONV PADLIST* Perl_pad_new(pTHX_ padnew_flags flags);
+PERL_CALLCONV void Perl_pad_undef(pTHX_ CV* cv, CV* outercv);
+PERL_CALLCONV PADOFFSET Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool clone);
+PERL_CALLCONV PADOFFSET Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type);
+PERL_CALLCONV void Perl_pad_check_dup(pTHX_ char* name, bool is_our, HV* ourstash);
+#ifdef DEBUGGING
+PERL_CALLCONV void Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv);
+#endif
+PERL_CALLCONV void Perl_pad_block_start(pTHX_ int full);
+PERL_CALLCONV void Perl_pad_tidy(pTHX_ padtidy_type type);
+PERL_CALLCONV void Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full);
+PERL_CALLCONV void Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv);
+
+PERL_CALLCONV void Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args);
+
+#if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
+STATIC PADOFFSET S_pad_findlex(pTHX_ char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, U32 flags);
+# if defined(DEBUGGING)
+STATIC void S_cv_dump(pTHX_ CV *cv, char *title);
+# endif
+STATIC CV* S_cv_clone2(pTHX_ CV *proto, CV *outside);
+#endif
+
+
END_EXTERN_C
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)) {
/*
PADOFFSET off = (PADOFFSET)SSPOPLONG;
ptr = SSPOPPTR;
if (ptr)
- ((SV**)ptr)[off] = (SV*)SSPOPPTR;
+ ((PAD)ptr)[off] = (SV*)SSPOPPTR;
}
break;
default:
} 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
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);
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 */
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);
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;
}
}
}
#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);
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);
{
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;
projects / p5sagit/p5-mst-13.2.git / commitdiff