mirror of
https://github.com/Perl/perl5.git
synced 2026-01-27 01:44:43 +00:00
while (my $x ...) { ...; redo } shouldn't undef $x.
In the presence of 'my' in the conditional of a while(), until(), or for(;;) loop, add an extra scope to the body so that redo doesn't undef the lexical p4raw-id: //depot/perl@24412
This commit is contained in:
Dave Mitchell
parent
5203fbcae6
commit
a034e688ae
@ -535,8 +535,8 @@ Apd |SV* |newSVrv |SV* rv|const char* classname
|
||||
Apd |SV* |newSVsv |SV* old
|
||||
Ap |OP* |newUNOP |I32 type|I32 flags|OP* first
|
||||
Ap |OP* |newWHILEOP |I32 flags|I32 debuggable|LOOP* loop \
|
||||
|I32 whileline|OP* expr|OP* block|OP* cont
|
||||
|
||||
|I32 whileline|OP* expr|OP* block|OP* cont \
|
||||
|I32 has_my
|
||||
Ap |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems
|
||||
Ap |char* |scan_vstring |const char *vstr|SV *sv
|
||||
Apd |char* |scan_version |const char *vstr|SV *sv|bool qv
|
||||
|
||||
2
embed.h
2
embed.h
@ -2531,7 +2531,7 @@
|
||||
#define newSVrv(a,b) Perl_newSVrv(aTHX_ a,b)
|
||||
#define newSVsv(a) Perl_newSVsv(aTHX_ a)
|
||||
#define newUNOP(a,b,c) Perl_newUNOP(aTHX_ a,b,c)
|
||||
#define newWHILEOP(a,b,c,d,e,f,g) Perl_newWHILEOP(aTHX_ a,b,c,d,e,f,g)
|
||||
#define newWHILEOP(a,b,c,d,e,f,g,h) Perl_newWHILEOP(aTHX_ a,b,c,d,e,f,g,h)
|
||||
#define new_stackinfo(a,b) Perl_new_stackinfo(aTHX_ a,b)
|
||||
#define scan_vstring(a,b) Perl_scan_vstring(aTHX_ a,b)
|
||||
#define scan_version(a,b,c) Perl_scan_version(aTHX_ a,b,c)
|
||||
|
||||
7
op.c
7
op.c
@ -3799,7 +3799,8 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
|
||||
}
|
||||
|
||||
OP *
|
||||
Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
|
||||
Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
|
||||
whileline, OP *expr, OP *block, OP *cont, I32 has_my)
|
||||
{
|
||||
dVAR;
|
||||
OP *redo;
|
||||
@ -3836,7 +3837,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *
|
||||
|
||||
if (!block)
|
||||
block = newOP(OP_NULL, 0);
|
||||
else if (cont) {
|
||||
else if (cont || has_my) {
|
||||
block = scope(block);
|
||||
}
|
||||
|
||||
@ -3989,7 +3990,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo
|
||||
Renew(loop, 1, LOOP);
|
||||
#endif
|
||||
loop->op_targ = padoff;
|
||||
wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
|
||||
wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
|
||||
PL_copline = forline;
|
||||
return newSTATEOP(0, label, wop);
|
||||
}
|
||||
|
||||
6
perly.h
6
perly.h
@ -1,8 +1,8 @@
|
||||
#ifdef PERL_CORE
|
||||
/* A Bison parser, made by GNU Bison 2.0. */
|
||||
/* A Bison parser, made by GNU Bison 1.875c. */
|
||||
|
||||
/* Skeleton parser for Yacc-like parsing with Bison,
|
||||
Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
|
||||
Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
@ -171,7 +171,7 @@ typedef union YYSTYPE {
|
||||
OP *opval;
|
||||
GV *gvval;
|
||||
} YYSTYPE;
|
||||
/* Line 1318 of yacc.c. */
|
||||
/* Line 1275 of yacc.c. */
|
||||
#line 174 "perly.h"
|
||||
# define yystype YYSTYPE /* obsolescent; will be withdrawn */
|
||||
# define YYSTYPE_IS_DECLARED 1
|
||||
|
||||
29
perly.y
29
perly.y
@ -48,11 +48,11 @@
|
||||
%token <ival> LOCAL MY MYSUB
|
||||
%token COLONATTR
|
||||
|
||||
%type <ival> prog decl format startsub startanonsub startformsub
|
||||
%type <ival> prog decl format startsub startanonsub startformsub mintro
|
||||
%type <ival> progstart remember mremember '&' savescope
|
||||
%type <opval> block mblock lineseq line loop cond else
|
||||
%type <opval> expr term subscripted scalar ary hsh arylen star amper sideff
|
||||
%type <opval> argexpr nexpr texpr iexpr mexpr mnexpr mtexpr miexpr
|
||||
%type <opval> argexpr nexpr texpr iexpr mexpr mnexpr miexpr
|
||||
%type <opval> listexpr listexprcom indirob listop method
|
||||
%type <opval> formname subname proto subbody cont my_scalar
|
||||
%type <opval> subattrlist myattrlist mysubrout myattrterm myterm
|
||||
@ -207,18 +207,18 @@ cont : /* NULL */
|
||||
;
|
||||
|
||||
/* Loops: while, until, for, and a bare block */
|
||||
loop : label WHILE '(' remember mtexpr ')' mblock cont
|
||||
loop : label WHILE '(' remember texpr ')' mintro mblock cont
|
||||
{ PL_copline = (line_t)$2;
|
||||
$$ = block_end($4,
|
||||
newSTATEOP(0, $1,
|
||||
newWHILEOP(0, 1, (LOOP*)Nullop,
|
||||
$2, $5, $7, $8))); }
|
||||
| label UNTIL '(' remember miexpr ')' mblock cont
|
||||
$2, $5, $8, $9, $7))); }
|
||||
| label UNTIL '(' remember iexpr ')' mintro mblock cont
|
||||
{ PL_copline = (line_t)$2;
|
||||
$$ = block_end($4,
|
||||
newSTATEOP(0, $1,
|
||||
newWHILEOP(0, 1, (LOOP*)Nullop,
|
||||
$2, $5, $7, $8))); }
|
||||
$2, $5, $8, $9, $7))); }
|
||||
| label FOR MY remember my_scalar '(' mexpr ')' mblock cont
|
||||
{ $$ = block_end($4,
|
||||
newFOROP(0, $1, (line_t)$2, $5, $7, $9, $10)); }
|
||||
@ -229,14 +229,15 @@ loop : label WHILE '(' remember mtexpr ')' mblock cont
|
||||
| label FOR '(' remember mexpr ')' mblock cont
|
||||
{ $$ = block_end($4,
|
||||
newFOROP(0, $1, (line_t)$2, Nullop, $5, $7, $8)); }
|
||||
| label FOR '(' remember mnexpr ';' mtexpr ';' mnexpr ')' mblock
|
||||
| label FOR '(' remember mnexpr ';' texpr ';' mintro mnexpr ')'
|
||||
mblock
|
||||
/* basically fake up an initialize-while lineseq */
|
||||
{ OP *forop;
|
||||
PL_copline = (line_t)$2;
|
||||
forop = newSTATEOP(0, $1,
|
||||
newWHILEOP(0, 1, (LOOP*)Nullop,
|
||||
$2, scalar($7),
|
||||
$11, $9));
|
||||
$12, $10, $9));
|
||||
if ($5) {
|
||||
forop = append_elem(OP_LINESEQ,
|
||||
newSTATEOP(0, ($1?savepv($1):Nullch),
|
||||
@ -248,9 +249,15 @@ loop : label WHILE '(' remember mtexpr ')' mblock cont
|
||||
| label block cont /* a block is a loop that happens once */
|
||||
{ $$ = newSTATEOP(0, $1,
|
||||
newWHILEOP(0, 1, (LOOP*)Nullop,
|
||||
NOLINE, Nullop, $2, $3)); }
|
||||
NOLINE, Nullop, $2, $3, 0)); }
|
||||
;
|
||||
|
||||
/* determine whether there are any new my declarations */
|
||||
mintro : /* NULL */
|
||||
{ $$ = (PL_min_intro_pending &&
|
||||
PL_max_intro_pending >= PL_min_intro_pending);
|
||||
intro_my(); }
|
||||
|
||||
/* Normal expression */
|
||||
nexpr : /* NULL */
|
||||
{ $$ = Nullop; }
|
||||
@ -277,10 +284,6 @@ mnexpr : nexpr
|
||||
{ $$ = $1; intro_my(); }
|
||||
;
|
||||
|
||||
mtexpr : texpr
|
||||
{ $$ = $1; intro_my(); }
|
||||
;
|
||||
|
||||
miexpr : iexpr
|
||||
{ $$ = $1; intro_my(); }
|
||||
;
|
||||
|
||||
11
pp_ctl.c
11
pp_ctl.c
@ -2160,6 +2160,7 @@ PP(pp_redo)
|
||||
I32 cxix;
|
||||
register PERL_CONTEXT *cx;
|
||||
I32 oldsave;
|
||||
OP* redo_op;
|
||||
|
||||
if (PL_op->op_flags & OPf_SPECIAL) {
|
||||
cxix = dopoptoloop(cxstack_ix);
|
||||
@ -2174,12 +2175,20 @@ PP(pp_redo)
|
||||
if (cxix < cxstack_ix)
|
||||
dounwind(cxix);
|
||||
|
||||
redo_op = cxstack[cxix].blk_loop.redo_op;
|
||||
if (redo_op->op_type == OP_ENTER) {
|
||||
/* pop one less context to avoid $x being freed in while (my $x..) */
|
||||
cxstack_ix++;
|
||||
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
|
||||
redo_op = redo_op->op_next;
|
||||
}
|
||||
|
||||
TOPBLOCK(cx);
|
||||
oldsave = PL_scopestack[PL_scopestack_ix - 1];
|
||||
LEAVE_SCOPE(oldsave);
|
||||
FREETMPS;
|
||||
PL_curcop = cx->blk_oldcop;
|
||||
return cx->blk_loop.redo_op;
|
||||
return redo_op;
|
||||
}
|
||||
|
||||
STATIC OP *
|
||||
|
||||
3
proto.h
3
proto.h
@ -512,8 +512,7 @@ PERL_CALLCONV SV* Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args);
|
||||
PERL_CALLCONV SV* Perl_newSVrv(pTHX_ SV* rv, const char* classname);
|
||||
PERL_CALLCONV SV* Perl_newSVsv(pTHX_ SV* old);
|
||||
PERL_CALLCONV OP* Perl_newUNOP(pTHX_ I32 type, I32 flags, OP* first);
|
||||
PERL_CALLCONV OP* Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP* loop, I32 whileline, OP* expr, OP* block, OP* cont);
|
||||
|
||||
PERL_CALLCONV OP* Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP* loop, I32 whileline, OP* expr, OP* block, OP* cont, I32 has_my);
|
||||
PERL_CALLCONV PERL_SI* Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems);
|
||||
PERL_CALLCONV char* Perl_scan_vstring(pTHX_ const char *vstr, SV *sv);
|
||||
PERL_CALLCONV char* Perl_scan_version(pTHX_ const char *vstr, SV *sv, bool qv);
|
||||
|
||||
@ -31,7 +31,7 @@
|
||||
#
|
||||
# -- .robin. <robin@kitsite.com> 2001-03-13
|
||||
|
||||
print "1..43\n";
|
||||
print "1..46\n";
|
||||
|
||||
my $ok;
|
||||
|
||||
@ -967,3 +967,28 @@ print ($ok ? "ok 41\n" : "not ok 41\n");
|
||||
}
|
||||
|
||||
|
||||
# ensure that redo doesn't clear a lexical delcared in the condition
|
||||
|
||||
{
|
||||
my $i = 1;
|
||||
while (my $x = $i) {
|
||||
$i++;
|
||||
redo if $i == 2;
|
||||
print $x == 1 ? "" : "not ", "ok 44 - while/redo lexical life\n";
|
||||
last;
|
||||
}
|
||||
$i = 1;
|
||||
until (! (my $x = $i)) {
|
||||
$i++;
|
||||
redo if $i == 2;
|
||||
print $x == 1 ? "" : "not ", "ok 45 - until/redo lexical life\n";
|
||||
last;
|
||||
}
|
||||
for ($i = 1; my $x = $i; ) {
|
||||
$i++;
|
||||
redo if $i == 2;
|
||||
print $x == 1 ? "" : "not ", "ok 46 - for/redo lexical life\n";
|
||||
last;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user