Mercurial > hg > CbC > CbC_xv6
annotate src/gearsTools/trans_impl.pl @ 161:06bf68d3b83b
tweak
| author | anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp> |
|---|---|
| date | Tue, 14 Jan 2020 20:54:21 +0900 |
| parents | eef045e9772a |
| children | d116d737fed0 |
| 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 | |
| 124 | 9 use Getopt::Std; |
| 122 | 10 use File::Spec; |
| 102 | 11 |
| 12 my %opt; | |
|
127
46d792f92156
impl output option at trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
125
diff
changeset
|
13 getopts("wo:" => \%opt); |
| 102 | 14 |
| 15 my $impl_file = shift or die 'require impl file'; | |
| 122 | 16 my $impl_ir = Gears::Util->parse_with_rewrite(File::Spec->rel2abs($impl_file)); |
| 112 | 17 my $interface_file = Gears::Util->find_header($impl_ir->{isa},"$FindBin::Bin/.."); |
| 102 | 18 |
| 112 | 19 my $inter_ir = Gears::Util->parse_with_rewrite($interface_file); |
| 102 | 20 |
| 21 | |
| 22 my $output_file = $impl_file; | |
| 23 $output_file =~ s/\.h/.cbc/; | |
| 123 | 24 my $stdout = *STDOUT; |
| 102 | 25 |
| 123 | 26 if ($opt{w}) { |
| 27 open $stdout, '>', $output_file; | |
|
127
46d792f92156
impl output option at trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
125
diff
changeset
|
28 } elsif ($opt{o}) { |
|
46d792f92156
impl output option at trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
125
diff
changeset
|
29 open $stdout, '>', $opt{o}; |
| 102 | 30 } |
| 31 | |
|
127
46d792f92156
impl output option at trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
125
diff
changeset
|
32 |
| 102 | 33 emit_include_part($stdout, $inter_ir->{name}); |
| 34 emit_impl_header_in_comment($stdout, $impl_file); | |
| 35 emit_constracutor($stdout,$impl_ir,$inter_ir); | |
| 36 emit_code_gears($stdout,$impl_ir,$inter_ir); | |
| 123 | 37 close $stdout; |
| 102 | 38 |
| 39 sub emit_include_part { | |
| 40 my ($out, $interface) = @_; | |
| 41 print $out <<"EOF" | |
| 132 | 42 #include "../context.h" |
| 43 #interface "$interface.h" | |
| 102 | 44 |
| 45 EOF | |
| 46 } | |
| 47 | |
| 48 sub emit_impl_header_in_comment { | |
| 49 my ($out, $impl_file) = @_; | |
| 50 my $line = Gears::Util->slup($impl_file); | |
| 51 print $out "// ----\n"; | |
| 52 map { print $out "// $_\n" } split /\n/, $line; | |
| 53 print $out "// ----\n\n"; | |
| 54 } | |
| 55 | |
| 56 sub emit_constracutor { | |
| 57 my ($out, $impl_ir, $inter_ir) = @_; | |
| 58 | |
| 112 | 59 my @inter_data = @{$inter_ir->{data}}; |
| 60 my @impl_data = @{$impl_ir->{data}}; | |
| 102 | 61 my $instance_inter = shift @inter_data; |
| 112 | 62 |
| 102 | 63 if ($instance_inter =~ /union\s*Data\*\s*(\w+)/) { |
| 64 $instance_inter = $1; | |
| 65 } | |
| 112 | 66 |
| 67 my $instance_impl = lcfirst $impl_ir->{name}; | |
| 68 $instance_impl =~ s/([A-Z])/_\l$1/g; | |
| 102 | 69 |
| 70 print $out <<"EOF"; | |
| 71 $impl_ir->{isa}* create$impl_ir->{name}(struct Context* cbc_context) { | |
| 72 struct $impl_ir->{isa}* $instance_inter = new $impl_ir->{isa}(); | |
| 73 struct $impl_ir->{name}* $instance_impl = new $impl_ir->{name}(); | |
| 74 $instance_inter->$instance_inter = (union Data*)$instance_impl; | |
| 75 EOF | |
| 76 | |
|
109
4f9d95dc4efd
fix createInstance
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
105
diff
changeset
|
77 for my $datum (@impl_data) { |
| 161 | 78 if ($datum =~ /\w+\s\w+\*\s(\w+)/) { |
| 102 | 79 print $out " ${instance_impl}->$1 = NULL;\n"; |
| 80 next; | |
| 81 } | |
| 161 | 82 if ($datum =~ /\w+\s\w+\s(\w+)/) { |
| 102 | 83 print $out " ${instance_impl}->$1 = 0;\n"; |
| 84 } | |
| 128 | 85 |
| 161 | 86 if ($datum =~ /\w+(\*)?\s(\w+)/) { |
| 128 | 87 my $is_pointer = $1; |
| 88 my $var_name = $2; | |
| 89 if ($1) { | |
| 90 print $out " ${instance_impl}->$var_name = NULL;\n"; | |
| 91 } else { | |
| 92 print $out " ${instance_impl}->$var_name = 0;\n"; | |
| 93 } | |
| 94 } | |
| 102 | 95 } |
| 96 | |
|
109
4f9d95dc4efd
fix createInstance
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
105
diff
changeset
|
97 for my $datum (@inter_data) { |
| 161 | 98 if ($datum =~ /\w+\s\w+\*\s(\w+)/) { |
|
109
4f9d95dc4efd
fix createInstance
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
105
diff
changeset
|
99 print $out " ${instance_inter}->$1 = NULL;\n"; |
|
4f9d95dc4efd
fix createInstance
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
105
diff
changeset
|
100 next; |
|
4f9d95dc4efd
fix createInstance
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
105
diff
changeset
|
101 } |
| 161 | 102 if ($datum =~ /\w+\s\w+\s(\w+)/) { |
|
109
4f9d95dc4efd
fix createInstance
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
105
diff
changeset
|
103 print $out " ${instance_inter}->$1 = 0;\n"; |
| 128 | 104 next; |
| 105 } | |
| 161 | 106 if ($datum =~ /\w+(\*)?\s(\w+)/) { |
| 128 | 107 my $is_pointer = $1; |
| 108 my $var_name = $2; | |
| 109 if ($1) { | |
| 130 | 110 print $out " ${instance_inter}->$var_name = NULL;\n"; |
| 128 | 111 } else { |
| 130 | 112 print $out " ${instance_inter}->$var_name = 0;\n"; |
| 128 | 113 } |
|
109
4f9d95dc4efd
fix createInstance
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
105
diff
changeset
|
114 } |
|
4f9d95dc4efd
fix createInstance
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
105
diff
changeset
|
115 } |
|
4f9d95dc4efd
fix createInstance
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
105
diff
changeset
|
116 |
| 144 | 117 |
| 118 for my $code (@{$impl_ir->{codes}}) { | |
| 119 my $code_gear = $code->{name}; | |
| 120 print $out " ${instance_impl}->$code_gear = C_$code_gear$impl_ir->{name};\n" | |
| 121 } | |
| 122 | |
| 102 | 123 for my $code (@{$inter_ir->{codes}}) { |
| 112 | 124 my $code_gear = $code->{name}; |
| 102 | 125 print $out " ${instance_inter}->$code_gear = C_$code_gear$impl_ir->{name};\n" |
| 126 } | |
| 127 | |
| 128 print $out " return $instance_inter;\n"; | |
| 129 print $out "}\n"; | |
| 130 } | |
| 131 | |
| 132 | |
| 133 sub emit_code_gears { | |
| 134 my ($out, $impl_ir, $inter_ir) = @_; | |
| 135 my $impl = $impl_ir->{name}; | |
| 124 | 136 my $interface_name = $inter_ir->{name}; |
| 102 | 137 |
| 138 my @inter_data = @{$inter_ir->{data}}; | |
| 139 my $instance_inter = shift @inter_data; | |
| 140 if ($instance_inter =~ /union\s*Data\*\s*(\w+)/) { | |
| 141 $instance_inter = $1; | |
| 142 } | |
| 143 my $instance_impl = lcfirst $impl_ir->{name}; | |
| 105 | 144 $instance_impl =~ s/([A-Z])/_\l$1/g; |
| 102 | 145 my $data_gear_types = {}; |
| 146 | |
| 124 | 147 if (defined $impl_ir->{codes}) { |
| 148 for my $cg (@{$impl_ir->{codes}}) { | |
| 149 my $data_gears = $cg->{args}; | |
| 150 while ($data_gears =~ /Type\*\s*(\w+),/g) { | |
| 151 $data_gears =~ s/Type\*/struct $impl*/; | |
| 152 } | |
| 153 | |
| 154 while ($data_gears =~ /Isa\*\s*(\w+),/g) { | |
| 155 $data_gears =~ s/Isa\*/struct $interface_name*/; | |
| 156 } | |
| 157 print $out "__code $cg->{name}$impl("; | |
| 158 print $out "$data_gears) {\n\n"; | |
| 159 | |
| 160 #__code next(...), __code whenEmpty(...) | |
| 161 my @cg = (); | |
| 162 while ($data_gears =~ /__code ([\w(\.)\*\s,]+?\)),?/g) { | |
| 163 push(@cg, $1); | |
| 164 } | |
| 165 | |
| 166 if (@cg) { | |
| 167 if (@cg == 2) { | |
| 168 print $out " if (:TODO:) {\n"; | |
| 169 print $out " goto ",shift(@cg),";\n"; | |
| 170 print $out " }\n"; | |
| 171 print $out " goto ",shift(@cg),";\n"; | |
| 172 } else { | |
| 173 print $out " goto ",shift(@cg),";\n"; | |
| 174 } | |
| 175 } | |
| 176 print $out "}\n\n"; | |
| 177 } | |
| 178 } | |
| 179 | |
| 102 | 180 for my $code_ir (@{$inter_ir->{codes}}) { |
| 112 | 181 my $data_gears = $code_ir->{args}; |
| 182 $data_gears =~ s/Impl/struct $impl/g; | |
| 124 | 183 |
| 103 | 184 while ($data_gears =~ /Type\*\s*(\w+),/g) { |
| 124 | 185 $data_gears =~ s/Type\*/struct $interface_name*/; |
| 102 | 186 } |
| 187 | |
| 112 | 188 print $out "__code $code_ir->{name}$impl("; |
| 102 | 189 print $out "$data_gears) {\n\n"; |
| 190 | |
| 191 #__code next(...), __code whenEmpty(...) | |
| 192 my @cg = (); | |
| 193 while ($data_gears =~ /__code ([\w(\.)\*\s,]+?\)),?/g) { | |
| 194 push(@cg, $1); | |
| 195 } | |
| 196 | |
| 197 if (@cg) { | |
| 198 if (@cg == 2) { | |
| 199 print $out " if (:TODO:) {\n"; | |
| 200 print $out " goto ",shift(@cg),";\n"; | |
| 201 print $out " }\n"; | |
| 202 print $out " goto ",shift(@cg),";\n"; | |
| 203 } else { | |
| 204 print $out " goto ",shift(@cg),";\n"; | |
| 205 } | |
| 206 } | |
| 207 print $out "}\n\n"; | |
| 208 } | |
| 209 } |