Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: nqp-p6
Fetching contributors…

Cannot retrieve contributors at this time

195 lines (161 sloc) 3.973 kb
#! 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:
Jump to Line
Something went wrong with that request. Please try again.