From: Gurusamy Sarathy Date: Sat, 22 Jan 2000 08:08:08 +0000 (+0000) Subject: fix deeply nested closures that have no references to lexical in X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=94f23f413fc20beae3970bde041120ceeceae8e4;p=p5sagit%2Fp5-mst-13.2.git fix deeply nested closures that have no references to lexical in intervening subs p4raw-id: //depot/perl@4834 --- diff --git a/embed.h b/embed.h index 2d5c36b..61ffadf 100644 --- a/embed.h +++ b/embed.h @@ -858,6 +858,7 @@ #define too_many_arguments S_too_many_arguments #define op_clear S_op_clear #define null S_null +#define pad_addlex S_pad_addlex #define pad_findlex S_pad_findlex #define newDEFSVOP S_newDEFSVOP #define new_logop S_new_logop @@ -2270,6 +2271,7 @@ #define too_many_arguments(a,b) S_too_many_arguments(aTHX_ a,b) #define op_clear(a) S_op_clear(aTHX_ a) #define null(a) S_null(aTHX_ a) +#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) @@ -4439,6 +4441,8 @@ #define op_clear S_op_clear #define S_null CPerlObj::S_null #define null S_null +#define S_pad_addlex CPerlObj::S_pad_addlex +#define pad_addlex S_pad_addlex #define S_pad_findlex CPerlObj::S_pad_findlex #define pad_findlex S_pad_findlex #define S_newDEFSVOP CPerlObj::S_newDEFSVOP diff --git a/embed.pl b/embed.pl index 95dfed9..f235ffb 100755 --- a/embed.pl +++ b/embed.pl @@ -1929,6 +1929,7 @@ s |OP* |too_few_arguments|OP *o|char* name s |OP* |too_many_arguments|OP *o|char* name s |void |op_clear |OP* o s |void |null |OP* o +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 diff --git a/op.c b/op.c index 386e9de..961fe50 100644 --- a/op.c +++ b/op.c @@ -204,6 +204,31 @@ Perl_pad_allocmy(pTHX_ char *name) 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 (SvOBJECT(proto_namesv)) { /* A typed var */ + SvOBJECT_on(namesv); + (void)SvUPGRADE(namesv, SVt_PVMG); + SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv)); + PL_sv_objcount++; + } + return newoff; +} + #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */ STATIC PADOFFSET @@ -246,28 +271,10 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, } depth = 1; } - oldpad = (AV*)*av_fetch(curlist, depth, FALSE); + oldpad = (AV*)AvARRAY(curlist)[depth]; oldsv = *av_fetch(oldpad, off, TRUE); if (!newoff) { /* Not a mere clone operation. */ - SV *namesv = NEWSV(1103,0); - newoff = pad_alloc(OP_PADSV, SVs_PADMY); - sv_upgrade(namesv, SVt_PVNV); - sv_setpv(namesv, name); - 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(sv) & SVpad_OUR) { /* An "our" variable */ - SvFLAGS(namesv) |= SVpad_OUR; - (void)SvUPGRADE(namesv, SVt_PVGV); - GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(sv)); - } - if (SvOBJECT(sv)) { /* A typed var */ - SvOBJECT_on(namesv); - (void)SvUPGRADE(namesv, SVt_PVMG); - SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(sv)); - PL_sv_objcount++; - } + newoff = pad_addlex(sv); if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) { /* "It's closures all the way down." */ CvCLONE_on(PL_compcv); @@ -281,8 +288,23 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, bcv && bcv != cv && !CvCLONE(bcv); bcv = CvOUTSIDE(bcv)) { - if (CvANON(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)) diff --git a/proto.h b/proto.h index 76cb2f3..6f60109 100644 --- a/proto.h +++ b/proto.h @@ -865,6 +865,7 @@ STATIC OP* S_too_few_arguments(pTHX_ OP *o, char* name); STATIC OP* S_too_many_arguments(pTHX_ OP *o, char* name); STATIC void S_op_clear(pTHX_ OP* o); STATIC void S_null(pTHX_ OP* o); +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); diff --git a/t/op/closure.t b/t/op/closure.t index 2284be6..52d2272 100755 --- a/t/op/closure.t +++ b/t/op/closure.t @@ -12,7 +12,7 @@ BEGIN { use Config; -print "1..169\n"; +print "1..170\n"; my $test = 1; sub test (&) { @@ -157,6 +157,22 @@ test { &{$foo[4]}(4) }; +for my $n (0..4) { + $foo[$n] = sub { + # no intervening reference to $n here + sub { $n == $_[0] } + }; +} + +test { + $foo[0]->()->(0) and + $foo[1]->()->(1) and + $foo[2]->()->(2) and + $foo[3]->()->(3) and + $foo[4]->()->(4) +}; + + # Additional tests by Tom Phoenix . {