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;
-}
-