[perl #38809] return do { } : take 3 (or 4...)

[Vincent Pit <perl@profvince.com>]

Attached is another patch for 38809. It does essentially two things.
- Mark ENTER ops that follows a return as SPECIAL at compile time.
- Set the gimme value of those blocks in pp_enter as the caller's one.
It's very similar to the previous one, except that it used to look for
the caller context in LEAVE instead of ENTER, which made it impossible
to handle cases like

    return do { 1; do { 2; @a } }

This is fixed with this version.
I'm not feeling that easy by looking at the caller's context in
pp_enter, but we need this information to solve the problem, and we need
it there, so I'm afraid it's the only way to get over it (besides
ignoring the bug :) ).
Tests included, ok with blead.

Vincent.
--- op.c	2008-09-19 23:04:16.000000000 +0200
+++ op.c	2008-09-29 17:09:05.000000000 +0200
@@ -7625,14 +7625,28 @@
 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)) {
+		/* This is a do block */
+		OP *op = cUNOPx(kid)->op_first;
+		assert(op && (op->op_type == OP_LEAVE) && (op->op_flags & OPf_KIDS));
+		op = cUNOPx(op)->op_first;
+		assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
+		/* Force the use of the caller's context */
+		op->op_flags |= OPf_SPECIAL;
+	    }
     }
+
     return o;
 }
 
--- op.h	2008-09-19 23:04:16.000000000 +0200
+++ op.h	2008-09-29 17:09:05.000000000 +0200
@@ -137,6 +137,7 @@
 				/*  On OP_SMARTMATCH, an implicit smartmatch */
 				/*  On OP_ANONHASH and OP_ANONLIST, create a
 				    reference to the new anon hash or array */
+				/*  On OP_ENTER, store caller context */
 
 /* old names; don't use in new code, but don't break them, either */
 #define OPf_LIST	OPf_WANT_LIST
--- pp_hot.c	2008-09-19 23:04:19.000000000 +0200
+++ pp_hot.c	2008-09-29 17:09:05.000000000 +0200
@@ -1748,9 +1748,13 @@
     I32 gimme = OP_GIMME(PL_op, -1);
 
     if (gimme == -1) {
-	if (cxstack_ix >= 0)
-	    gimme = cxstack[cxstack_ix].blk_gimme;
-	else
+	if (cxstack_ix >= 0) {
+	    /* If this flag is set, we're just inside a return, so we should
+	     * store the caller's context */
+	    gimme = (PL_op->op_flags & OPf_SPECIAL)
+		? block_gimme()
+		: cxstack[cxstack_ix].blk_gimme;
+	} else
 	    gimme = G_SCALAR;
     }
 
@@ -1858,13 +1862,7 @@
 
     POPBLOCK(cx,newpm);
 
-    gimme = OP_GIMME(PL_op, -1);
-    if (gimme == -1) {
-	if (cxstack_ix >= 0)
-	    gimme = cxstack[cxstack_ix].blk_gimme;
-	else
-	    gimme = G_SCALAR;
-    }
+    gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
 
     TAINT_NOT;
     if (gimme == G_VOID)
--- t/op/do.t	2008-09-19 23:04:20.000000000 +0200
+++ t/op/do.t	2008-09-29 17:09:41.000000000 +0200
@@ -29,7 +29,7 @@
     return $ok;
 }
 
-print "1..26\n";
+print "1..32\n";
 
 # Test do &sub and proper @_ handling.
 $_[0] = 0;
@@ -104,6 +104,23 @@
 $owww = do { 4 if not $zok };
 ok( $owww eq '', 'last is if not' );
 
+# [perl #38809]
+@a = (7, 8);
+$x = sub { do { return do { 1; @a } }; 3 }->();
+ok(defined $x && $x == 2, 'return do { } receives caller scalar context');
+@x = sub { do { return do { 1; @a } }; 3 }->();
+ok("@x" eq "7 8", 'return do { } receives caller list context');
+@a = (7, 8, 9);
+$x = sub { do { do { 1; return @a } }; 4 }->();
+ok(defined $x && $x == 3, 'do { return } receives caller scalar context');
+@x = sub { do { do { 1; return @a } }; 4 }->();
+ok("@x" eq "7 8 9", 'do { return } receives caller list context');
+@a = (7, 8, 9, 10);
+$x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
+ok(defined $x && $x == 4, 'return do { do { } } receives caller scalar context');
+@x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
+ok("@x" eq "7 8 9 10", 'return do { do { } } receives caller list context');
+
 END {
     1 while unlink("$$.16", "$$.17", "$$.18");
 }

---

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

---