--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/trans_impl.pl	Fri Mar 06 14:59:59 2020 +0900
@@ -0,0 +1,244 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+use Gears::Util;
+
+use Getopt::Std;
+use File::Spec;
+
+my %opt;
+getopts("wo:" => \%opt);
+
+my $impl_file = shift or die 'require impl file';
+my $impl_ir         = Gears::Util->parse_with_separate_code_data_gears(File::Spec->rel2abs($impl_file));
+my $interface_file  = Gears::Util->find_using_interface_header($impl_ir->{isa},"$FindBin::Bin/..");
+
+my $inter_ir        = Gears::Util->parse_with_separate_code_data_gears($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;
+
+if ($opt{w}) {
+    if(-f $output_file) {
+      update_file($output_file, $interface, $impl, $impl_file);
+      exit 0;
+    }
+    open $stdout, '>', $output_file;
+} elsif ($opt{o}) {
+    if(-f $opt{o}) {
+      update_file($opt{o}, $interface, $impl, $impl_file);
+      exit 0;
+    }
+    open $stdout, '>', $opt{o};
+}
+
+emit_include_part($stdout, $inter_ir->{name});
+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) = @_;
+  print $out <<"EOF"
+#include "../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* cbc_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) = @_;
+    my $under_code = collection_save_code_gears($output_file,$interface->{var_name});
+    open my $fh, '>', $output_file;
+    emit_include_part($fh, $interface->{ir}->{name});
+    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;
+}