File Coverage

blib/lib/VIC/PIC/Gpsim.pm
Criterion Covered Total %
statement 276 323 85.4
branch 115 210 54.7
condition 21 51 41.1
subroutine 26 26 100.0
pod 0 14 0.0
total 438 624 70.1


line stmt bran cond sub pod time code
1             package VIC::PIC::Gpsim;
2 34     34   123 use strict;
  34         46  
  34         792  
3 34     34   598 use warnings;
  34         42  
  34         652  
4 34     34   521 use bigint;
  34         2322  
  34         197  
5 34     34   45866 use Carp;
  34         39  
  34         1533  
6 34     34   607 use Pegex::Base; # use this instead of Mo
  34         1199  
  34         149  
7              
8             our $VERSION = '0.29';
9             $VERSION = eval $VERSION;
10              
11             has type => 'gpsim';
12              
13             has include => 'coff.inc';
14              
15             has pic => undef; # refer to the PIC object
16              
17             has node_count => 0;
18              
19             has scope_channels => 0;
20              
21             has stimulus_count => 0;
22              
23             has should_autorun => 0;
24              
25             has disable => 0;
26              
27             sub supports_modifier {
28 12     12 0 108 my $self = shift;
29 12         34 my $mod = shift;
30 12 100       130 return 1 if $mod =~ /^(?:every|wave)$/i;
31 1         8 0;
32             }
33              
34             sub init_code {
35 19     19 0 84 my $self = shift;
36 19 50       54 croak "This chip is not supported" unless $self->pic->doesroles(qw(Chip CodeGen GPIO));
37 19         36 my $pic = '';
38 19 50       60 $pic = $self->pic->type if $self->pic;
39 19 50       205 my $freq = $self->pic->f_osc if $self->pic;
40 19 50       162 if ($freq) {
41 19         65 $freq = qq{\t.sim "$pic.frequency = $freq"};
42             } else {
43 0         0 $freq = '';
44             }
45 19         75 return << "...";
46             ;;;; generated common code for the Simulator
47             \t.sim "module library libgpsim_modules"
48             \t.sim "$pic.xpos = 200"
49             \t.sim "$pic.ypos = 200"
50             $freq
51             ...
52             }
53              
54             sub _gen_led {
55 30     30   35 my $self = shift;
56 30         41 my ($id, $x, $y, $name, $port, $color) = @_;
57 30 100 66     103 if (defined $color and ref $color eq 'HASH') {
58 4         6 $color = $color->{string};
59             }
60 30 100       60 $color = 'red' unless defined $color;
61 30 50       166 $color = 'red' unless $color =~ /red|orange|green|yellow|blue/i;
62 30         39 $color = lc $color;
63 30 50       62 $color = substr ($color, 1) if $color =~ /^@/;
64 30         68 return << "...";
65             \t.sim "module load led L$id"
66             \t.sim "L$id.xpos = $x"
67             \t.sim "L$id.ypos = $y"
68             \t.sim "L$id.color = $color"
69             \t.sim "node $name"
70             \t.sim "attach $name $port L$id.in"
71             ...
72             }
73              
74              
75             sub _get_gpio_info {
76 101     101   103 my ($self, $port) = @_;
77 101         142 my $gpio_pin = $self->pic->get_input_pin($port);
78 101 50       138 if ($gpio_pin) {
79             # this is a pin
80 101         93 return @{$self->pic->input_pins->{$gpio_pin}};
  101         176  
81             } else {
82 0         0 $gpio_pin = $self->pic->get_output_pin($port);
83 0 0       0 if ($gpio_pin) {
84             # this is a pin
85 0         0 return @{$self->pic->output_pins->{$gpio_pin}};
  0         0  
86             }
87             }
88 0         0 return;
89             }
90              
91             sub _get_simreg {
92 32     32   42 my ($self, $port) = @_;
93 32         43 my $simreg = lc $port;
94 32 50       62 if ($self->pic) {
95 32 100       127 if (exists $self->pic->registers->{$port}) {
    50          
96             # this is a port
97 1         5 $simreg = lc $port;
98             } elsif (exists $self->pic->pins->{$port}) {
99 31         234 my ($io1) = $self->_get_gpio_info($port);
100 31 50       148 if (defined $io1) {
101 31         48 $simreg = lc $io1;
102             } else {
103 0         0 my $pic = $self->pic->type;
104 0         0 carp "Cannot find '$port' in PIC $pic. Using '$simreg'";
105             }
106             } else {
107 0         0 my $pic = $self->pic->type;
108 0         0 carp "Cannot find '$port' in PIC $pic. Using '$simreg'";
109             }
110             }
111 32         52 return $simreg;
112             }
113              
114             sub _get_simport {
115 94     94   105 my ($self, $port, $pin) = @_;
116 94         113 my $simport = lc $port;
117 94 50       170 if ($self->pic) {
118 94 100       378 if (exists $self->pic->registers->{$port}) {
    50          
119             # this is a port
120 25         83 $simport = lc $port;
121 25 100       52 $simport .= $pin if defined $pin;
122             } elsif (exists $self->pic->pins->{$port}) {
123 69         511 my ($io1, $io2, $io3) = $self->_get_gpio_info($port);
124 69 50 33     470 if (defined $io1 and defined $io3) {
125 69         132 $simport = lc "$io1$io3";
126             } else {
127 0         0 my $pic = $self->pic->type;
128 0         0 carp "Cannot find '$port' in PIC $pic. Using '$simport'";
129             }
130             } else {
131 0         0 my $pic = $self->pic->type;
132 0         0 carp "Cannot find '$port' in PIC $pic. Using '$simport'";
133             }
134             }
135 94         140 return $simport;
136             }
137              
138             sub _get_portpin {
139 27     27   25 my ($self, $port) = @_;
140 27         27 my $simport = lc $port;
141 27         20 my $simpin;
142 27 50       58 if ($self->pic) {
143 27 50       110 if (exists $self->pic->registers->{$port}) {
    100          
144             # this is a port
145 0         0 $simport = lc $port;
146             } elsif (exists $self->pic->pins->{$port}) {
147 1         11 my ($io1, $io2, $io3) = $self->_get_gpio_info($port);
148 1 50       6 if (defined $io1) {
149 1         2 $simport = lc $io1;
150 1         1 $simpin = $io3;
151             } else {
152 0         0 my $pic = $self->pic->type;
153 0         0 carp "Cannot find '$port' in PIC $pic. Using '$simport'";
154             }
155             } else {
156 26         186 return;
157             }
158             }
159 1 50       4 return wantarray ? ($simport, $simpin) : $simport;
160             }
161              
162             sub attach_led {
163 17     17 0 108 my ($self, $port, $count, $color) = @_;
164 17 100       48 $count = 1 unless $count;
165 17 50       50 $count = 1 if int($count) < 1;
166 17         724 my $code = '';
167 17 100       39 if ($count == 1) {
168 14         267 my $c = $self->node_count;
169 14         61 my $node = lc $port . 'led';
170 14         64 $self->node_count($c + 1);
171 14 50       812 my $x = ($c >= 4) ? 400 : 100;
172 14         258 my $y = 50 + 50 * $c;
173             # use the default pin 0 here
174 14         1224 my $simport = $self->_get_simport($port, 0);
175 14         50 $code = $self->_gen_led($c, $x, $y, $node, $simport, $color);
176             } else {
177 3         153 $count--;
178 3 50       9 if ($self->pic) {
179 3         19 for (0 .. $count) {
180 16         957 my $c = $self->node_count + $_;
181 16 100       1295 my $x = ($_ >= 4) ? 400 : 100;
182 16         870 my $y = 50 + 50 * $c;
183 16         1274 my $node = lc $port . $c . 'led';
184 16         225 my $simport = $self->_get_simport($port, $_);
185 16         27 $code .= $self->_gen_led($c, $x, $y, $node, $simport, $color);
186             }
187 3         219 $self->node_count($self->node_count + $count + 1);
188             }
189             }
190 17         1491 return $code;
191             }
192              
193             sub attach_led7seg {
194 1     1 0 7 my ($self, @pins) = @_;
195 1         2 my $code = '';
196 1         2 my @simpins = ();
197 1         1 my $color = 'red';
198 1         2 foreach my $p (@pins) {
199 2 50 33     13 if (defined $p and ref $p eq 'HASH') {
200 0         0 $p = $p->{string};
201 0 0       0 next unless defined $p;
202             }
203 2 100       5 if (exists $self->pic->pins->{$p}) {
    50          
    0          
204 1         7 push @simpins, $p;
205             } elsif (exists $self->pic->registers->{$p}) {
206             # find all the output pins for the port
207 1         8 foreach (sort(keys %{$self->pic->output_pins})) {
  1         3  
208 17 50       168 next unless defined $self->pic->output_pins->{$_}->[0];
209 17 100       204 push @simpins, $_ if $self->pic->output_pins->{$_}->[0] eq $p;
210             }
211             } elsif ($p =~ /red|orange|green|yellow|blue/i) {
212 0         0 $color = $p;
213 0 0       0 $color = substr($p, 1) if $p =~ /^@/;
214 0         0 next;
215             } else {
216 0         0 carp "Ignoring port $p as it doesn't exist\n";
217             }
218             }
219 1 50       13 return unless scalar @simpins;
220 1         4 my $id = $self->node_count;
221 1         6 $self->node_count($id + 1);
222 1         58 my $x = 500;
223 1         2 my $y = 50 + 50 * $id;
224 1         75 $code .= << "...";
225             \t.sim "module load led_7segments L$id"
226             \t.sim "L$id.xpos = $x"
227             \t.sim "L$id.ypos = $y"
228             ...
229 1         58 my @nodes = qw(cc seg0 seg1 seg2 seg3 seg4 seg5 seg6);
230 1         3 foreach my $n (@nodes) {
231 8         107 my $p = shift @simpins;
232 8         14 my $sp = $self->_get_simport($p);
233 8         17 $code .= << "...";
234             \t.sim "node $n"
235             \t.sim "attach $n $sp L$id.$n"
236             ...
237             }
238 1         16 return $code;
239             }
240              
241             sub stop_after {
242 16     16 0 90 my ($self, $usecs) = @_;
243             # convert $secs to cycles
244 16         45 my $cycles = $usecs * 10;
245 16         1426 my $code = << "...";
246             \t.sim "break c $cycles"
247             ...
248 16         282 return $code;
249             }
250              
251             sub logfile {
252 7     7 0 36 my ($self, $file) = @_;
253 7 50       24 $file = "vicsim.log" unless defined $file;
254 7 50       20 if (ref $file eq 'HASH') {
255 7   50     33 $file = $file->{string} || 'vicsim.log';
256             }
257 7 50       22 $file = substr($file, 1) if $file =~ /^@/;
258 7 50       42 return "\t.sim \"log lxt $file\"\n" if $file =~ /\.lxt/i;
259 0         0 return "\t.sim \"log on $file\"\n";
260             }
261              
262             sub log {
263 20     20 0 86 my $self = shift;
264 20         33 my $code = '';
265 20         39 foreach my $port (@_) {
266 29 100       90 if ($port =~ /US?ART/) {
267 3 50       9 next unless $self->pic->doesrole('USART');
268 3         8 my $ipin = $self->pic->usart_pins->{async_in};
269 3         16 my $opin = $self->pic->usart_pins->{async_out};
270 3 50 33     25 if (defined $ipin and defined $opin) {
271 3         10 my $ireg = $self->_get_simreg($ipin);
272 3         9 my $oreg = $self->_get_simreg($opin);
273 3         12 $code .= $self->log($ipin);
274 3 50       11 $code .= $self->log($opin) if $ireg ne $oreg;
275             }
276             } else {
277 26         52 my $reg = $self->_get_simreg($port);
278 26 50       57 next unless $reg;
279 26         71 $code .= << "...";
280             \t.sim "log r $reg"
281             \t.sim "log w $reg"
282             ...
283             }
284             }
285 20         37 return $code;
286             }
287              
288             sub _set_scope {
289 33     33   50 my ($self, $port) = @_;
290 33         66 my $simport = $self->_get_simport($port);
291 33         89 my $chnl = $self->scope_channels;
292 33 50       125 carp "Maximum of 8 channels can be used in the scope\n" if $chnl > 7;
293 33 50       681 return '' if $chnl > 7;
294 33 100       541 if (lc($simport) eq lc($port)) {
295 1         2 my @code = ();
296 1         3 for (0 .. 7) {
297 8         134 $simport = $self->_get_simport($port, $_);
298 8 50       12 if ($self->scope_channels < 8) {
299 8         127 $chnl = $self->scope_channels;
300 8         25 push @code, "\t.sim \"scope.ch$chnl = \\\"$simport\\\"\"";
301 8         112 $self->scope_channels($chnl + 1);
302             }
303 8 50       332 carp "Maximum of 8 channels can be used in the scope\n" if $chnl > 7;
304 8 50       126 last if $chnl > 7;
305             }
306 1         24 return join("\n", @code);
307             } else {
308 32         60 $self->scope_channels($chnl + 1);
309 32         1473 return << "...";
310             \t.sim "scope.ch$chnl = \\"$simport\\""
311             ...
312             }
313             }
314              
315             sub scope {
316 17     17 0 84 my $self = shift;
317 17         24 my $code = '';
318 17         30 foreach my $port (@_) {
319 30 100       271 if ($port =~ /US?ART/) {
320 3 50       7 next unless $self->pic->doesrole('USART');
321 3         8 my $ipin = $self->pic->usart_pins->{async_in};
322 3         14 my $opin = $self->pic->usart_pins->{async_out};
323 3 50       20 $code .= $self->_set_scope($ipin) if defined $opin;
324 3 50       70 $code .= $self->_set_scope($opin) if defined $opin;
325             } else {
326 27         50 $code .= $self->_set_scope($port);
327             }
328             }
329 17         285 return $code;
330             }
331              
332             ### have to change the operator back to the form acceptable by gpsim
333             sub _get_operator {
334 27     27   21 my $self = shift;
335 27         22 my $op = shift;
336 27 50       61 return '==' if $op eq 'EQ';
337 0 0       0 return '!=' if $op eq 'NE';
338 0 0       0 return '>' if $op eq 'GT';
339 0 0       0 return '>=' if $op eq 'GE';
340 0 0       0 return '<' if $op eq 'LT';
341 0 0       0 return '<=' if $op eq 'LE';
342 0         0 return undef;
343             }
344              
345             sub sim_assert {
346 29     29 0 120 my ($self, $condition, $msg) = @_;
347 29         28 my $assert_msg;
348 29 100       59 if ($condition =~ /@@/) {
349 27         55 my @args = split /@@/, $condition;
350 27         58 my $literal = qr/^\d+$/;
351 27 50       51 if (scalar @args == 3) {
352 27         1585 my $lhs = shift @args;
353 27         23 my $op = shift @args;
354 27         24 my $rhs = shift @args;
355 27         47 my $op2 = $self->_get_operator($op);
356 27 50       124 if ($lhs !~ $literal) {
357 27         52 my ($port, $pin) = $self->_get_portpin($lhs);
358 27 100       49 if (defined $pin) {
    50          
359 1         3 my $pval = sprintf "0x%02X", (1 << $pin);
360 1         142 $lhs = lc "($port & $pval)";
361             } elsif (defined $port) {
362 0         0 $lhs = lc $port;
363             } else {
364             # may be a variable
365 26         34 $lhs = uc $lhs;
366             }
367             } else {
368 0         0 $lhs = sprintf "0x%02X", $lhs;
369             }
370 27 50       93 if ($rhs !~ $literal) {
371 0         0 my ($port, $pin) = $self->_get_portpin($lhs);
372 0 0       0 if (defined $pin) {
    0          
373 0         0 my $pval = sprintf "0x%02X", (1 << $pin);
374 0         0 $rhs = lc "($port & $pval)";
375             } elsif (defined $port) {
376 0         0 $rhs = lc $port;
377             } else {
378             # may be a variable
379 0         0 $rhs = uc $rhs;
380             }
381             } else {
382 27         87 $rhs = sprintf "0x%02X", $rhs;
383             }
384 27         56 $condition = "$lhs $op2 $rhs";
385             }
386             #TODO: handle more complex expressions
387 27 100 66     116 if (defined $msg and ref $msg eq 'HASH') {
388 26         39 $msg = $msg->{string};
389             }
390 27 100       40 $msg = "$condition is false" unless $msg;
391 27 50       47 $msg = substr($msg, 1) if $msg =~ /^@/;
392 27 50       43 $condition = substr($condition, 1) if $condition =~ /^@/;
393 27         59 $assert_msg = qq{$condition, \\\"$msg\\\"};
394             } else {
395 2 50 33     15 if (defined $msg and ref $msg eq 'HASH') {
396 0         0 $msg = $msg->{string};
397             }
398 2 50 33     18 if (defined $condition and ref $condition eq 'HASH') {
399 2         4 $condition = $condition->{string};
400             }
401 2 50 33     29 if (defined $condition and defined $msg) {
    50 33        
    0 0        
402 0 0       0 $msg = substr($msg, 1) if $msg =~ /^@/;
403 0 0       0 $condition = substr($condition, 1) if $condition =~ /^@/;
404 0         0 $assert_msg = qq{$condition, \\\"$msg\\\"};
405             } elsif (defined $condition and not defined $msg) {
406 2 50       10 $condition = substr($condition, 1) if $condition =~ /^@/;
407 2         6 $assert_msg = qq{\\\"$condition\\\"};
408             } elsif (defined $msg and not defined $condition) {
409 0 0       0 $msg = substr($msg, 1) if $msg =~ /^@/;
410 0         0 $assert_msg = qq{\\\"$msg\\\"};
411             } else {
412 0         0 $assert_msg = qq{\\\"user requested an assert\\\"};
413             }
414             }
415              
416             return << "..."
417             \t;; break if the condition evaluates to false
418             \t.assert "$assert_msg"
419             \tnop ;; needed for the assert
420             ...
421 29         96 }
422              
423             sub stimulate {
424 9     9 0 38 my $self = shift;
425 9         10 my $pin = shift;
426 9         16 my %hh = ();
427 9         19 foreach my $href (@_) {
428 11         41 %hh = (%hh, %$href);
429             }
430 9         11 my $period = '';
431 9 100 66     34 $period = $hh{EVERY} if (defined $hh{EVERY} and length $hh{EVERY});
432 9 100 66     78 $period = qq{\t.sim "period $period"} if (defined $period and length $period);
433 9         64 my $wave = '';
434 9         11 my $wave_type = 'digital';
435 9 50 33     50 if (exists $hh{WAVE} and ref $hh{WAVE} eq 'ARRAY') {
436 9         12 my $arr = $hh{WAVE};
437 9 50       50 $wave = "\t.sim \"{ " . join(',', @$arr) . " }\"" if scalar @$arr;
438 9         9 my $ad = 0;
439 9         21 foreach (@$arr) {
440 66 100       302 $ad |= 1 unless /^\d+$/;
441             }
442 9 100       46 $wave_type = 'analog' if $ad;
443             }
444 9   50     175 my $start = $hh{START} || 0;
445 9         85 $start = qq{\t.sim "start_cycle $start"};
446 9   50     148 my $init = $hh{INITIAL} || 0;
447 9         86 $init = qq{\t.sim "initial_state $init"};
448 9         120 my $num = $self->stimulus_count;
449 9         30 $self->stimulus_count($num + 1);
450 9         385 my $node = "stim$num$pin";
451 9         119 my $simpin = $self->_get_simport($pin);
452             return << "..."
453             \t.sim \"echo creating stimulus number $num\"
454             \t.sim \"stimulus asynchronous_stimulus\"
455             $init
456             $start
457             \t.sim \"$wave_type\"
458             $period
459             $wave
460             \t.sim \"name stim$num\"
461             \t.sim \"end\"
462             \t.sim \"echo done creating stimulus number $num\"
463             \t.sim \"node $node\"
464             \t.sim \"attach $node stim$num $simpin\"
465             ...
466 9         20 }
467              
468             sub get_autorun_code {
469 12     12 0 92 return qq{\t.sim "run"\n};
470             }
471              
472             sub autorun {
473 12     12 0 58 my $self = shift;
474 12         47 $self->should_autorun(1);
475 12         44 return "\t;;;; will autorun on start\n";
476             }
477              
478             sub stopwatch {
479 1     1 0 5 my ($self, $rollover) = @_;
480 1         2 my $code = qq{\t.sim "stopwatch.enable = true"\n};
481 1 50       5 $code .= qq{\t.sim "stopwatch.rollover = $rollover"\n} if defined $rollover;
482 1 50       2 $code .= qq{\t.sim "break stopwatch"\n} if defined $rollover;
483 1         2 return $code;
484             }
485              
486             sub attach {
487 3     3 0 19 my $self = shift;
488 3 50       11 return unless @_;
489 3         7 my $pin = shift;
490 3         5 my $code = '';
491 3 50       14 if ($pin =~ /US?ART/) {
492             # TX - connect to UART
493             # RX - connect to UART but also send it data
494 3 50       16 unless ($self->pic->doesrole('USART')) {
495 0         0 carp "PIC ", $self->pic->type, " does not do USART";
496 0         0 return;
497             }
498 3 50       9 my $baudrate = shift if @_;
499 3 100       14 my $loopback = shift if @_;
500 3 50       13 my $key = ($pin =~ /^UART/) ? 'uart' : 'usart';
501             $baudrate = $self->pic->code_config->{$key}->{baud} unless defined
502 3 50       9 $baudrate;
503 3 50       6 $baudrate = 9600 unless defined $baudrate;
504 3         15 my $id = $self->node_count;
505 3         17 $self->node_count($id + 1);
506 3         214 my $ipin = $self->pic->usart_pins->{async_in};
507 3         21 my $rxport = $self->_get_simport($ipin);
508 3         9 my $opin = $self->pic->usart_pins->{async_out};
509 3         16 my $txport = $self->_get_simport($opin);
510 3 50 33     9 return unless (exists $self->pic->pins->{$ipin} and exists $self->pic->pins->{$opin});
511 3         40 $code .= qq{\t.sim "module load usart U$id"\n};
512 3         81 $code .= qq{\t.sim "node TX_U$id"\n};
513 3         39 $code .= qq{\t.sim "node RX_U$id"\n};
514 3         39 $code .= qq{\t.sim "attach TX_U$id $txport U$id.RXPIN"\n};
515 3         71 $code .= qq{\t.sim "attach RX_U$id $rxport U$id.TXPIN"\n};
516 3         66 $code .= qq{\t.sim "U$id.txbaud = $baudrate"\n};
517 3         38 $code .= qq{\t.sim "U$id.rxbaud = $baudrate"\n};
518 3         34 my $x = 500;
519 3         7 my $y = 50 + 50 * $id;
520 3         273 $code .= qq{\t.sim "U$id.xpos = $x"\n};
521 3         83 $code .= qq{\t.sim "U$id.ypos = $y"\n};
522 3 100       70 if (defined $loopback) {
523 2 50 33     17 if (ref $loopback eq 'HASH' and $loopback->{string} =~ /loopback/i) {
524 2         6 $code .= qq{\t.sim "U$id.loop = true"\n};
525             }
526             }
527             }
528 3         37 return $code;
529             }
530              
531             1;
532              
533             =encoding utf8
534              
535             =head1 NAME
536              
537             VIC::Receiver
538              
539             =head1 SYNOPSIS
540              
541             The Pegex::Receiver class for handling the grammar.
542              
543             =head1 DESCRIPTION
544              
545             INTERNAL CLASS.
546              
547             =head1 AUTHOR
548              
549             Vikas N Kumar
550              
551             =head1 COPYRIGHT
552              
553             Copyright (c) 2014. Vikas N Kumar
554              
555             This program is free software; you can redistribute it and/or modify it
556             under the same terms as Perl itself.
557              
558             See http://www.perl.com/perl/misc/Artistic.html
559              
560             =cut