Mercurial > hg > GearsTemplate
annotate src/parallel_execution/trans_impl.pl @ 563:928d01b70e62
fix
author | anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp> |
---|---|
date | Thu, 21 Nov 2019 21:25:36 +0900 |
parents | b7db5cb2e2c1 |
children | ba529ff3f068 |
rev | line source |
---|---|
555 | 1 #!/usr/bin/env perl |
2 use strict; | |
3 use warnings; | |
4 | |
557 | 5 use FindBin; |
6 use lib "$FindBin::Bin/lib"; | |
7 use Gears::Util; | |
555 | 8 |
561 | 9 use Getopt::Std; |
10 | |
11 my %opt; | |
12 getopts("w" => \%opt); | |
555 | 13 |
557 | 14 my $impl_file = shift or die 'require impl file'; |
560
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
15 my $impl_ir = Gears::Util->parse_code_verbose($impl_file); |
559 | 16 my $interface_file = Gears::Util->find_header($impl_ir->{isa},"$FindBin::Bin"); |
17 | |
18 my $inter_ir = Gears::Util->parse_code_verbose($interface_file); | |
561 | 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 | |
560
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
30 emit_include_part($stdout, $inter_ir->{name}); |
561 | 31 emit_impl_header_in_comment($stdout, $impl_file); |
559 | 32 emit_constracutor($stdout,$impl_ir,$inter_ir); |
560
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
33 emit_code_gears($stdout,$impl_ir,$inter_ir); |
561 | 34 close $fh; |
559 | 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; | |
561 | 50 print $out "// ----\n\n"; |
559 | 51 } |
558 | 52 |
559 | 53 sub emit_constracutor { |
54 my ($out, $impl_ir, $inter_ir) = @_; | |
55 | |
563 | 56 my @inter_data = @{$inter_ir->{data}}; |
57 my @impl_data = @{$impl_ir->{data}}; | |
560
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
58 my $instance_inter = shift @inter_data; |
563 | 59 |
559 | 60 if ($instance_inter =~ /union\s*Data\*\s*(\w+)/) { |
61 $instance_inter = $1; | |
62 } | |
563 | 63 |
64 my $instance_impl = lcfirst $impl_ir->{name}; | |
65 $instance_impl =~ s/([A-Z])/_\l$1/g; | |
559 | 66 |
67 print $out <<"EOF"; | |
560
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
68 $impl_ir->{isa}* create$impl_ir->{name}(struct Context* context) { |
559 | 69 struct $impl_ir->{isa}* $instance_inter = new $impl_ir->{isa}(); |
70 struct $impl_ir->{name}* $instance_impl = new $impl_ir->{name}(); | |
71 $instance_inter->$instance_inter = (union Data*)$instance_impl; | |
72 EOF | |
73 | |
563 | 74 for my $datum (@impl_data) { |
559 | 75 if ($datum =~ /\w+ \w+\* (\w+)/) { |
563 | 76 print $out " ${impl_inter}->$1 = NULL;\n"; |
560
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
77 next; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
78 } |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
79 if ($datum =~ /\w+ \w+ (\w+)/) { |
563 | 80 print $out " ${impl_inter}->$1 = 0;\n"; |
81 } | |
82 } | |
83 | |
84 for my $datum (@inter_data) { | |
85 if ($datum =~ /\w+ \w+\* (\w+)/) { | |
86 print $out " ${instance_inter}->$1 = NULL;\n"; | |
87 next; | |
88 } | |
89 if ($datum =~ /\w+ \w+ (\w+)/) { | |
90 print $out " ${instance_inter}->$1 = 0;\n"; | |
559 | 91 } |
92 } | |
93 | |
94 for my $code (@{$inter_ir->{codes}}) { | |
95 my $code_gear = $code->[0]; | |
96 print $out " ${instance_inter}->$code_gear = C_$code_gear$impl_ir->{name};\n" | |
97 } | |
98 | |
99 print $out " return $instance_inter;\n"; | |
100 print $out "}\n"; | |
101 } | |
102 | |
560
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
103 |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
104 sub emit_code_gears { |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
105 my ($out, $impl_ir, $inter_ir) = @_; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
106 my $impl = $impl_ir->{name}; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
107 |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
108 my @inter_data = @{$inter_ir->{data}}; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
109 my $instance_inter = shift @inter_data; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
110 if ($instance_inter =~ /union\s*Data\*\s*(\w+)/) { |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
111 $instance_inter = $1; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
112 } |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
113 my $instance_impl = lcfirst $impl_ir->{name}; |
563 | 114 $instance_impl =~ s/([A-Z])/_\l$1/g; |
560
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
115 my $data_gear_types = {}; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
116 |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
117 for my $code_ir (@{$inter_ir->{codes}}) { |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
118 my $data_gears = $code_ir->[1]; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
119 $data_gears =~ s/Impl/$impl/g; |
562 | 120 while ($data_gears =~ /Type\*\s*(\w+),/g) { |
560
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
121 my $target = $1; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
122 if (exists $data_gear_types->{$target}){ |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
123 $data_gears =~ s/Type\*/$data_gear_types->{$target}/; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
124 } else { |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
125 my $td = ""; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
126 map { $td = $_ if ($_ =~ /$target/) } @inter_data; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
127 if ($td =~ /(\w+)\s*([\w\*]+)\s*(\w+)/) { |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
128 my $tmp = "$1 $2"; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
129 $data_gears =~ s/Type\*/$tmp/; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
130 $data_gear_types->{$target} = $tmp; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
131 } |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
132 } |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
133 } |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
134 |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
135 print $out "__code $code_ir->[0]$impl("; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
136 print $out "$data_gears) {\n\n"; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
137 |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
138 #__code next(...), __code whenEmpty(...) |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
139 my @cg = (); |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
140 while ($data_gears =~ /__code ([\w(\.)\*\s,]+?\)),?/g) { |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
141 push(@cg, $1); |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
142 } |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
143 |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
144 if (@cg) { |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
145 if (@cg == 2) { |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
146 print $out " if (:TODO:) {\n"; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
147 print $out " goto ",shift(@cg),";\n"; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
148 print $out " }\n"; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
149 print $out " goto ",shift(@cg),";\n"; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
150 } else { |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
151 print $out " goto ",shift(@cg),";\n"; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
152 } |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
153 } |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
154 print $out "}\n\n"; |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
155 } |
2276952ed717
impl trans_impl.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
156 } |