package TestIntermediate;
use strict;
use warnings;
use TestParser qw(parse_string);
use Language::P::Intermediate::Generator;
use Language::P::Intermediate::Transform;
use Language::P::Opcodes;
use Exporter 'import';
our @EXPORT_OK = qw(generate_main basic_blocks blocks_as_string
generate_and_diff generate_tree_and_diff
generate_ssa_and_diff);
our %EXPORT_TAGS =
( all => \@EXPORT_OK,
);
sub generate_main {
my( $code ) = @_;
my $parsetree = parse_string( $code );
my $gen = Language::P::Intermediate::Generator->new;
my $segments = $gen->generate_bytecode( $parsetree );
return $segments;
}
sub generate_main_tree {
my( $code ) = @_;
my $parsetree = parse_string( $code );
my $gen = Language::P::Intermediate::Generator->new;
my $segments = $gen->generate_bytecode( $parsetree );
my $trans = Language::P::Intermediate::Transform->new;
my $trees = $trans->all_to_tree( $segments );
return $trees;
}
sub generate_main_ssa {
my( $code ) = @_;
my $parsetree = parse_string( $code );
my $gen = Language::P::Intermediate::Generator->new;
my $segments = $gen->generate_bytecode( $parsetree );
my $trans = Language::P::Intermediate::Transform->new;
my $trees = $trans->all_to_ssa( $segments );
return $trees;
}
my $op_map = \%Language::P::Opcodes::NUMBER_TO_NAME;
my $op_attr = \%Language::P::Opcodes::OP_ATTRIBUTES;
sub blocks_as_string {
my( $segments ) = @_;
my $str = '';
foreach my $segment ( @$segments ) {
my $name = $segment->is_main ? 'main' :
$segment->name || 'anoncode';
$str .= "# " . $name . "\n";
foreach my $block ( sort { $a->start_label cmp $b->start_label}
@{$segment->basic_blocks} ) {
foreach my $instr ( @{$block->bytecode} ) {
$str .= $instr->as_string( $op_map, $op_attr )
}
}
}
return $str;
}
sub generate_and_diff {
my( $code, $assembly ) = @_;
my $blocks = generate_main( $code );
my $asm_string = blocks_as_string( $blocks );
require Test::Differences;
local $Test::Builder::Level = $Test::Builder::Level + 1;
Test::Differences::eq_or_diff( $asm_string, $assembly );
}
sub generate_tree_and_diff {
my( $code, $assembly ) = @_;
my $blocks = generate_main_tree( $code );
my $asm_string = blocks_as_string( $blocks );
require Test::Differences;
local $Test::Builder::Level = $Test::Builder::Level + 1;
Test::Differences::eq_or_diff( $asm_string, $assembly );
}
sub generate_ssa_and_diff {
my( $code, $assembly ) = @_;
my $blocks = generate_main_ssa( $code );
my $asm_string = blocks_as_string( $blocks );
require Test::Differences;
local $Test::Builder::Level = $Test::Builder::Level + 1;
Test::Differences::eq_or_diff( $asm_string, $assembly );
}
1;