Mercurial > hg > CbC > CbC_xv6
annotate src/gearsTools/trans_impl.pl @ 105:f1be2d5abc8a
fix camel2snake
| author | anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp> |
|---|---|
| date | Thu, 21 Nov 2019 14:45:01 +0900 |
| parents | 9bfc4fbb5502 |
| children | 4f9d95dc4efd |
| rev | line source |
|---|---|
| 102 | 1 #!/usr/bin/env perl |
| 2 use strict; | |
| 3 use warnings; | |
| 4 | |
| 5 use FindBin; | |
| 6 use lib "$FindBin::Bin/lib"; | |
| 7 use Gears::Util; | |
| 8 | |
| 9 use Getopt::Std; | |
| 10 | |
| 11 my %opt; | |
| 12 getopts("w" => \%opt); | |
| 13 | |
| 14 my $impl_file = shift or die 'require impl file'; | |
| 15 my $impl_ir = Gears::Util->parse_code_verbose($impl_file); | |
|
104
9bfc4fbb5502
create PipeRead.cbc
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
103
diff
changeset
|
16 my $interface_file = Gears::Util->find_header($impl_ir->{isa},"$FindBin::Bin/../"); |
| 102 | 17 |
| 18 my $inter_ir = Gears::Util->parse_code_verbose($interface_file); | |
| 19 | |
| 20 | |
| 21 my $output_file = $impl_file; | |
| 22 $output_file =~ s/\.h/.cbc/; | |
| 23 open my $fh, '>', $output_file; | |
| 24 my $stdout = $fh; | |
| 25 | |
| 26 unless ($opt{w}) { | |
| 27 $stdout = *STDOUT; | |
| 28 } | |
| 29 | |
| 30 emit_include_part($stdout, $inter_ir->{name}); | |
| 31 emit_impl_header_in_comment($stdout, $impl_file); | |
| 32 emit_constracutor($stdout,$impl_ir,$inter_ir); | |
| 33 emit_code_gears($stdout,$impl_ir,$inter_ir); | |
| 34 close $fh; | |
| 35 | |
| 36 sub emit_include_part { | |
| 37 my ($out, $interface) = @_; | |
| 38 print $out <<"EOF" | |
| 39 #include "../context.h"; | |
| 40 #interface "$interface.h"; | |
| 41 | |
| 42 EOF | |
| 43 } | |
| 44 | |
| 45 sub emit_impl_header_in_comment { | |
| 46 my ($out, $impl_file) = @_; | |
| 47 my $line = Gears::Util->slup($impl_file); | |
| 48 print $out "// ----\n"; | |
| 49 map { print $out "// $_\n" } split /\n/, $line; | |
| 50 print $out "// ----\n\n"; | |
| 51 } | |
| 52 | |
| 53 sub emit_constracutor { | |
| 54 my ($out, $impl_ir, $inter_ir) = @_; | |
| 55 | |
| 56 my @inter_data = @{$inter_ir->{data}}; | |
| 57 my $instance_inter = shift @inter_data; | |
| 58 if ($instance_inter =~ /union\s*Data\*\s*(\w+)/) { | |
| 59 $instance_inter = $1; | |
| 60 } | |
| 61 my $instance_impl = lcfirst $impl_ir->{name}; | |
| 105 | 62 $instance_impl =~ s/([A-Z])/_\l$1/g; |
| 102 | 63 |
| 64 print $out <<"EOF"; | |
| 65 $impl_ir->{isa}* create$impl_ir->{name}(struct Context* cbc_context) { | |
| 66 struct $impl_ir->{isa}* $instance_inter = new $impl_ir->{isa}(); | |
| 67 struct $impl_ir->{name}* $instance_impl = new $impl_ir->{name}(); | |
| 68 $instance_inter->$instance_inter = (union Data*)$instance_impl; | |
| 69 EOF | |
| 70 | |
| 71 for my $datum (@inter_data) { | |
| 72 if ($datum =~ /\w+ \w+\* (\w+)/) { | |
| 73 print $out " ${instance_impl}->$1 = NULL;\n"; | |
| 74 next; | |
| 75 } | |
| 76 if ($datum =~ /\w+ \w+ (\w+)/) { | |
| 77 print $out " ${instance_impl}->$1 = 0;\n"; | |
| 78 } | |
| 79 } | |
| 80 | |
| 81 for my $code (@{$inter_ir->{codes}}) { | |
| 82 my $code_gear = $code->[0]; | |
| 83 print $out " ${instance_inter}->$code_gear = C_$code_gear$impl_ir->{name};\n" | |
| 84 } | |
| 85 | |
| 86 print $out " return $instance_inter;\n"; | |
| 87 print $out "}\n"; | |
| 88 } | |
| 89 | |
| 90 | |
| 91 sub emit_code_gears { | |
| 92 my ($out, $impl_ir, $inter_ir) = @_; | |
| 93 my $impl = $impl_ir->{name}; | |
| 94 | |
| 95 my @inter_data = @{$inter_ir->{data}}; | |
| 96 my $instance_inter = shift @inter_data; | |
| 97 if ($instance_inter =~ /union\s*Data\*\s*(\w+)/) { | |
| 98 $instance_inter = $1; | |
| 99 } | |
| 100 my $instance_impl = lcfirst $impl_ir->{name}; | |
| 105 | 101 $instance_impl =~ s/([A-Z])/_\l$1/g; |
| 102 | 102 my $data_gear_types = {}; |
| 103 | |
| 104 for my $code_ir (@{$inter_ir->{codes}}) { | |
| 105 my $data_gears = $code_ir->[1]; | |
| 106 $data_gears =~ s/Impl/$impl/g; | |
| 103 | 107 while ($data_gears =~ /Type\*\s*(\w+),/g) { |
| 102 | 108 my $target = $1; |
| 109 if (exists $data_gear_types->{$target}){ | |
| 110 $data_gears =~ s/Type\*/$data_gear_types->{$target}/; | |
| 111 } else { | |
| 112 my $td = ""; | |
| 113 map { $td = $_ if ($_ =~ /$target/) } @inter_data; | |
| 114 if ($td =~ /(\w+)\s*([\w\*]+)\s*(\w+)/) { | |
| 115 my $tmp = "$1 $2"; | |
| 116 $data_gears =~ s/Type\*/$tmp/; | |
| 117 $data_gear_types->{$target} = $tmp; | |
| 118 } | |
| 119 } | |
| 120 } | |
| 121 | |
| 122 print $out "__code $code_ir->[0]$impl("; | |
| 123 print $out "$data_gears) {\n\n"; | |
| 124 | |
| 125 #__code next(...), __code whenEmpty(...) | |
| 126 my @cg = (); | |
| 127 while ($data_gears =~ /__code ([\w(\.)\*\s,]+?\)),?/g) { | |
| 128 push(@cg, $1); | |
| 129 } | |
| 130 | |
| 131 if (@cg) { | |
| 132 if (@cg == 2) { | |
| 133 print $out " if (:TODO:) {\n"; | |
| 134 print $out " goto ",shift(@cg),";\n"; | |
| 135 print $out " }\n"; | |
| 136 print $out " goto ",shift(@cg),";\n"; | |
| 137 } else { | |
| 138 print $out " goto ",shift(@cg),";\n"; | |
| 139 } | |
| 140 } | |
| 141 print $out "}\n\n"; | |
| 142 } | |
| 143 } |