Mercurial > hg > Gears > GearsTools

comparison trans_impl.pl @ 1:9a4279c88aa7 default tip

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
copy from xv6 repository
author anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
date Fri, 06 Mar 2020 14:59:59 +0900
parents
children
comparison
equal deleted inserted replaced
0:720e9c0936e0 1:9a4279c88aa7
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 use File::Spec;
11
12 my %opt;
13 getopts("wo:" => \%opt);
14
15 my $impl_file = shift or die 'require impl file';
16 my $impl_ir = Gears::Util->parse_with_separate_code_data_gears(File::Spec->rel2abs($impl_file));
17 my $interface_file = Gears::Util->find_using_interface_header($impl_ir->{isa},"$FindBin::Bin/..");
18
19 my $inter_ir = Gears::Util->parse_with_separate_code_data_gears($interface_file);
20
21 my $interface_var_name = shift @{$inter_ir->{data}};
22
23 if ($interface_var_name =~ /union\s*Data\*\s*(\w+)/) {
24 $interface_var_name = $1;
25 }
26
27 my $impl_var_name = decamelize($impl_ir->{name});
28
29 my $interface = {ir => $inter_ir, var_name => $interface_var_name};
30 my $impl = {ir => $impl_ir, var_name => $impl_var_name};
31
32 my $output_file = $impl_file;
33 $output_file =~ s/\.h/.cbc/;
34 my $stdout = *STDOUT;
35
36 if ($opt{w}) {
37 if(-f $output_file) {
38 update_file($output_file, $interface, $impl, $impl_file);
39 exit 0;
40 }
41 open $stdout, '>', $output_file;
42 } elsif ($opt{o}) {
43 if(-f $opt{o}) {
44 update_file($opt{o}, $interface, $impl, $impl_file);
45 exit 0;
46 }
47 open $stdout, '>', $opt{o};
48 }
49
50 emit_include_part($stdout, $inter_ir->{name});
51 emit_impl_header_in_comment($stdout, $impl_file);
52 emit_constracutor($stdout,$impl,$interface);
53 emit_code_gears($stdout,$impl,$interface);
54 close $stdout;
55
56 sub emit_include_part {
57 my ($out, $interface) = @_;
58 print $out <<"EOF"
59 #include "../context.h"
60 #interface "$interface.h"
61
62 EOF
63 }
64
65 sub emit_impl_header_in_comment {
66 my ($out, $impl_file) = @_;
67 my $line = Gears::Util->slup($impl_file);
68 print $out "// ----\n";
69 map { print $out "// $_\n" } split /\n/, $line;
70 print $out "// ----\n\n";
71 }
72
73
74 sub emit_constracutor {
75 my ($out, $impl, $interface) = @_;
76
77 my $impl_ir = $impl->{ir};
78 my $inter_ir = $interface->{ir};
79 my $impl_var_name = $impl->{var_name};
80 my $interface_var_name = $interface->{var_name};
81
82 my @inter_data = @{$inter_ir->{data}};
83 my @impl_data = @{$impl_ir->{data}};
84
85 print $out <<"EOF";
86 $impl_ir->{isa}* create$impl_ir->{name}(struct Context* cbc_context) {
87 struct $impl_ir->{isa}* $interface_var_name = new $impl_ir->{isa}();
88 struct $impl_ir->{name}* $impl_var_name = new $impl_ir->{name}();
89 $interface_var_name->$interface_var_name = (union Data*)$impl_var_name;
90 EOF
91
92 for my $datum (@impl_data) {
93 $datum =~ s|//[\s\w]+||;
94 if ($datum =~ /^\s+#/) {
95 next;
96 }
97
98 if ($datum =~ /\w+\s\w+\*\s(\w+)/) {
99 print $out " ${impl_var_name}->$1 = NULL;\n";
100 next;
101 }
102 if ($datum =~ /\w+\s\w+\s(\w+)/) {
103 print $out " ${impl_var_name}->$1 = 0;\n";
104 }
105
106 if ($datum =~ /\w+(\*)?\s(\w+)/) {
107 my $is_pointer = $1;
108 my $var_name = $2;
109 if ($1) {
110 print $out " ${impl_var_name}->$var_name = NULL;\n";
111 } else {
112 print $out " ${impl_var_name}->$var_name = 0;\n";
113 }
114 }
115 }
116
117
118 for my $code (@{$impl_ir->{codes}}) {
119 my $code_gear = $code->{name};
120 next if $code_gear eq 'next';
121 print $out " ${impl_var_name}->$code_gear = C_$code_gear;\n"
122 }
123
124 for my $code (@{$inter_ir->{codes}}) {
125 my $code_gear = $code->{name};
126 next if $code_gear eq 'next';
127 print $out " ${interface_var_name}->$code_gear = C_$code_gear$impl_ir->{name};\n"
128 }
129
130 print $out " return $interface_var_name;\n";
131 print $out "}\n";
132 }
133
134
135 sub emit_code_gears {
136 my ($out, $impl, $interface) = @_;
137
138 my $inter_ir = $interface->{ir};
139 my $impl_ir = $impl->{ir};
140
141 my $impl_name = $impl_ir->{name};
142 my $interface_name = $inter_ir->{name};
143
144 my $impl_var_name = $impl->{var_name};
145 my $interface_var_name = $interface->{var_name};
146
147 my @inter_data = @{$inter_ir->{data}};
148
149 my $data_gear_types = {};
150
151 if (defined $impl_ir->{codes}) {
152 replace_code_gears($impl_ir,$impl_name,$interface_name,1,$out);
153 }
154 replace_code_gears($inter_ir,$impl_name,$interface_name,0,$out);
155 }
156
157 sub replace_code_gears {
158 my ($ir, $impl, $interface_name, $is_impl, $out) = @_;
159
160 my $replace_impl = $is_impl ? $impl : $interface_name;
161
162 for my $cg (@{$ir->{codes}}) {
163 next if ($cg->{name} eq 'next');
164 my $data_gears = $cg->{args};
165 while ($data_gears =~ /Type\*\s*(\w+),/g) {
166 $data_gears =~ s/Type\*/struct $replace_impl*/;
167 }
168
169 if ($is_impl) {
170 while ($data_gears =~ /Isa\*\s*(\w+),/g) {
171 $data_gears =~ s/Isa\*/struct $interface_name*/;
172 }
173 } else {
174 $data_gears =~ s/Impl/struct $impl/g;
175 }
176 print $out "__code $cg->{name}";
177 unless ($is_impl) {
178 print $out $impl;
179 }
180 print $out "(";
181 print $out "$data_gears) {\n\n";
182 _emit_cg($out,$data_gears);
183 }
184 }
185
186
187 sub _emit_cg {
188 my ($out, $data_gears) = @_;
189 my @cg = ();
190 while ($data_gears =~ /__code ([\w(\.)\*\s,]+?\)),?/g) {
191 push(@cg, $1);
192 }
193 if (@cg) {
194 if (@cg == 2) {
195 print $out " if (:TODO:) {\n";
196 print $out " goto ",shift(@cg),";\n";
197 print $out " }\n";
198 print $out " goto ",shift(@cg),";\n";
199 } else {
200 print $out " goto ",shift(@cg),";\n";
201 }
202 }
203 print $out "}\n\n";
204 }
205
206 sub update_file {
207 my ($output_file, $interface, $impl, $impl_file) = @_;
208 my $under_code = collection_save_code_gears($output_file,$interface->{var_name});
209 open my $fh, '>', $output_file;
210 emit_include_part($fh, $interface->{ir}->{name});
211 emit_impl_header_in_comment($fh, $impl_file);
212 emit_constracutor($fh,$impl,$interface);
213 map { print $fh $_ } @{$under_code};
214 close $fh;
215 }
216
217 sub collection_save_code_gears {
218 my ($output_file,$interface_name) = @_;
219 open my $fh, '<', $output_file;
220 while (my $line = <$fh>) {
221 if ($line =~ /\s*return $interface_name;\s*/) {
222 $line = <$fh>; # } skip...
223 last;
224 }
225 }
226
227 my @res;
228 push(@res, <$fh>);
229 return \@res;
230 }
231
232 #https://metacpan.org/pod/String::CamelCase
233 sub decamelize
234 {
235 my $s = shift;
236 $s =~ s{([^a-zA-Z]?)([A-Z]*)([A-Z])([a-z]?)}{
237 my $fc = pos($s)==0;
238 my ($p0,$p1,$p2,$p3) = ($1,lc$2,lc$3,$4);
239 my $t = $p0 || $fc ? $p0 : '_';
240 $t .= $p3 ? $p1 ? "${p1}_$p2$p3" : "$p2$p3" : "$p1$p2";
241 $t;
242 }ge;
243 $s;
244 }