-
Notifications
You must be signed in to change notification settings - Fork 138
/
pbc_dump.t
251 lines (190 loc) · 6.19 KB
/
pbc_dump.t
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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
#! perl
# Copyright (C) 2009-2010, Parrot Foundation.
=head1 NAME
t/tools/pbc_dump.t - test the Parrot Bytecode (PBC) Dumper
=head1 SYNOPSIS
% prove t/tools/pbc_dump.t
=head1 DESCRIPTION
Tests the C<pbc_dump> tool by providing it with a number of source
files, and running through it with various commands.
We never actually check the I<full> output of pbc_dump. We simply check
several smaller components to avoid a test file that is far too unwieldy.
=head1 REQUIREMENTS
This test script requires you to build pbc_dump, by typing
"make parrot_utils" (using a suitable make tool for your platform).
If this requirement has not been met, all tests will be skipped.
=cut
use strict;
use warnings;
use lib qw(lib);
use Test::More;
use Parrot::Config;
use Parrot::Test;
use File::Spec;
use Parrot::Test::Util 'create_tempfile';
my ($path, $exefile);
my $PARROT = ".$PConfig{slash}parrot$PConfig{exe}";
BEGIN {
$path = File::Spec->catfile( ".", "pbc_dump" );
$exefile = $path . $PConfig{exe};
unless ( -f $exefile ) {
plan skip_all => "pbc_dump hasn't been built. Run make parrot_utils";
exit(0);
}
plan tests => 25;
}
dump_output_like( <<PIR, "pir", [qr/CONSTANT_t/, qr/BYTECODE_t/], 'pbc_dump basic sanity');
.sub main :main
\$I0 = 42
.end
PIR
dump_output_like( <<PIR, "pir", qr/HEADER\s*=>\s*\[.*wordsize.*byteorder.*floattype.*parrot-version.*bytecode-version.*UUID.*\]/ms, 'pbc_dump HEADER sanity');
.sub main :main
\$I0 = 42
.end
PIR
dump_output_like( <<PIR, "pir", qr/DIRECTORY\s*=>\s*\[.*offs.*op_count.*itype.*id.*size.*segments/ms, 'pbc_dump DIRECTORY sanity');
.sub main :main
\$I0 = 42
.end
PIR
dump_output_like( <<PIR, "pir", qr/BYTECODE_t.*=>.*\[.*offs.*op_count.*itype.*id.*size.*mappings/ms, 'pbc_dump BYTECODE sanity');
.sub main :main
\$I0 = 42
.end
PIR
for my $enc ( qw(binary iso-8859-1 utf8 utf16 ucs2 ucs4) ) {
dump_output_like( <<PIR, "pir", qr/ENCODING.*=>.*$enc/ms, "pbc_dump $enc encoding");
.sub main :main
\$S0 = $enc:"abc"
.end
PIR
}
my $longcode = ".sub main :main\n";
for (0 ... 10000) {
$longcode .= "\$I0 = \$I0 + 1234\n";
}
$longcode .= ".end";
dump_output_like( $longcode, "pir", qr/BYTECODE.*_DB.*=>/,
"large pir program doesn't mess up pbc_dump");
open my $INC1, '>', "inc_a.pir";
print $INC1 <<'EOF';
.sub does :vtable
.param string provides
.end
EOF
close $INC1;
open my $INC2, '>', "inc_b.pir";
print $INC2 <<'EOF';
.namespace [ 'TclConst' ]
.sub class_init :anon :load
$P0 = get_class 'String'
.end
EOF
close $INC2;
open my $INC3, '>', "inc_c.pir";
print $INC3 <<'EOF';
.namespace [ 'TclDict' ]
.sub class_init :anon :load :main
say "wut"
.end
EOF
close $INC3;
#test known-good hard-coded values. These values come from looking at
#pbc_dump's #output and sanity checking with the locations of the various subs.
dump_output_like( <<PIR, "pir", qr/BYTECODE.*_DB.*OFFSET => 0,.*OFFSET => 7.*OFFSET => 13/ms, 'debug segments contain accurate offsets');
.include 'inc_a.pir'
.include 'inc_b.pir'
.include 'inc_c.pir'
PIR
unlink('inc_a.pir');
unlink('inc_b.pir');
unlink('inc_c.pir');
my $annotated_pir = <<'PIR';
.sub 'main' :main
.annotate 'line', 1
.annotate 'hello', 'world'
.local int i
i = 123
.annotate 'hello', 'dragon'
.annotate 'line', 441
dec i
.annotate 'goodbye', 'cactus'
.end
PIR
dump_output_like($annotated_pir, "pir", qr/_ANN/s, 'dump output contains annotations segments');
dump_output_like($annotated_pir, "pir", qr/NAME => line.*NAME => hello.*NAME => goodbye/s, 'annotation names are present');
dump_output_like($annotated_pir, "pir", qr/dragon/s, 'annotation values are present');
## Test pbc_dump tool
# Test help
my $helpregex = <<OUTPUT;
/pbc_dump - dump or convert parrot bytecode/
OUTPUT
dump_raw_output_like( "--help", $helpregex, "pbc_dump help message --help");
# Run it without params should also trigger the help
dump_raw_output_like( "", $helpregex, "pbc_dump help message (not enough params)");
# Create sample files
my ($pir_i, $pir_file) = create_tempfile( SUFFIX => '.pir', UNLINK => 1 );
my (undef, $pbc_file) = create_tempfile( SUFFIX => '.pbc', UNLINK => 1 );
my (undef, $pbcpack_file) = create_tempfile( SUFFIX => '.pbc', UNLINK => 1 );
print $pir_i <<'EOF';
.sub main :main
.const 'String' s = "Hello World"
print s
.end
EOF
close $pir_i;
# Compile them
system($PARROT, '-o', $pbc_file, $pir_file);
# Test -n option
dump_raw_output_like("-n " . $pbc_file, qr/0003: returncc/s, "pbc_dump -n command");
# Test -t option
dump_raw_output_like("-t " . $pbc_file, qr/HEADER.*DIRECTORY.*BYTECODE.*CONSTANT/s, "pbc_dump -t command");
# Test -h option
dump_raw_output_like("-h " . $pbc_file, qr/HEADER/s, "pbc_dump -h command");
# Test -d option
dump_raw_output_like("-d " . $pbc_file, qr/HEADER.*DIRECTORY.*BYTECODE/s, "pbc_dump -d command");
# Test -o option
dump_raw_output_like("-o " . $pbcpack_file . " " . $pbc_file, qr//s, "pbc_dump -o command");
# Test if the generated pbc file really works
my $output = `$PARROT $pbc_file 2>&1`;
is($output, "Hello World", "pbc_dump -o created a file that works");
# Test PackFile_Constant_dump_pmc on packdump.c
($pir_i, $pir_file) = create_tempfile( SUFFIX => '.pir', UNLINK => 1 );
(undef, $pbc_file) = create_tempfile( SUFFIX => '.pbc', UNLINK => 1 );
print $pir_i <<'EOF';
.sub main :main
$P0 = new ['Hash']
$P0['key';0] = 2
$I0 = 1
$S0 = 'new_key'
$P0[$I0; $S0] = 'value'
print "Hallo Welt"
.end
EOF
close $pir_i;
system($PARROT, '-o', $pbc_file, $pir_file);
dump_raw_output_like("" . $pbc_file, qr/I REGISTER.*S REGISTER/s, "pbc_dump packdump.c");
=head1 HELPER SUBROUTINES
=head2 dump_output_like
dump_output_like(<<PASM, "pasm", "some output", "running $file");
Takes 3-4 arguments: a file to run,
the filename-extension of the file (probably "pir" or "pasm"),
an arrayref or single regex string to match within pbc_dump's output,
and the optional test diagnostic.
=cut
sub dump_output_like {
pbc_postprocess_output_like($path, @_ );
}
sub dump_raw_output_like {
my ($options, $snippet, $desc) = @_;
my $out = `$exefile $options 2>&1`;
like( $out, $snippet, $desc );
return;
}
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4: