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   130 use strict;
  33         46  
  33         892  
3 33     33   114 use warnings;
  33         41  
  33         703  
4 33     33   14173 use bigint;
  33         71718  
  33         116  
5 33     33   900852 use POSIX ();
  33         159052  
  33         905  
6 33     33   181 use List::Util qw(max);
  33         45  
  33         2725  
7 33     33   15103 use List::MoreUtils qw(any firstidx indexes);
  33         268378  
  33         216  
8              
9             our $VERSION = '0.29';
10             $VERSION = eval $VERSION;
11              
12 33     33   19565 use Pegex::Base;
  33         50  
  33         318  
13             extends 'Pegex::Tree';
14              
15 33     33   54870 use VIC::PIC::Any;
  33         71  
  33         1388  
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 307 sub stack { reverse @{shift->parser->stack}; }
  431         850  
37              
38 2     2 0 10 sub supported_chips { return VIC::PIC::Any::supported_chips(); }
39              
40 1     1 0 5 sub supported_simulators { return VIC::PIC::Any::supported_simulators(); }
41              
42 19     19 0 48 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 218 sub current_chip { return $_[0]->pic->type; }
51              
52 31     31 0 145 sub current_simulator { return $_[0]->simulator->type; }
53              
54             sub got_mcu_select {
55 33     33 0 1551 my ($self, $type) = @_;
56             # override the PIC in code if defined
57 33 50       165 $type = $self->pic_override if defined $self->pic_override;
58 33         308 $type = lc $type;
59             # assume supported type else return
60 33         305 $self->pic(VIC::PIC::Any->new($type));
61 33 50 33     584 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         609 $self->ast->{include} = $self->pic->include;
66             # set the defaults in case the headers are not provided by the user
67 33         333 $self->ast->{org} = $self->pic->org;
68 33         247 $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         460 $self->simulator(VIC::PIC::Any->new_simulator(pic => $self->pic));
72 33         2810 return;
73             }
74              
75             sub got_pragmas {
76 20     20 0 424 my ($self, $list) = @_;
77 20         54 $self->flatten($list);
78 20         284 $self->pic->update_code_config(@$list);
79             # get the updated config
80 20         44 $self->ast->{chip_config} = $self->pic->get_chip_config;
81 20         93 $self->ast->{code_config} = $self->pic->code_config;
82 20 50       130 my ($sim, $stype) = @$list if scalar @$list;
83 20 100 100     128 if ($sim eq 'simulator' and $stype !~ /disable/i) {
    100 66        
84 2         8 $self->simulator(VIC::PIC::Any->new_simulator(
85             type => $stype, pic => $self->pic));
86 2 50       112 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       6 $self->simulator->disable(1) if $self->simulator;
96             }
97 20         79 return;
98             }
99              
100             sub handle_named_block {
101 94     94 0 161 my ($self, $name, $anon_block, $parent) = @_;
102 94 50       593 my $id = $1 if $anon_block =~ /_anonblock(\d+)/;
103 94 50       216 $id = $self->ast->{block_count} unless defined $id;
104 94         162 my ($expected_label, $expected_param) = ('', '');
105 94 100       606 if ($name eq 'Main') {
    100          
    100          
    100          
    100          
    100          
    50          
106 32         87 $expected_label = "_start";
107             } elsif ($name =~ /^Loop/) {
108 16         43 $expected_label = "_loop_${id}";
109             } elsif ($name =~ /^Action/) {
110 6         13 $expected_label = "_action_${id}";
111 6         18 $expected_param = "action${id}_param";
112             } elsif ($name =~ /^True/) {
113 12         22 $expected_label = "_true_${id}";
114             } elsif ($name =~ /^False/) {
115 4         9 $expected_label = "_false_${id}";
116             } elsif ($name =~ /^ISR/) {
117 5         10 $expected_label = "_isr_${id}";
118 5         15 $expected_param = "isr${id}_param";
119             } elsif ($name eq 'Simulator') {
120 19         53 $expected_label = '_vic_simulator';
121             } else {
122 0         0 $expected_label = lc "_$name$id";
123             }
124 94 100       361 $name .= $id if $name =~ /^(?:Loop|Action|True|False|ISR)/;
125 94         578 $self->ast->{block_mapping}->{$name} = {
126             label => $expected_label,
127             block => $anon_block,
128             params => [],
129             param_prefix => $expected_param,
130             };
131 94         704 $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         397 $self->ast->{$name} = $self->ast->{$anon_block};
139              
140 94   33     464 my $stack = $self->ast->{$name} || $self->ast->{$anon_block};
141 94 50 33     859 if (defined $stack and ref $stack eq 'ARRAY') {
142 94         253 my $block_label = $stack->[0];
143             ## this expression is dependent on got_start_block()
144 94         1314 my ($tag, $label, @others) = split /::/, $block_label;
145 94 50       265 $label = $expected_label if $label ne $expected_label;
146 94 50       336 $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         293 $stack->[0] = join("::", $tag, $label, @others);
151 94         927 my $elabel = "_end$label"; # end label
152 94         120 my $slabel = $label; # start label
153 94 100       236 if (defined $parent) {
154 43 50       165 unless ($parent =~ /BLOCK::/) {
155 43         78 $block_label .= "::$parent";
156 43 50 33     119 if (exists $self->ast->{$parent} and
      33        
157             ref $self->ast->{$parent} eq 'ARRAY' and
158             $parent ne $anon_block) {
159 43         570 my ($ptag, $plabel) = split /::/, $self->ast->{$parent}->[0];
160 43 50       624 $block_label .= "::$plabel" if $plabel;
161             }
162             }
163 43         107 my $ccount = $self->ast->{conditionals};
164 43 100       334 if ($block_label =~ /True|False/i) {
165 16         32 $elabel = "_end_conditional_$ccount";
166 16         284 $slabel = "_start_conditional_$ccount";
167             }
168 43         242 $block_label .= "::$elabel";
169 43 100       106 $block_label .= "::$expected_param" if length $expected_param;
170 43         45 push @{$self->ast->{$parent}}, $block_label;
  43         98  
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         342 $self->ast->{block_mapping}->{$name}->{parent} = $parent;
175 94         397 $self->ast->{block_mapping}->{$anon_block}->{parent} = $parent;
176 94         351 $self->ast->{block_mapping}->{$name}->{end_label} = $elabel;
177 94         342 $self->ast->{block_mapping}->{$anon_block}->{end_label} = $elabel;
178 94         325 $self->ast->{block_mapping}->{$name}->{start_label} = $slabel;
179 94         343 $self->ast->{block_mapping}->{$anon_block}->{start_label} = $slabel;
180 94 100       627 $self->ast->{block_mapping}->{$anon_block}->{loop} = '1' if $block_label =~ /Loop/i;
181 94         469 return $block_label;
182             }
183             }
184              
185             sub got_named_block {
186 78     78 0 1808 my ($self, $list) = @_;
187 78 50       402 $self->flatten($list) if ref $list eq 'ARRAY';
188 78         1225 my ($name, $anon_block, $parent_block) = @$list;
189 78         233 return $self->handle_named_block(@$list);
190             }
191              
192             sub got_anonymous_block {
193 94     94 0 2247 my $self = shift;
194 94         121 my $list = shift;
195 94         152 my ($anon_block, $block_stack, $parent) = @$list;
196             # returns anon_block and parent_block
197 94         331 return [$anon_block, $parent];
198             }
199              
200             sub got_start_block {
201 95     95 0 2635 my ($self, $list) = @_;
202 95         309 my $id = $self->ast->{block_count};
203             # we may not know the block name here
204 95         711 my $block = lc "_anonblock$id";
205 95         2643 push @{$self->ast->{block_stack}}, $block;
  95         224  
206 95         615 $self->ast->{$block} = [ "LABEL::$block" ];
207 95         573 $self->ast->{block_count}++;
208 95         5856 return $block;
209             }
210              
211             sub got_end_block {
212 94     94 0 2483 my ($self, $list) = @_;
213             # we are not capturing anything here
214 94         334 my $stack = $self->ast->{block_stack};
215 94         349 my $block = pop @$stack;
216 94         291 return $stack->[-1];
217             }
218              
219             sub got_name {
220 779     779 0 16102 my ($self, $list) = @_;
221 779 50       1389 if (ref $list eq 'ARRAY') {
222 779         1932 $self->flatten($list);
223 779         5825 return shift(@$list);
224             } else {
225 0         0 return $list;
226             }
227             }
228              
229             sub update_intermediate {
230 381     381 0 1062 my $self = shift;
231 381         728 my $block = $self->ast->{block_stack}->[-1];
232 381 50       6286 push @{$self->ast->{$block}}, @_ if $block;
  381         746  
233 381         1423 return;
234             }
235              
236             sub got_instruction {
237 246     246 0 5202 my ($self, $list) = @_;
238 246         355 my $method = shift @$list;
239 246 50       906 $self->flatten($list) if $list;
240 246         3955 my $tag = 'INS';
241             # check if it is a simulator method
242 246 100 66     626 if ($self->simulator and $self->simulator->can($method)) {
243             # this is a simulator instruction
244 107         1166 $tag = 'SIM';
245             } else {
246 139 100       2213 unless ($self->pic->can($method)) {
247 1         11 my $err = "Unsupported instruction '$method' for chip " . uc $self->pic->type;
248 1         11 return $self->parser->throw_error($err);
249             }
250             }
251 245         1049 my @args = ();
252 245         494 while (scalar @$list) {
253 355         362 my $a = shift @$list;
254 355 100       660 if ($a =~ /BLOCK::(\w+)::(Action|ISR)\w+::.*::(_end_\w+)::(\w+)$/) {
255 11         123 push @args, uc($2) . "::$1::END::$3::PARAM::$4";
256             } else {
257 344         1607 push @args, $a;
258             }
259             }
260 245         1017 $self->update_intermediate("${tag}::${method}::" . join ("::", @args));
261 245         646 return;
262             }
263              
264             sub got_unary_rhs {
265 1     1 0 23 my ($self, $list) = @_;
266 1         4 $self->flatten($list);
267 1         10 return [ reverse @$list ];
268             }
269              
270             sub got_unary_expr {
271 8     8 0 154 my ($self, $list) = @_;
272 8         26 $self->flatten($list);
273 8         52 my $op = shift @$list;
274 8         14 my $varname = shift @$list;
275 8         44 $self->update_intermediate("UNARY::${op}::${varname}");
276 8         20 return;
277             }
278              
279             sub got_assign_expr {
280 85     85 0 1750 my ($self, $list) = @_;
281 85         206 $self->flatten($list);
282 85         1283 my $varname = shift @$list;
283 85         101 my $op = shift @$list;
284 85         163 my $rhsx = $self->got_expr_value($list);
285 85 50       183 my $rhs = ref $rhsx eq 'ARRAY' ? join ("::", @$rhsx) : $rhsx;
286 85 100       167 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         10 my $block = $1;
291 5         34 $self->update_intermediate("PARAM::${op}::${block}::${varname}");
292             } else {
293 80         455 $self->update_intermediate("SET::${op}::${varname}::${rhs}");
294             }
295 85         242 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         3 my $rhsx = $self->got_expr_value($list);
302 1 50       5 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         15 my $tvar = sprintf "_vic_tmp_%02d", scalar(keys %$tvref);
307 1         4 my $vref = $self->ast->{variables}->{$var1};
308 1         5 my @ops = ('OP');
309 1 50 33     11 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         5 $tvref->{$tvar} = join("::", @ops);
321             # create a new variable here
322 1         4 my $varname = sprintf "vic_el_%02d", scalar(keys %$tvref);
323 1         4 $varname = $self->got_variable([$varname]);
324 1 50       4 if ($varname) {
325 1         8 $self->update_intermediate("SET::ASSIGN::${varname}::${tvar}");
326 1         5 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 136 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         17 my $block = $self->ast->{block_stack}->[-1];
337 5         103 return "PARAM::$block";
338             }
339              
340             sub got_declaration {
341 3     3 0 97 my ($self, $list) = @_;
342 3         6 my $lhs = shift @$list;
343 3         4 my $rhs;
344 3 50       13 if (scalar @$list == 1) {
345 3         266 $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       12 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     35 if (exists $rhs->{TABLE} or ref $rhs eq 'ARRAY') {
    50          
355 1 50 33     18 my $label = lc "_table_$lhs" if ref $rhs eq 'HASH' and exists $rhs->{TABLE};
356 1 50 33     6 my $szpref = "VIC_TBLSZ_" if ref $rhs eq 'HASH' and exists $rhs->{TABLE};
357 1 50       3 $szpref = "VIC_ARRSZ_" if ref $rhs eq 'ARRAY';
358 1         4 $self->ast->{variables}->{$lhs}->{type} = ref $rhs;
359 1         7 $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         3 $self->ast->{variables}->{$lhs}->{name};
364             }
365             } elsif (exists $rhs->{string}) {
366             # handle variable that are strings here
367 2         5 $self->ast->{variables}->{$lhs}->{data} = $rhs;
368 2         9 $self->ast->{variables}->{$lhs}->{type} = 'string';
369             $self->ast->{variables}->{$lhs}->{size} = "VIC_STRSZ_" .
370 2         10 $self->ast->{variables}->{$lhs}->{name};
371 2         18 $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         13 return;
392             }
393              
394             sub got_conditional_statement {
395 12     12 0 247 my ($self, $list) = @_;
396 12         24 my ($type, $subject, $predicate) = @$list;
397 12 50       27 return unless scalar @$predicate;
398 12 100       28 my $is_loop = ($type eq 'while') ? 1 : 0;
399 12         27 my ($current, $parent) = $self->stack;
400 12         23 my $subcond = 0;
401 12 100       33 $subcond = 1 if $parent =~ /^conditional/;
402 12 50       31 if (ref $predicate ne 'ARRAY') {
403 0         0 $predicate = [ $predicate ];
404             }
405 12         19 my @condblocks = ();
406 12 50       34 if (scalar @$predicate < 3) {
407 12   50     800 my $tb = $predicate->[0] || undef;
408 12   50     152 my $fb = $predicate->[1] || undef;
409 12 50       139 $self->flatten($tb) if $tb;
410 12 50       104 $self->flatten($fb) if $fb;
411 12 50 50     151 my $true_block = $self->handle_named_block('True', @$tb) if $tb and scalar @$tb;
412 12 50       29 push @condblocks, $true_block if $true_block;
413 12 100 50     47 my $false_block = $self->handle_named_block('False', @$fb) if $fb and scalar @$fb;
414 12 100       29 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         18 my $inter;
419 12 50       27 if (scalar @condblocks < 3) {
420 12         704 my ($false_label, $true_label, $end_label);
421 0         0 my ($false_name, $true_name);
422 12         21 foreach my $p (@condblocks) {
423 16 100       42 ($false_label, $false_name) = ($1, $2) if $p =~ /BLOCK::(\w+)::(False\d+)::/;
424 16 100       80 ($true_label, $true_name) = ($1, $2) if $p =~ /BLOCK::(\w+)::(True\d+)::/;
425 16 50       80 $end_label = $1 if $p =~ /BLOCK::.*::(_end_conditional\w+)$/;
426             }
427 12 100       50 $false_label = $end_label unless defined $false_label;
428 12 50       23 $true_label = $end_label unless defined $true_label;
429 12         12 my $subj = $subject;
430 12 50       25 $subj = shift @$subject if ref $subject eq 'ARRAY';
431             $inter = join("::",
432             COND => $self->ast->{conditionals},
433 12         33 SUBJ => $subj,
434             FALSE => $false_label,
435             TRUE => $true_label,
436             END => $end_label,
437             LOOP => $is_loop,
438             SUBCOND => $subcond);
439 12         482 my $mapping = $self->ast->{block_mapping};
440 12 50 33     69 if ($true_name and exists $mapping->{$true_name}) {
441 12         19 $mapping->{$true_name}->{loop} = "$is_loop";
442 12         156 my $ab = $mapping->{$true_name}->{block};
443 12         16 $mapping->{$ab}->{loop} = "$is_loop";
444             }
445 12 50 66     322 if ($false_name and exists $mapping->{$false_name}) {
446 4         9 $mapping->{$false_name}->{loop} = "$is_loop";
447 4         216 my $ab = $mapping->{$false_name}->{block};
448 4         10 $mapping->{$ab}->{loop} = "$is_loop";
449             }
450             } else {
451 0         0 return $self->parser->throw_error("Multiple predicate conditionals not implemented");
452             }
453 12         76 $self->update_intermediate($inter);
454 12 100       23 $self->ast->{conditionals}++ unless $subcond;
455 12         586 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 848 my ($self, $list) = @_;
465 16 50       41 if (ref $list eq 'ARRAY') {
466 16         44 $self->flatten($list);
467 16 100       192 if (scalar @$list == 1) {
    50          
    100          
468 4         221 my $var1 = shift @$list;
469 4 100       20 return $var1 if $var1 =~ /^\d+$/;
470 3         11 my $vref = $self->ast->{tmp_variables};
471 3         24 my $tvar = sprintf "_vic_tmp_%02d", scalar(keys %$vref);
472 3         13 $vref->{$tvar} = "OP::${var1}::EQ::1";
473 3         14 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         1631 my ($var1, $op, $var2) = @$list;
482 11         32 my $vref = $self->ast->{tmp_variables};
483 11         89 my $tvar = sprintf "_vic_tmp_%02d", scalar(keys %$vref);
484 11         42 $vref->{$tvar} = "OP::${var1}::${op}::${var2}";
485 11         124 return $tvar;
486             } else {
487             # handle precedence with left-to-right association
488 1         156 my @arr = @$list;
489 1     2   18 my $idx = firstidx { $_ =~ /^GE|GT|LE|LT|EQ|NE$/ } @arr;
  2         7  
490 1         6 while ($idx >= 0) {
491 2         114 my $res = $self->got_conditional_subject([$arr[$idx - 1], $arr[$idx], $arr[$idx + 1]]);
492 2         8 $arr[$idx - 1] = $res;
493 2         215 splice @arr, $idx, 2; # remove the extra elements
494 2     7   23 $idx = firstidx { $_ =~ /^GE|GT|LE|LT|EQ|NE$/ } @arr;
  7         18  
495             }
496 1     2   58 $idx = firstidx { $_ =~ /^AND|OR$/ } @arr;
  2         4  
497 1         4 while ($idx >= 0) {
498 1         52 my $res = $self->got_conditional_subject([$arr[$idx - 1], $arr[$idx], $arr[$idx + 1]]);
499 1         3 $arr[$idx - 1] = $res;
500 1         89 splice @arr, $idx, 2; # remove the extra elements
501 1     1   12 $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 6743 my ($self, $list) = @_;
515 296 50       541 if (ref $list eq 'ARRAY') {
516 296         545 $self->flatten($list);
517 296 100       2298 if (scalar @$list == 1) {
    100          
    100          
    50          
518 236         14144 my $val = shift @$list;
519 236 100       408 if ($val =~ /MOP::/) {
520 2         7 my $vref = $self->ast->{tmp_variables};
521 2         15 my $tvar = sprintf "_vic_tmp_%02d", scalar(keys %$vref);
522 2         5 $vref->{$tvar} = $val;
523 2         9 return $tvar;
524             } else {
525 234         1177 return $val;
526             }
527             } elsif (scalar @$list == 2) {
528 8         862 my ($op, $var) = @$list;
529 8         23 my $vref = $self->ast->{tmp_variables};
530 8         75 my $tvar = sprintf "_vic_tmp_%02d", scalar(keys %$vref);
531 8         33 $vref->{$tvar} = "OP::${op}::${var}";
532 8         31 return $tvar;
533             } elsif (scalar @$list == 3) {
534 46         6883 my ($var1, $op, $var2) = @$list;
535 46         104 my $vref = $self->ast->{tmp_variables};
536 46         301 my $tvar = sprintf "_vic_tmp_%02d", scalar(keys %$vref);
537 46         145 $vref->{$tvar} = "OP::${var1}::${op}::${var2}";
538 46         102 return $tvar;
539             } elsif (scalar @$list > 3) {
540             # handle precedence with left-to-right association
541 6         1175 my @arr = @$list;
542 6     24   63 my $idx = firstidx { $_ =~ /^MUL|DIV|MOD$/ } @arr;
  24         43  
543 6         30 while ($idx >= 0) {
544 8         420 my $res = $self->got_expr_value([$arr[$idx - 1], $arr[$idx], $arr[$idx + 1]]);
545 8         31 $arr[$idx - 1] = $res;
546 8         772 splice @arr, $idx, 2; # remove the extra elements
547 8     34   105 $idx = firstidx { $_ =~ /^MUL|DIV|MOD$/ } @arr;
  34         81  
548             }
549 6     12   352 $idx = firstidx { $_ =~ /^ADD|SUB$/ } @arr;
  12         25  
550 6         18 while ($idx >= 0) {
551 8         399 my $res = $self->got_expr_value([$arr[$idx - 1], $arr[$idx], $arr[$idx + 1]]);
552 8         28 $arr[$idx - 1] = $res;
553 8         732 splice @arr, $idx, 2; # remove the extra elements
554 8     10   94 $idx = firstidx { $_ =~ /^ADD|SUB$/ } @arr;
  10         43  
555             }
556 6     6   314 $idx = firstidx { $_ =~ /^SHL|SHR$/ } @arr;
  6         16  
557 6         16 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   310 $idx = firstidx { $_ =~ /^BAND|BXOR|BOR$/ } @arr;
  6         20  
564 6         18 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         287 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 1145 my ($self, $op) = @_;
582 42 100       102 return 'ADD' if $op eq '+';
583 26 100       52 return 'SUB' if $op eq '-';
584 20 100       45 return 'MUL' if $op eq '*';
585 10 100       27 return 'DIV' if $op eq '/';
586 4 50       22 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 102 my ($self, $op) = @_;
592 4 100       15 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 59 my ($self, $op) = @_;
607 2 100       8 return 'AND' if $op eq '&&';
608 1 50       5 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 978 my ($self, $op) = @_;
614 37 100       85 return 'LE' if $op eq '<=';
615 36 50       61 return 'LT' if $op eq '<';
616 36 50       67 return 'GE' if $op eq '>=';
617 36 100       63 return 'GT' if $op eq '>';
618 35 100       112 return 'EQ' if $op eq '==';
619 4 50       18 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 224 my ($self, $op) = @_;
625 8 50       37 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 3323 my ($self, $op) = @_;
632 88 50       205 if (ref $op eq 'ARRAY') {
633 0         0 $self->flatten($op);
634 0         0 $op = shift @$op;
635             }
636 88 100       285 return 'ASSIGN' if $op eq '=';
637 25 100       65 return 'ADD_ASSIGN' if $op eq '+=';
638 23 100       59 return 'SUB_ASSIGN' if $op eq '-=';
639 21 100       41 return 'MUL_ASSIGN' if $op eq '*=';
640 19 100       37 return 'DIV_ASSIGN' if $op eq '/=';
641 17 100       38 return 'MOD_ASSIGN' if $op eq '%=';
642 15 100       35 return 'BXOR_ASSIGN' if $op eq '^=';
643 13 100       35 return 'BOR_ASSIGN' if $op eq '|=';
644 11 100       192 return 'BAND_ASSIGN' if $op eq '&=';
645 8 100       23 return 'SHL_ASSIGN' if $op eq '<<=';
646 6 100       28 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 228 my ($self, $op) = @_;
653 8 100       40 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 220 my ($self, $arr) = @_;
660 10 50       63 $self->flatten($arr) if ref $arr eq 'ARRAY';
661 10         440 $self->global_collections->{"$arr"} = $arr;
662 10         66 return $arr;
663             }
664              
665             sub got_modifier_constant {
666 12     12 0 264 my ($self, $list) = @_;
667             # we don't flatten since $value can be an array as well
668 12         23 my ($modifier, $value) = @$list;
669 12         22 $modifier = uc $modifier;
670             ## first check if the modifier is an operator
671 12         45 my $method = $self->pic->validate_modifier_operator($modifier);
672 12 50 33     38 $self->flatten($value) if ($method and ref $value eq 'ARRAY');
673 12 50       27 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     38 if ($self->simulator and $self->simulator->supports_modifier($modifier)) {
676 11         377 my $hh = { $modifier => $value };
677 11         35 $self->global_collections->{"$hh"} = $hh;
678 11         72 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       40 if ($modifier eq 'TABLE') {
    0          
    0          
683 1 50       8 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       10 $self->flatten($list) if ref $list eq 'ARRAY';
699 2         13 $modifier = shift @$list;
700 2         3 $varname = shift @$list;
701 2         4 $modifier = uc $modifier;
702 2         7 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         9 return $self->got_expr_value(["MOP::${modifier}::${varname}"]);
705             }
706              
707             sub got_validated_variable {
708 207     207 0 8932 my ($self, $list) = @_;
709 207         220 my $varname;
710 207 50       433 if (ref $list eq 'ARRAY') {
711 207         471 $self->flatten($list);
712 207         1352 $varname = shift @$list;
713 207         253 my $suffix = shift @$list;
714 207 50       481 $varname .= $suffix if defined $suffix;
715             } else {
716 0         0 $varname = $list;
717             }
718 207 50       539 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 8672 my ($self, $list) = @_;
724 419 50       1369 $self->flatten($list) if ref $list eq 'ARRAY';
725 419         2399 my $varname = shift @$list;
726 419         694 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       832 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       695 } unless exists $self->ast->{variables}->{$varname};
739 419 100       6427 $self->ast->{variables}->{$varname}->{scope} = 'global' if $parent =~ /assert_/;
740 419         1099 return $varname;
741             }
742              
743             sub got_boolean {
744 11     11 0 314 my ($self, $list) = @_;
745 11         12 my $b;
746 11 50       34 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       29 return 0 unless defined $b;
753 11 100       65 return 1 if $b =~ /TRUE|true/i;
754 5 50       16 return 1 if $b == 1;
755 5 50       338 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 1435 my $self = shift;
761 43         57 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         340 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         803 $str =~ s/\\(["\/\\bfnrt0])/$escapes{$1}/ge;
  3         9  
776 43         143 return $str;
777             }
778              
779             sub got_string {
780 48     48 0 916 my $self = shift;
781 48         55 my $str = shift;
782             ##TODO: handle empty strings as initializers
783             # store only unique strings otherwise re-use them
784 48         45 foreach (%{$self->global_collections}) {
  48         144  
785 617         820 my $h = $self->global_collections->{$_};
786 617 100       1655 return $h if ($h->{string} eq $str);
787             }
788 47 100       187 my $is_empty = 1 if $str eq '';
789             my $stref = {
790             string => $str,
791             block => $self->ast->{block_stack}->[-1],
792 47         104 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         6187 $self->global_collections->{"$stref"} = $stref;
797 47         241 $self->ast->{strings}++;
798 47         1405 return $stref;
799             #return '@' . $str;
800             }
801              
802             sub got_number {
803 400     400 0 15291 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       2009 return hex($list) if $list =~ /0x|0X/;
807 344         759 my $val = int($list);
808 344 50       1032 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 1153 my ($self, $list) = @_;
818 51         211 $self->flatten($list);
819 51         358 my $num = shift @$list;
820 51         97 my $units = shift @$list;
821 51 50       131 return $num unless defined $units;
822 51 100       149 $num *= 1 if $units eq 'us';
823 51 100       363 $num *= 1000 if $units eq 'ms';
824 51 100       1734 $num *= 1e6 if $units eq 's';
825 51 100       2290 $num *= 1 if $units eq 'Hz';
826 51 100       812 $num *= 1000 if $units eq 'kHz';
827 51 50       634 $num *= 1e6 if $units eq 'MHz';
828             # ignore the '%' sign for now
829 51         160 return $num;
830             }
831              
832             sub got_real_number {
833 5     5 0 188 my ($self, $list) = @_;
834 5 50       12 $list .= '0' if $list =~ /\d+\.$/;
835 5 50       21 $list = "0.$1" if $list =~ /^\.(\d+)$/;
836 5 50       17 $list = "-0.$1" if $list =~ /^-\.(\d+)$/;
837 5         14 return $list;
838             }
839              
840             # remove the dumb stuff from the tree
841 68     68 0 2535 sub got_comment { return; }
842              
843             sub _update_funcs {
844 66     66   75 my ($self, $funcs, $macros) = @_;
845 66 50       171 if (ref $funcs eq 'HASH') {
846 66         309 foreach (keys %$funcs) {
847 21         57 $self->ast->{funcs}->{$_} = $funcs->{$_};
848             }
849             }
850 66 50       200 if (ref $macros eq 'HASH') {
851 66 50       137 return unless ref $macros eq 'HASH';
852 66         140 foreach (keys %$macros) {
853 140         375 $self->ast->{macros}->{$_} = $macros->{$_};
854             }
855             }
856 66         191 1;
857             }
858              
859             sub _update_tables {
860 18     18   20 my ($self, $tables) = @_;
861 18 50       36 if (ref $tables eq 'HASH') {
862 0         0 $tables = [ $tables ];
863             }
864 18 50       37 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         27 foreach my $s (@$tables) {
869 5 50       12 next unless defined $s->{bytes};
870 5 50       13 next unless defined $s->{name};
871 5         4 push @{$self->ast->{tables}}, $s;
  5         11  
872             }
873 18         34 1;
874             }
875              
876             ## assert handling is special for now
877             sub got_assert_comparison {
878 28     28 0 560 my ($self, $list) = @_;
879 28 50       71 return unless $self->simulator;
880 28 50       169 $self->flatten($list) if ref $list eq 'ARRAY';
881 28 50       448 if (scalar @$list < 3) {
882 0         0 return $self->parser->throw_error("Error in assert statement");
883             }
884 28         1665 return join("@@", @$list);
885             }
886              
887             sub got_assert_statement {
888 28     28 0 563 my ($self, $list) = @_;
889 28 50       121 $self->flatten($list) if ref $list eq 'ARRAY';
890 28         596 my ($method, $cond, $msg) = @$list;
891 28 100       49 $msg = '' unless defined $msg;
892 28         55 $self->ast->{asserts}++;
893 28         835 $self->update_intermediate("SIM::${method}::${cond}::${msg}");
894 28         64 return;
895             }
896              
897             sub generate_simulator_instruction {
898 130     130 0 133 my ($self, $line) = @_;
899 130         308 my @ins = split /::/, $line;
900 130         138 my $tag = shift @ins;
901 130         104 my $method = shift @ins;
902 130         130 my @code = ();
903 130 50       248 push @code, "\t;; $line" if $self->intermediate_inline;
904 130         497 foreach (@ins) {
905 188 100       502 next unless /HASH|ARRAY/;
906 50 50       104 next unless exists $self->global_collections->{$_};
907 50         218 $_ = $self->global_collections->{$_};
908             }
909 130 100       320 return @code if $self->simulator->disable;
910 129         2869 my $code = $self->simulator->$method(@ins);
911 129 50       672 return $self->parser->throw_error("Error in simulator intermediate code '$line'") unless $code;
912 129 50       280 push @code, $code if $code;
913 129         395 return @code;
914             }
915              
916             sub generate_code_instruction {
917 136     136 0 159 my ($self, $line) = @_;
918 136         401 my @ins = split /::/, $line;
919 136         287 my $tag = shift @ins;
920 136         286 my $method = shift @ins;
921 136         152 my @code = ();
922 136         224 foreach (@ins) {
923 269 100       783 if (exists $self->global_collections->{$_}) {
924 6         31 $_ = $self->global_collections->{$_};
925 6         22 next;
926             }
927 263 100       1043 if (exists $self->ast->{variables}->{$_}) {
928 29         129 my $vhref = $self->ast->{variables}->{$_};
929 29 100       133 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         575 my ($code, $funcs, $macros, $tables) = $self->pic->$method(@ins);
940 136 100       306 return $self->parser->throw_error("Error in intermediate code '$line'") unless $code;
941 135 50       341 push @code, "\t;; $line" if $self->intermediate_inline;
942 135 50       807 push @code, $code if $code;
943 135 100 66     563 $self->_update_funcs($funcs, $macros) if ($funcs or $macros);
944 135 100       243 $self->_update_tables($tables) if $tables;
945 135         510 return @code;
946             }
947              
948             sub generate_code_unary_expr {
949 8     8 0 10 my ($self, $line) = @_;
950 8         12 my @code = ();
951 8         20 my $ast = $self->ast;
952 8         37 my ($tag, $op, $varname) = split /::/, $line;
953 8         18 my $method = $self->pic->validate_operator($op);
954 8 50       32 $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       70 if (exists $ast->{variables}->{$varname}) {
957 8   33     34 my $nvar = $ast->{variables}->{$varname}->{name} || $varname;
958 8         19 my ($code, $funcs, $macros, $tables) = $self->pic->$method($nvar);
959 8 50       19 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       50 push @code, $code if $code;
962 8 50 33     38 $self->_update_funcs($funcs, $macros) if ($funcs or $macros);
963 8 50       21 $self->_update_tables($tables) if $tables;
964             } else {
965 0         0 return $self->parser->throw_error("Error in intermediate code '$line'");
966             }
967 8         25 return @code;
968             }
969              
970             sub generate_code_operations {
971 70     70 0 157 my ($self, $line, %extra) = @_;
972 70         70 my @code = ();
973 70         169 my ($tag, @args) = split /::/, $line;
974 70         67 my ($op, $var1, $var2);
975 70 100       134 if (scalar @args == 2) {
    100          
    50          
976 9         518 $op = shift @args;
977 9         12 $var1 = shift @args;
978             } elsif (scalar @args == 3) {
979 60         6237 $var1 = shift @args;
980 60         61 $op = shift @args;
981 60         54 $var2 = shift @args;
982             } elsif (scalar @args == 4) {
983 1         149 $var1 = shift @args;
984 1         1 $op = shift @args;
985 1         2 $var2 = shift @args;
986 1         1 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       156 if (exists $extra{STACK}) {
992 36 50       55 if (defined $var1) {
993 36   66     96 $var1 = $extra{STACK}->{$var1} || $var1;
994             }
995 36 100       51 if (defined $var2) {
996 35   100     95 $var2 = $extra{STACK}->{$var2} || $var2;
997             }
998             }
999 70 100       211 my $method = $self->pic->validate_operator($op) if $tag eq 'OP';
1000 70 100       129 $method = $self->pic->validate_modifier_operator($op) if $tag eq 'MOP';
1001 70 50 33     172 $self->parser->throw_error("Invalid operator '$op' in intermediate code") unless
1002             ($method and $self->pic->can($method));
1003 70 50       443 push @code, "\t;; $line" if $self->intermediate_inline;
1004 70         274 my ($code, $funcs, $macros, $tables) = $self->pic->$method($var1, $var2, %extra);
1005 70 50       125 return $self->parser->throw_error("Error in intermediate code '$line'") unless $code;
1006 70 50       136 push @code, $code if $code;
1007 70 100 66     211 $self->_update_funcs($funcs, $macros) if ($funcs or $macros);
1008 70 50       94 $self->_update_tables($tables) if $tables;
1009 70         193 return @code;
1010             }
1011              
1012             sub find_tmpvar_dependencies {
1013 70     70 0 71 my ($self, $tvar) = @_;
1014 70         110 my $tcode = $self->ast->{tmp_variables}->{$tvar};
1015 70         323 my ($tag, @args) = split /::/, $tcode;
1016 70 100       143 return unless $tag eq 'OP';
1017 68         60 my @deps = ();
1018 68         61 my $sz = scalar @args;
1019 68 100 66     124 if ($sz == 2) {
    50          
1020 7         420 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         6131 my ($var1, $op, $var2) = @args;
1028 61 100       130 if (exists $self->ast->{tmp_variables}->{$var1}) {
1029 15         57 push @deps, $var1;
1030 15         54 my @rdeps = $self->find_tmpvar_dependencies($var1);
1031 15 100       34 push @deps, @rdeps if @rdeps;
1032             }
1033 61 100       218 if (exists $self->ast->{tmp_variables}->{$var2}) {
1034 13         45 push @deps, $var2;
1035 13         29 my @rdeps = $self->find_tmpvar_dependencies($var2);
1036 13 100       30 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       302 return wantarray ? @deps : \@deps;
1042             }
1043              
1044             sub find_var_dependencies {
1045 42     42 0 42 my ($self, $tvar) = @_;
1046 42         73 my $tcode = $self->ast->{tmp_variables}->{$tvar};
1047 42         164 my ($tag, @args) = split /::/, $tcode;
1048 42 100       91 return unless $tag eq 'OP';
1049 40         37 my @deps = ();
1050 40         38 my $sz = scalar @args;
1051 40 100 66     74 if ($sz == 2) {
    50          
1052 6         315 my ($op, $var) = @args;
1053 6 50       16 if (exists $self->ast->{variables}->{$var}) {
1054 6         28 push @deps, $var;
1055             }
1056             } elsif ($sz == 3 or $sz == 4) {
1057 34         3472 my ($var1, $op, $var2) = @args;
1058 34 100       67 if (exists $self->ast->{variables}->{$var1}) {
1059 27         107 push @deps, $var1;
1060             }
1061 34 100       81 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       164 return wantarray ? @deps : \@deps;
1068             }
1069              
1070             sub do_i_use_stack {
1071 34     34 0 43 my ($self, @deps) = @_;
1072 34 100       63 return 0 unless @deps;
1073 32         43 my @bits = map { $self->pic->address_bits($_) } @deps;
  43         81  
1074 32 50       126 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 96 my ($self, $line) = @_;
1080 88         99 my @code = ();
1081 88         356 my $ast = $self->ast;
1082 88         395 my ($tag, $op, $varname, $rhs) = split /::/, $line;
1083 88 50       168 push @code, ";;; $line\n" if $self->intermediate_inline;
1084 88 50       354 if (exists $ast->{variables}->{$varname}) {
1085 88 100       177 if (exists $ast->{tmp_variables}->{$rhs}) {
1086 31         42 my $tmp_code = $ast->{tmp_variables}->{$rhs};
1087 31         62 my @deps = $self->find_tmpvar_dependencies($rhs);
1088 31         54 my @vdeps = $self->find_var_dependencies($rhs);
1089 31 100       59 push @deps, $rhs if @deps;
1090 31 50       55 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         17 $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         22 my %tmpstack = map { $_ => 'VIC_STACK + ' . $counter++ } sort(@deps);
  30         998  
1106 6         263 foreach (sort @deps) {
1107 30         41 my $tcode = $ast->{tmp_variables}->{$_};
1108 30         28 my $result = $tmpstack{$_};
1109 30 100       46 $result = uc $varname if $_ eq $rhs;
1110 30 50       69 my @newcode = $self->generate_code_operations($tcode,
1111             STACK => \%tmpstack, RESULT => $result) if $tcode;
1112 30 50       57 push @code, "\t;; $_ = $tcode" if $self->intermediate_inline;
1113 30 50       144 push @code, @newcode if @newcode;
1114             }
1115             } else {
1116             # no tmp-var dependencies
1117 25 50       79 my $use_stack = $self->do_i_use_stack(@vdeps) unless scalar @deps;
1118 25 50       153 unless ($use_stack) {
1119 25         337 my @newcode = $self->generate_code_operations($tmp_code,
1120             RESULT => uc $varname);
1121 25 50       70 push @code, @newcode if @newcode;
1122             } else {
1123             # TODO: stack
1124 0         0 XXX @vdeps;
1125             }
1126             }
1127             } else {
1128 57   33     154 my $nvar = $ast->{variables}->{$varname}->{name} || $varname;
1129 57 100       136 if ($rhs =~ /HASH|ARRAY/) {
1130 2 50       6 if (exists $self->global_collections->{$rhs}) {
1131 2         14 $rhs = $self->global_collections->{$rhs};
1132             }
1133             }
1134 57 50       107 if (exists $self->ast->{variables}->{$varname}) {
1135 57         241 my $vhref = $self->ast->{variables}->{$varname};
1136 57 100       229 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         6 $nvar = $vhref;
1143             }
1144             }
1145 57         114 my $method = $self->pic->validate_operator($op);
1146 57 50       115 $self->parser->throw_error("Invalid operator '$op' in intermediate code") unless $self->pic->can($method);
1147 57         343 my ($code, $funcs, $macros, $tables) = $self->pic->$method($nvar, $rhs);
1148 57 50       130 return $self->parser->throw_error("Error in intermediate code '$line'") unless $code;
1149 57 50       136 push @code, "\t;; $line" if $self->intermediate_inline;
1150 57 50       302 push @code, $code if $code;
1151 57 100 66     232 $self->_update_funcs($funcs, $macros) if ($funcs or $macros);
1152 57 100       136 $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         281 return @code;
1159             }
1160              
1161             sub find_nearest_loop {
1162 7     7 0 9 my ($self, $mapping, $child) = @_;
1163 7 50       8 return unless exists $mapping->{$child};
1164 7 50       14 if (exists $mapping->{$child}->{loop}) {
1165 7 100       14 return $child if $mapping->{$child}->{loop} eq '1';
1166             }
1167 3 50       8 return unless $mapping->{$child}->{parent};
1168 3         10 return $self->find_nearest_loop($mapping, $mapping->{$child}->{parent});
1169             }
1170              
1171             sub generate_code_blocks {
1172 43     43 0 86 my ($self, $line, $block) = @_;
1173 43         59 my @code = ();
1174 43         111 my $ast = $self->ast;
1175 43         133 my $mapping = $ast->{block_mapping};
1176 43   33     122 my $mapped_block = $mapping->{$block}->{block} || $block;
1177 43         180 my ($tag, $label, $child, $parent, $parent_label, $end_label) = split/::/, $line;
1178 43 50 33     330 return if ($child eq $block or $child eq $mapped_block or $child eq $parent);
      33        
1179 43 50       112 return if exists $ast->{generated_blocks}->{$child};
1180 43 50       111 push @code, "\t;; $line" if $self->intermediate_inline;
1181 43         395 my @newcode = $self->generate_code($ast, $child);
1182 43     192   464 my @bindexes = indexes { $_ eq 'BREAK' } @newcode;
  192         176  
1183 43     192   222 my @cindexes = indexes { $_ eq 'CONTINUE' } @newcode;
  192         156  
1184 43 100 66     515 if ($child =~ /^(?:True|False)/ and @newcode) {
    100 66        
    50 33        
1185 16         35 my $cond_end = "\tgoto $end_label;; go back to end of conditional\n";
1186             # handle break
1187 16 100       34 if (@bindexes) {
1188             #find top most parent loop
1189 2         5 my $el = $self->find_nearest_loop($mapping, $child);
1190 2 50       5 $el = $mapping->{$el}->{end_label} if $el;
1191 2         2 my $break_end;
1192 2 50       4 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         4 $break_end = "\tgoto $el;; break from the conditional\n";
1197             }
1198 2         6 $newcode[$_] = $break_end foreach @bindexes;
1199             }
1200             # handle continue
1201 16 100       24 if (@cindexes) {
1202             #find top most parent loop
1203 2         5 my $sl = $self->find_nearest_loop($mapping, $child);
1204 2 50       5 $sl = $mapping->{$sl}->{start_label} if $sl;
1205 2 50       6 my $cont_start = "\tgoto $sl;; go back to start of conditional\n" if $sl;
1206 2 50       17 $cont_start = "\tnop ;; $child or $parent have no start_label" unless $sl;
1207 2         6 $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     12 my $slabel = $mapping->{$child}->{start_label} || $end_label;
1213 4 50       13 my $start_code = "\tgoto $slabel ;; go back to start of conditional\n" if $slabel;
1214 4 50       11 $start_code = $cond_end unless $start_code;
1215 4         6 push @newcode, $start_code;
1216             } else {
1217 12         13 push @newcode, $cond_end;
1218             }
1219 16         27 push @newcode, ";;;; end of $label";
1220             # hack into the function list
1221 16         59 $ast->{funcs}->{$label} = [@newcode];
1222             } elsif ($child =~ /^(?:Action|ISR)/ and @newcode) {
1223 11         36 my $cond_end = "\tgoto $end_label ;; go back to end of block\n";
1224 11 50       54 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       30 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         26 push @newcode, $cond_end, ";;;; end of $label";
1236             # hack into the function list
1237 11         46 $ast->{funcs}->{$label} = [@newcode];
1238             } elsif ($child =~ /^Loop/ and @newcode) {
1239 16         51 my $cond_end = "\tgoto $end_label;; go back to end of block\n";
1240 16 50       45 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       48 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         39 push @code, @newcode;
1252 16         58 push @code, "\tgoto $label ;;;; end of $label\n";
1253 16         42 push @code, "$end_label:\n";
1254             } else {
1255 0 0       0 push @code, @newcode if @newcode;
1256             }
1257 43 50       147 $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     411 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         176 return @code;
1268             }
1269              
1270             sub generate_code_conditionals {
1271 9     9 0 16 my ($self, @condblocks) = @_;
1272 9         10 my @code = ();
1273 9         23 my $ast = $self->ast;
1274 9         26 my ($start_label, $end_label, $is_loop);
1275 9         12 my $blockcount = scalar @condblocks;
1276 9         16 my $index = 0;
1277 9         14 foreach my $line (@condblocks) {
1278 12 50       25 push @code, "\t;; $line" if $self->intermediate_inline;
1279 12         112 my %hh = split /::/, $line;
1280 12         22 my $subj = $hh{SUBJ};
1281 12 100       27 $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       110 $start_label = "_start_conditional_$hh{COND}" unless defined $start_label;
1285 12 100       22 $is_loop = $hh{LOOP} unless defined $is_loop;
1286 12 100       22 $end_label = $hh{END} unless defined $end_label;
1287             # we now modify the TRUE/FALSE/END labels
1288 12 100       25 if ($blockcount > 1) {
1289 4         267 my $el = "$hh{END}_$index"; # new label
1290 4 100       68 $hh{FALSE} = $el if $hh{FALSE} eq $hh{END};
1291 4 50       9 $hh{TRUE} = $el if $hh{TRUE} eq $hh{END};
1292 4         5 $hh{END} = $el;
1293             }
1294 12 100       513 if ($subj =~ /^\d+?$/) { # if subject is a literal
    50          
    50          
1295 1 50       4 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       21 push @code, "\tgoto $hh{TRUE}" if $hh{TRUE};
1302             }
1303 1 50       5 push @code, "\tgoto $hh{END}" if $hh{END};
1304 1 50       4 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         19 my $tmp_code = $ast->{tmp_variables}->{$subj};
1311 11         28 my @deps = $self->find_tmpvar_dependencies($subj);
1312 11         22 my @vdeps = $self->find_var_dependencies($subj);
1313 11 100       19 push @deps, $subj if @deps;
1314 11 50       23 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       57 if (scalar @deps) {
1320 2         7 $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         54 my $counter = 0;
1325 2         10 my %tmpstack = map { $_ => 'VIC_STACK + ' . $counter++ } sort(@deps);
  6         181  
1326 2         78 $counter = 0; # reset
1327 2         6 foreach (sort @deps) {
1328 6         13 my $tcode = $ast->{tmp_variables}->{$_};
1329 6         20 my %extra = (%hh, COUNTER => $counter++);
1330 6 100       228 $extra{RESULT} = $tmpstack{$_} if $_ ne $subj;
1331 6 50       27 my @newcode = $self->generate_code_operations($tcode,
1332             STACK => \%tmpstack, %extra) if $tcode;
1333 6 50       31 push @code, @newcode if @newcode;
1334             }
1335             } else {
1336             # no tmp-var dependencies
1337 9         21 my $use_stack = $self->do_i_use_stack(@vdeps);
1338 9 50       56 unless ($use_stack) {
1339 9         185 my @newcode = $self->generate_code_operations($tmp_code, %hh);
1340 9 50       36 push @code, @newcode if @newcode;
1341 9 50       44 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       37 unshift @code, "$start_label:" if defined $start_label;
1353 9 100 66     40 push @code, "$end_label:" if defined $end_label and $blockcount > 1;
1354 9         602 return @code;
1355             }
1356              
1357             sub generate_code {
1358 94     94 0 159 my ($self, $ast, $block_name) = @_;
1359 94         154 my @code = ();
1360 94 0       217 return wantarray ? @code : [] unless defined $ast;
    50          
1361 94 50       226 return wantarray ? @code : [] unless exists $ast->{$block_name};
    100          
1362 93 100       249 $ast->{generated_blocks} = {} unless defined $ast->{generated_blocks};
1363 93         202 push @code, ";;;; generated code for $block_name";
1364 93         134 my $blocks = $ast->{$block_name};
1365 93         198 while (@$blocks) {
1366 510         546 my $line = shift @$blocks;
1367 510 100       755 next unless defined $line;
1368 507 100       2598 if ($line =~ /^BLOCK::\w+/) {
    100          
    100          
    100          
    100          
    100          
    100          
    50          
1369 43   50     148 my $blockparams = $ast->{block_mapping}->{$block_name}->{params} || [];
1370 43         220 push @code, $self->generate_code_blocks($line, $block_name, $blockparams);
1371             } elsif ($line =~ /^INS::\w+/) {
1372 136         312 push @code, $self->generate_code_instruction($line);
1373             } elsif ($line =~ /^UNARY::\w+/) {
1374 8         29 push @code, $self->generate_code_unary_expr($line);
1375             } elsif ($line =~ /^SET::\w+/) {
1376 83         174 push @code, $self->generate_code_assign_expr($line);
1377             } elsif ($line =~ /^PARAM::(\w+)::(\w+)::(\w+)/) {
1378 5 50       18 if (exists $ast->{block_mapping}->{$block_name}) {
1379 5         9 my $op = $1;
1380 5         11 my $pblock = $2;
1381 5         10 my $pvar = $3;
1382 5         10 my $mapping = $ast->{block_mapping}->{$pblock};
1383 5         6 my $param_idx = scalar @{$mapping->{params}};
  5         11  
1384 5   33     313 my $paramvar = $mapping->{param_prefix} || lc($block_name . '_param');
1385 5         9 $paramvar .= $param_idx;
1386 5         7 push @{$mapping->{params}}, $paramvar;
  5         12  
1387             # map the param index back to the other mapping too
1388 5 50 33     41 if ($pblock ne $block_name and $mapping->{block} eq $block_name) {
1389 5         12 my $mapping2 = $ast->{block_mapping}->{$block_name};
1390 5         10 $mapping2->{params} = $mapping->{params};
1391             }
1392 5         18 my $pline = "SET::${op}::${pvar}::${paramvar}";
1393             #YYY [$pblock, $pvar, $block_name, $param_idx, $pline, $paramvar];
1394 5         19 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         194 my $lbl = $1;
1401 93 50       241 push @code, ";; $line" if $self->intermediate_inline;
1402 93 100       653 push @code, "$lbl:\n" if $lbl ne '_vic_simulator';
1403             } elsif ($line =~ /^COND::(\d+)::/) {
1404 9         18 my $cblock = $1;
1405 9         21 my @condblocks = ( $line );
1406 9         27 for my $i (1 .. scalar @$blocks) {
1407 17 100       1626 next unless $blocks->[$i - 1] =~ /^COND::${cblock}::/;
1408 3         299 push @condblocks, $blocks->[$i - 1];
1409 3         277 delete $blocks->[$i - 1];
1410             }
1411 9         483 push @code, $self->generate_code_conditionals(reverse @condblocks);
1412             } elsif ($line =~ /^SIM::\w+/) {
1413 130         245 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       470 return wantarray ? @code : [@code];
1419             }
1420              
1421             sub final {
1422 32     32 1 922 my ($self, $got) = @_;
1423 32         118 my $ast = $self->ast;
1424 32 50       118 return $self->parser->throw_error("Missing '}'") if scalar @{$ast->{block_stack}};
  32         138  
1425 32 50       115 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         162 my @main_code = $self->generate_code($ast, 'Main');
1429 31         103 push @main_code, "_end_start:\n", "\tgoto \$\t;;;; end of Main";
1430 31         171 my $main_code = join("\n", @main_code);
1431             # variables are part of macros and need to go first
1432 31         51 my $variables = '';
1433 31         64 my $vhref = $ast->{variables};
1434 31 100       146 $variables .= "GLOBAL_VAR_UDATA udata\n" if keys %$vhref;
1435 31         68 my @global_vars = ();
1436 31         55 my @tables = ();
1437 31         52 my @init_vars = ();
1438 31         153 foreach my $var (sort(keys %$vhref)) {
1439 42         77 my $name = $vhref->{$var}->{name};
1440 42   50     117 my $typ = $vhref->{$var}->{type} || 'byte';
1441 42         53 my $data = $vhref->{$var}->{data};
1442 42   66     165 my $label = $vhref->{$var}->{label} || $name;
1443 42         58 my $szvar = $vhref->{$var}->{size};
1444 42 100       163 if ($typ eq 'string') {
    50          
    100          
1445             ##this may need to be stored in a different location
1446 2 50       8 $data = '' unless defined $data;
1447             ## different PICs may have different string handling
1448 2         6 my ($scode, $szdecl)= $self->pic->store_string($data, $label, $szvar);
1449 2         5 push @tables, $scode;
1450 2 50       10 $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       4 $data = {} unless defined $data;
1457 1 50       3 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         2 push @tables, $code;
1462 1 50       4 push @init_vars, $szdecl if $szdecl;
1463             } else {# $typ == 'byte' or any other
1464             # should we care about scope ?
1465 39         229 $variables .= "$name res $vhref->{$var}->{size}\n";
1466 39 100 66     172 if (($vhref->{$var}->{scope} eq 'global') or
1467             ($ast->{code_config}->{variable}->{export})) {
1468 20         36 push @global_vars, $name;
1469             }
1470             }
1471             }
1472 31 100       235 if ($ast->{tmp_stack_size}) {
1473 3         12 $variables .= "VIC_STACK res $ast->{tmp_stack_size}\t;; temporary stack\n";
1474             }
1475 31 100       752 if (scalar @global_vars) {
1476             # export the variables
1477 5         20 $variables .= "\tglobal ". join (", ", @global_vars) . "\n";
1478             }
1479 31 100       105 if (scalar @init_vars) {
1480 1         3 $variables .= "\nGLOBAL_VAR_IDATA idata\n"; # initialized variables
1481 1         4 $variables .= join("\n", @init_vars);
1482             }
1483 31         53 my $macros = '';
1484 31         52 foreach my $mac (sort(keys %{$ast->{macros}})) {
  31         166  
1485 80 100       264 $variables .= "\n" . $ast->{macros}->{$mac} . "\n", next if $mac =~ /_var$/;
1486 55         152 $macros .= $ast->{macros}->{$mac};
1487 55         60 $macros .= "\n";
1488             }
1489 31         67 my $isr_checks = '';
1490 31         48 my $isr_code = '';
1491 31         79 my $funcs = '';
1492 31         46 foreach my $fn (sort(keys %{$ast->{funcs}})) {
  31         121  
1493 45         68 my $fn_val = $ast->{funcs}->{$fn};
1494             # the default ISR checks to be done first
1495 45 100       162 if ($fn =~ /^isr_\w+$/) {
    100          
1496 5 50       17 if (ref $fn_val eq 'ARRAY') {
1497 0         0 $isr_checks .= join("\n", @$fn_val);
1498             } else {
1499 5         15 $isr_checks .= $fn_val . "\n";
1500             }
1501             # the user ISR code to be handled next
1502             } elsif ($fn =~ /^_isr_\w+$/) {
1503 5 50       15 if (ref $fn_val eq 'ARRAY') {
1504 5         28 $isr_code .= join("\n", @$fn_val);
1505             } else {
1506 0         0 $isr_code .= $fn_val . "\n";
1507             }
1508             } else {
1509 35 100       62 if (ref $fn_val eq 'ARRAY') {
1510 22         61 $funcs .= join("\n", @$fn_val);
1511             } else {
1512 13         25 $funcs .= "$fn:\n";
1513 13 50       38 $funcs .= $fn_val unless ref $fn_val eq 'ARRAY';
1514             }
1515 35         69 $funcs .= "\n";
1516             }
1517             }
1518 31         50 foreach my $tbl (@{$ast->{tables}}) {
  31         107  
1519 5         7 my $dt = $tbl->{bytes};
1520 5         8 my $dn = $tbl->{name};
1521             }
1522 31 100       106 $funcs .= join ("\n", @tables) if scalar @tables;
1523 31         110 $funcs .= $self->pic->store_bytes($ast->{tables});
1524 31 100       136 if (length $isr_code) {
1525 5         15 my $isr_entry = $self->pic->isr_entry;
1526 5         12 my $isr_exit = $self->pic->isr_exit;
1527 5         14 my $isr_var = $self->pic->isr_var;
1528 5         9 $isr_checks .= "\tgoto _isr_exit\n";
1529 5         22 $isr_code = "\tgoto _start\n$isr_entry\n$isr_checks\n$isr_code\n$isr_exit\n";
1530 5         11 $variables .= "\n$isr_var\n";
1531             }
1532 31         200 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         603 my $stype = $self->simulator->type;
1538 19         164 $sim_include .= ";;;; generated code for $stype header file\n";
1539 19         51 $sim_include .= '#include <' . $self->simulator->include .">\n";
1540 19         158 my @setup_code = $self->generate_code($ast, 'Simulator');
1541 19         59 my $init_code = $self->simulator->init_code;
1542 19 50       90 $sim_setup_code .= $init_code . "\n" if defined $init_code;
1543 19 100       114 $sim_setup_code .= join("\n", @setup_code) if scalar @setup_code;
1544 19 100       54 if ($self->simulator->should_autorun) {
1545 12         306 $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         877 $self->ast->{chip_config} = $self->pic->get_chip_config;
1550 31         581 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         192 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