Mercurial > hg > Gears > Gears
annotate src/parallel_execution/lib/Gears/Util.pm @ 681:04df4583de36
...
author | anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp> |
---|---|
date | Fri, 21 Aug 2020 05:59:24 +0900 |
parents | c65f8f00ba6f |
children | 49d57e7fce39 |
rev | line source |
---|---|
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
1 package Gears::Util; |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
2 use strict; |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
3 use warnings; |
677
47910f7c731e
remove some global variables
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
667
diff
changeset
|
4 use Carp qw/croak carp/; |
557 | 5 use File::Find; |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
6 |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
7 sub parse { |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
8 my ($class, $file_name) = @_; |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
9 my $ir = _parse_base($file_name); |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
10 return $ir; |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
11 } |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
12 |
559 | 13 |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
14 sub parse_interface { |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
15 my ($class, $file_name) = @_; |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
16 my $ir = _parse_base($file_name); |
663 | 17 |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
18 unless ($ir->{name}) { |
624
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
19 croak "invalid struct name $file_name"; |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
20 } |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
21 |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
22 |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
23 sub _parse_base { |
681 | 24 |
25 # create this data structure | |
26 # \ { | |
27 # content [ | |
28 # [0] "union Data* stack; | |
29 #", | |
30 # [1] "union Data* data; | |
31 #", | |
32 # [2] "union Data* data1; | |
33 #", | |
34 # [3] "enum Code whenEmpty; | |
35 #", | |
36 # [4] "enum Code clear; | |
37 #", | |
38 # [5] "enum Code push; | |
39 #", | |
40 # [6] "enum Code pop; | |
41 #", | |
42 # [7] "enum Code pop2; | |
43 #", | |
44 # [8] "enum Code isEmpty; | |
45 #", | |
46 # [9] "enum Code get; | |
47 #", | |
48 # [10] "enum Code get2; | |
49 #", | |
50 # [11] "enum Code next; | |
51 #" | |
52 # ], | |
53 # file_name "/Users/anatofuz/src/firefly/hg/Gears/Gears/src/parallel_execution/tools/../Stack.h", | |
54 # name "Stack" | |
55 #} | |
56 | |
559 | 57 my ($file,$code_verbose) = @_; |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
58 my $ir = {}; |
594 | 59 $ir->{file_name} = $file; |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
60 |
564
9cca20bcb558
add auto_generate_context.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
61 Gears::Util->file_checking($file); |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
62 open my $fh, '<', $file; |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
63 my $line = <$fh>; |
598 | 64 my $static_data_gear_write_mode = 0; |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
65 |
624
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
66 my $directory_containing_file = ""; |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
67 |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
68 if ($file =~ m<([\.\w/]+)/\w+\.(?:cbc|h|c)>) { |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
69 $directory_containing_file = $1; |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
70 } |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
71 |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
72 |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
73 while ($line =~ /#include\s+"([\w\/\.]+)"/) { |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
74 my $header_file = $1; |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
75 if ($header_file =~ m|\./context\.h|) { |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
76 next; |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
77 } |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
78 push(@{$ir->{cbc_context_include_headers}}, "$directory_containing_file/$header_file"); |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
79 $line = <$fh>; |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
80 } |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
81 |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
82 # skip space |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
83 |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
84 while ($line =~ /^\s*$/) { |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
85 $line = <$fh>; |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
86 } |
d560184a7ce7
auto load header to context
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
621
diff
changeset
|
87 |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
88 if ($line =~ /typedef struct (\w+)\s?<.*>([\s\w{]+)/) { |
679
c65f8f00ba6f
analyze the interface when goto using the interface
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
677
diff
changeset
|
89 my $vname = $1; |
c65f8f00ba6f
analyze the interface when goto using the interface
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
677
diff
changeset
|
90 unless ($vname) { |
c65f8f00ba6f
analyze the interface when goto using the interface
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
677
diff
changeset
|
91 carp "[WARN] invalied struct name from $file"; |
c65f8f00ba6f
analyze the interface when goto using the interface
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
677
diff
changeset
|
92 return undef; |
c65f8f00ba6f
analyze the interface when goto using the interface
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
677
diff
changeset
|
93 } |
c65f8f00ba6f
analyze the interface when goto using the interface
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
677
diff
changeset
|
94 $ir->{name} = $vname; |
c65f8f00ba6f
analyze the interface when goto using the interface
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
677
diff
changeset
|
95 my $annotation = $2; |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
96 |
679
c65f8f00ba6f
analyze the interface when goto using the interface
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
677
diff
changeset
|
97 if ($annotation =~ m|\s*impl\s*([\w+]+)\s*{|) { |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
98 $ir->{isa} = $1; |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
99 } |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
100 } |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
101 |
598 | 102 unless ($ir->{name}) { |
103 return undef; | |
104 } | |
105 | |
597
410924949569
impl auto search data gear
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
595
diff
changeset
|
106 my @tmp_args; |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
107 while ($line = <$fh>) { |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
108 if ($line =~ m|\s*/\*|) { |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
109 while ( $line !~ m|\*/|) { |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
110 $line = <$fh>; |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
111 next; |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
112 } |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
113 next; |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
114 } |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
115 next if ($line =~ /^\s+$/); |
583 | 116 next if ($line =~ m[^\s*//]); |
575 | 117 next if ($line =~ m[^\}\s*$ir->{name};]); |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
118 |
597
410924949569
impl auto search data gear
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
595
diff
changeset
|
119 if ($line =~ m|__code (\w+)|) { |
410924949569
impl auto search data gear
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
595
diff
changeset
|
120 push(@tmp_args,"enum Code $1;\n"); |
598 | 121 next if $static_data_gear_write_mode; |
597
410924949569
impl auto search data gear
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
595
diff
changeset
|
122 my $args = $'; |
410924949569
impl auto search data gear
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
595
diff
changeset
|
123 #$args eq (Impl* vm, pde_t* pgdir, char* init, uint sz, __code next(...)); |
644 | 124 while ($args =~ /\s*(struct|union|const|enum)?\s*([\w*\[\]_]+)\s*(\w+)?,?/g) { |
597
410924949569
impl auto search data gear
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
595
diff
changeset
|
125 my $const_type = $1; |
410924949569
impl auto search data gear
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
595
diff
changeset
|
126 my $type = $2; |
410924949569
impl auto search data gear
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
595
diff
changeset
|
127 my $vname = $3; |
410924949569
impl auto search data gear
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
595
diff
changeset
|
128 next if ($type eq '__code'); |
644 | 129 next unless $vname; # __code hoge(int ret, __code next(ret, ...); this is second "ret" case |
625 | 130 $type =~ s/^(?:Impl|Type|Isa)\s*(\*)?/union Data$1/; |
597
410924949569
impl auto search data gear
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
595
diff
changeset
|
131 my $val = "$type $vname;\n"; |
598 | 132 push(@tmp_args, $const_type ? "$const_type $val" : $val); |
597
410924949569
impl auto search data gear
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
595
diff
changeset
|
133 } |
410924949569
impl auto search data gear
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
595
diff
changeset
|
134 next; |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
135 } |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
136 |
597
410924949569
impl auto search data gear
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
595
diff
changeset
|
137 $line =~ s/^\s+//; |
410924949569
impl auto search data gear
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
595
diff
changeset
|
138 push(@tmp_args,$line); |
598 | 139 $static_data_gear_write_mode = 1; |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
140 } |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
141 |
598 | 142 push(@{$ir->{content}}, _uniq(@tmp_args)); |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
143 return $ir; |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
144 } |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
145 |
598 | 146 sub _uniq { |
147 my %seen; | |
148 return grep { !$seen{$_}++ } @_; | |
149 } | |
150 | |
666 | 151 sub separate_code_and_data_gear_after_parse { |
152 # create this data structure | |
153 #\ { | |
154 # codes [ | |
155 # [0] { | |
156 # args "Impl* stackTest, struct Stack* stack, __code next(...)", | |
157 # name "insertTest1" | |
158 # }, | |
159 # [1] { | |
160 # args "Impl* stackTest, struct Stack* stack, __code next(...)", | |
161 # name "insertTest2" | |
162 # }, | |
163 # [2] { | |
164 # args "Impl* stackTest, struct Stack* stack, __code next(...)", | |
165 # name "pop2Test" | |
166 # }, | |
167 # [3] { | |
168 # args "Impl* stackTest, union Data* data, union Data* data1, struct Stack* stack, __code next(...)", | |
169 # name "pop2Test1" | |
170 # }, | |
171 # [4] { | |
172 # args "...", | |
173 # name "next" | |
174 # } | |
175 # ], | |
176 # content [ | |
177 # [0] "enum Code insertTest1; | |
178 #", | |
179 # [1] "union Data* stackTest; | |
180 #", | |
181 # [2] "struct Stack* stack; | |
182 #", | |
183 # [3] "enum Code insertTest2; | |
184 #", | |
185 # [4] "enum Code pop2Test; | |
186 #", | |
187 # [5] "enum Code pop2Test1; | |
188 #", | |
189 # [6] "union Data* data; | |
190 #", | |
191 # [7] "union Data* data1; | |
192 #", | |
193 # [8] "enum Code next; | |
194 #" | |
195 # ], | |
196 # data [ | |
197 # [0] "union Data* stackTest; | |
198 #", | |
199 # [1] "struct Stack* stack; | |
200 #", | |
201 # [2] "union Data* data; | |
202 #", | |
203 # [3] "union Data* data1; | |
204 #" | |
205 # ], | |
206 # file_name "/Users/anatofuz/src/firefly/hg/Gears/Gears/src/parallel_execution/tools/../examples/pop_and_push/StackTest.h", | |
207 # name "StackTest" | |
208 #} | |
209 # | |
210 | |
583 | 211 my ($class, $file) = @_; |
212 my $ir = _parse_base($file); | |
213 | |
681 | 214 $ir->{hasOutputArgs} = {}; |
215 | |
583 | 216 my @data_gears; |
217 my @code_gears; | |
218 map { push (@data_gears, $_) unless ($_ =~ /enum Code/);} @{$ir->{content}}; | |
219 map { push (@code_gears, $1) if ($_ =~ /enum Code (\w+);/);} @{$ir->{content}}; | |
220 | |
221 open my $fh , '<', $file; | |
222 my $i = 0; | |
681 | 223 my @have_output_data; |
583 | 224 while (($i < scalar @code_gears) && (my $line = <$fh>)) { |
681 | 225 my $codeGearName = $code_gears[$i]; |
226 if ($line =~ m|__code $codeGearName\(([()\.\*\s\w,_]+)\)|) { | |
227 my $arg = $1; | |
583 | 228 $code_gears[$i] = { |
681 | 229 name => $codeGearName, |
230 args => $arg, | |
583 | 231 }; |
681 | 232 # args "Impl* stack, __code next(Type* data, Type* data1, ...)", |
233 if ($arg =~ /__code \w+\((.+),\s*\.\.\.\s*\)/) { | |
234 my $outputArgs = $1; | |
235 while ($outputArgs =~ /([\w*]+)\s(\w+),?/g) { | |
236 my $ttype = $1; | |
237 my $tname = $2; | |
238 $ir->{hasOutputArgs}->{$codeGearName}->{$tname} = $ttype; | |
239 } | |
240 } | |
583 | 241 $i++; |
242 } | |
243 } | |
681 | 244 |
583 | 245 $ir->{codes} = \@code_gears; |
246 $ir->{data} = \@data_gears; | |
247 return $ir; | |
248 } | |
249 | |
564
9cca20bcb558
add auto_generate_context.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
250 sub file_checking { |
9cca20bcb558
add auto_generate_context.pl
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
559
diff
changeset
|
251 my ($class, $file_name) = @_; |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
252 unless (-f $file_name) { |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
253 croak "invalid filepath :$file_name\n"; |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
254 } |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
255 } |
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
256 |
557 | 257 sub slup { |
258 my ($class,$file) = @_; | |
259 open my $fh, '<', $file; | |
260 local $/; | |
261 my $f = <$fh>; | |
262 return $f; | |
263 } | |
264 | |
265 | |
663 | 266 sub find_cbc_sources_from_path { |
267 my $class = shift; | |
268 my $find_path = shift // "."; | |
269 | |
270 my @files; | |
271 find( { wanted => sub { push @files, $_ if /\.cbc/ }, no_chdir => 1 }, $find_path); | |
272 | |
273 return \@files; | |
274 } | |
275 | |
657
3e3f282d62e4
refactoring Gears perl modules
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
652
diff
changeset
|
276 sub find_headers_from_path { |
573
5f4b7ff18a34
set header path each include struct
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
564
diff
changeset
|
277 my $class = shift; |
5f4b7ff18a34
set header path each include struct
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
564
diff
changeset
|
278 my $find_path = shift // "."; |
5f4b7ff18a34
set header path each include struct
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
564
diff
changeset
|
279 |
5f4b7ff18a34
set header path each include struct
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
564
diff
changeset
|
280 my @files; |
583 | 281 find( { wanted => sub { push @files, $_ if /\.(?:h|dg)/ }, no_chdir => 1 }, $find_path); |
573
5f4b7ff18a34
set header path each include struct
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
564
diff
changeset
|
282 |
5f4b7ff18a34
set header path each include struct
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
564
diff
changeset
|
283 return \@files; |
5f4b7ff18a34
set header path each include struct
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
564
diff
changeset
|
284 } |
5f4b7ff18a34
set header path each include struct
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
564
diff
changeset
|
285 |
595 | 286 sub extraction_dg_compile_sources { |
287 my ($class, $compile_sources) = @_; | |
288 my %counter; | |
289 my %include_pool = (); | |
290 for my $cbc_file (@{$compile_sources}) { | |
291 open my $fh , '<', $cbc_file; | |
292 while (my $line = <$fh>) { | |
293 if ($line =~ m|//\s*:skip|) { | |
294 next; | |
295 } | |
296 | |
297 if ($line =~ /#interface\s*"(.*)\.h"/) { | |
298 push(@{$counter{interfaces}->{$1}->{$cbc_file}},$.); | |
299 next; | |
300 } | |
301 | |
644 | 302 if ($line =~ /^\/\/\s*include\s*"(.*)\.(?:h|dg)?"/) { |
595 | 303 push(@{$include_pool{$1}->{$cbc_file}},$.); |
304 next; | |
305 } | |
306 | |
307 if ($line =~ m|//\s*Skip:\s*generate_context|) { | |
308 $line = <$fh>; | |
309 next; | |
310 } | |
311 | |
312 | |
598 | 313 if ($line =~ /^(\w+)\*\s*create(\w+)\(([*\w\s]+)\)/) { |
595 | 314 my $interface = $1; |
315 my $implementation = $2; | |
598 | 316 my $arg = $3; |
317 if ($arg eq "") { | |
318 next; | |
319 } | |
595 | 320 push(@{$counter{interfaces}->{$interface}->{$cbc_file}},$.); |
321 push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.); | |
322 next; | |
323 } | |
324 | |
325 if ($line =~ /Gearef\(context,\s*(\w+)\)/) { | |
326 my $implementation = $1; | |
327 push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.); | |
328 next; | |
329 } | |
330 | |
667 | 331 # ALLOCATE is generated by generate_stub.pl |
332 # because extraction_dg_compile_sources caller after translated .cbc to .c | |
595 | 333 #Element* element = &ALLOCATE(cbc_context, Element)->Element; |
334 if ($line =~ /ALLOCATE\w*\((?:cbc_)?context,\s*(\w+)\)/) { | |
335 my $implementation = $1; | |
336 push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.); | |
337 next; | |
338 } | |
339 | |
340 if ($line =~ /ALLOCATE_(?:PTR_)?ARRAY\((?:cbc_)?context,\s*(\w+),[\s\w]+\)/) { | |
341 my $implementation = $1; | |
342 push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.); | |
343 next; | |
344 } | |
345 | |
346 if ($line =~ /new\s+(\w+?)\([\w\s]*\);/) { | |
347 my $implementation = $1; | |
348 push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.); | |
349 next; | |
350 } | |
351 | |
352 if ($line =~ /ALLOCATE_DATA_GEAR\((\w+),\s*(\w+)\)/) { | |
353 my $implementation = $2; | |
354 push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.); | |
355 next; | |
356 } | |
357 | |
358 #TaskManagerImpl* taskManager = (TaskManagerImpl*)GearImpl(context, TaskManager, taskManager); | |
359 if ($line =~ /\((\w+)\*\)GearImpl\(context,\s*(\w+),\s*(\w+)\)/) { | |
360 my $interface = $2; | |
361 my $implementation = $1; | |
362 push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.); | |
363 push(@{$counter{interfaces}->{$interface}->{$cbc_file}},$.); | |
364 next; | |
365 } | |
366 | |
367 if ($line =~ /^__code/) { | |
368 while ($line =~ /struct (\w+)\s*\*/g) { | |
369 next if $1 eq "Context"; | |
370 next if (exists $counter{interfaces}->{$1}); | |
371 push(@{$counter{impl}->{$1}->{$cbc_file}},$.); | |
372 } | |
373 } | |
374 } | |
375 close $fh; | |
376 } | |
377 use Data::Dumper; | |
378 | |
379 for my $cg_name (keys %include_pool) { | |
380 my @tmp_cbc_file_names = keys %{$include_pool{$cg_name}}; | |
381 my $tmp_cbc_file_name = shift @tmp_cbc_file_names; | |
382 if (exists $counter{interfaces}->{$cg_name}){ | |
383 push(@{$counter{interfaces}->{$cg_name}->{$tmp_cbc_file_name}},$include_pool{$cg_name}->{$tmp_cbc_file_name}); | |
384 delete $include_pool{$cg_name}; | |
385 next; | |
386 } | |
387 | |
388 if (exists $counter{impl}->{$cg_name}){ | |
389 push(@{$counter{impl}->{$cg_name}->{$tmp_cbc_file_name}},$include_pool{$cg_name}->{$tmp_cbc_file_name}); | |
390 delete $include_pool{$cg_name}; | |
391 next; | |
392 } | |
393 push(@{$counter{interfaces}->{$cg_name}->{$tmp_cbc_file_name}},$include_pool{$cg_name}->{$tmp_cbc_file_name}); | |
394 delete $include_pool{$cg_name}; | |
395 } | |
396 | |
397 $counter{interfaces}->{Meta}++; | |
398 $counter{interfaces}->{TaskManager}++; | |
652
f666c6daba96
omit debug infomation
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
644
diff
changeset
|
399 #print "-----------\n"; |
667 | 400 #print Dumper \%counter; #this line is debug message |
652
f666c6daba96
omit debug infomation
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
644
diff
changeset
|
401 #print "-----------\n"; |
595 | 402 return \%counter; |
403 } | |
404 | |
405 | |
556
a0b7eb5e58c0
add Gears::Util module
anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
parents:
diff
changeset
|
406 1; |