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