[perl #38809][PATCH] loss of stack elements with a do block insidea return

[Vincent Pit <perl@profvince.com>]

This is the bug that makes

   sub foo { do { return do { 1; 2 } }; 3 }

returns undef. The 1 is here to prevent the return do block to be
optimized away, and the 3 to ensure that the first statement receives
void context. Concise says :

1  <;> nextstate(main 3 -e:1) v
2  <0> enter v
3  <;> nextstate(main 2 -e:1) v
4  <0> pushmark s
5  <0> enter
6  <;> nextstate(main 1 -e:1) v
7  <;> nextstate(main 1 -e:1) v
8  <$> const[IV 2] s
9  <@> leave KP
a  <@> return K
b  <@> leave vKP
c  <;> nextstate(main 3 -e:1) v
d  <$> const[IV 3] s
e  <1> leavesub[1 ref] K/REFC,1

The problem is that the enter after the pushmark has no context and
hence its associated leave won't drop its return value on the stack.

The patch attached is a way better solution compared to the previous one
I sent some months ago. In ck_return, it looks at the kids and force
list context on NULLs that have the OPf_SPECIAL flag set (which
corresponds to do { } blocks, op.h says). Maybe other kids could receive
the same treatment.

Vincent.
--- op.c	2008-06-17 13:25:08.000000000 +0200
+++ op.c	2008-08-30 17:21:16.000000000 +0200
@@ -7561,13 +7561,19 @@
 Perl_ck_return(pTHX_ OP *o)
 {
     dVAR;
+    OP *kid;
 
     PERL_ARGS_ASSERT_CK_RETURN;
 
+    kid = cLISTOPo->op_first->op_sibling;
     if (CvLVALUE(PL_compcv)) {
-        OP *kid;
-	for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+	for (; kid; kid = kid->op_sibling)
 	    mod(kid, OP_LEAVESUBLV);
+    } else {
+	for (; kid; kid = kid->op_sibling) {
+	    if (kid->op_type == OP_NULL && kid->op_flags & OPf_SPECIAL) /* do */
+	    	list(kid);
+	}
     }
     return o;
 }
--- t/op/do.t	2007-01-08 22:22:52.000000000 +0100
+++ t/op/do.t	2008-08-30 16:32:00.000000000 +0200
@@ -29,7 +29,7 @@
     return $ok;
 }
 
-print "1..22\n";
+print "1..23\n";
 
 # Test do &sub and proper @_ handling.
 $_[0] = 0;
@@ -92,6 +92,10 @@
 push @t, ($u = (do {} . "This should be pushed."));
 ok( $#t == 0, "empty do result value" );
 
+# [perl #38809]
+@a = sub { do { return 38, do { 1; 80, 9 } }; 2 }->();
+ok( join('', @a) eq '38809', "do blocks in return should have list context" );
+
 END {
     1 while unlink("$$.16", "$$.17", "$$.18");
 }

---

Follow-Ups from:

Vincent Pit <perl@profvince.com>

---

[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]

---