-
Notifications
You must be signed in to change notification settings - Fork 138
/
pbc_merge.t
194 lines (161 loc) · 3.88 KB
/
pbc_merge.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
#! perl
# Copyright (C) 2005-2007, Parrot Foundation.
=head1 NAME
t/tools/pbc_merge.t - test the PBC merge tool
=head1 SYNOPSIS
% prove t/tools/pbc_merge.t
=head1 DESCRIPTION
Tests the C<pbc_merge> utility by providing it with a number of source
bytecode files, having it merge them and then checking the output is what
would be expected.
=cut
use strict;
use warnings;
use lib qw( . lib ../lib ../../lib );
use Test::More;
use Parrot::Test;
use Parrot::Config;
my $PARROT = ".$PConfig{slash}$PConfig{test_prog}";
my $PBC_MERGE = ".$PConfig{slash}pbc_merge$PConfig{exe}";
# Only test if we have the PBC merge tool built.
if ( -e $PBC_MERGE ) {
plan tests => 5;
}
else {
plan skip_all => "PBC Merge tool not built or test disabled";
}
sub pir_to_pbc {
my ( $name, $pir ) = @_;
open my $FILE, '>', "t$PConfig{slash}tools$PConfig{slash}$name.pir";
print $FILE $pir;
close $FILE;
system(
"$PARROT -o t$PConfig{slash}tools$PConfig{slash}$name.pbc t$PConfig{slash}tools$PConfig{slash}$name.pir"
);
}
sub pbc_merge {
my $outname = "t$PConfig{slash}tools$PConfig{slash}" . shift() . ".pbc";
my $inputs = join( ' ', map { "t$PConfig{slash}tools$PConfig{slash}$_.pbc" } @_ );
system("$PBC_MERGE -o $outname $inputs");
}
sub run_pbc {
return `$PARROT t$PConfig{slash}tools$PConfig{slash}$_[0].pbc`;
}
# First test - check sub relocation works.
{
pir_to_pbc( "pbc_merge_t1_1", <<'PIR' );
.sub _main :main
_testcall()
.end
PIR
pir_to_pbc( "pbc_merge_t1_2", <<'PIR' );
.sub _testcall
print 42
.end
PIR
pbc_merge( "pbc_merge_t1", "pbc_merge_t1_1", "pbc_merge_t1_2" );
is( run_pbc("pbc_merge_t1"), "42" );
}
# Second test - check constant table pointers in bytecode are fixed up.
{
pir_to_pbc( "pbc_merge_t2_1", <<'PIR' );
.sub _main :main
.local num years
.local string rockers
years = _get_years()
rockers = _band()
print rockers
print " have rocked for over "
print years
print " years!"
.end
PIR
pir_to_pbc( "pbc_merge_t2_2", <<'PIR' );
.sub _band
.local string s
s = "Rammstein"
.return(s)
.end
.sub _get_years
.local num n
n = 10.398571
.return(n)
.end
PIR
pbc_merge( "pbc_merge_t2", "pbc_merge_t2_1", "pbc_merge_t2_2" );
is( run_pbc("pbc_merge_t2"), "Rammstein have rocked for over 10.398571 years!" );
}
# Third test - sub calls back and forth between blocks.
{
pir_to_pbc( "pbc_merge_t3_1", <<'PIR' );
.sub main :main
.local string s
s = test1()
print s
.end
.sub test2
.local string s
s = "Stirb nicht vor mir"
.return(s)
.end
PIR
pir_to_pbc( "pbc_merge_t3_2", <<'PIR' );
.sub test1
.local string s
s = test2()
.return(s)
.end
PIR
pbc_merge( "pbc_merge_t3", "pbc_merge_t3_1", "pbc_merge_t3_2" );
is( run_pbc("pbc_merge_t3"), "Stirb nicht vor mir" );
}
# Fourth test - passing constant string arguments.
{
pir_to_pbc( "pbc_merge_t4_1", <<'PIR' );
.sub main :main
elephant()
.end
PIR
pir_to_pbc( "pbc_merge_t4_2", <<'PIR' );
.sub elephant
trunk_action("spray")
.end
.sub trunk_action
.param string s
print s
.end
PIR
pbc_merge( "pbc_merge_t4", "pbc_merge_t4_1", "pbc_merge_t4_2" );
is( run_pbc("pbc_merge_t4"), "spray" );
}
# Fifth test - passing constant-string-named arguments
{
pir_to_pbc( "pbc_merge_t5_1", <<'PIR' );
.sub main :main
t5_other_sub()
.end
.sub t5_say_arg
.param pmc args :named :slurpy
$S0 = args['t5_named_arg']
if null $S0 goto no_arg
print $S0
goto end
no_arg:
print "got no named arg"
end:
.end
PIR
pir_to_pbc( "pbc_merge_t5_2", <<'PIR' );
.sub t5_other_sub
t5_say_arg('success' :named("t5_named_arg"))
.end
PIR
pbc_merge( "pbc_merge_t5", "pbc_merge_t5_1", "pbc_merge_t5_2" );
is( run_pbc( "pbc_merge_t5" ), "success");
}
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4: