Mercurial > hg > Gears > Gears
view src/parallel_execution/tools/trans_impl.pl @ 693:aeab4866ee36
defined separate_code_and_data_gear_after_parse test
author | anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp> |
---|---|
date | Fri, 21 Aug 2020 17:07:01 +0900 |
parents | 72b7863ea5b4 |
children | 284fa7d7326e |
line wrap: on
line source
#!/usr/bin/env perl use strict; use warnings; use FindBin; use lib "$FindBin::Bin/../lib"; use Gears::Interface; use Gears::Util; use Getopt::Std; use File::Spec; 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->separate_code_and_data_gear_after_parse(File::Spec->rel2abs($impl_file)); my $interface_file = find_using_interface_header($impl_ir->{isa},"$FindBin::Bin/.."); my $inter_ir = Gears::Interface->separate_code_and_data_gear_after_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 = () = $impl_file =~ /\//g; 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); emit_constracutor($stdout,$impl,$interface); 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"; map { print $out "// $_\n" } split /\n/, $line; print $out "// ----\n\n"; } sub emit_constracutor { my ($out, $impl, $interface) = @_; my $impl_ir = $impl->{ir}; my $inter_ir = $interface->{ir}; my $impl_var_name = $impl->{var_name}; my $interface_var_name = $interface->{var_name}; my @inter_data = @{$inter_ir->{data}}; my @impl_data = @{$impl_ir->{data}}; print $out <<"EOF"; $impl_ir->{isa}* create$impl_ir->{name}(struct Context* context) { struct $impl_ir->{isa}* $interface_var_name = new $impl_ir->{isa}(); struct $impl_ir->{name}* $impl_var_name = new $impl_ir->{name}(); $interface_var_name->$interface_var_name = (union Data*)$impl_var_name; EOF for my $datum (@impl_data) { $datum =~ s|//[\s\w]+||; if ($datum =~ /^\s+#/) { next; } if ($datum =~ /\w+\s\w+\*\s(\w+)/) { print $out " ${impl_var_name}->$1 = NULL;\n"; next; } if ($datum =~ /\w+\s\w+\s(\w+)/) { print $out " ${impl_var_name}->$1 = 0;\n"; } if ($datum =~ /\w+(\*)?\s(\w+)/) { my $is_pointer = $1; my $var_name = $2; if ($1) { print $out " ${impl_var_name}->$var_name = NULL;\n"; } else { print $out " ${impl_var_name}->$var_name = 0;\n"; } } } for my $code (@{$impl_ir->{codes}}) { my $code_gear = $code->{name}; next if $code_gear eq 'next'; print $out " ${impl_var_name}->$code_gear = C_$code_gear;\n" } for my $code (@{$inter_ir->{codes}}) { my $code_gear = $code->{name}; next if $code_gear eq 'next'; print $out " ${interface_var_name}->$code_gear = C_${code_gear}_$impl_ir->{name};\n" } print $out " return $interface_var_name;\n"; print $out "}\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 =~ /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}"; unless ($is_impl) { print $out "_$impl"; } 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); emit_constracutor($fh,$impl,$interface); map { print $fh $_ } @{$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) = @_; 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) { # @find_headers == (hoge.h, hoge.dg) @find_headers = grep { $_ =~ /\/$header_name\.dg/} @find_headers; #only dg } if (scalar(@find_headers) != 1) { croak '[WARN]multiple header files found'; } return shift @find_headers; }