File Coverage

blib/lib/VIC/Receiver.pm
Criterion Covered Total %
statement 891 1010 88.2
branch 480 714 67.2
condition 78 162 48.1
subroutine 81 87 93.1
pod 1 63 1.5
total 1531 2036 75.2


line stmt bran cond sub pod time code
1             package VIC::Receiver;
2 33     33   142 use strict;
  33         45  
  33         964  
3 33     33   128 use warnings;
  33         44  
  33         771  
4 33     33   16160 use bigint;
  33         76668  
  33         128  
5 33     33   957435 use POSIX ();
  33         167230  
  33         1112  
6 33     33   186 use List::Util qw(max);
  33         41  
  33         2828  
7 33     33   15744 use List::MoreUtils qw(any firstidx indexes);
  33         272306  
  33         220  
8              
9             our $VERSION = '0.31';
10             $VERSION = eval $VERSION;
11              
12 33     33   19235 use Pegex::Base;
  33         54  
  33         255  
13             extends 'Pegex::Tree';
14              
15 33     33   54383 use VIC::PIC::Any;
  33         66  
  33         1372  
16              
17             has pic_override => undef;
18             has pic => undef;
19             has simulator => undef;
20             has ast => {
21             block_stack => [],
22             block_mapping => {},
23             block_count => 0,
24             funcs => {},
25             variables => {},
26             tmp_variables => {},
27             conditionals => 0,
28             tmp_stack_size => 0,
29             strings => 0,
30             tables => [],
31             asserts => 0,
32             };
33             has intermediate_inline => undef;
34             has global_collections => {};
35              
36 431     431 0 335 sub stack { reverse @{shift->parser->stack}; }
  431         875  
37              
38 1     1 0 4 sub supported_chips { return VIC::PIC::Any::supported_chips(); }
39              
40 1     1 0 4 sub supported_simulators { return VIC::PIC::Any::supported_simulators(); }
41              
42 19     19 0 36 sub is_chip_supported { return VIC::PIC::Any::is_chip_supported(@_); }
43              
44 0     0 0 0 sub is_simulator_supported { return VIC::PIC::Any::is_simulator_supported(@_); }
45              
46 0     0 0 0 sub list_chip_features { return VIC::PIC::Any::list_chip_features(@_); }
47              
48 0     0 0 0 sub print_pinout { return VIC::PIC::Any::print_pinout(@_); }
49              
50 31     31 0 490 sub current_chip { return $_[0]->pic->type; }
51              
52 31     31 0 164 sub current_simulator { return $_[0]->simulator->type; }
53              
54             sub got_mcu_select {
55 33     33 0 1599 my ($self, $type) = @_;
56             # override the PIC in code if defined
57 33 50       191 $type = $self->pic_override if defined $self->pic_override;
58 33         298 $type = lc $type;
59             # assume supported type else return
60 33         316 $self->pic(VIC::PIC::Any->new($type));
61 33 50 33     590 unless (defined $self->pic and
62             defined $self->pic->type) {
63 0         0 $self->parser->throw_error("$type is not a supported chip");
64             }
65 33         592 $self->ast->{include} = $self->pic->include;
66             # set the defaults in case the headers are not provided by the user
67 33         342 $self->ast->{org} = $self->pic->org;
68 33         236 $self->ast->{chip_config} = $self->pic->get_chip_config;
69 33         203 $self->ast->{code_config} = $self->pic->code_config;
70             # create the default simulator
71 33         385 $self->simulator(VIC::PIC::Any->new_simulator(pic => $self->pic));
72 33         2709 return;
73             }
74              
75             sub got_pragmas {
76 20     20 0 420 my ($self, $list) = @_;
77 20         91 $self->flatten($list);
78 20         291 $self->pic->update_code_config(@$list);
79             # get the updated config
80 20         50 $self->ast->{chip_config} = $self->pic->get_chip_config;
81 20         103 $self->ast->{code_config} = $self->pic->code_config;
82 20 50       126 my ($sim, $stype) = @$list if scalar @$list;
83 20 100 100     154 if ($sim eq 'simulator' and $stype !~ /disable/i) {
    100 66        
84 2         6 $self->simulator(VIC::PIC::Any->new_simulator(
85             type => $stype, pic => $self->pic));
86 2 50       107 if ($self->simulator) {
87 2 50       11 unless ($self->simulator->type eq $stype) {
88 0         0 warn "$stype is not a supported chip. Disabling simulator.";
89 0         0 $self->simulator->disable(1);
90             }
91             } else {
92 0         0 die "$stype is not a supported simulator.";
93             }
94             } elsif ($sim eq 'simulator' and $stype =~ /disable/i) {
95 1 50       5 $self->simulator->disable(1) if $self->simulator;
96             }
97 20         88 return;
98             }
99              
100             sub handle_named_block {
101 94     94 0 144 my ($self, $name, $anon_block, $parent) = @_;
102 94 50       586 my $id = $1 if $anon_block =~ /_anonblock(\d+)/;
103 94 50       225 $id = $self->ast->{block_count} unless defined $id;
104 94         164 my ($expected_label, $expected_param) = ('', '');
105 94 100       594 if ($name eq 'Main') {
    100          
    100          
    100          
    100          
    100          
    50          
106 32         78 $expected_label = "_start";
107             } elsif ($name =~ /^Loop/) {
108 16         37 $expected_label = "_loop_${id}";
109             } elsif ($name =~ /^Action/) {
110 6         18 $expected_label = "_action_${id}";
111 6         18 $expected_param = "action${id}_param";
112             } elsif ($name =~ /^True/) {
113 12         15 $expected_label = "_true_${id}";
114             } elsif ($name =~ /^False/) {
115 4         8 $expected_label = "_false_${id}";
116             } elsif ($name =~ /^ISR/) {
117 5         21 $expected_label = "_isr_${id}";
118 5         17 $expected_param = "isr${id}_param";
119             } elsif ($name eq 'Simulator') {
120 19         44 $expected_label = '_vic_simulator';
121             } else {
122 0         0 $expected_label = lc "_$name$id";
123             }
124 94 100       356 $name .= $id if $name =~ /^(?:Loop|Action|True|False|ISR)/;
125 94         567 $self->ast->{block_mapping}->{$name} = {
126             label => $expected_label,
127             block => $anon_block,
128             params => [],
129             param_prefix => $expected_param,
130             };
131 94         714 $self->ast->{block_mapping}->{$anon_block} = {
132             label => $expected_label,
133             block => $name,
134             params => [],
135             param_prefix => $expected_param,
136             };
137             # make sure the anon-block and named-block refer to the same block
138 94         435 $self->ast->{$name} = $self->ast->{$anon_block};
139              
140 94   33     483 my $stack = $self->ast->{$name} || $self->ast->{$anon_block};
141 94 50 33     864 if (defined $stack and ref $stack eq 'ARRAY') {
142 94         243 my $block_label = $stack->[0];
143             ## this expression is dependent on got_start_block()
144 94         1319 my ($tag, $label, @others) = split /::/, $block_label;
145 94 50       266 $label = $expected_label if $label ne $expected_label;
146 94 50       337 $block_label = "BLOCK::${label}::${name}" if $label;
147             # change the LABEL:: value in the stack for code-generation ease
148             # we want to use the expected label and not the anon one unless it is an
149             # anon-block
150 94         280 $stack->[0] = join("::", $tag, $label, @others);
151 94         905 my $elabel = "_end$label"; # end label
152 94         116 my $slabel = $label; # start label
153 94 100       227 if (defined $parent) {
154 43 50       131 unless ($parent =~ /BLOCK::/) {
155 43         78 $block_label .= "::$parent";
156 43 50 33     93 if (exists $self->ast->{$parent} and
      33        
157             ref $self->ast->{$parent} eq 'ARRAY' and
158             $parent ne $anon_block) {
159 43         585 my ($ptag, $plabel) = split /::/, $self->ast->{$parent}->[0];
160 43 50       612 $block_label .= "::$plabel" if $plabel;
161             }
162             }
163 43         93 my $ccount = $self->ast->{conditionals};
164 43 100       317 if ($block_label =~ /True|False/i) {
165 16         34 $elabel = "_end_conditional_$ccount";
166 16         241 $slabel = "_start_conditional_$ccount";
167             }
168 43         237 $block_label .= "::$elabel";
169 43 100       101 $block_label .= "::$expected_param" if length $expected_param;
170 43         50 push @{$self->ast->{$parent}}, $block_label;
  43         90  
171             }
172             # save this for referencing when we need to know what the parent of
173             # this block is in case we need to jump out of the block
174 94         316 $self->ast->{block_mapping}->{$name}->{parent} = $parent;
175 94         405 $self->ast->{block_mapping}->{$anon_block}->{parent} = $parent;
176 94         343 $self->ast->{block_mapping}->{$name}->{end_label} = $elabel;
177 94         361 $self->ast->{block_mapping}->{$anon_block}->{end_label} = $elabel;
178 94         328 $self->ast->{block_mapping}->{$name}->{start_label} = $slabel;
179 94         368 $self->ast->{block_mapping}->{$anon_block}->{start_label} = $slabel;
180 94 100       682 $self->ast->{block_mapping}->{$anon_block}->{loop} = '1' if $block_label =~ /Loop/i;
181 94         435 return $block_label;
182             }
183             }
184              
185             sub got_named_block {
186 78     78 0 1918 my ($self, $list) = @_;
187 78 50       406 $self->flatten($list) if ref $list eq 'ARRAY';
188 78         1249 my ($name, $anon_block, $parent_block) = @$list;
189 78         245 return $self->handle_named_block(@$list);
190             }
191              
192             sub got_anonymous_block {
193 94     94 0 2305 my $self = shift;
194 94         108 my $list = shift;
195 94         168 my ($anon_block, $block_stack, $parent) = @$list;
196             # returns anon_block and parent_block
197 94         328 return [$anon_block, $parent];
198             }
199              
200             sub got_start_block {
201 95     95 0 2607 my ($self, $list) = @_;
202 95         282 my $id = $self->ast->{block_count};
203             # we may not know the block name here
204 95         686 my $block = lc "_anonblock$id";
205 95         2537 push @{$self->ast->{block_stack}}, $block;
  95         226  
206 95         595 $self->ast->{$block} = [ "LABEL::$block" ];
207 95         548 $self->ast->{block_count}++;
208 95         5540 return $block;
209             }
210              
211             sub got_end_block {
212 94     94 0 2522 my ($self, $list) = @_;
213             # we are not capturing anything here
214 94         315 my $stack = $self->ast->{block_stack};
215 94         361 my $block = pop @$stack;
216 94         287 return $stack->[-1];
217             }
218              
219             sub got_name {
220 779     779 0 16413 my ($self, $list) = @_;
221 779 50       1440 if (ref $list eq 'ARRAY') {
222 779         2024 $self->flatten($list);
223 779         5918 return shift(@$list);
224             } else {
225 0         0 return $list;
226             }
227             }
228              
229             sub update_intermediate {
230 381     381 0 1065 my $self = shift;
231 381         770 my $block = $self->ast->{block_stack}->[-1];
232 381 50       6478 push @{$self->ast->{$block}}, @_ if $block;
  381         782  
233 381         1428 return;
234             }
235              
236             sub got_instruction {
237 246     246 0 5414 my ($self, $list) = @_;
238 246         365 my $method = shift @$list;
239 246 50       917 $self->flatten($list) if $list;
240 246         4349 my $tag = 'INS';
241             # check if it is a simulator method
242 246 100 66     637 if ($self->simulator and $self->simulator->can($method)) {
243             # this is a simulator instruction
244 107         1189 $tag = 'SIM';
245             } else {
246 139 100       2181 unless ($self->pic->can($method)) {
247 1         16 my $err = "Unsupported instruction '$method' for chip " . uc $self->pic->type;
248 1         17 return $self->parser->throw_error($err);
249             }
250             }
251 245         1036 my @args = ();
252 245         503 while (scalar @$list) {
253 355         382 my $a = shift @$list;
254 355 100       660 if ($a =~ /BLOCK::(\w+)::(Action|ISR)\w+::.*::(_end_\w+)::(\w+)$/) {
255 11         102 push @args, uc($2) . "::$1::END::$3::PARAM::$4";
256             } else {
257 344         1587 push @args, $a;
258             }
259             }
260 245         973 $self->update_intermediate("${tag}::${method}::" . join ("::", @args));
261 245         688 return;
262             }
263              
264             sub got_unary_rhs {
265 1     1 0 22 my ($self, $list) = @_;
266 1         3 $self->flatten($list);
267 1         8 return [ reverse @$list ];
268             }
269              
270             sub got_unary_expr {
271 8     8 0 157 my ($self, $list) = @_;
272 8         25 $self->flatten($list);
273 8         54 my $op = shift @$list;
274 8         14 my $varname = shift @$list;
275 8         31 $self->update_intermediate("UNARY::${op}::${varname}");
276 8         18 return;
277             }
278              
279             sub got_assign_expr {
280 85     85 0 1800 my ($self, $list) = @_;
281 85         218 $self->flatten($list);
282 85         1321 my $varname = shift @$list;
283 85         123 my $op = shift @$list;
284 85         167 my $rhsx = $self->got_expr_value($list);
285 85 50       206 my $rhs = ref $rhsx eq 'ARRAY' ? join ("::", @$rhsx) : $rhsx;
286 85 100       164 if ($rhs =~ /PARAM::(\w+)/) {
287             ## ok now we push this as our statement and handle the rest during
288             ## code generation
289             ## this is of the format PARAM::op::block_name::variable
290 5         11 my $block = $1;
291 5         30 $self->update_intermediate("PARAM::${op}::${block}::${varname}");
292             } else {
293 80         454 $self->update_intermediate("SET::${op}::${varname}::${rhs}");
294             }
295 85         241 return;
296             }
297              
298             sub got_array_element {
299 1     1 0 23 my ($self, $list) = @_;
300 1         2 my $var1 = shift @$list;
301 1         2 my $rhsx = $self->got_expr_value($list);
302 1 50       4 if (ref $rhsx eq 'ARRAY') {
303 0         0 XXX $rhsx; # why would this even happen
304             }
305 1         3 my $tvref = $self->ast->{tmp_variables};
306 1         9 my $tvar = sprintf "_vic_tmp_%02d", scalar(keys %$tvref);
307 1         3 my $vref = $self->ast->{variables}->{$var1};
308 1         4 my @ops = ('OP');
309 1 50 33     7 if (exists $vref->{type} and $vref->{type} eq 'HASH') {
    0 0        
    0 0        
310 1         4 push @ops, $vref->{label}, 'TBLIDX', $rhsx, $vref->{size};
311             } elsif (exists $vref->{type} and $vref->{type} eq 'ARRAY') {
312 0         0 push @ops, $vref->{label}, 'ARRIDX', $rhsx, $vref->{size};
313             } elsif (exists $vref->{type} and $vref->{type} eq 'string') {
314 0         0 push @ops, $vref->{label}, 'STRIDX', $rhsx, $vref->{size};
315             } else {
316             # this must be a byte
317 0         0 return $self->parser->throw_error(
318             "Variable '$var1' is not an array, table or string");
319             }
320 1         9 $tvref->{$tvar} = join("::", @ops);
321             # create a new variable here
322 1         4 my $varname = sprintf "vic_el_%02d", scalar(keys %$tvref);
323 1         3 $varname = $self->got_variable([$varname]);
324 1 50       3 if ($varname) {
325 1         5 $self->update_intermediate("SET::ASSIGN::${varname}::${tvar}");
326 1         4 return $varname;
327             }
328 0 0       0 return $self->parser->throw_error(
329             "Unable to create intermediary variable '$varname'") unless $varname;
330             }
331              
332             sub got_parameter {
333 5     5 0 140 my $self = shift;
334             ## ok the target variable needs a parameter here
335             ## this works only in block scope so we want to check which block we are in
336 5         18 my $block = $self->ast->{block_stack}->[-1];
337 5         109 return "PARAM::$block";
338             }
339              
340             sub got_declaration {
341 3     3 0 92 my ($self, $list) = @_;
342 3         5 my $lhs = shift @$list;
343 3         4 my $rhs;
344 3 50       18 if (scalar @$list == 1) {
345 3         238 $rhs = shift @$list;
346             } else {
347 0         0 $rhs = $list;
348             }
349             # TODO: generate intermediate code here
350 3 50 33     17 if (ref $rhs eq 'HASH' or ref $rhs eq 'ARRAY') {
351 3 50       10 if (not exists $self->ast->{variables}->{$lhs}) {
352 0         0 return $self->parser->throw_error("Variable '$lhs' doesn't exist");
353             }
354 3 100 66     31 if (exists $rhs->{TABLE} or ref $rhs eq 'ARRAY') {
    50          
355 1 50 33     11 my $label = lc "_table_$lhs" if ref $rhs eq 'HASH' and exists $rhs->{TABLE};
356 1 50 33     7 my $szpref = "VIC_TBLSZ_" if ref $rhs eq 'HASH' and exists $rhs->{TABLE};
357 1 50       7 $szpref = "VIC_ARRSZ_" if ref $rhs eq 'ARRAY';
358 1         2 $self->ast->{variables}->{$lhs}->{type} = ref $rhs;
359 1         15 $self->ast->{variables}->{$lhs}->{data} = $rhs;
360 1   33     5 $self->ast->{variables}->{$lhs}->{label} = $label || $lhs;
361 1 50       5 if ($szpref) {
362             $self->ast->{variables}->{$lhs}->{size} = $szpref .
363 1         2 $self->ast->{variables}->{$lhs}->{name};
364             }
365             } elsif (exists $rhs->{string}) {
366             # handle variable that are strings here
367 2         6 $self->ast->{variables}->{$lhs}->{data} = $rhs;
368 2         14 $self->ast->{variables}->{$lhs}->{type} = 'string';
369             $self->ast->{variables}->{$lhs}->{size} = "VIC_STRSZ_" .
370 2         9 $self->ast->{variables}->{$lhs}->{name};
371 2         19 $self->update_intermediate("SET::ASSIGN::${lhs}::${rhs}");
372             } else {
373 0         0 return $self->parser->throw_error("We should not be here");
374             }
375             } else {
376             # var = number | string etc.
377 0 0       0 if ($rhs =~ /^-?\d+$/) {
378             # we just use the got_assign_expr. this should never be called in
379             # reality but is here in case the grammar rules change
380 0         0 $self->update_intermediate("SET::ASSIGN::${lhs}::${rhs}");
381             } else {
382             #VIKAS: check this!
383             # handle strings here
384 0         0 $self->ast->{variables}->{$lhs}->{type} = 'string';
385 0         0 $self->ast->{variables}->{$lhs}->{data} = $rhs;
386 0         0 $self->ast->{variables}->{$lhs}->{label} = $lhs;
387             $self->ast->{variables}->{$lhs}->{size} = "VIC_STRSZ_" .
388 0         0 $self->ast->{variables}->{$lhs}->{name};
389             }
390             }
391 3         17 return;
392             }
393              
394             sub got_conditional_statement {
395 12     12 0 242 my ($self, $list) = @_;
396 12         22 my ($type, $subject, $predicate) = @$list;
397 12 50       33 return unless scalar @$predicate;
398 12 100       26 my $is_loop = ($type eq 'while') ? 1 : 0;
399 12         22 my ($current, $parent) = $self->stack;
400 12         18 my $subcond = 0;
401 12 100       31 $subcond = 1 if $parent =~ /^conditional/;
402 12 50       29 if (ref $predicate ne 'ARRAY') {
403 0         0 $predicate = [ $predicate ];
404             }
405 12         18 my @condblocks = ();
406 12 50       33 if (scalar @$predicate < 3) {
407 12   50     742 my $tb = $predicate->[0] || undef;
408 12   50     137 my $fb = $predicate->[1] || undef;
409 12 50       132 $self->flatten($tb) if $tb;
410 12 50       107 $self->flatten($fb) if $fb;
411 12 50 50     150 my $true_block = $self->handle_named_block('True', @$tb) if $tb and scalar @$tb;
412 12 50       27 push @condblocks, $true_block if $true_block;
413 12 100 50     42 my $false_block = $self->handle_named_block('False', @$fb) if $fb and scalar @$fb;
414 12 100       25 push @condblocks, $false_block if $false_block;
415             } else {
416 0         0 return $self->parser->throw_error("Multiple predicate conditionals not implemented");
417             }
418 12         10 my $inter;
419 12 50       25 if (scalar @condblocks < 3) {
420 12         717 my ($false_label, $true_label, $end_label);
421 0         0 my ($false_name, $true_name);
422 12         19 foreach my $p (@condblocks) {
423 16 100       46 ($false_label, $false_name) = ($1, $2) if $p =~ /BLOCK::(\w+)::(False\d+)::/;
424 16 100       65 ($true_label, $true_name) = ($1, $2) if $p =~ /BLOCK::(\w+)::(True\d+)::/;
425 16 50       74 $end_label = $1 if $p =~ /BLOCK::.*::(_end_conditional\w+)$/;
426             }
427 12 100       33 $false_label = $end_label unless defined $false_label;
428 12 50       23 $true_label = $end_label unless defined $true_label;
429 12         16 my $subj = $subject;
430 12 50       23 $subj = shift @$subject if ref $subject eq 'ARRAY';
431             $inter = join("::",
432             COND => $self->ast->{conditionals},
433 12         26 SUBJ => $subj,
434             FALSE => $false_label,
435             TRUE => $true_label,
436             END => $end_label,
437             LOOP => $is_loop,
438             SUBCOND => $subcond);
439 12         485 my $mapping = $self->ast->{block_mapping};
440 12 50 33     60 if ($true_name and exists $mapping->{$true_name}) {
441 12         21 $mapping->{$true_name}->{loop} = "$is_loop";
442 12         153 my $ab = $mapping->{$true_name}->{block};
443 12         21 $mapping->{$ab}->{loop} = "$is_loop";
444             }
445 12 50 66     289 if ($false_name and exists $mapping->{$false_name}) {
446 4         9 $mapping->{$false_name}->{loop} = "$is_loop";
447 4         197 my $ab = $mapping->{$false_name}->{block};
448 4         8 $mapping->{$ab}->{loop} = "$is_loop";
449             }
450             } else {
451 0         0 return $self->parser->throw_error("Multiple predicate conditionals not implemented");
452             }
453 12         73 $self->update_intermediate($inter);
454 12 100       22 $self->ast->{conditionals}++ unless $subcond;
455 12         575 return;
456             }
457              
458             ##WARNING: do not change this function without looking at its effect on
459             #got_conditional_statement() above which calls this function explicitly
460             # this function is identical to got_expr_value() and hence redundant
461             # we may need to just use the same one although precedence will be different
462             # so maybe not
463             sub got_conditional_subject {
464 16     16 0 800 my ($self, $list) = @_;
465 16 50       39 if (ref $list eq 'ARRAY') {
466 16         44 $self->flatten($list);
467 16 100       187 if (scalar @$list == 1) {
    50          
    100          
468 4         215 my $var1 = shift @$list;
469 4 100       13 return $var1 if $var1 =~ /^\d+$/;
470 3         10 my $vref = $self->ast->{tmp_variables};
471 3         20 my $tvar = sprintf "_vic_tmp_%02d", scalar(keys %$vref);
472 3         10 $vref->{$tvar} = "OP::${var1}::EQ::1";
473 3         12 return $tvar;
474             } elsif (scalar @$list == 2) {
475 0         0 my ($op, $var) = @$list;
476 0         0 my $vref = $self->ast->{tmp_variables};
477 0         0 my $tvar = sprintf "_vic_tmp_%02d", scalar(keys %$vref);
478 0         0 $vref->{$tvar} = "OP::${op}::${var}";
479 0         0 return $tvar;
480             } elsif (scalar @$list == 3) {
481 11         1684 my ($var1, $op, $var2) = @$list;
482 11         27 my $vref = $self->ast->{tmp_variables};
483 11         79 my $tvar = sprintf "_vic_tmp_%02d", scalar(keys %$vref);
484 11         44 $vref->{$tvar} = "OP::${var1}::${op}::${var2}";
485 11         120 return $tvar;
486             } else {
487             # handle precedence with left-to-right association
488 1         157 my @arr = @$list;
489 1     2   15 my $idx = firstidx { $_ =~ /^GE|GT|LE|LT|EQ|NE$/ } @arr;
  2         6  
490 1         5 while ($idx >= 0) {
491 2         111 my $res = $self->got_conditional_subject([$arr[$idx - 1], $arr[$idx], $arr[$idx + 1]]);
492 2         7 $arr[$idx - 1] = $res;
493 2         189 splice @arr, $idx, 2; # remove the extra elements
494 2     7   24 $idx = firstidx { $_ =~ /^GE|GT|LE|LT|EQ|NE$/ } @arr;
  7         17  
495             }
496 1     2   55 $idx = firstidx { $_ =~ /^AND|OR$/ } @arr;
  2         5  
497 1         4 while ($idx >= 0) {
498 1         50 my $res = $self->got_conditional_subject([$arr[$idx - 1], $arr[$idx], $arr[$idx + 1]]);
499 1         4 $arr[$idx - 1] = $res;
500 1         87 splice @arr, $idx, 2; # remove the extra elements
501 1     1   13 $idx = firstidx { $_ =~ /^AND|OR$/ } @arr;
  1         6  
502             }
503             # YYY $self->ast->{tmp_variables};
504 1         52 return $self->got_conditional_subject([@arr]);
505             }
506             } else {
507 0         0 return $list;
508             }
509             }
510              
511             ##WARNING: do not change this function without looking at its effect on
512             #got_assign_expr() above which calls this function explicitly
513             sub got_expr_value {
514 296     296 0 7200 my ($self, $list) = @_;
515 296 50       521 if (ref $list eq 'ARRAY') {
516 296         575 $self->flatten($list);
517 296 100       2297 if (scalar @$list == 1) {
    100          
    100          
    50          
518 236         14066 my $val = shift @$list;
519 236 100       415 if ($val =~ /MOP::/) {
520 2         7 my $vref = $self->ast->{tmp_variables};
521 2         14 my $tvar = sprintf "_vic_tmp_%02d", scalar(keys %$vref);
522 2         6 $vref->{$tvar} = $val;
523 2         10 return $tvar;
524             } else {
525 234         1186 return $val;
526             }
527             } elsif (scalar @$list == 2) {
528 8         855 my ($op, $var) = @$list;
529 8         22 my $vref = $self->ast->{tmp_variables};
530 8         62 my $tvar = sprintf "_vic_tmp_%02d", scalar(keys %$vref);
531 8         28 $vref->{$tvar} = "OP::${op}::${var}";
532 8         30 return $tvar;
533             } elsif (scalar @$list == 3) {
534 46         6600 my ($var1, $op, $var2) = @$list;
535 46         97 my $vref = $self->ast->{tmp_variables};
536 46         293 my $tvar = sprintf "_vic_tmp_%02d", scalar(keys %$vref);
537 46         163 $vref->{$tvar} = "OP::${var1}::${op}::${var2}";
538 46         109 return $tvar;
539             } elsif (scalar @$list > 3) {
540             # handle precedence with left-to-right association
541 6         1126 my @arr = @$list;
542 6     24   64 my $idx = firstidx { $_ =~ /^MUL|DIV|MOD$/ } @arr;
  24         48  
543 6         32 while ($idx >= 0) {
544 8         418 my $res = $self->got_expr_value([$arr[$idx - 1], $arr[$idx], $arr[$idx + 1]]);
545 8         31 $arr[$idx - 1] = $res;
546 8         755 splice @arr, $idx, 2; # remove the extra elements
547 8     34   94 $idx = firstidx { $_ =~ /^MUL|DIV|MOD$/ } @arr;
  34         70  
548             }
549 6     12   338 $idx = firstidx { $_ =~ /^ADD|SUB$/ } @arr;
  12         28  
550 6         21 while ($idx >= 0) {
551 8         395 my $res = $self->got_expr_value([$arr[$idx - 1], $arr[$idx], $arr[$idx + 1]]);
552 8         26 $arr[$idx - 1] = $res;
553 8         700 splice @arr, $idx, 2; # remove the extra elements
554 8     10   87 $idx = firstidx { $_ =~ /^ADD|SUB$/ } @arr;
  10         46  
555             }
556 6     6   342 $idx = firstidx { $_ =~ /^SHL|SHR$/ } @arr;
  6         20  
557 6         20 while ($idx >= 0) {
558 0         0 my $res = $self->got_expr_value([$arr[$idx - 1], $arr[$idx], $arr[$idx + 1]]);
559 0         0 $arr[$idx - 1] = $res;
560 0         0 splice @arr, $idx, 2; # remove the extra elements
561 0     0   0 $idx = firstidx { $_ =~ /^SHL|SHR$/ } @arr;
  0         0  
562             }
563 6     6   314 $idx = firstidx { $_ =~ /^BAND|BXOR|BOR$/ } @arr;
  6         24  
564 6         21 while ($idx >= 0) {
565 0         0 my $res = $self->got_expr_value([$arr[$idx - 1], $arr[$idx], $arr[$idx + 1]]);
566 0         0 $arr[$idx - 1] = $res;
567 0         0 splice @arr, $idx, 2; # remove the extra elements
568 0     0   0 $idx = firstidx { $_ =~ /^BAND|BXOR|BOR$/ } @arr;
  0         0  
569             }
570             # YYY $self->ast->{tmp_variables};
571 6         281 return $self->got_expr_value([@arr]);
572             } else {
573 0         0 return $list;
574             }
575             } else {
576 0         0 return $list;
577             }
578             }
579              
580             sub got_math_operator {
581 42     42 0 1199 my ($self, $op) = @_;
582 42 100       109 return 'ADD' if $op eq '+';
583 26 100       61 return 'SUB' if $op eq '-';
584 20 100       57 return 'MUL' if $op eq '*';
585 10 100       29 return 'DIV' if $op eq '/';
586 4 50       21 return 'MOD' if $op eq '%';
587 0         0 return $self->parser->throw_error("Math operator '$op' is not supported");
588             }
589              
590             sub got_shift_operator {
591 4     4 0 111 my ($self, $op) = @_;
592 4 100       14 return 'SHL' if $op eq '<<';
593 2 50       11 return 'SHR' if $op eq '>>';
594 0         0 return $self->parser->throw_error("Shift operator '$op' is not supported");
595             }
596              
597             sub got_bit_operator {
598 0     0 0 0 my ($self, $op) = @_;
599 0 0       0 return 'BXOR' if $op eq '^';
600 0 0       0 return 'BOR' if $op eq '|';
601 0 0       0 return 'BAND' if $op eq '&';
602 0         0 return $self->parser->throw_error("Bitwise operator '$op' is not supported");
603             }
604              
605             sub got_logic_operator {
606 2     2 0 88 my ($self, $op) = @_;
607 2 100       10 return 'AND' if $op eq '&&';
608 1 50       6 return 'OR' if $op eq '||';
609 0         0 return $self->parser->throw_error("Logic operator '$op' is not supported");
610             }
611              
612             sub got_compare_operator {
613 37     37 0 1062 my ($self, $op) = @_;
614 37 100       101 return 'LE' if $op eq '<=';
615 36 50       84 return 'LT' if $op eq '<';
616 36 50       72 return 'GE' if $op eq '>=';
617 36 100       69 return 'GT' if $op eq '>';
618 35 100       118 return 'EQ' if $op eq '==';
619 4 50       21 return 'NE' if $op eq '!=';
620 0         0 return $self->parser->throw_error("Compare operator '$op' is not supported");
621             }
622              
623             sub got_complement_operator {
624 8     8 0 218 my ($self, $op) = @_;
625 8 50       35 return 'NOT' if $op eq '!';
626 0 0       0 return 'COMP' if $op eq '~';
627 0         0 return $self->parser->throw_error("Complement operator '$op' is not supported");
628             }
629              
630             sub got_assign_operator {
631 88     88 0 3349 my ($self, $op) = @_;
632 88 50       243 if (ref $op eq 'ARRAY') {
633 0         0 $self->flatten($op);
634 0         0 $op = shift @$op;
635             }
636 88 100       266 return 'ASSIGN' if $op eq '=';
637 25 100       55 return 'ADD_ASSIGN' if $op eq '+=';
638 23 100       61 return 'SUB_ASSIGN' if $op eq '-=';
639 21 100       40 return 'MUL_ASSIGN' if $op eq '*=';
640 19 100       38 return 'DIV_ASSIGN' if $op eq '/=';
641 17 100       42 return 'MOD_ASSIGN' if $op eq '%=';
642 15 100       44 return 'BXOR_ASSIGN' if $op eq '^=';
643 13 100       31 return 'BOR_ASSIGN' if $op eq '|=';
644 11 100       157 return 'BAND_ASSIGN' if $op eq '&=';
645 8 100       26 return 'SHL_ASSIGN' if $op eq '<<=';
646 6 100       43 return 'SHR_ASSIGN' if $op eq '>>=';
647 1 50       5 return 'CAT_ASSIGN' if $op eq '.=';
648 0         0 return $self->parser->throw_error("Assignment operator '$op' is not supported");
649             }
650              
651             sub got_unary_operator {
652 8     8 0 219 my ($self, $op) = @_;
653 8 100       54 return 'INC' if $op eq '++';
654 2 50       10 return 'DEC' if $op eq '--';
655 0         0 return $self->parser->throw_error("Increment/Decrement operator '$op' is not supported");
656             }
657              
658             sub got_array {
659 10     10 0 235 my ($self, $arr) = @_;
660 10 50       71 $self->flatten($arr) if ref $arr eq 'ARRAY';
661 10         433 $self->global_collections->{"$arr"} = $arr;
662 10         73 return $arr;
663             }
664              
665             sub got_modifier_constant {
666 12     12 0 275 my ($self, $list) = @_;
667             # we don't flatten since $value can be an array as well
668 12         34 my ($modifier, $value) = @$list;
669 12         27 $modifier = uc $modifier;
670             ## first check if the modifier is an operator
671 12         44 my $method = $self->pic->validate_modifier_operator($modifier);
672 12 50 33     43 $self->flatten($value) if ($method and ref $value eq 'ARRAY');
673 12 50       36 return $self->got_expr_value(["MOP::${modifier}::${value}"]) if $method;
674             ## if not then check if it is a type modifier for use by the simulator
675 12 100 66     39 if ($self->simulator and $self->simulator->supports_modifier($modifier)) {
676 11         420 my $hh = { $modifier => $value };
677 11         31 $self->global_collections->{"$hh"} = $hh;
678 11         78 return $hh;
679             }
680             ## ok check if the modifier is a type modifier for code generation
681             ## this is reallly a bad hack
682 1 50       33 if ($modifier eq 'TABLE') {
    0          
    0          
683 1 50       7 return { TABLE => $value } if ref $value eq 'ARRAY';
684 0         0 return { TABLE => [$value] };
685             } elsif ($modifier eq 'ARRAY') {
686 0 0       0 return $value if ref $value eq 'ARRAY';
687 0         0 return [$value];
688             } elsif ($modifier eq 'STRING') {
689 0 0       0 return { STRING => $value } if ref $value eq 'ARRAY';
690 0         0 return { STRING => [$value] };
691             }
692 0 0       0 $self->parser->throw_error("Modifying operator '$modifier' not supported") unless $method;
693             }
694              
695             sub got_modifier_variable {
696 2     2 0 47 my ($self, $list) = @_;
697 2         2 my ($modifier, $varname);
698 2 50       11 $self->flatten($list) if ref $list eq 'ARRAY';
699 2         13 $modifier = shift @$list;
700 2         4 $varname = shift @$list;
701 2         6 $modifier = uc $modifier;
702 2         6 my $method = $self->pic->validate_modifier_operator($modifier);
703 2 50       6 $self->parser->throw_error("Modifying operator '$modifier' not supported") unless $method;
704 2         10 return $self->got_expr_value(["MOP::${modifier}::${varname}"]);
705             }
706              
707             sub got_validated_variable {
708 207     207 0 9405 my ($self, $list) = @_;
709 207         199 my $varname;
710 207 50       446 if (ref $list eq 'ARRAY') {
711 207         528 $self->flatten($list);
712 207         1406 $varname = shift @$list;
713 207         252 my $suffix = shift @$list;
714 207 50       497 $varname .= $suffix if defined $suffix;
715             } else {
716 0         0 $varname = $list;
717             }
718 207 50       530 return $varname if $self->pic->validate($varname);
719 0         0 return $self->parser->throw_error("'$varname' is not a valid part of the " . uc $self->pic->type);
720             }
721              
722             sub got_variable {
723 419     419 0 8785 my ($self, $list) = @_;
724 419 50       1416 $self->flatten($list) if ref $list eq 'ARRAY';
725 419         2317 my $varname = shift @$list;
726 419         687 my ($current, $parent) = $self->stack;
727             # if the variable is used from the pragma grammar rule
728             # we do not want to store it yet and definitely not store the size yet
729             # we could remove this if we set the size after the code generation or so
730             # but that may lead to more complexity. this is much easier
731 419 50       874 return $varname if $parent eq 'pragmas';
732             $self->ast->{variables}->{$varname} = {
733             name => uc $varname,
734             scope => $self->ast->{block_stack}->[-1],
735             size => POSIX::ceil($self->pic->address_bits($varname) / 8),
736             type => 'byte',
737             data => undef,
738 419 100       791 } unless exists $self->ast->{variables}->{$varname};
739 419 100       6507 $self->ast->{variables}->{$varname}->{scope} = 'global' if $parent =~ /assert_/;
740 419         1084 return $varname;
741             }
742              
743             sub got_boolean {
744 11     11 0 288 my ($self, $list) = @_;
745 11         10 my $b;
746 11 50       27 if (ref $list eq 'ARRAY') {
747 0         0 $self->flatten($list);
748 0         0 $b = shift @$list;
749             } else {
750 11         14 $b = $list;
751             }
752 11 50       24 return 0 unless defined $b;
753 11 100       61 return 1 if $b =~ /TRUE|true/i;
754 5 50       16 return 1 if $b == 1;
755 5 50       355 return 0 if $b =~ /FALSE|false/i;
756 0         0 return 0; # default boolean is false
757             }
758              
759             sub got_double_quoted_string {
760 43     43 0 1550 my $self = shift;
761 43         63 my $str = pop;
762             ## Ripped from Ingy's pegex-json-pm Pegex::JSON::Data
763             ## Unicode support not implemented yet but available in Pegex::JSON::Data
764 43         389 my %escapes = (
765             '"' => '"',
766             '/' => '/',
767             "\\" => "\\",
768             b => "\b",
769             f => "\x12",
770             n => "\n",
771             r => "\r",
772             t => "\t",
773             0 => "\0",
774             );
775 43         875 $str =~ s/\\(["\/\\bfnrt0])/$escapes{$1}/ge;
  3         10  
776 43         153 return $str;
777             }
778              
779             sub got_string {
780 48     48 0 952 my $self = shift;
781 48         58 my $str = shift;
782             ##TODO: handle empty strings as initializers
783             # store only unique strings otherwise re-use them
784 48         70 foreach (%{$self->global_collections}) {
  48         162  
785 585         802 my $h = $self->global_collections->{$_};
786 585 100       1553 return $h if ($h->{string} eq $str);
787             }
788 47 100       189 my $is_empty = 1 if $str eq '';
789             my $stref = {
790             string => $str,
791             block => $self->ast->{block_stack}->[-1],
792 47         123 name => sprintf("_vic_str_%02d", $self->ast->{strings}),
793             size => length($str) + 1, # trailing null byte
794             empty => $is_empty, # required for variable allocation later
795             };
796 47         6417 $self->global_collections->{"$stref"} = $stref;
797 47         253 $self->ast->{strings}++;
798 47         1531 return $stref;
799             #return '@' . $str;
800             }
801              
802             sub got_number {
803 400     400 0 15358 my ($self, $list) = @_;
804             # if it is a hexadecimal number we can just convert it to number using int()
805             # since hex is returned here as a string
806 400 100       1977 return hex($list) if $list =~ /0x|0X/;
807 344         771 my $val = int($list);
808 344 50       1041 return $val if $val >= 0;
809             ##TODO: check the negative value
810 0         0 my $bits = (2 ** $self->pic->address_bits) - 1;
811 0         0 $val = sprintf "0x%02X", $val;
812 0         0 return hex($val) & $bits;
813             }
814              
815             # convert the number to appropriate units
816             sub got_number_units {
817 51     51 0 1143 my ($self, $list) = @_;
818 51         170 $self->flatten($list);
819 51         369 my $num = shift @$list;
820 51         106 my $units = shift @$list;
821 51 50       149 return $num unless defined $units;
822 51 100       131 $num *= 1 if $units eq 'us';
823 51 100       476 $num *= 1000 if $units eq 'ms';
824 51 100       1732 $num *= 1e6 if $units eq 's';
825 51 100       2219 $num *= 1 if $units eq 'Hz';
826 51 100       792 $num *= 1000 if $units eq 'kHz';
827 51 50       621 $num *= 1e6 if $units eq 'MHz';
828             # ignore the '%' sign for now
829 51         157 return $num;
830             }
831              
832             sub got_real_number {
833 5     5 0 190 my ($self, $list) = @_;
834 5 50       13 $list .= '0' if $list =~ /\d+\.$/;
835 5 50       7 $list = "0.$1" if $list =~ /^\.(\d+)$/;
836 5 50       8 $list = "-0.$1" if $list =~ /^-\.(\d+)$/;
837 5         11 return $list;
838             }
839              
840             # remove the dumb stuff from the tree
841 68     68 0 2616 sub got_comment { return; }
842              
843             sub _update_funcs {
844 66     66   74 my ($self, $funcs, $macros) = @_;
845 66 50       165 if (ref $funcs eq 'HASH') {
846 66         173 foreach (keys %$funcs) {
847 21         221 $self->ast->{funcs}->{$_} = $funcs->{$_};
848             }
849             }
850 66 50       222 if (ref $macros eq 'HASH') {
851 66 50       129 return unless ref $macros eq 'HASH';
852 66         145 foreach (keys %$macros) {
853 140         398 $self->ast->{macros}->{$_} = $macros->{$_};
854             }
855             }
856 66         193 1;
857             }
858              
859             sub _update_tables {
860 18     18   19 my ($self, $tables) = @_;
861 18 50       37 if (ref $tables eq 'HASH') {
862 0         0 $tables = [ $tables ];
863             }
864 18 50       40 unless (ref $tables eq 'ARRAY') {
865 0         0 return $self->parser->throw_error(
866             "Code generation error. PIC methods should return strings as a HASH or ARRAY");
867             }
868 18         28 foreach my $s (@$tables) {
869 5 50       15 next unless defined $s->{bytes};
870 5 50       8 next unless defined $s->{name};
871 5         4 push @{$self->ast->{tables}}, $s;
  5         15  
872             }
873 18         32 1;
874             }
875              
876             ## assert handling is special for now
877             sub got_assert_comparison {
878 28     28 0 632 my ($self, $list) = @_;
879 28 50       80 return unless $self->simulator;
880 28 50       200 $self->flatten($list) if ref $list eq 'ARRAY';
881 28 50       483 if (scalar @$list < 3) {
882 0         0 return $self->parser->throw_error("Error in assert statement");
883             }
884 28         1822 return join("@@", @$list);
885             }
886              
887             sub got_assert_statement {
888 28     28 0 653 my ($self, $list) = @_;
889 28 50       120 $self->flatten($list) if ref $list eq 'ARRAY';
890 28         689 my ($method, $cond, $msg) = @$list;
891 28 100       60 $msg = '' unless defined $msg;
892 28         74 $self->ast->{asserts}++;
893 28         924 $self->update_intermediate("SIM::${method}::${cond}::${msg}");
894 28         78 return;
895             }
896              
897             sub generate_simulator_instruction {
898 130     130 0 138 my ($self, $line) = @_;
899 130         319 my @ins = split /::/, $line;
900 130         130 my $tag = shift @ins;
901 130         121 my $method = shift @ins;
902 130         132 my @code = ();
903 130 50       233 push @code, "\t;; $line" if $self->intermediate_inline;
904 130         528 foreach (@ins) {
905 188 100       511 next unless /HASH|ARRAY/;
906 50 50       106 next unless exists $self->global_collections->{$_};
907 50         261 $_ = $self->global_collections->{$_};
908             }
909 130 100       359 return @code if $self->simulator->disable;
910 129         2846 my $code = $self->simulator->$method(@ins);
911 129 50       656 return $self->parser->throw_error("Error in simulator intermediate code '$line'") unless $code;
912 129 50       243 push @code, $code if $code;
913 129         365 return @code;
914             }
915              
916             sub generate_code_instruction {
917 136     136 0 161 my ($self, $line) = @_;
918 136         393 my @ins = split /::/, $line;
919 136         170 my $tag = shift @ins;
920 136         406 my $method = shift @ins;
921 136         162 my @code = ();
922 136         209 foreach (@ins) {
923 269 100       715 if (exists $self->global_collections->{$_}) {
924 6         32 $_ = $self->global_collections->{$_};
925 6         23 next;
926             }
927 263 100       1002 if (exists $self->ast->{variables}->{$_}) {
928 29         120 my $vhref = $self->ast->{variables}->{$_};
929 29 100       127 if ($vhref->{type} eq 'string') {
930             # send the string variable information to the method
931             # and hope that the method knows how to handle it
932             # this is useful for I/O methods and operator methods
933             # other methods should outright fail to use this and it should
934             # make sense there.#TODO: make better error messages for that.
935 1         2 $_ = $vhref;
936             }
937             }
938             }
939 136         583 my ($code, $funcs, $macros, $tables) = $self->pic->$method(@ins);
940 136 100       446 return $self->parser->throw_error("Error in intermediate code '$line'") unless $code;
941 135 50       318 push @code, "\t;; $line" if $self->intermediate_inline;
942 135 50       661 push @code, $code if $code;
943 135 100 66     540 $self->_update_funcs($funcs, $macros) if ($funcs or $macros);
944 135 100       255 $self->_update_tables($tables) if $tables;
945 135         493 return @code;
946             }
947              
948             sub generate_code_unary_expr {
949 8     8 0 16 my ($self, $line) = @_;
950 8         13 my @code = ();
951 8         19 my $ast = $self->ast;
952 8         39 my ($tag, $op, $varname) = split /::/, $line;
953 8         21 my $method = $self->pic->validate_operator($op);
954 8 50       22 $self->parser->throw_error("Invalid operator '$op' in intermediate code") unless $self->pic->can($method);
955             # check if temporary variable or not
956 8 50       64 if (exists $ast->{variables}->{$varname}) {
957 8   33     28 my $nvar = $ast->{variables}->{$varname}->{name} || $varname;
958 8         19 my ($code, $funcs, $macros, $tables) = $self->pic->$method($nvar);
959 8 50       27 return $self->parser->throw_error("Error in intermediate code '$line'") unless $code;
960 8 50       27 push @code, "\t;; $line" if $self->intermediate_inline;
961 8 50       46 push @code, $code if $code;
962 8 50 33     72 $self->_update_funcs($funcs, $macros) if ($funcs or $macros);
963 8 50       23 $self->_update_tables($tables) if $tables;
964             } else {
965 0         0 return $self->parser->throw_error("Error in intermediate code '$line'");
966             }
967 8         26 return @code;
968             }
969              
970             sub generate_code_operations {
971 70     70 0 148 my ($self, $line, %extra) = @_;
972 70         67 my @code = ();
973 70         160 my ($tag, @args) = split /::/, $line;
974 70         64 my ($op, $var1, $var2);
975 70 100       127 if (scalar @args == 2) {
    100          
    50          
976 9         491 $op = shift @args;
977 9         18 $var1 = shift @args;
978             } elsif (scalar @args == 3) {
979 60         6043 $var1 = shift @args;
980 60         63 $op = shift @args;
981 60         55 $var2 = shift @args;
982             } elsif (scalar @args == 4) {
983 1         145 $var1 = shift @args;
984 1         2 $op = shift @args;
985 1         1 $var2 = shift @args;
986 1         2 my $var3 = shift @args;
987 1         2 $extra{SIZE} = $var3;
988             } else {
989 0         0 return $self->parser->throw_error("Error in intermediate code '$line'");
990             }
991 70 100       133 if (exists $extra{STACK}) {
992 36 50       55 if (defined $var1) {
993 36   66     99 $var1 = $extra{STACK}->{$var1} || $var1;
994             }
995 36 100       48 if (defined $var2) {
996 35   100     84 $var2 = $extra{STACK}->{$var2} || $var2;
997             }
998             }
999 70 100       206 my $method = $self->pic->validate_operator($op) if $tag eq 'OP';
1000 70 100       135 $method = $self->pic->validate_modifier_operator($op) if $tag eq 'MOP';
1001 70 50 33     177 $self->parser->throw_error("Invalid operator '$op' in intermediate code") unless
1002             ($method and $self->pic->can($method));
1003 70 50       440 push @code, "\t;; $line" if $self->intermediate_inline;
1004 70         253 my ($code, $funcs, $macros, $tables) = $self->pic->$method($var1, $var2, %extra);
1005 70 50       126 return $self->parser->throw_error("Error in intermediate code '$line'") unless $code;
1006 70 50       129 push @code, $code if $code;
1007 70 100 66     232 $self->_update_funcs($funcs, $macros) if ($funcs or $macros);
1008 70 50       98 $self->_update_tables($tables) if $tables;
1009 70         193 return @code;
1010             }
1011              
1012             sub find_tmpvar_dependencies {
1013 70     70 0 68 my ($self, $tvar) = @_;
1014 70         113 my $tcode = $self->ast->{tmp_variables}->{$tvar};
1015 70         293 my ($tag, @args) = split /::/, $tcode;
1016 70 100       138 return unless $tag eq 'OP';
1017 68         65 my @deps = ();
1018 68         49 my $sz = scalar @args;
1019 68 100 66     124 if ($sz == 2) {
    50          
1020 7         406 my ($op, $var) = @args;
1021 7 50       18 if (exists $self->ast->{tmp_variables}->{$var}) {
1022 0         0 push @deps, $var;
1023 0         0 my @rdeps = $self->find_tmpvar_dependencies($var);
1024 0 0       0 push @deps, @rdeps if @rdeps;
1025             }
1026             } elsif ($sz == 3 or $sz == 4) {
1027 61         5950 my ($var1, $op, $var2) = @args;
1028 61 100       113 if (exists $self->ast->{tmp_variables}->{$var1}) {
1029 15         55 push @deps, $var1;
1030 15         58 my @rdeps = $self->find_tmpvar_dependencies($var1);
1031 15 100       30 push @deps, @rdeps if @rdeps;
1032             }
1033 61 100       203 if (exists $self->ast->{tmp_variables}->{$var2}) {
1034 13         44 push @deps, $var2;
1035 13         29 my @rdeps = $self->find_tmpvar_dependencies($var2);
1036 13 100       28 push @deps, @rdeps if @rdeps;
1037             }
1038             } else {
1039 0         0 return $self->parser->throw_error("Error in intermediate code '$tcode'");
1040             }
1041 68 50       320 return wantarray ? @deps : \@deps;
1042             }
1043              
1044             sub find_var_dependencies {
1045 42     42 0 40 my ($self, $tvar) = @_;
1046 42         82 my $tcode = $self->ast->{tmp_variables}->{$tvar};
1047 42         164 my ($tag, @args) = split /::/, $tcode;
1048 42 100       84 return unless $tag eq 'OP';
1049 40         41 my @deps = ();
1050 40         37 my $sz = scalar @args;
1051 40 100 66     68 if ($sz == 2) {
    50          
1052 6         359 my ($op, $var) = @args;
1053 6 50       15 if (exists $self->ast->{variables}->{$var}) {
1054 6         29 push @deps, $var;
1055             }
1056             } elsif ($sz == 3 or $sz == 4) {
1057 34         3191 my ($var1, $op, $var2) = @args;
1058 34 100       65 if (exists $self->ast->{variables}->{$var1}) {
1059 27         111 push @deps, $var1;
1060             }
1061 34 100       72 if (exists $self->ast->{variables}->{$var2}) {
1062 12         40 push @deps, $var2;
1063             }
1064             } else {
1065 0         0 return $self->parser->throw_error("Error in intermediate code '$tcode'");
1066             }
1067 40 50       177 return wantarray ? @deps : \@deps;
1068             }
1069              
1070             sub do_i_use_stack {
1071 34     34 0 46 my ($self, @deps) = @_;
1072 34 100       55 return 0 unless @deps;
1073 32         45 my @bits = map { $self->pic->address_bits($_) } @deps;
  43         83  
1074 32 50       101 return 0 if max(@bits) == $self->pic->wreg_size;
1075 0         0 return 1;
1076             }
1077              
1078             sub generate_code_assign_expr {
1079 88     88 0 94 my ($self, $line) = @_;
1080 88         96 my @code = ();
1081 88         170 my $ast = $self->ast;
1082 88         395 my ($tag, $op, $varname, $rhs) = split /::/, $line;
1083 88 50       154 push @code, ";;; $line\n" if $self->intermediate_inline;
1084 88 50       510 if (exists $ast->{variables}->{$varname}) {
1085 88 100       167 if (exists $ast->{tmp_variables}->{$rhs}) {
1086 31         43 my $tmp_code = $ast->{tmp_variables}->{$rhs};
1087 31         66 my @deps = $self->find_tmpvar_dependencies($rhs);
1088 31         58 my @vdeps = $self->find_var_dependencies($rhs);
1089 31 100       60 push @deps, $rhs if @deps;
1090 31 50       59 if ($self->intermediate_inline) {
1091 0 0       0 push @code, "\t;; TMP_VAR DEPS - $rhs, ". join (',', @deps) if @deps;
1092 0 0       0 push @code, "\t;; VAR DEPS - ". join (',', @vdeps) if @vdeps;
1093 0         0 foreach (sort @deps) {
1094 0         0 my $tcode = $ast->{tmp_variables}->{$_};
1095 0         0 push @code, "\t;; $_ = $tcode";
1096             }
1097 0         0 push @code, "\t;; $line";
1098             }
1099 31 100       123 if (scalar @deps) {
1100 6         18 $ast->{tmp_stack_size} = max(scalar(@deps), $ast->{tmp_stack_size});
1101             ## it is assumed that the dependencies and intermediate code are
1102             #arranged in expected order
1103             # TODO: bits check
1104 6         101 my $counter = 0;
1105 6         23 my %tmpstack = map { $_ => 'VIC_STACK + ' . $counter++ } sort(@deps);
  30         994  
1106 6         245 foreach (sort @deps) {
1107 30         42 my $tcode = $ast->{tmp_variables}->{$_};
1108 30         26 my $result = $tmpstack{$_};
1109 30 100       55 $result = uc $varname if $_ eq $rhs;
1110 30 50       67 my @newcode = $self->generate_code_operations($tcode,
1111             STACK => \%tmpstack, RESULT => $result) if $tcode;
1112 30 50       54 push @code, "\t;; $_ = $tcode" if $self->intermediate_inline;
1113 30 50       142 push @code, @newcode if @newcode;
1114             }
1115             } else {
1116             # no tmp-var dependencies
1117 25 50       87 my $use_stack = $self->do_i_use_stack(@vdeps) unless scalar @deps;
1118 25 50       159 unless ($use_stack) {
1119 25         350 my @newcode = $self->generate_code_operations($tmp_code,
1120             RESULT => uc $varname);
1121 25 50       68 push @code, @newcode if @newcode;
1122             } else {
1123             # TODO: stack
1124 0         0 XXX @vdeps;
1125             }
1126             }
1127             } else {
1128 57   33     139 my $nvar = $ast->{variables}->{$varname}->{name} || $varname;
1129 57 100       140 if ($rhs =~ /HASH|ARRAY/) {
1130 2 50       5 if (exists $self->global_collections->{$rhs}) {
1131 2         11 $rhs = $self->global_collections->{$rhs};
1132             }
1133             }
1134 57 50       107 if (exists $self->ast->{variables}->{$varname}) {
1135 57         249 my $vhref = $self->ast->{variables}->{$varname};
1136 57 100       238 if ($vhref->{type} eq 'string') {
1137             # send the string variable information to the method
1138             # and hope that the method knows how to handle it
1139             # this is useful for I/O methods and operator methods
1140             # other methods should outright fail to use this and it should
1141             # make sense there.#TODO: make better error messages for that.
1142 3         3 $nvar = $vhref;
1143             }
1144             }
1145 57         123 my $method = $self->pic->validate_operator($op);
1146 57 50       103 $self->parser->throw_error("Invalid operator '$op' in intermediate code") unless $self->pic->can($method);
1147 57         366 my ($code, $funcs, $macros, $tables) = $self->pic->$method($nvar, $rhs);
1148 57 50       124 return $self->parser->throw_error("Error in intermediate code '$line'") unless $code;
1149 57 50       144 push @code, "\t;; $line" if $self->intermediate_inline;
1150 57 50       290 push @code, $code if $code;
1151 57 100 66     236 $self->_update_funcs($funcs, $macros) if ($funcs or $macros);
1152 57 100       127 $self->_update_tables($tables) if $tables;
1153             }
1154             } else {
1155 0         0 return $self->parser->throw_error(
1156             "Error in intermediate code '$line': $varname doesn't exist");
1157             }
1158 88         276 return @code;
1159             }
1160              
1161             sub find_nearest_loop {
1162 7     7 0 7 my ($self, $mapping, $child) = @_;
1163 7 50       12 return unless exists $mapping->{$child};
1164 7 50       10 if (exists $mapping->{$child}->{loop}) {
1165 7 100       17 return $child if $mapping->{$child}->{loop} eq '1';
1166             }
1167 3 50       6 return unless $mapping->{$child}->{parent};
1168 3         8 return $self->find_nearest_loop($mapping, $mapping->{$child}->{parent});
1169             }
1170              
1171             sub generate_code_blocks {
1172 43     43 0 63 my ($self, $line, $block) = @_;
1173 43         64 my @code = ();
1174 43         100 my $ast = $self->ast;
1175 43         142 my $mapping = $ast->{block_mapping};
1176 43   33     138 my $mapped_block = $mapping->{$block}->{block} || $block;
1177 43         167 my ($tag, $label, $child, $parent, $parent_label, $end_label) = split/::/, $line;
1178 43 50 33     319 return if ($child eq $block or $child eq $mapped_block or $child eq $parent);
      33        
1179 43 50       100 return if exists $ast->{generated_blocks}->{$child};
1180 43 50       92 push @code, "\t;; $line" if $self->intermediate_inline;
1181 43         385 my @newcode = $self->generate_code($ast, $child);
1182 43     192   397 my @bindexes = indexes { $_ eq 'BREAK' } @newcode;
  192         191  
1183 43     192   187 my @cindexes = indexes { $_ eq 'CONTINUE' } @newcode;
  192         150  
1184 43 100 66     479 if ($child =~ /^(?:True|False)/ and @newcode) {
    100 66        
    50 33        
1185 16         67 my $cond_end = "\tgoto $end_label;; go back to end of conditional\n";
1186             # handle break
1187 16 100       37 if (@bindexes) {
1188             #find top most parent loop
1189 2         4 my $el = $self->find_nearest_loop($mapping, $child);
1190 2 50       5 $el = $mapping->{$el}->{end_label} if $el;
1191 2         1 my $break_end;
1192 2 50       5 unless ($el) {
1193 0         0 $break_end = "\t;; break from existing block since $child not part of any loop\n";
1194 0         0 $break_end .= "\tgoto $end_label;; break from the conditional\n";
1195             } else {
1196 2         5 $break_end = "\tgoto $el;; break from the conditional\n";
1197             }
1198 2         4 $newcode[$_] = $break_end foreach @bindexes;
1199             }
1200             # handle continue
1201 16 100       27 if (@cindexes) {
1202             #find top most parent loop
1203 2         4 my $sl = $self->find_nearest_loop($mapping, $child);
1204 2 50       4 $sl = $mapping->{$sl}->{start_label} if $sl;
1205 2 50       5 my $cont_start = "\tgoto $sl;; go back to start of conditional\n" if $sl;
1206 2 50       16 $cont_start = "\tnop ;; $child or $parent have no start_label" unless $sl;
1207 2         5 $newcode[$_] = $cont_start foreach @cindexes;
1208             }
1209             # add the end _label
1210             # if the current block is a loop, the end label is the start label
1211 16 100 66     77 if (exists $mapping->{$child}->{loop} and $mapping->{$child}->{loop} eq '1') {
1212 4   33     11 my $slabel = $mapping->{$child}->{start_label} || $end_label;
1213 4 50       10 my $start_code = "\tgoto $slabel ;; go back to start of conditional\n" if $slabel;
1214 4 50       13 $start_code = $cond_end unless $start_code;
1215 4         11 push @newcode, $start_code;
1216             } else {
1217 12         15 push @newcode, $cond_end;
1218             }
1219 16         22 push @newcode, ";;;; end of $label";
1220             # hack into the function list
1221 16         52 $ast->{funcs}->{$label} = [@newcode];
1222             } elsif ($child =~ /^(?:Action|ISR)/ and @newcode) {
1223 11         31 my $cond_end = "\tgoto $end_label ;; go back to end of block\n";
1224 11 50       32 if (@bindexes) {
1225             # we just break from the current block since we are not in any
1226             # sub-block
1227 0         0 my $break_end = "\tgoto $end_label ;; break from the block\n";
1228 0         0 $newcode[$_] = $break_end foreach @bindexes;
1229             }
1230 11 50       29 if (@cindexes) {
1231             # continue gets ignored
1232 0         0 my $cont_start = ";; continue is a NOP for $child block";
1233 0         0 $newcode[$_] = $cont_start foreach @cindexes;
1234             }
1235 11         32 push @newcode, $cond_end, ";;;; end of $label";
1236             # hack into the function list
1237 11         47 $ast->{funcs}->{$label} = [@newcode];
1238             } elsif ($child =~ /^Loop/ and @newcode) {
1239 16         50 my $cond_end = "\tgoto $end_label;; go back to end of block\n";
1240 16 50       59 if (@bindexes) {
1241             # we just break from the current block since we are not in any
1242             # sub-block and are in a Loop already
1243 0         0 my $break_end = "\tgoto $end_label ;; break from the block\n";
1244 0         0 $newcode[$_] = $break_end foreach @bindexes;
1245             }
1246 16 50       49 if (@cindexes) {
1247             # continue goes to start of the loop
1248 0         0 my $cont_start = "\tgoto $label ;; go back to start of loop\n";
1249 0         0 $newcode[$_] = $cont_start foreach @cindexes;
1250             }
1251 16         47 push @code, @newcode;
1252 16         51 push @code, "\tgoto $label ;;;; end of $label\n";
1253 16         45 push @code, "$end_label:\n";
1254             } else {
1255 0 0       0 push @code, @newcode if @newcode;
1256             }
1257 43 50       136 $ast->{generated_blocks}->{$child} = 1 if @newcode;
1258             # parent equals block if it is the topmost of the stack
1259             # if the child is not a loop construct it will need a goto back to
1260             # the parent construct. if a child is a loop construct it will
1261             # already have a goto back to itself
1262 43 50 33     405 if (defined $parent and exists $ast->{$parent} and
      33        
      33        
1263             ref $ast->{$parent} eq 'ARRAY' and $parent ne $mapped_block) {
1264 0         0 my ($ptag, $plabel) = split /::/, $ast->{$parent}->[0];
1265 0 0       0 push @code, "\tgoto $plabel;; $plabel" if $plabel;
1266             }
1267 43         173 return @code;
1268             }
1269              
1270             sub generate_code_conditionals {
1271 9     9 0 16 my ($self, @condblocks) = @_;
1272 9         16 my @code = ();
1273 9         22 my $ast = $self->ast;
1274 9         27 my ($start_label, $end_label, $is_loop);
1275 9         12 my $blockcount = scalar @condblocks;
1276 9         11 my $index = 0;
1277 9         14 foreach my $line (@condblocks) {
1278 12 50       32 push @code, "\t;; $line" if $self->intermediate_inline;
1279 12         109 my %hh = split /::/, $line;
1280 12         23 my $subj = $hh{SUBJ};
1281 12 100       29 $index++ if $hh{SUBCOND};
1282             # for multiple if-else-if-else we adjust the labels
1283             # for single ones we do not
1284 12 100       107 $start_label = "_start_conditional_$hh{COND}" unless defined $start_label;
1285 12 100       25 $is_loop = $hh{LOOP} unless defined $is_loop;
1286 12 100       21 $end_label = $hh{END} unless defined $end_label;
1287             # we now modify the TRUE/FALSE/END labels
1288 12 100       33 if ($blockcount > 1) {
1289 4         223 my $el = "$hh{END}_$index"; # new label
1290 4 100       63 $hh{FALSE} = $el if $hh{FALSE} eq $hh{END};
1291 4 50       6 $hh{TRUE} = $el if $hh{TRUE} eq $hh{END};
1292 4         6 $hh{END} = $el;
1293             }
1294 12 100       512 if ($subj =~ /^\d+?$/) { # if subject is a literal
    50          
    50          
1295 1 50       3 push @code, "\t;; $line" if $self->intermediate_inline;
1296 1 50       6 if ($subj eq 0) {
1297             # is false
1298 0 0       0 push @code, "\tgoto $hh{FALSE}" if $hh{FALSE};
1299             } else {
1300             # is true
1301 1 50       22 push @code, "\tgoto $hh{TRUE}" if $hh{TRUE};
1302             }
1303 1 50       3 push @code, "\tgoto $hh{END}" if $hh{END};
1304 1 50       5 push @code, "$hh{END}:\n" if $hh{END};
1305             } elsif (exists $ast->{variables}->{$subj}) {
1306             ## we will never get here actually since we have eliminated this
1307             #possibility
1308 0         0 XXX \%hh;
1309             } elsif (exists $ast->{tmp_variables}->{$subj}) {
1310 11         14 my $tmp_code = $ast->{tmp_variables}->{$subj};
1311 11         23 my @deps = $self->find_tmpvar_dependencies($subj);
1312 11         21 my @vdeps = $self->find_var_dependencies($subj);
1313 11 100       22 push @deps, $subj if @deps;
1314 11 50       24 if ($self->intermediate_inline) {
1315 0 0       0 push @code, "\t;; TMP_VAR DEPS - $subj, ". join (',', @deps) if @deps;
1316 0 0       0 push @code, "\t;; VAR DEPS - ". join (',', @vdeps) if @vdeps;
1317 0         0 push @code, "\t;; $subj = $tmp_code";
1318             }
1319 11 100       44 if (scalar @deps) {
1320 2         6 $ast->{tmp_stack_size} = max(scalar(@deps), $ast->{tmp_stack_size});
1321             ## it is assumed that the dependencies and intermediate code are
1322             #arranged in expected order
1323             # TODO: bits check
1324 2         49 my $counter = 0;
1325 2         6 my %tmpstack = map { $_ => 'VIC_STACK + ' . $counter++ } sort(@deps);
  6         182  
1326 2         104 $counter = 0; # reset
1327 2         6 foreach (sort @deps) {
1328 6         10 my $tcode = $ast->{tmp_variables}->{$_};
1329 6         18 my %extra = (%hh, COUNTER => $counter++);
1330 6 100       209 $extra{RESULT} = $tmpstack{$_} if $_ ne $subj;
1331 6 50       26 my @newcode = $self->generate_code_operations($tcode,
1332             STACK => \%tmpstack, %extra) if $tcode;
1333 6 50       27 push @code, @newcode if @newcode;
1334             }
1335             } else {
1336             # no tmp-var dependencies
1337 9         20 my $use_stack = $self->do_i_use_stack(@vdeps);
1338 9 50       54 unless ($use_stack) {
1339 9         138 my @newcode = $self->generate_code_operations($tmp_code, %hh);
1340 9 50       23 push @code, @newcode if @newcode;
1341 9 50       38 return $self->parser->throw_error("Error in intermediate code '$tmp_code'")
1342             unless @newcode;
1343             } else {
1344             # TODO: stack
1345 0         0 XXX \%hh;
1346             }
1347             }
1348             } else {
1349 0         0 return $self->parser->throw_error("Error in intermediate code '$line'");
1350             }
1351             }
1352 9 50       34 unshift @code, "$start_label:" if defined $start_label;
1353 9 100 66     36 push @code, "$end_label:" if defined $end_label and $blockcount > 1;
1354 9         619 return @code;
1355             }
1356              
1357             sub generate_code {
1358 94     94 0 141 my ($self, $ast, $block_name) = @_;
1359 94         134 my @code = ();
1360 94 0       221 return wantarray ? @code : [] unless defined $ast;
    50          
1361 94 50       209 return wantarray ? @code : [] unless exists $ast->{$block_name};
    100          
1362 93 100       240 $ast->{generated_blocks} = {} unless defined $ast->{generated_blocks};
1363 93         193 push @code, ";;;; generated code for $block_name";
1364 93         131 my $blocks = $ast->{$block_name};
1365 93         208 while (@$blocks) {
1366 510         553 my $line = shift @$blocks;
1367 510 100       728 next unless defined $line;
1368 507 100       2593 if ($line =~ /^BLOCK::\w+/) {
    100          
    100          
    100          
    100          
    100          
    100          
    50          
1369 43   50     446 my $blockparams = $ast->{block_mapping}->{$block_name}->{params} || [];
1370 43         195 push @code, $self->generate_code_blocks($line, $block_name, $blockparams);
1371             } elsif ($line =~ /^INS::\w+/) {
1372 136         310 push @code, $self->generate_code_instruction($line);
1373             } elsif ($line =~ /^UNARY::\w+/) {
1374 8         33 push @code, $self->generate_code_unary_expr($line);
1375             } elsif ($line =~ /^SET::\w+/) {
1376 83         165 push @code, $self->generate_code_assign_expr($line);
1377             } elsif ($line =~ /^PARAM::(\w+)::(\w+)::(\w+)/) {
1378 5 50       15 if (exists $ast->{block_mapping}->{$block_name}) {
1379 5         13 my $op = $1;
1380 5         10 my $pblock = $2;
1381 5         15 my $pvar = $3;
1382 5         8 my $mapping = $ast->{block_mapping}->{$pblock};
1383 5         12 my $param_idx = scalar @{$mapping->{params}};
  5         9  
1384 5   33     18 my $paramvar = $mapping->{param_prefix} || lc($block_name . '_param');
1385 5         8 $paramvar .= $param_idx;
1386 5         6 push @{$mapping->{params}}, $paramvar;
  5         12  
1387             # map the param index back to the other mapping too
1388 5 50 33     30 if ($pblock ne $block_name and $mapping->{block} eq $block_name) {
1389 5         7 my $mapping2 = $ast->{block_mapping}->{$block_name};
1390 5         11 $mapping2->{params} = $mapping->{params};
1391             }
1392 5         16 my $pline = "SET::${op}::${pvar}::${paramvar}";
1393             #YYY [$pblock, $pvar, $block_name, $param_idx, $pline, $paramvar];
1394 5         20 push @code, $self->generate_code_assign_expr($pline);
1395             } else {
1396 0         0 $self->parser->throw_error("Intermediate code '$line' in block "
1397             . "$block_name cannot be handled");
1398             }
1399             } elsif ($line =~ /^LABEL::(\w+)/) {
1400 93         203 my $lbl = $1;
1401 93 50       241 push @code, ";; $line" if $self->intermediate_inline;
1402 93 100       619 push @code, "$lbl:\n" if $lbl ne '_vic_simulator';
1403             } elsif ($line =~ /^COND::(\d+)::/) {
1404 9         18 my $cblock = $1;
1405 9         14 my @condblocks = ( $line );
1406 9         28 for my $i (1 .. scalar @$blocks) {
1407 17 100       1463 next unless $blocks->[$i - 1] =~ /^COND::${cblock}::/;
1408 3         287 push @condblocks, $blocks->[$i - 1];
1409 3         272 delete $blocks->[$i - 1];
1410             }
1411 9         439 push @code, $self->generate_code_conditionals(reverse @condblocks);
1412             } elsif ($line =~ /^SIM::\w+/) {
1413 130         262 push @code, $self->generate_simulator_instruction($line);
1414             } else {
1415 0         0 $self->parser->throw_error("Intermediate code '$line' cannot be handled");
1416             }
1417             }
1418 92 50       451 return wantarray ? @code : [@code];
1419             }
1420              
1421             sub final {
1422 32     32 1 941 my ($self, $got) = @_;
1423 32         118 my $ast = $self->ast;
1424 32 50       132 return $self->parser->throw_error("Missing '}'") if scalar @{$ast->{block_stack}};
  32         149  
1425 32 50       107 return $self->parser->throw_error("Main not defined") unless defined $ast->{Main};
1426             # generate main code first so that any addition to functions, macros,
1427             # variables during generation can be handled after
1428 32         140 my @main_code = $self->generate_code($ast, 'Main');
1429 31         87 push @main_code, "_end_start:\n", "\tgoto \$\t;;;; end of Main";
1430 31         207 my $main_code = join("\n", @main_code);
1431             # variables are part of macros and need to go first
1432 31         45 my $variables = '';
1433 31         66 my $vhref = $ast->{variables};
1434 31 100       130 $variables .= "GLOBAL_VAR_UDATA udata\n" if keys %$vhref;
1435 31         80 my @global_vars = ();
1436 31         57 my @tables = ();
1437 31         62 my @init_vars = ();
1438 31         116 foreach my $var (sort(keys %$vhref)) {
1439 42         66 my $name = $vhref->{$var}->{name};
1440 42   50     112 my $typ = $vhref->{$var}->{type} || 'byte';
1441 42         56 my $data = $vhref->{$var}->{data};
1442 42   66     161 my $label = $vhref->{$var}->{label} || $name;
1443 42         53 my $szvar = $vhref->{$var}->{size};
1444 42 100       156 if ($typ eq 'string') {
    50          
    100          
1445             ##this may need to be stored in a different location
1446 2 50       7 $data = '' unless defined $data;
1447             ## different PICs may have different string handling
1448 2         9 my ($scode, $szdecl)= $self->pic->store_string($data, $label, $szvar);
1449 2         5 push @tables, $scode;
1450 2 50       8 $variables .= $szdecl if $szdecl;
1451             } elsif ($typ eq 'ARRAY') {
1452 0 0       0 $data = [] unless defined $data;
1453 0         0 push @init_vars, $self->pic->store_array($data, $label,
1454             scalar(@$data), $szvar);
1455             } elsif ($typ eq 'HASH') {
1456 1 50       3 $data = {} unless defined $data;
1457 1 50       2 next unless defined $data->{TABLE};
1458 1         2 my $table = $data->{TABLE};
1459 1         3 my ($code, $szdecl) = $self->pic->store_table($table, $label,
1460             scalar(@$table), $szvar);
1461 1         1 push @tables, $code;
1462 1 50       11 push @init_vars, $szdecl if $szdecl;
1463             } else {# $typ == 'byte' or any other
1464             # should we care about scope ?
1465 39         226 $variables .= "$name res $vhref->{$var}->{size}\n";
1466 39 100 66     174 if (($vhref->{$var}->{scope} eq 'global') or
1467             ($ast->{code_config}->{variable}->{export})) {
1468 20         40 push @global_vars, $name;
1469             }
1470             }
1471             }
1472 31 100       240 if ($ast->{tmp_stack_size}) {
1473 3         13 $variables .= "VIC_STACK res $ast->{tmp_stack_size}\t;; temporary stack\n";
1474             }
1475 31 100       705 if (scalar @global_vars) {
1476             # export the variables
1477 5         20 $variables .= "\tglobal ". join (", ", @global_vars) . "\n";
1478             }
1479 31 100       96 if (scalar @init_vars) {
1480 1         4 $variables .= "\nGLOBAL_VAR_IDATA idata\n"; # initialized variables
1481 1         3 $variables .= join("\n", @init_vars);
1482             }
1483 31         60 my $macros = '';
1484 31         51 foreach my $mac (sort(keys %{$ast->{macros}})) {
  31         159  
1485 80 100       249 $variables .= "\n" . $ast->{macros}->{$mac} . "\n", next if $mac =~ /_var$/;
1486 55         149 $macros .= $ast->{macros}->{$mac};
1487 55         65 $macros .= "\n";
1488             }
1489 31         57 my $isr_checks = '';
1490 31         42 my $isr_code = '';
1491 31         45 my $funcs = '';
1492 31         42 foreach my $fn (sort(keys %{$ast->{funcs}})) {
  31         109  
1493 45         62 my $fn_val = $ast->{funcs}->{$fn};
1494             # the default ISR checks to be done first
1495 45 100       146 if ($fn =~ /^isr_\w+$/) {
    100          
1496 5 50       15 if (ref $fn_val eq 'ARRAY') {
1497 0         0 $isr_checks .= join("\n", @$fn_val);
1498             } else {
1499 5         14 $isr_checks .= $fn_val . "\n";
1500             }
1501             # the user ISR code to be handled next
1502             } elsif ($fn =~ /^_isr_\w+$/) {
1503 5 50       24 if (ref $fn_val eq 'ARRAY') {
1504 5         22 $isr_code .= join("\n", @$fn_val);
1505             } else {
1506 0         0 $isr_code .= $fn_val . "\n";
1507             }
1508             } else {
1509 35 100       65 if (ref $fn_val eq 'ARRAY') {
1510 22         67 $funcs .= join("\n", @$fn_val);
1511             } else {
1512 13         31 $funcs .= "$fn:\n";
1513 13 50       45 $funcs .= $fn_val unless ref $fn_val eq 'ARRAY';
1514             }
1515 35         51 $funcs .= "\n";
1516             }
1517             }
1518 31         48 foreach my $tbl (@{$ast->{tables}}) {
  31         105  
1519 5         7 my $dt = $tbl->{bytes};
1520 5         9 my $dn = $tbl->{name};
1521             }
1522 31 100       99 $funcs .= join ("\n", @tables) if scalar @tables;
1523 31         111 $funcs .= $self->pic->store_bytes($ast->{tables});
1524 31 100       106 if (length $isr_code) {
1525 5         10 my $isr_entry = $self->pic->isr_entry;
1526 5         17 my $isr_exit = $self->pic->isr_exit;
1527 5         12 my $isr_var = $self->pic->isr_var;
1528 5         9 $isr_checks .= "\tgoto _isr_exit\n";
1529 5         25 $isr_code = "\tgoto _start\n$isr_entry\n$isr_checks\n$isr_code\n$isr_exit\n";
1530 5         13 $variables .= "\n$isr_var\n";
1531             }
1532 31         73 my ($sim_include, $sim_setup_code) = ('', '');
1533             # we need to generate simulator code if either the Simulator block is
1534             # present or if any asserts are present
1535 31 100 66     112 if ($self->simulator and not $self->simulator->disable and
      66        
      66        
1536             ($ast->{Simulator} or $ast->{asserts})) {
1537 19         729 my $stype = $self->simulator->type;
1538 19         162 $sim_include .= ";;;; generated code for $stype header file\n";
1539 19         50 $sim_include .= '#include <' . $self->simulator->include .">\n";
1540 19         151 my @setup_code = $self->generate_code($ast, 'Simulator');
1541 19         58 my $init_code = $self->simulator->init_code;
1542 19 50       84 $sim_setup_code .= $init_code . "\n" if defined $init_code;
1543 19 100       111 $sim_setup_code .= join("\n", @setup_code) if scalar @setup_code;
1544 19 100       62 if ($self->simulator->should_autorun) {
1545 12         291 $sim_setup_code .= $self->simulator->get_autorun_code;
1546             }
1547             }
1548             # final get of the chip config in case it has been modified
1549 31         796 $self->ast->{chip_config} = $self->pic->get_chip_config;
1550 31         619 my $pic = <<"...";
1551             ;;;; generated code for PIC header file
1552             #include <$ast->{include}>
1553             $sim_include
1554             ;;;; generated code for variables
1555             $variables
1556             ;;;; generated code for macros
1557             $macros
1558              
1559             $ast->{chip_config}
1560              
1561             \torg $ast->{org}
1562              
1563             $sim_setup_code
1564              
1565             $isr_code
1566              
1567             $main_code
1568              
1569             ;;;; generated code for functions
1570             $funcs
1571             ;;;; generated code for end-of-file
1572             \tend
1573             ...
1574 31         210 return $pic;
1575             }
1576              
1577             1;
1578              
1579             =encoding utf8
1580              
1581             =head1 NAME
1582              
1583             VIC::Receiver
1584              
1585             =head1 SYNOPSIS
1586              
1587             The Pegex::Receiver class for handling the grammar.
1588              
1589             =head1 DESCRIPTION
1590              
1591             INTERNAL CLASS.
1592              
1593             =head1 AUTHOR
1594              
1595             Vikas N Kumar
1596              
1597             =head1 COPYRIGHT
1598              
1599             Copyright (c) 2014. Vikas N Kumar
1600              
1601             This program is free software; you can redistribute it and/or modify it
1602             under the same terms as Perl itself.
1603              
1604             See http://www.perl.com/perl/misc/Artistic.html
1605              
1606             =cut