Mercurial > hg > Gears > Gears
changeset 929:2c1f2acadf40
rename
author | anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp> |
---|---|
date | Sun, 31 Jan 2021 15:05:58 +0900 |
parents | 917fb0cc6d6b |
children | b4b4bd0767c2 |
files | src/parallel_execution/tools/impl2cbc.pl src/parallel_execution/tools/trans_impl.pl |
diffstat | 2 files changed, 231 insertions(+), 231 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/parallel_execution/tools/impl2cbc.pl Sun Jan 31 15:05:58 2021 +0900 @@ -0,0 +1,231 @@ +#!/usr/bin/env perl +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Gears::Interface; +use Gears::Stub; +use Gears::Util; + +use Getopt::Std; +use File::Spec; +use File::Basename; +use Carp qw/croak/; + +my %opt; +getopts("wo:" => \%opt); + +my $impl_file = shift or die 'require impl file'; +if ($impl_file !~ /\.h$/) { + die "require header file"; +} + +my $impl_ir = Gears::Interface->detailed_parse(File::Spec->rel2abs($impl_file)); +my $interface_file = find_using_interface_header($impl_ir->{isa},"$FindBin::Bin/..", $impl_file); + +my $inter_ir = Gears::Interface->detailed_parse($interface_file); + +my $interface_var_name = shift @{$inter_ir->{data}}; + +if ($interface_var_name =~ /union\s*Data\*\s*(\w+)/) { + $interface_var_name = $1; +} + +my $impl_var_name = decamelize($impl_ir->{name}); + +my $interface = {ir => $inter_ir, var_name => $interface_var_name}; +my $impl = {ir => $impl_ir, var_name => $impl_var_name}; + +my $output_file = $impl_file; +$output_file =~ s/\.h/.cbc/; + +my $stdout = *STDOUT; + +my $context_deeps = get_word_count_in_str($impl_file, "/"); + +if ($opt{w}) { + if(-f $output_file) { + update_file($output_file, $interface, $impl, $impl_file, $context_deeps); + exit 0; + } + + open $stdout, '>', $output_file; + +} elsif ($opt{o}) { + if(-f $opt{o}) { + update_file($opt{o}, $interface, $impl, $impl_file, $context_deeps); + exit 0; + } + + open $stdout, '>', $opt{o}; +} + +emit_include_part($stdout, $inter_ir->{name}, $context_deeps); +emit_impl_header_in_comment($stdout, $impl_file); + +print $stdout Gears::Stub->generate_constructor($interface->{ir},$impl->{ir}, 0); + +emit_code_gears($stdout,$impl,$interface); + +close $stdout; + +sub emit_include_part { + my ($out, $interface, $context_deeps) = @_; + my $comma = ""; + for (0..$context_deeps) { + $comma .= "../"; + } + print $out <<"EOF" +#include "${comma}context.h" +#interface "$interface.h" + +EOF +} + +sub emit_impl_header_in_comment { + my ($out, $impl_file) = @_; + my $line = Gears::Util->slup($impl_file); + print $out "// ----\n"; + for my $c (split /\n/, $line) { + print $out "// $c\n"; + } + print $out "// ----\n\n"; +} + + +sub emit_code_gears { + my ($out, $impl, $interface) = @_; + + my $inter_ir = $interface->{ir}; + my $impl_ir = $impl->{ir}; + + my $impl_name = $impl_ir->{name}; + my $interface_name = $inter_ir->{name}; + + my $impl_var_name = $impl->{var_name}; + my $interface_var_name = $interface->{var_name}; + + my @inter_data = @{$inter_ir->{data}}; + + my $data_gear_types = {}; + + if (defined $impl_ir->{codes}) { + replace_code_gears($impl_ir,$impl_name,$interface_name,1,$out); + } + replace_code_gears($inter_ir,$impl_name,$interface_name,0,$out); +} + +sub replace_code_gears { + my ($ir, $impl, $interface_name, $is_impl, $out) = @_; + + my $replace_impl = $is_impl ? $impl : $interface_name; + + for my $cg (@{$ir->{codes}}) { + next if ($cg->{name} eq 'next'); + my $data_gears = $cg->{args}; + while ($data_gears =~ /Self\*\s*(\w+),/g) { + $data_gears =~ s/Self\*/struct $replace_impl*/; + } + while ($data_gears =~ /Type\*\s*(\w+),/g) { + $data_gears =~ s/Type\*/struct $replace_impl*/; + } + + if ($is_impl) { + while ($data_gears =~ /Isa\*\s*(\w+),/g) { + $data_gears =~ s/Isa\*/struct $interface_name*/; + } + } else { + $data_gears =~ s/Impl/struct $impl/g; + } + print $out "__code $cg->{name}"; + print $out "("; + print $out "$data_gears) {\n\n"; + _emit_cg($out,$data_gears); + } +} + + +sub _emit_cg { + my ($out, $data_gears) = @_; + my @cg = (); + while ($data_gears =~ /__code ([\w(\.)\*\s,]+?\)),?/g) { + push(@cg, $1); + } + if (@cg) { + if (@cg == 2) { + print $out " if (:TODO:) {\n"; + print $out " goto ",shift(@cg),";\n"; + print $out " }\n"; + print $out " goto ",shift(@cg),";\n"; + } else { + print $out " goto ",shift(@cg),";\n"; + } + } + print $out "}\n\n"; +} + +sub update_file { + my ($output_file, $interface, $impl, $impl_file,$context_deeps) = @_; + my $under_code = collection_save_code_gears($output_file,$interface->{var_name}); + open my $fh, '>', $output_file; + emit_include_part($fh, $interface->{ir}->{name},$context_deeps); + emit_impl_header_in_comment($fh, $impl_file); + print $fh Gears::Stub->generate_constructor($impl->{ir},$interface->{ir}, 0); + print $fh $_ for @{$under_code}; + close $fh; +} + +sub collection_save_code_gears { + my ($output_file,$interface_name) = @_; + open my $fh, '<', $output_file; + while (my $line = <$fh>) { + if ($line =~ /\s*return $interface_name;\s*/) { + $line = <$fh>; # } skip... + last; + } + } + + my @res; + push(@res, <$fh>); + return \@res; +} + +#https://metacpan.org/pod/String::CamelCase +sub decamelize { + my $s = shift; + $s =~ s{([^a-zA-Z]?)([A-Z]*)([A-Z])([a-z]?)}{ + my $fc = pos($s)==0; + my ($p0,$p1,$p2,$p3) = ($1,lc$2,lc$3,$4); + my $t = $p0 || $fc ? $p0 : '_'; + $t .= $p3 ? $p1 ? "${p1}_$p2$p3" : "$p2$p3" : "$p1$p2"; + $t; + }ge; + $s; +} + +sub find_using_interface_header { + my ($header_name, $find_path, $impl_file) = @_; + + my $header_list = Gears::Util->find_headers_from_path($find_path); + + my @find_headers = grep { /\/$header_name\.(h|dg)$/} @{$header_list}; + + if ((scalar(@find_headers) > 1) && (grep { /\.dg/} @find_headers) ) { # @find_headers == (hoge.h, hoge.dg) + @find_headers = grep { $_ =~ /\/$header_name\.dg/} @find_headers; #only dg + } + + if (scalar(@find_headers) != 1) { + my $basedir = dirname($impl_file); + @find_headers = grep {/$basedir/} @find_headers; + } + + return shift @find_headers; +} + +sub get_word_count_in_str { + my ($str, $pattern) = @_; + my $count = () = $str =~ m/$pattern/g; + return $count; +} +
--- a/src/parallel_execution/tools/trans_impl.pl Sun Jan 31 08:45:12 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,231 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; -use Gears::Interface; -use Gears::Stub; -use Gears::Util; - -use Getopt::Std; -use File::Spec; -use File::Basename; -use Carp qw/croak/; - -my %opt; -getopts("wo:" => \%opt); - -my $impl_file = shift or die 'require impl file'; -if ($impl_file !~ /\.h$/) { - die "require header file"; -} - -my $impl_ir = Gears::Interface->detailed_parse(File::Spec->rel2abs($impl_file)); -my $interface_file = find_using_interface_header($impl_ir->{isa},"$FindBin::Bin/..", $impl_file); - -my $inter_ir = Gears::Interface->detailed_parse($interface_file); - -my $interface_var_name = shift @{$inter_ir->{data}}; - -if ($interface_var_name =~ /union\s*Data\*\s*(\w+)/) { - $interface_var_name = $1; -} - -my $impl_var_name = decamelize($impl_ir->{name}); - -my $interface = {ir => $inter_ir, var_name => $interface_var_name}; -my $impl = {ir => $impl_ir, var_name => $impl_var_name}; - -my $output_file = $impl_file; -$output_file =~ s/\.h/.cbc/; - -my $stdout = *STDOUT; - -my $context_deeps = get_word_count_in_str($impl_file, "/"); - -if ($opt{w}) { - if(-f $output_file) { - update_file($output_file, $interface, $impl, $impl_file, $context_deeps); - exit 0; - } - - open $stdout, '>', $output_file; - -} elsif ($opt{o}) { - if(-f $opt{o}) { - update_file($opt{o}, $interface, $impl, $impl_file, $context_deeps); - exit 0; - } - - open $stdout, '>', $opt{o}; -} - -emit_include_part($stdout, $inter_ir->{name}, $context_deeps); -emit_impl_header_in_comment($stdout, $impl_file); - -print $stdout Gears::Stub->generate_constructor($interface->{ir},$impl->{ir}, 0); - -emit_code_gears($stdout,$impl,$interface); - -close $stdout; - -sub emit_include_part { - my ($out, $interface, $context_deeps) = @_; - my $comma = ""; - for (0..$context_deeps) { - $comma .= "../"; - } - print $out <<"EOF" -#include "${comma}context.h" -#interface "$interface.h" - -EOF -} - -sub emit_impl_header_in_comment { - my ($out, $impl_file) = @_; - my $line = Gears::Util->slup($impl_file); - print $out "// ----\n"; - for my $c (split /\n/, $line) { - print $out "// $c\n"; - } - print $out "// ----\n\n"; -} - - -sub emit_code_gears { - my ($out, $impl, $interface) = @_; - - my $inter_ir = $interface->{ir}; - my $impl_ir = $impl->{ir}; - - my $impl_name = $impl_ir->{name}; - my $interface_name = $inter_ir->{name}; - - my $impl_var_name = $impl->{var_name}; - my $interface_var_name = $interface->{var_name}; - - my @inter_data = @{$inter_ir->{data}}; - - my $data_gear_types = {}; - - if (defined $impl_ir->{codes}) { - replace_code_gears($impl_ir,$impl_name,$interface_name,1,$out); - } - replace_code_gears($inter_ir,$impl_name,$interface_name,0,$out); -} - -sub replace_code_gears { - my ($ir, $impl, $interface_name, $is_impl, $out) = @_; - - my $replace_impl = $is_impl ? $impl : $interface_name; - - for my $cg (@{$ir->{codes}}) { - next if ($cg->{name} eq 'next'); - my $data_gears = $cg->{args}; - while ($data_gears =~ /Self\*\s*(\w+),/g) { - $data_gears =~ s/Self\*/struct $replace_impl*/; - } - while ($data_gears =~ /Type\*\s*(\w+),/g) { - $data_gears =~ s/Type\*/struct $replace_impl*/; - } - - if ($is_impl) { - while ($data_gears =~ /Isa\*\s*(\w+),/g) { - $data_gears =~ s/Isa\*/struct $interface_name*/; - } - } else { - $data_gears =~ s/Impl/struct $impl/g; - } - print $out "__code $cg->{name}"; - print $out "("; - print $out "$data_gears) {\n\n"; - _emit_cg($out,$data_gears); - } -} - - -sub _emit_cg { - my ($out, $data_gears) = @_; - my @cg = (); - while ($data_gears =~ /__code ([\w(\.)\*\s,]+?\)),?/g) { - push(@cg, $1); - } - if (@cg) { - if (@cg == 2) { - print $out " if (:TODO:) {\n"; - print $out " goto ",shift(@cg),";\n"; - print $out " }\n"; - print $out " goto ",shift(@cg),";\n"; - } else { - print $out " goto ",shift(@cg),";\n"; - } - } - print $out "}\n\n"; -} - -sub update_file { - my ($output_file, $interface, $impl, $impl_file,$context_deeps) = @_; - my $under_code = collection_save_code_gears($output_file,$interface->{var_name}); - open my $fh, '>', $output_file; - emit_include_part($fh, $interface->{ir}->{name},$context_deeps); - emit_impl_header_in_comment($fh, $impl_file); - print $fh Gears::Stub->generate_constructor($impl->{ir},$interface->{ir}, 0); - print $fh $_ for @{$under_code}; - close $fh; -} - -sub collection_save_code_gears { - my ($output_file,$interface_name) = @_; - open my $fh, '<', $output_file; - while (my $line = <$fh>) { - if ($line =~ /\s*return $interface_name;\s*/) { - $line = <$fh>; # } skip... - last; - } - } - - my @res; - push(@res, <$fh>); - return \@res; -} - -#https://metacpan.org/pod/String::CamelCase -sub decamelize { - my $s = shift; - $s =~ s{([^a-zA-Z]?)([A-Z]*)([A-Z])([a-z]?)}{ - my $fc = pos($s)==0; - my ($p0,$p1,$p2,$p3) = ($1,lc$2,lc$3,$4); - my $t = $p0 || $fc ? $p0 : '_'; - $t .= $p3 ? $p1 ? "${p1}_$p2$p3" : "$p2$p3" : "$p1$p2"; - $t; - }ge; - $s; -} - -sub find_using_interface_header { - my ($header_name, $find_path, $impl_file) = @_; - - my $header_list = Gears::Util->find_headers_from_path($find_path); - - my @find_headers = grep { /\/$header_name\.(h|dg)$/} @{$header_list}; - - if ((scalar(@find_headers) > 1) && (grep { /\.dg/} @find_headers) ) { # @find_headers == (hoge.h, hoge.dg) - @find_headers = grep { $_ =~ /\/$header_name\.dg/} @find_headers; #only dg - } - - if (scalar(@find_headers) != 1) { - my $basedir = dirname($impl_file); - @find_headers = grep {/$basedir/} @find_headers; - } - - return shift @find_headers; -} - -sub get_word_count_in_str { - my ($str, $pattern) = @_; - my $count = () = $str =~ m/$pattern/g; - return $count; -} -