1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
#!perl -T
use strict;
use warnings;
use lib 't/lib';
use Test::Leaner 'no_plan';
use Scope::Upper qw<unwind UP HERE>;
our ($call, @args, $args);
$call = sub {
my ($height, $level, $i) = @_;
$level = $level ? 'UP ' x $level : 'HERE';
return [ [ "unwind(\@args => $level)\n", '' ] ];
};
sub list { @_ }
my @blocks = (
[ 'sub {', '}->()' ],
[ 'eval {', '}' ],
);
my @contexts = (
[ '', '; ()' ],
[ 'scalar(', ')' ],
[ 'list(', ')' ],
);
@blocks = map [ map "$_\n", @$_ ], @blocks;
@contexts = map [ map "$_\n", @$_ ], @contexts;
sub gen {
my ($height, $level, $i) = @_;
push @_, $i = 0 if @_ == 2;
my @res;
my $up = $i == $height + 1 ? $call->(@_) : gen($height, $level, $i + 1);
if ($i + $level == $height + 1) {
for (@$up) {
$_->[1] = "return($args)\n";
}
}
for my $base (@$up) {
my ($code, $exp) = @$base;
for my $blk (@blocks) {
for my $cx (@contexts) {
push @res, [
$blk->[0] . $cx->[0] . $code . $cx->[1] . $blk->[1],
$blk->[0] . $cx->[0] . $exp . $cx->[1] . $blk->[1],
];
my $list = join ', ', map { int rand 10 } 0 .. rand 3;
push @res, [
$blk->[0] . $cx->[0] . "($list, " . $code . ')' . $cx->[1] . $blk->[1],
$blk->[0] . $cx->[0] . "($list, " . $exp . ')' . $cx->[1] . $blk->[1],
];
}
}
}
return \@res;
}
sub linearize { join ', ', map { defined($_) ? $_ : '(undef)' } @_ }
sub runtests {
my ($height, $level) = @_;
my $i;
my $tests = gen @_;
for (@$tests) {
++$i;
no warnings 'void';
my $res = linearize eval $_->[0];
$res = '*TEST DID NOT COMPILE*' if $@;
my $exp;
unless ($@) {
$exp = linearize eval $_->[1];
$exp = '*REFERENCE DID NOT COMPILE*' if $@;
}
if ($@ || $res ne $exp) {
diag <<DIAG;
=== This testcase failed ===
$_->[0];
==== vvvvv Errors vvvvvv ===
DIAG
}
is $res, $exp, "stress unwind $height $level $i";
}
}
for ([ ], [ 'A' ], [ qw<B C> ]) {
@args = @$_;
$args = '(' . join(', ', map "'$_'", @args) . ')';
runtests 0, 0;
runtests 0, 1;
runtests 1, 0;
runtests 1, 1;
}
|
