Fix context propagation below return()

A.k.a. "RT #38809 strikes back".

Back in the time of perl 5.003, there was no void context, so "do" blocks
below a return needed special handling to use the dynamic context of the
caller instead of the static context implied by the return op location.

But nowadays context is applied by the scalarvoid(), scalar() and list()
functions, and they all already skip the return ops. "do" blocks below a
return don't get a static context, and GIMME_V ought to correctly return
the caller's context. The old workaround isn't even required anymore.

1 files changed, 67 insertions, 0 deletions

diff --git a/t/op/do.t b/t/op/do.t
index 787d632a6b..aae6aacb3d 100644
--- a/t/op/do.t
+++ b/t/op/do.t
@@ -159,6 +159,73 @@ is($x, 4, 'return do { do { ; } } receives caller scalar context');
 @x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
 is("@x", "7 8 9 10", 'return do { do { ; } } receives caller list context');
 
+# More tests about context propagation below return()
+@a = (11, 12);
+@b = (21, 22, 23);
+
+my $test_code = sub {
+    my ($x, $y) = @_;
+    if ($x) {
+	return $y ? do { my $z; @a } : do { my $z; @b };
+    } else {
+	return (
+	    do { my $z; @a },
+	    (do { my$z; @b }) x $y
+	);
+    }
+    'xxx';
+};
+
+$x = $test_code->(1, 1);
+is($x, 2, 'return $y ? do { } : do { } - scalar context 1');
+$x = $test_code->(1, 0);
+is($x, 3, 'return $y ? do { } : do { } - scalar context 2');
+@x = $test_code->(1, 1);
+is("@x", '11 12', 'return $y ? do { } : do { } - list context 1');
+@x = $test_code->(1, 0);
+is("@x", '21 22 23', 'return $y ? do { } : do { } - list context 2');
+
+$x = $test_code->(0, 0);
+is($x, "", 'return (do { }, (do { }) x ...) - scalar context 1');
+$x = $test_code->(0, 1);
+is($x, 3, 'return (do { }, (do { }) x ...) - scalar context 2');
+@x = $test_code->(0, 0);
+is("@x", '11 12', 'return (do { }, (do { }) x ...) - list context 1');
+@x = $test_code->(0, 1);
+is("@x", '11 12 21 22 23', 'return (do { }, (do { }) x ...) - list context 2');
+
+$test_code = sub {
+    my ($x, $y) = @_;
+    if ($x) {
+	return do {
+	    if ($y == 0) {
+		my $z;
+		@a;
+	    } elsif ($y == 1) {
+		my $z;
+		@b;
+	    } else {
+		my $z;
+		(wantarray ? reverse(@a) : '99');
+	    }
+	};
+    }
+    'xxx';
+};
+
+$x = $test_code->(1, 0);
+is($x, 2, 'return do { if () { } elsif () { } else { } } - scalar 1');
+$x = $test_code->(1, 1);
+is($x, 3, 'return do { if () { } elsif () { } else { } } - scalar 2');
+$x = $test_code->(1, 2);
+is($x, 99, 'return do { if () { } elsif () { } else { } } - scalar 3');
+@x = $test_code->(1, 0);
+is("@x", '11 12', 'return do { if () { } elsif () { } else { } } - list 1');
+@x = $test_code->(1, 1);
+is("@x", '21 22 23', 'return do { if () { } elsif () { } else { } } - list 2');
+@x = $test_code->(1, 2);
+is("@x", '12 11', 'return do { if () { } elsif () { } else { } } - list 3');
+
 # Do blocks created by constant folding
 # [perl #68108]
 $x = sub { if (1) { 20 } }->();