File Coverage

blib/lib/VIC/PIC/Functions/Operators.pm
Criterion Covered Total %
statement 479 740 64.7
branch 166 374 44.3
condition 38 155 24.5
subroutine 64 72 88.8
pod 0 52 0.0
total 747 1393 53.6


line stmt bran cond sub pod time code
1             package VIC::PIC::Functions::Operators;
2 31     31   19733 use strict;
  31         46  
  31         791  
3 31     31   104 use warnings;
  31         40  
  31         696  
4 31     31   110 use bigint;
  31         35  
  31         222  
5             our $VERSION = '0.31';
6             $VERSION = eval $VERSION;
7 31     31   20683 use Carp;
  31         46  
  31         1548  
8 31     31   154 use POSIX ();
  31         43  
  31         592  
9 31     31   103 use Moo::Role;
  31         41  
  31         174  
10              
11             sub _assign_literal {
12 36     36   46 my ($self, $var, $val) = @_;
13 36 50       68 return unless $self->doesrole('Chip'); # needed for address_bits
14 36 50 33     247 if (ref $var eq 'HASH' and $var->{type} eq 'string') {
15             #YYY { lhs => $var, rhs => $var };
16 0         0 carp $var->{name}, " has been defined as a string and '$val' is not a string !";
17 0         0 return;
18             }
19 36         101 my $bits = $self->address_bits($var);
20 36         108 my $bytes = POSIX::ceil($bits / 8);
21 36         2920 my $nibbles = 2 * $bytes;
22 36         3453 $var = uc $var;
23 36         108 my $code = sprintf "\t;; moves $val (0x%0${nibbles}X) to $var\n", $val;
24 36 100       726 if ($val >= 2 ** $bits) {
25 2         834 carp "Warning: Value $val doesn't fit in $bits-bits";
26 2         308 $code .= "\t;; $val doesn't fit in $bits-bits. Using ";
27 2         8 $val &= (2 ** $bits) - 1;
28 2         643 $code .= sprintf "%d (0x%0${nibbles}X)\n", $val, $val;
29             }
30 36 100       6089 if ($val == 0) {
31 8         617 $code .= "\tclrf $var\n";
32 8         22 for (2 .. $bytes) {
33 0         0 $code .= sprintf "\tclrf $var + %d\n", ($_ - 1);
34             }
35             } else {
36 28         1346 my $valbyte = $val & ((2 ** 8) - 1);
37 28         2399 $code .= "\tbanksel $var\n";
38 28 50       58 $code .= sprintf "\tmovlw 0x%02X\n\tmovwf $var\n", $valbyte if $valbyte > 0;
39 28 50       811 $code .= "\tclrf $var\n" if $valbyte == 0;
40 28         446 for (2 .. $bytes) {
41 0         0 my $k = $_ * 8;
42 0         0 my $i = $_ - 1;
43 0         0 my $j = $i * 8;
44             # get the right byte. 64-bit math requires bigint
45 0         0 $valbyte = (($val & ((2 ** $k) - 1)) & (2 ** $k - 2 ** $j)) >> $j;
46 0 0       0 $code .= sprintf "\tmovlw 0x%02X\n\tmovwf $var + $i\n", $valbyte if $valbyte > 0;
47 0 0       0 $code .= "\tclrf $var + $i\n" if $valbyte == 0;
48             }
49             }
50 36         925 return $code;
51             }
52              
53             sub _op_assign_str_var {
54 3     3   5 return <<"....";
55             ;;;; for m_op_assign_str/m_op_nullify_str/m_op_concat_byte
56             VIC_VAR_ASSIGN_STRIDX res 1
57             VIC_VAR_ASSIGN_STRLEN res 1
58             ....
59             }
60              
61             sub _op_nullify_str {
62 2     2   4 return << "...";
63             m_op_nullify_str macro dvar, dlen, didx
64             \tlocal _op_nullify_str_loop_0
65             \tlocal _op_nullify_str_loop_1
66             \tbanksel VIC_VAR_ASSIGN_STRLEN
67             \tmovlw dlen
68             \tmovwf VIC_VAR_ASSIGN_STRLEN
69             \tbanksel dvar
70             \tmovlw (dvar - 1)
71             \tmovwf FSR
72             \tbanksel VIC_VAR_ASSIGN_STRIDX
73             \tclrf VIC_VAR_ASSIGN_STRIDX
74             _op_nullify_str_loop_0:
75             \tclrw
76             \tincf FSR, F
77             \tmovwf INDF
78             \tbanksel VIC_VAR_ASSIGN_STRIDX
79             \tincf VIC_VAR_ASSIGN_STRIDX, F
80             \tbcf STATUS, Z
81             \tbcf STATUS, C
82             \tmovf VIC_VAR_ASSIGN_STRIDX, W
83             \tsubwf VIC_VAR_ASSIGN_STRLEN, W
84             \t;; W == 0
85             \tbtfsc STATUS, Z
86             \tgoto _op_nullify_str_loop_1
87             \tgoto _op_nullify_str_loop_0
88             _op_nullify_str_loop_1:
89             \tbanksel didx
90             \tclrf didx
91             \tendm
92             ...
93             }
94              
95             sub _op_assign_str {
96 2     2   7 return <<"...";
97             m_op_assign_str macro dvar, dlen, cvar, clen
98             \tlocal _op_assign_str_loop_0
99             \tlocal _op_assign_str_loop_1
100             \tbanksel VIC_VAR_ASSIGN_STRLEN
101             if dlen > clen
102             \tmovlw clen
103             else
104             \tmovlw dlen
105             endif
106             \tmovwf VIC_VAR_ASSIGN_STRLEN
107             \tbanksel dvar
108             \tmovlw (dvar - 1)
109             \tmovwf FSR
110             \tbanksel VIC_VAR_ASSIGN_STRIDX
111             \tclrf VIC_VAR_ASSIGN_STRIDX
112             _op_assign_str_loop_0:
113             \tmovf VIC_VAR_ASSIGN_STRIDX, W
114             \tcall cvar
115             \tincf FSR, F
116             \tmovwf INDF
117             \tbanksel VIC_VAR_ASSIGN_STRIDX
118             \tincf VIC_VAR_ASSIGN_STRIDX, F
119             \tbcf STATUS, Z
120             \tbcf STATUS, C
121             \tmovf VIC_VAR_ASSIGN_STRIDX, W
122             \tsubwf VIC_VAR_ASSIGN_STRLEN, W
123             \t;; W == 0
124             \tbtfsc STATUS, Z
125             \tgoto _op_assign_str_loop_1
126             \tgoto _op_assign_str_loop_0
127             _op_assign_str_loop_1:
128             \tnop
129             \tendm
130             ...
131             }
132              
133             sub _get_idx_var {
134 3     3   3 my ($self, $var) = @_;
135 3         7 return uc ($var . '_IDX');
136             }
137              
138             sub op_assign {
139 52     52 0 201 my ($self, $var1, $var2, %extra) = @_;
140 52 50       120 return unless $self->doesrole('Operators');
141 52         190 my $literal = qr/^\d+$/;
142 52 100       404 return $self->_assign_literal($var1, $var2) if $var2 =~ $literal;
143 16         45 my $code = '';
144 16 100       51 if (ref $var1 eq 'HASH') {
145 2 50       9 if ($var1->{type} eq 'string') {
146 2 50 33     12 if (ref $var2 eq 'HASH' && exists $var2->{string}) {
147             # allocate the constant string into the variable location
148 2         4 my $cvar = $var2->{name};# constant var location
149 2         9 my $clen = sprintf "0x%02X", $var2->{size};# constant length definition
150 2         30 my $dlen = $var1->{size};# destination length definition
151 2         2 my $dvar = $var1->{name};
152 2         8 my $macros = {};
153 2         9 $macros->{m_op_assign_str} = $self->_op_assign_str;
154 2         9 $macros->{m_op_assign_var} = $self->_op_assign_str_var;
155 2         6 $macros->{m_op_nullify_str} = $self->_op_nullify_str;
156 2 100       7 unless ($var2->{empty}) {
157 1         3 $code .= "\t;;;; moving contents of $cvar into $dvar with bounds checking\n";
158 1         3 $code .= "\tm_op_assign_str $dvar, $dlen, $cvar, $clen\n";
159             } else {
160 1         27 $code .= "\t;;;; storing an empty string in $dvar\n";
161 1         4 my $idxvar = $self->_get_idx_var($dvar);
162 1         4 $code .= "\tm_op_nullify_str $dvar, $dlen, $idxvar\n";
163             }
164 2 50       13 return wantarray ? ($code, {}, $macros, []) : $code;
165             } else {
166             #YYY { lhs => $var1, rhs => $var2 };
167 0         0 carp $var1->{name}, " has been defined as a string and '$var2' is not a string !";
168 0         0 return;
169             }
170             }
171             }
172 14         53 my $b1 = POSIX::ceil($self->address_bits($var1) / 8);
173 14         1241 my $b2 = POSIX::ceil($self->address_bits($var2) / 8);
174 14         1056 $var2 = uc $var2;
175 14         24 $var1 = uc $var1;
176 14         61 $code = "\t;; moving $var2 to $var1\n";
177 14 50       49 if ($b1 == $b2) {
    0          
    0          
178 14         47 $code .= "\tmovf $var2, W\n\tmovwf $var1\n";
179 14         45 for (2 .. $b1) {
180 0         0 my $i = $_ - 1;
181 0         0 $code .= "\tmovf $var2 + $i, W\n\tmovwf $var1 + $i\n";
182             }
183             } elsif ($b1 > $b2) {
184             # we are moving a smaller var into a larger var
185 0         0 $code .= "\t;; $var2 has a smaller size than $var1\n";
186 0         0 $code .= "\tmovf $var2, W\n\tmovwf $var1\n";
187 0         0 for (2 .. $b2) {
188 0         0 my $i = $_ - 1;
189 0         0 $code .= "\tmovf $var2 + $i, W\n\tmovwf $var1 + $i\n";
190             }
191 0         0 $code .= "\t;; we practice safe assignment here. zero out the rest\n";
192             # we practice safe mathematics here. zero-out the rest of the place
193 0         0 $b2++;
194 0         0 for ($b2 .. $b1) {
195 0         0 $code .= sprintf "\tclrf $var1 + %d\n", ($_ - 1);
196             }
197             } elsif ($b1 < $b2) {
198             # we are moving a larger var into a smaller var
199 0         0 $code .= "\t;; $var2 has a larger size than $var1. truncating..,\n";
200 0         0 $code .= "\tmovf $var2, W\n\tmovwf $var1\n";
201 0         0 for (2 .. $b1) {
202 0         0 my $i = $_ - 1;
203 0         0 $code .= "\tmovf $var2 + $i, W\n\tmovwf $var1 + $i\n";
204             }
205             } else {
206 0         0 carp "Warning: should never reach here: $var1 is $b1 bytes and $var2 is $b2 bytes";
207             }
208 14 50       344 $code .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
209 14         60 return $code;
210             }
211              
212             sub op_assign_wreg {
213 80     80 0 79 my ($self, $var) = @_;
214 80 50       134 return unless $self->doesrole('Operators');
215 80 50       110 return unless $var;
216 80         73 $var = uc $var;
217 80         137 return "\tmovwf $var\n";
218             }
219              
220             sub rol {
221 2     2 0 13 my ($self, $var, $bits) = @_;
222 2 50       7 return unless $self->doesroles(qw(Operators Chip));
223 2 50       9 unless (exists $self->registers->{STATUS}) {
224 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
225 0         0 return;
226             }
227 2         4 $var = uc $var;
228 2         3 my $code = <<"...";
229             \tbcf STATUS, C
230             ...
231 2         7 for (1 .. $bits) {
232 2         58 $code .= << "...";
233             \trlf $var, 1
234             \tbtfsc STATUS, C
235             \tbsf $var, 0
236             ...
237             }
238 2         5 return $code;
239             }
240              
241             sub ror {
242 4     4 0 25 my ($self, $var, $bits) = @_;
243 4 50       13 return unless $self->doesroles(qw(Operators Chip));
244 4 50       21 unless (exists $self->registers->{STATUS}) {
245 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
246 0         0 return;
247             }
248 4         9 $var = uc $var;
249 4         6 my $code = <<"...";
250             \tbcf STATUS, C
251             ...
252 4         13 for (1 .. $bits) {
253 4         127 $code .= << "...";
254             \trrf $var, 1
255             \tbtfsc STATUS, C
256             \tbsf $var, 7
257             ...
258             }
259 4         10 return $code;
260             }
261              
262             sub op_shl {
263 4     4 0 17 my ($self, $var, $bits, %extra) = @_;
264 4 50       16 return unless $self->doesroles(qw(Operators Chip));
265 4 50       17 unless (exists $self->registers->{STATUS}) {
266 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
267 0         0 return;
268             }
269 4         17 my $literal = qr/^\d+$/;
270 4         5 my $code = '';
271 4 50 33     36 if ($var !~ $literal and $bits =~ $literal) {
    0 0        
272 4         6 $var = uc $var;
273 4         10 $code .= "\t;;;; perform $var << $bits\n";
274 4 50       10 if ($bits == 1) {
    0          
275 4         228 $code .= << "...";
276             \tbcf STATUS, C
277             \trlf $var, W
278             \tbtfsc STATUS, C
279             \tbcf $var, 0
280             ...
281             } elsif ($bits == 0) {
282 0         0 $code .= "\tmovf $var, W\n";
283             } else {
284 0         0 carp "Not implemented. use the 'shl' instruction\n";
285 0         0 return;
286             }
287             } elsif ($var =~ $literal and $bits =~ $literal) {
288 0         0 my $res = $var << $bits;
289 0         0 $code .= "\t;;;; perform $var << $bits = $res\n";
290 0         0 $code .= sprintf "\tmovlw 0x%02X\n", $res;
291             } else {
292 0         0 carp "Unable to handle $var << $bits";
293 0         0 return;
294             }
295 4 100       14 $code .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
296 4         11 return $code;
297             }
298              
299             sub op_shr {
300 7     7 0 23 my ($self, $var, $bits, %extra) = @_;
301 7 50       21 return unless $self->doesroles(qw(Operators Chip));
302 7 50       31 unless (exists $self->registers->{STATUS}) {
303 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
304 0         0 return;
305             }
306 7         19 my $literal = qr/^\d+$/;
307 7         9 my $code = '';
308 7 50 33     73 if ($var !~ $literal and $bits =~ $literal) {
    0 0        
309 7         13 $var = uc $var;
310 7         19 $code .= "\t;;;; perform $var >> $bits\n";
311 7 50       32 if ($bits == 1) {
    0          
312 7         408 $code .= << "...";
313             \tbcf STATUS, C
314             \trrf $var, W
315             \tbtfsc STATUS, C
316             \tbcf $var, 7
317             ...
318             } elsif ($bits == 0) {
319 0         0 $code .= "\tmovf $var, W\n";
320             } else {
321 0         0 carp "Not implemented. use the 'shr' instruction\n";
322 0         0 return;
323             }
324             } elsif ($var =~ $literal and $bits =~ $literal) {
325 0         0 my $res = $var >> $bits;
326 0         0 $code .= "\t;;;; perform $var >> $bits = $res\n";
327 0         0 $code .= sprintf "\tmovlw 0x%02X\n", $res;
328             } else {
329 0         0 carp "Unable to handle $var >> $bits";
330 0         0 return;
331             }
332 7 100       24 $code .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
333 7         20 return $code;
334             }
335              
336             sub shl {
337 0     0 0 0 my ($self, $var, $bits) = @_;
338 0 0       0 return unless $self->doesroles(qw(Operators Chip));
339 0 0       0 unless (exists $self->registers->{STATUS}) {
340 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
341 0         0 return;
342             }
343 0         0 $var = uc $var;
344 0         0 my $code = '';
345 0         0 for (1 .. $bits) {
346 0         0 $code .= << "...";
347             \trlf $var, 1
348             ...
349             }
350 0         0 $code .= << "...";
351             \tbcf STATUS, C
352             ...
353             }
354              
355             sub shr {
356 0     0 0 0 my ($self, $var, $bits) = @_;
357 0 0       0 return unless $self->doesroles(qw(Operators Chip));
358 0 0       0 unless (exists $self->registers->{STATUS}) {
359 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
360 0         0 return;
361             }
362 0         0 $var = uc $var;
363 0         0 my $code = '';
364 0         0 for (1 .. $bits) {
365 0         0 $code .= << "...";
366             \trrf $var, 1
367             ...
368             }
369 0         0 $code .= << "...";
370             \tbcf STATUS, C
371             ...
372             }
373              
374             sub op_not {
375 7     7 0 34 my $self = shift;
376 7         7 my $var2 = shift;
377 7 50       22 return unless $self->doesroles(qw(Operators Chip));
378 7 50       29 unless (exists $self->registers->{STATUS}) {
379 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
380 0         0 return;
381             }
382 7         9 my $pred = '';
383 7 50       15 if (@_) {
384 7         19 my ($dummy, %extra) = @_;
385 7 50       27 $pred .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
386             }
387 7         10 $var2 = uc $var2;
388 7         30 return << "...";
389             \t;;;; generate code for !$var2
390             \tmovf $var2, W
391             \tbtfss STATUS, Z
392             \tgoto \$ + 3
393             \tmovlw 1
394             \tgoto \$ + 2
395             \tclrw
396             $pred
397             ...
398             # used to be
399             #;;\tcomf $var2, W
400             #;;\tbtfsc STATUS, Z
401             #;;\tmovlw 1
402             }
403              
404             sub op_comp {
405 0     0 0 0 my $self = shift;
406 0         0 my $var2 = shift;
407 0         0 my $pred = '';
408 0 0       0 if (@_) {
409 0         0 my ($dummy, %extra) = @_;
410 0 0       0 $pred .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
411             }
412 0         0 $var2 = uc $var2;
413 0         0 return << "...";
414             \t;;;; generate code for ~$var2
415             \tcomf $var2, W
416             $pred
417             ...
418             }
419              
420             sub op_add_assign_literal {
421 2     2 0 4 my ($self, $var, $val, %extra) = @_;
422 2 50       6 return unless $self->doesroles(qw(Operators Chip));
423 2 50       8 unless (exists $self->registers->{STATUS}) {
424 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
425 0         0 return;
426             }
427 2         7 my $b1 = POSIX::ceil($self->address_bits($var) / 8);
428 2         147 $var = uc $var;
429 2         4 my $nibbles = 2 * $b1;
430 2         172 my $code = sprintf "\t;; $var = $var + 0x%0${nibbles}X\n", $val;
431 2 50       38 return $code if $val == 0;
432             # we expect b1 == 1,2,4,8
433 2 50       112 my $b2 = 1 if $val < 2 ** 8;
434 2 50 33     97 $b2 = 2 if ($val < 2 ** 16 and $val >= 2 ** 8);
435 2 50 33     190 $b2 = 4 if ($val < 2 ** 32 and $val >= 2 ** 16);
436 2 50 33     200 $b2 = 8 if ($val < 2 ** 64 and $val >= 2 ** 32);
437 2 50       211 if ($b1 > $b2) {
    50          
438             } elsif ($b1 < $b2) {
439              
440             } else {
441             # $b1 == $b2
442 2         214 my $valbyte = $val & ((2 ** 8) - 1);
443 2         166 $code .= sprintf "\t;; add 0x%02X to byte[0]\n", $valbyte;
444 2 50       27 $code .= sprintf "\tmovlw 0x%02X\n\taddwf $var, F\n", $valbyte if $valbyte > 0;
445 2 50       55 $code .= sprintf "\tbcf STATUS, C\n" if $valbyte == 0;
446 2         31 for (2 .. $b1) {
447 0         0 my $k = $_ * 8;
448 0         0 my $i = $_ - 1;
449 0         0 my $j = $i * 8;
450             # get the right byte. 64-bit math requires bigint
451 0         0 $valbyte = (($val & ((2 ** $k) - 1)) & (2 ** $k - 2 ** $j)) >> $j;
452 0         0 $code .= sprintf "\t;; add 0x%02X to byte[$i]\n", $valbyte;
453 0         0 $code .= "\tbtfsc STATUS, C\n\tincf $var + $i, F\n";
454 0 0       0 $code .= sprintf "\tmovlw 0x%02X\n\taddwf $var + $i, F\n", $valbyte if $valbyte > 0;
455             }
456             }
457 2 50       51 $code .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
458 2         10 return $code;
459             }
460              
461             ## TODO: handle carry bit
462             sub op_add_assign {
463 2     2 0 11 my ($self, $var, $var2, %extra) = @_;
464 2         5 my $literal = qr/^\d+$/;
465 2 50       21 return $self->op_add_assign_literal($var, $var2, %extra) if $var2 =~ $literal;
466 0         0 $var = uc $var;
467 0         0 $var2 = uc $var2;
468 0         0 my $code = '';
469 0 0       0 $code .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
470 0         0 return << "...";
471             \t;;moves $var2 to W
472             \tmovf $var2, W
473             \taddwf $var, F
474             $code
475             ...
476             }
477              
478             ## TODO: handle carry bit
479             sub op_sub_assign {
480 2     2 0 11 my ($self, $var, $var2) = @_;
481 2         7 my ($code, $funcs, $macros) = $self->op_sub($var, $var2);
482 2         10 $code .= $self->op_assign_wreg($var);
483 2 50       10 return wantarray ? ($code, $funcs, $macros) : $code;
484             }
485              
486             sub op_mul_assign {
487 2     2 0 9 my ($self, $var, $var2) = @_;
488 2         5 my ($code, $funcs, $macros) = $self->op_mul($var, $var2);
489 2         7 $code .= $self->op_assign_wreg($var);
490 2 50       13 return wantarray ? ($code, $funcs, $macros) : $code;
491             }
492              
493             sub op_div_assign {
494 2     2 0 7 my ($self, $var, $var2) = @_;
495 2         6 my ($code, $funcs, $macros) = $self->op_div($var, $var2);
496 2         5 $code .= $self->op_assign_wreg($var);
497 2 50       7 return wantarray ? ($code, $funcs, $macros) : $code;
498             }
499              
500             sub op_mod_assign {
501 2     2 0 10 my ($self, $var, $var2) = @_;
502 2         10 my ($code, $funcs, $macros) = $self->op_mod($var, $var2);
503 2         5 $code .= $self->op_assign_wreg($var);
504 2 50       12 return wantarray ? ($code, $funcs, $macros) : $code;
505             }
506              
507             sub op_bxor_assign {
508 2     2 0 10 my ($self, $var, $var2) = @_;
509 2         8 my ($code, $funcs, $macros) = $self->op_bxor($var, $var2);
510 2         12 $code .= $self->op_assign_wreg($var);
511 2 50       9 return wantarray ? ($code, $funcs, $macros) : $code;
512             }
513              
514             sub op_band_assign {
515 3     3 0 15 my ($self, $var, $var2) = @_;
516 3         12 my ($code, $funcs, $macros) = $self->op_band($var, $var2);
517 3         9 $code .= $self->op_assign_wreg($var);
518 3 50       9 return wantarray ? ($code, $funcs, $macros) : $code;
519             }
520              
521             sub op_bor_assign {
522 2     2 0 10 my ($self, $var, $var2) = @_;
523 2         11 my ($code, $funcs, $macros) = $self->op_bor($var, $var2);
524 2         5 $code .= $self->op_assign_wreg($var);
525 2 50       7 return wantarray ? ($code, $funcs, $macros) : $code;
526             }
527              
528             sub op_shl_assign {
529 2     2 0 8 my ($self, $var, $var2) = @_;
530 2         8 my ($code, $funcs, $macros) = $self->op_shl($var, $var2);
531 2         9 $code .= $self->op_assign_wreg($var);
532 2 50       9 return wantarray ? ($code, $funcs, $macros) : $code;
533             }
534              
535             sub op_shr_assign {
536 5     5 0 22 my ($self, $var, $var2) = @_;
537 5         16 my ($code, $funcs, $macros) = $self->op_shr($var, $var2);
538 5         14 $code .= $self->op_assign_wreg($var);
539 5 50       20 return wantarray ? ($code, $funcs, $macros) : $code;
540             }
541              
542             sub op_inc {
543 6     6 0 27 my ($self, $var) = @_;
544 6 50       24 return unless $self->doesroles(qw(Operators Chip));
545 6 50       31 unless (exists $self->registers->{STATUS}) {
546 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
547 0         0 return;
548             }
549             # we expect b1 == 1,2,4,8
550 6         24 my $b1 = POSIX::ceil($self->address_bits($var) / 8);
551 6         447 my $code = "\t;; increments $var in place\n";
552 6         15 $code .= "\t;; increment byte[0]\n\tincf $var, F\n";
553 6         21 for (2 .. $b1) {
554 0         0 my $j = $_ - 1;
555 0         0 my $i = $_ - 2;
556 0         0 $code .= << "...";
557             \t;; increment byte[$j] iff byte[$i] == 0
558             \tbtfsc STATUS, Z
559             \tincf $var + $j, F
560             ...
561             }
562 6         132 return $code;
563             }
564              
565             sub op_dec {
566 2     2 0 10 my ($self, $var) = @_;
567 2 50       16 return unless $self->doesroles(qw(Operators Chip));
568 2 50       11 unless (exists $self->registers->{STATUS}) {
569 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
570 0         0 return;
571             }
572 2         7 my $b1 = POSIX::ceil($self->address_bits($var) / 8);
573 2         178 my $code = "\t;; decrements $var in place\n";
574 2 50       5 $code .= "\tmovf $var, W\n" if $b1 > 1;
575 2         132 for (2 .. $b1) {
576 0         0 my $i = $_ - 1;
577 0         0 my $j = $i - 1;
578 0         0 $code .= << "...";
579             \t;; decrement byte[$i] iff byte[$j] == 0
580             \tbtfsc STATUS, Z
581             \tdecf $var + $i, F
582             ...
583             }
584 2         47 $code .= "\t;; decrement byte[0]\n\tdecf $var, F\n";
585 2         6 return $code;
586             }
587              
588             sub op_add {
589 16     16 0 78 my ($self, $var1, $var2, %extra) = @_;
590 16 50       33 return unless $self->doesrole('Chip');
591 16         33 my $literal = qr/^\d+$/;
592 16         17 my $code = '';
593             #TODO: temporary only 8-bit math
594 16         11 my ($b1, $b2);
595 16 100 66     182 if ($var1 !~ $literal and $var2 !~ $literal) {
    50 33        
    50 33        
596 12         17 $var1 = uc $var1;
597 12         13 $var2 = uc $var2;
598 12         26 $b1 = $self->address_bits($var1);
599 12         43 $b2 = $self->address_bits($var2);
600             # both are variables
601 12         35 $code .= << "...";
602             \t;; add $var1 and $var2 without affecting either
603             \tmovf $var1, W
604             \taddwf $var2, W
605             ...
606             } elsif ($var1 =~ $literal and $var2 !~ $literal) {
607 0         0 $var2 = uc $var2;
608 0         0 $var1 = sprintf "0x%02X", $var1;
609 0         0 $b2 = $self->address_bits($var2);
610             # var1 is literal and var2 is variable
611             # TODO: check for bits for var1
612 0         0 $code .= << "...";
613             \t;; add $var1 and $var2 without affecting $var2
614             \tmovf $var2, W
615             \taddlw $var1
616             ...
617             } elsif ($var1 !~ $literal and $var2 =~ $literal) {
618 4         8 $var1 = uc $var1;
619 4         15 $var2 = sprintf "0x%02X", $var2;
620             # var2 is literal and var1 is variable
621 4         12 $b1 = $self->address_bits($var1);
622             # TODO: check for bits for var1
623 4         15 $code .= << "...";
624             \t;; add $var2 and $var1 without affecting $var1
625             \tmovf $var1, W
626             \taddlw $var2
627             ...
628             } else {
629             # both are literals
630             # TODO: check for bits
631 0         0 my $var3 = $var1 + $var2;
632 0         0 $var3 = sprintf "0x%02X", $var3;
633 0         0 $code .= << "...";
634             \t;; $var1 + $var2 = $var3
635             \tmovlw $var3
636             ...
637             }
638 16 50       52 $code .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
639 16         47 return $code;
640             }
641              
642             sub op_sub {
643 8     8 0 35 my ($self, $var1, $var2, %extra) = @_;
644 8 50       21 return unless $self->doesrole('Chip');
645 8         19 my $literal = qr/^\d+$/;
646 8         10 my $code = '';
647             #TODO: temporary only 8-bit math
648 8         6 my ($b1, $b2);
649 8 50 33     69 if ($var1 !~ $literal and $var2 !~ $literal) {
    0 0        
    0 0        
650 8         12 $var1 = uc $var1;
651 8         8 $var2 = uc $var2;
652 8         17 $b1 = $self->address_bits($var1);
653 8         16 $b2 = $self->address_bits($var2);
654             # both are variables
655 8         27 $code .= << "...";
656             \t;; perform $var1 - $var2 without affecting either
657             \tmovf $var2, W
658             \tsubwf $var1, W
659             ...
660             } elsif ($var1 =~ $literal and $var2 !~ $literal) {
661 0         0 $var2 = uc $var2;
662 0         0 $var1 = sprintf "0x%02X", $var1;
663 0         0 $b2 = $self->address_bits($var2);
664             # var1 is literal and var2 is variable
665             # TODO: check for bits for var1
666 0         0 $code .= << "...";
667             \t;; perform $var1 - $var2 without affecting $var2
668             \tmovf $var2, W
669             \tsublw $var1
670             ...
671             } elsif ($var1 !~ $literal and $var2 =~ $literal) {
672 0         0 $var1 = uc $var1;
673 0         0 $var2 = sprintf "0x%02X", $var2;
674             # var2 is literal and var1 is variable
675 0         0 $b1 = $self->address_bits($var1);
676             # TODO: check for bits for var1
677 0         0 $code .= << "...";
678             \t;; perform $var1 - $var2 without affecting $var1
679             \tmovlw $var2
680             \tsubwf $var1, W
681             ...
682             } else {
683             # both are literals
684             # TODO: check for bits
685 0         0 my $var3 = $var1 - $var2;
686 0         0 $var3 = sprintf "0x%02X", $var3;
687 0         0 $code .= << "...";
688             \t;; $var1 - $var2 = $var3
689             \tmovlw $var3
690             ...
691             }
692 8 100       23 $code .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
693 8         23 return $code;
694             }
695              
696             sub _macro_multiply_var {
697             # TODO: do more than 8 bits
698 12     12   22 return << "...";
699             ;;;;;; VIC_VAR_MULTIPLY VARIABLES ;;;;;;;
700              
701             VIC_VAR_MULTIPLY_UDATA udata
702             VIC_VAR_MULTIPLICAND res 2
703             VIC_VAR_MULTIPLIER res 2
704             VIC_VAR_PRODUCT res 2
705             ...
706             }
707              
708             sub _macro_multiply_macro {
709 12     12   31 return << "...";
710             ;;;;;; Taken from Microchip PIC examples.
711             ;;;;;; multiply v1 and v2 using shifting. multiplication of 8-bit values is done
712             ;;;;;; using 16-bit variables. v1 is a variable and v2 is a constant
713             m_multiply_internal macro
714             local _m_multiply_loop_0, _m_multiply_skip
715             clrf VIC_VAR_PRODUCT
716             clrf VIC_VAR_PRODUCT + 1
717             _m_multiply_loop_0:
718             rrf VIC_VAR_MULTIPLICAND, F
719             btfss STATUS, C
720             goto _m_multiply_skip
721             movf VIC_VAR_MULTIPLIER + 1, W
722             addwf VIC_VAR_PRODUCT + 1, F
723             movf VIC_VAR_MULTIPLIER, W
724             addwf VIC_VAR_PRODUCT, F
725             btfsc STATUS, C
726             incf VIC_VAR_PRODUCT + 1, F
727             _m_multiply_skip:
728             bcf STATUS, C
729             rlf VIC_VAR_MULTIPLIER, F
730             rlf VIC_VAR_MULTIPLIER + 1, F
731             movf VIC_VAR_MULTIPLICAND, F
732             btfss STATUS, Z
733             goto _m_multiply_loop_0
734             movf VIC_VAR_PRODUCT, W
735             endm
736             ;;;;;;; v1 is variable and v2 is literal
737             m_multiply_1 macro v1, v2
738             movf v1, W
739             movwf VIC_VAR_MULTIPLIER
740             clrf VIC_VAR_MULTIPLIER + 1
741             movlw v2
742             movwf VIC_VAR_MULTIPLICAND
743             clrf VIC_VAR_MULTIPLICAND + 1
744             m_multiply_internal
745             endm
746             ;;;;;; multiply v1 and v2 using shifting. multiplication of 8-bit values is done
747             ;;;;;; using 16-bit variables. v1 and v2 are variables
748             m_multiply_2 macro v1, v2
749             movf v1, W
750             movwf VIC_VAR_MULTIPLIER
751             clrf VIC_VAR_MULTIPLIER + 1
752             movf v2, W
753             movwf VIC_VAR_MULTIPLICAND
754             clrf VIC_VAR_MULTIPLICAND + 1
755             m_multiply_internal
756             endm
757             ...
758             }
759              
760             sub op_mul {
761 12     12 0 56 my ($self, $var1, $var2, %extra) = @_;
762 12         32 my $literal = qr/^\d+$/;
763 12         9 my $code = '';
764             #TODO: temporary only 8-bit math
765 12         10 my ($b1, $b2);
766 12 100 66     138 if ($var1 !~ $literal and $var2 !~ $literal) {
    50 33        
    50 33        
767 8         9 $var1 = uc $var1;
768 8         10 $var2 = uc $var2;
769 8         24 $b1 = $self->address_bits($var1);
770 8         18 $b2 = $self->address_bits($var2);
771             # both are variables
772 8         25 $code .= << "...";
773             \t;; perform $var1 * $var2 without affecting either
774             \tm_multiply_2 $var1, $var2
775             ...
776             } elsif ($var1 =~ $literal and $var2 !~ $literal) {
777 0         0 $var2 = uc $var2;
778 0         0 $var1 = sprintf "0x%02X", $var1;
779 0         0 $b2 = $self->address_bits($var2);
780             # var1 is literal and var2 is variable
781             # TODO: check for bits for var1
782 0         0 $code .= << "...";
783             \t;; perform $var1 * $var2 without affecting $var2
784             \tm_multiply_1 $var2, $var1
785             ...
786             } elsif ($var1 !~ $literal and $var2 =~ $literal) {
787 4         7 $var1 = uc $var1;
788 4         14 $var2 = sprintf "0x%02X", $var2;
789             # var2 is literal and var1 is variable
790 4         10 $b1 = $self->address_bits($var1);
791             # TODO: check for bits for var1
792 4         17 $code .= << "...";
793             \t;; perform $var1 * $var2 without affecting $var1
794             \tm_multiply_1 $var1, $var2
795             ...
796             } else {
797             # both are literals
798             # TODO: check for bits
799 0         0 my $var3 = $var1 * $var2;
800 0         0 $var3 = sprintf "0x%02X", $var3;
801 0         0 $code .= << "...";
802             \t;; $var1 * $var2 = $var3
803             \tmovlw $var3
804             ...
805             }
806 12         30 my $macros = {
807             m_multiply_var => $self->_macro_multiply_var,
808             m_multiply_macro => $self->_macro_multiply_macro,
809             };
810 12 100       37 $code .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
811 12 50       43 return wantarray ? ($code, {}, $macros) : $code;
812             }
813              
814             sub _macro_divide_var {
815             # TODO: do more than 8 bits
816 14     14   32 return << "...";
817             ;;;;;; VIC_VAR_DIVIDE VARIABLES ;;;;;;;
818              
819             VIC_VAR_DIVIDE_UDATA udata
820             VIC_VAR_DIVISOR res 2
821             VIC_VAR_REMAINDER res 2
822             VIC_VAR_QUOTIENT res 2
823             VIC_VAR_BITSHIFT res 2
824             VIC_VAR_DIVTEMP res 1
825             ...
826             }
827              
828             sub _macro_divide_macro {
829 14     14   32 return << "...";
830             ;;;;;; Taken from Microchip PIC examples.
831             m_divide_internal macro
832             local _m_divide_shiftuploop, _m_divide_loop, _m_divide_shift
833             clrf VIC_VAR_QUOTIENT
834             clrf VIC_VAR_QUOTIENT + 1
835             clrf VIC_VAR_BITSHIFT + 1
836             movlw 0x01
837             movwf VIC_VAR_BITSHIFT
838             _m_divide_shiftuploop:
839             bcf STATUS, C
840             rlf VIC_VAR_DIVISOR, F
841             rlf VIC_VAR_DIVISOR + 1, F
842             bcf STATUS, C
843             rlf VIC_VAR_BITSHIFT, F
844             rlf VIC_VAR_BITSHIFT + 1, F
845             btfss VIC_VAR_DIVISOR + 1, 7
846             goto _m_divide_shiftuploop
847             _m_divide_loop:
848             movf VIC_VAR_DIVISOR, W
849             subwf VIC_VAR_REMAINDER, W
850             movwf VIC_VAR_DIVTEMP
851             movf VIC_VAR_DIVISOR + 1, W
852             btfss STATUS, C
853             addlw 0x01
854             subwf VIC_VAR_REMAINDER + 1, W
855             btfss STATUS, C
856             goto _m_divide_shift
857             movwf VIC_VAR_REMAINDER + 1
858             movf VIC_VAR_DIVTEMP, W
859             movwf VIC_VAR_REMAINDER
860             movf VIC_VAR_BITSHIFT + 1, W
861             addwf VIC_VAR_QUOTIENT + 1, F
862             movf VIC_VAR_BITSHIFT, W
863             addwf VIC_VAR_QUOTIENT, F
864             _m_divide_shift:
865             bcf STATUS, C
866             rrf VIC_VAR_DIVISOR + 1, F
867             rrf VIC_VAR_DIVISOR, F
868             bcf STATUS, C
869             rrf VIC_VAR_BITSHIFT + 1, F
870             rrf VIC_VAR_BITSHIFT, F
871             btfss STATUS, C
872             goto _m_divide_loop
873             endm
874             ;;;;;; v1 and v2 are variables
875             m_divide_2 macro v1, v2
876             movf v1, W
877             movwf VIC_VAR_REMAINDER
878             clrf VIC_VAR_REMAINDER + 1
879             movf v2, W
880             movwf VIC_VAR_DIVISOR
881             clrf VIC_VAR_DIVISOR + 1
882             m_divide_internal
883             movf VIC_VAR_QUOTIENT, W
884             endm
885             ;;;;;; v1 is literal and v2 is variable
886             m_divide_1a macro v1, v2
887             movlw v1
888             movwf VIC_VAR_REMAINDER
889             clrf VIC_VAR_REMAINDER + 1
890             movf v2, W
891             movwf VIC_VAR_DIVISOR
892             clrf VIC_VAR_DIVISOR + 1
893             m_divide_internal
894             movf VIC_VAR_QUOTIENT, W
895             endm
896             ;;;;;;; v2 is literal and v1 is variable
897             m_divide_1b macro v1, v2
898             movf v1, W
899             movwf VIC_VAR_REMAINDER
900             clrf VIC_VAR_REMAINDER + 1
901             movlw v2
902             movwf VIC_VAR_DIVISOR
903             clrf VIC_VAR_DIVISOR + 1
904             m_divide_internal
905             movf VIC_VAR_QUOTIENT, W
906             endm
907             m_mod_2 macro v1, v2
908             m_divide_2 v1, v2
909             movf VIC_VAR_REMAINDER, W
910             endm
911             ;;;;;; v1 is literal and v2 is variable
912             m_mod_1a macro v1, v2
913             m_divide_1a v1, v2
914             movf VIC_VAR_REMAINDER, W
915             endm
916             ;;;;;;; v2 is literal and v1 is variable
917             m_mod_1b macro v1, v2
918             m_divide_1b v1, v2
919             movf VIC_VAR_REMAINDER, W
920             endm
921             ...
922             }
923              
924             sub op_div {
925 8     8 0 34 my ($self, $var1, $var2, %extra) = @_;
926 8         18 my $literal = qr/^\d+$/;
927 8         16 my $code = '';
928             #TODO: temporary only 8-bit math
929 8         10 my ($b1, $b2);
930 8 100 66     84 if ($var1 !~ $literal and $var2 !~ $literal) {
    50 33        
    50 33        
931 6         9 $var1 = uc $var1;
932 6         7 $var2 = uc $var2;
933 6         17 $b1 = $self->address_bits($var1);
934 6         15 $b2 = $self->address_bits($var2);
935             # both are variables
936 6         20 $code .= << "...";
937             \t;; perform $var1 / $var2 without affecting either
938             \tm_divide_2 $var1, $var2
939             ...
940             } elsif ($var1 =~ $literal and $var2 !~ $literal) {
941 0         0 $var2 = uc $var2;
942 0         0 $var1 = sprintf "0x%02X", $var1;
943 0         0 $b2 = $self->address_bits($var2);
944             # var1 is literal and var2 is variable
945             # TODO: check for bits for var1
946 0         0 $code .= << "...";
947             \t;; perform $var1 / $var2 without affecting $var2
948             \tm_divide_1a $var1, $var2
949             ...
950             } elsif ($var1 !~ $literal and $var2 =~ $literal) {
951 2         5 $var1 = uc $var1;
952 2         8 $var2 = sprintf "0x%02X", $var2;
953             # var2 is literal and var1 is variable
954 2         11 $b1 = $self->address_bits($var1);
955             # TODO: check for bits for var1
956 2         10 $code .= << "...";
957             \t;; perform $var1 / $var2 without affecting $var1
958             \tm_divide_1b $var1, $var2
959             ...
960             } else {
961             # both are literals
962             # TODO: check for bits
963 0         0 my $var3 = int($var1 / $var2);
964 0         0 $var3 = sprintf "0x%02X", $var3;
965 0         0 $code .= << "...";
966             \t;; $var1 / $var2 = $var3
967             \tmovlw $var3
968             ...
969             }
970 8         16 my $macros = {
971             m_divide_var => $self->_macro_divide_var,
972             m_divide_macro => $self->_macro_divide_macro,
973             };
974 8 100       32 $code .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
975 8 50       34 return wantarray ? ($code, {}, $macros) : $code;
976             }
977              
978             sub op_mod {
979 6     6 0 31 my ($self, $var1, $var2, %extra) = @_;
980 6         16 my $literal = qr/^\d+$/;
981 6         6 my $code = '';
982             #TODO: temporary only 8-bit math
983 6         8 my ($b1, $b2);
984 6 50 33     55 if ($var1 !~ $literal and $var2 !~ $literal) {
    0 0        
    0 0        
985 6         8 $var1 = uc $var1;
986 6         8 $var2 = uc $var2;
987 6         15 $b1 = $self->address_bits($var1);
988 6         12 $b2 = $self->address_bits($var2);
989             # both are variables
990 6         20 $code .= << "...";
991             \t;; perform $var1 / $var2 without affecting either
992             \tm_mod_2 $var1, $var2
993             ...
994             } elsif ($var1 =~ $literal and $var2 !~ $literal) {
995 0         0 $var2 = uc $var2;
996 0         0 $var1 = sprintf "0x%02X", $var1;
997 0         0 $b2 = $self->address_bits($var2);
998             # var1 is literal and var2 is variable
999             # TODO: check for bits for var1
1000 0         0 $code .= << "...";
1001             \t;; perform $var1 / $var2 without affecting $var2
1002             \tm_mod_1a $var1, $var2
1003             ...
1004             } elsif ($var1 !~ $literal and $var2 =~ $literal) {
1005 0         0 $var1 = uc $var1;
1006 0         0 $var2 = sprintf "0x%02X", $var2;
1007             # var2 is literal and var1 is variable
1008 0         0 $b1 = $self->address_bits($var1);
1009             # TODO: check for bits for var1
1010 0         0 $code .= << "...";
1011             \t;; perform $var1 / $var2 without affecting $var1
1012             \tm_mod_1b $var1, $var2
1013             ...
1014             } else {
1015             # both are literals
1016             # TODO: check for bits
1017 0         0 my $var3 = int($var1 % $var2);
1018 0         0 $var3 = sprintf "0x%02X", $var3;
1019 0         0 $code .= << "...";
1020             \t;; $var1 / $var2 = $var3
1021             \tmovlw $var3
1022             ...
1023             }
1024 6         12 my $macros = {
1025             m_divide_var => $self->_macro_divide_var,
1026             m_divide_macro => $self->_macro_divide_macro,
1027             };
1028 6 100       21 $code .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
1029 6 50       28 return wantarray ? ($code, {}, $macros) : $code;
1030             }
1031              
1032             sub op_bxor {
1033 2     2 0 5 my ($self, $var1, $var2, %extra) = @_;
1034 2         6 my $literal = qr/^\d+$/;
1035 2         3 my $code = '';
1036 2 50       6 $code .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
1037 2 50 33     38 if ($var1 !~ $literal and $var2 !~ $literal) {
    50 33        
    0 0        
1038 0         0 $var1 = uc $var1;
1039 0         0 $var2 = uc $var2;
1040 0         0 return << "...";
1041             \t;; perform $var1 ^ $var2 and move into W
1042             \tmovf $var1, W
1043             \txorwf $var2, W
1044             $code
1045             ...
1046             } elsif ($var1 !~ $literal and $var2 =~ $literal) {
1047 2         4 $var1 = uc $var1;
1048 2         8 $var2 = sprintf "0x%02X", $var2;
1049 2         12 return << "...";
1050             \t;; perform $var1 ^ $var2 and move into W
1051             \tmovlw $var2
1052             \txorwf $var1, W
1053             $code
1054             ...
1055             } elsif ($var1 =~ $literal and $var2 !~ $literal) {
1056 0         0 $var2 = uc $var2;
1057 0         0 $var1 = sprintf "0x%02X", $var1;
1058 0         0 return << "...";
1059             \t;; perform $var1 ^ $var2 and move into W
1060             \tmovlw $var1
1061             \txorwf $var2, W
1062             $code
1063             ...
1064             } else {
1065 0         0 my $var3 = $var1 ^ $var2;
1066 0         0 $var3 = sprintf "0x%02X", $var3;
1067 0         0 return << "...";
1068             \t;; $var3 = $var1 ^ $var2. move into W
1069             \tmovlw $var3
1070             $code
1071             ...
1072             }
1073             }
1074              
1075             sub op_band {
1076 3     3 0 7 my ($self, $var1, $var2, %extra) = @_;
1077 3         19 my $literal = qr/^\d+$/;
1078 3         6 my $code = '';
1079 3 50       12 $code .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
1080 3 50 33     51 if ($var1 !~ $literal and $var2 !~ $literal) {
    50 33        
    0 0        
1081 0         0 $var1 = uc $var1;
1082 0         0 $var2 = uc $var2;
1083 0         0 return << "...";
1084             \t;; perform $var1 & $var2 and move into W
1085             \tmovf $var1, W
1086             \tandwf $var2, W
1087             $code
1088             ...
1089             } elsif ($var1 !~ $literal and $var2 =~ $literal) {
1090 3         7 $var1 = uc $var1;
1091 3         13 $var2 = sprintf "0x%02X", $var2;
1092 3         17 return << "...";
1093             \t;; perform $var1 & $var2 and move into W
1094             \tmovlw $var2
1095             \tandwf $var1, W
1096             $code
1097             ...
1098             } elsif ($var1 =~ $literal and $var2 !~ $literal) {
1099 0         0 $var2 = uc $var2;
1100 0         0 $var1 = sprintf "0x%02X", $var1;
1101 0         0 return << "...";
1102             \t;; perform $var1 & $var2 and move into W
1103             \tmovlw $var1
1104             \tandwf $var2, W
1105             $code
1106             ...
1107             } else {
1108 0         0 my $var3 = $var2 & $var1;
1109 0         0 $var3 = sprintf "0x%02X", $var3;
1110 0         0 return << "...";
1111             \t;; $var3 = $var1 & $var2. move into W
1112             \tmovlw $var3
1113             $code
1114             ...
1115             }
1116             }
1117              
1118             sub op_bor {
1119 2     2 0 3 my ($self, $var1, $var2, %extra) = @_;
1120 2         6 my $literal = qr/^\d+$/;
1121 2         4 my $code = '';
1122 2 50       6 $code .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
1123 2 50 33     32 if ($var1 !~ $literal and $var2 !~ $literal) {
    50 33        
    0 0        
1124 0         0 $var1 = uc $var1;
1125 0         0 $var2 = uc $var2;
1126 0         0 return << "...";
1127             \t;; perform $var1 | $var2 and move into W
1128             \tmovf $var1, W
1129             \tiorwf $var2, W
1130             $code
1131             ...
1132             } elsif ($var1 !~ $literal and $var2 =~ $literal) {
1133 2         9 $var1 = uc $var1;
1134 2         7 $var2 = sprintf "0x%02X", $var2;
1135 2         17 return << "...";
1136             \t;; perform $var1 | $var2 and move into W
1137             \tmovlw $var2
1138             \tiorwf $var1, W
1139             $code
1140             ...
1141             } elsif ($var1 =~ $literal and $var2 !~ $literal) {
1142 0         0 $var2 = uc $var2;
1143 0         0 $var1 = sprintf "0x%02X", $var1;
1144 0         0 return << "...";
1145             \t;; perform $var1 | $var2 and move into W
1146             \tmovlw $var1
1147             \tiorwf $var2, W
1148             $code
1149             ...
1150             } else {
1151 0         0 my $var3 = $var1 | $var2;
1152 0         0 $var3 = sprintf "0x%02X", $var3;
1153 0         0 return << "...";
1154             \t;; $var3 = $var1 | $var2. move into W
1155             \tmovlw $var3
1156             $code
1157             ...
1158             }
1159             }
1160              
1161             sub _get_predicate {
1162 14     14   44 my ($self, $comment, %extra) = @_;
1163 14         12 my $pred = '';
1164 14         17 my %labels = ();
1165             ## predicate can be either a result or a jump block
1166 14 100       30 unless (defined $extra{RESULT}) {
1167 11 100       23 my $flabel = $extra{SWAP} ? $extra{TRUE} : $extra{FALSE};
1168 11 100       42 my $tlabel = $extra{SWAP} ? $extra{FALSE} : $extra{TRUE};
1169 11         37 my $elabel = $extra{END};
1170 11         14 $labels{TRUE} = $tlabel;
1171 11         12 $labels{FALSE} = $flabel;
1172 11         10 $labels{END} = $elabel;
1173 11         37 $pred .= << "..."
1174             ;; $comment
1175             \tgoto $flabel
1176             \tgoto $tlabel
1177             $elabel:
1178             ...
1179             } else {
1180 3 100       6 my $flabel = $extra{SWAP} ? "$extra{END}_t_$extra{COUNTER}" :
1181             "$extra{END}_f_$extra{COUNTER}";
1182 3 100       82 my $tlabel = $extra{SWAP} ? "$extra{END}_f_$extra{COUNTER}" :
1183             "$extra{END}_t_$extra{COUNTER}";
1184 3         62 my $elabel = "$extra{END}_e_$extra{COUNTER}";
1185 3         32 $labels{TRUE} = $tlabel;
1186 3         3 $labels{FALSE} = $flabel;
1187 3         4 $labels{END} = $elabel;
1188 3         9 $pred .= << "...";
1189             ;; $comment
1190             \tgoto $flabel
1191             \tgoto $tlabel
1192             $flabel:
1193             \tclrw
1194             \tgoto $elabel
1195             $tlabel:
1196             \tmovlw 0x01
1197             $elabel:
1198             ...
1199 3         7 $pred .= $self->op_assign_wreg($extra{RESULT});
1200             }
1201 14 100       50 return wantarray ? ($pred, %labels) : $pred;
1202             }
1203              
1204             sub _get_predicate_literals {
1205 0     0   0 my ($self, $comment, $res, %extra) = @_;
1206 0 0       0 if (defined $extra{RESULT}) {
1207 0         0 my $tcode = 'movlw 0x01';
1208 0         0 my $fcode = 'clrw';
1209 0         0 my $code;
1210 0 0       0 if ($res) {
1211 0 0       0 $code = $extra{SWAP} ? $fcode : $tcode;
1212             } else {
1213 0 0       0 $code = $extra{SWAP} ? $tcode : $fcode;
1214             }
1215 0         0 my $ecode = $self->op_assign_wreg($extra{RESULT});
1216 0         0 return "\t$code ;;$comment\n$ecode\n";
1217             } else {
1218 0         0 my $label;
1219 0 0       0 if ($res) {
1220 0 0       0 $label = $extra{SWAP} ? $extra{FALSE} : $extra{TRUE};
1221             } else {
1222 0 0       0 $label = $extra{SWAP} ? $extra{TRUE} : $extra{FALSE};
1223             }
1224 0         0 return "\tgoto $label ;; $comment\n$extra{END}:\n";
1225             }
1226             }
1227              
1228             sub op_eq {
1229 10     10 0 58 my ($self, $lhs, $rhs, %extra) = @_;
1230 10 50       33 return unless $self->doesroles(qw(Operators Chip));
1231 10 50       51 unless (exists $self->registers->{STATUS}) {
1232 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
1233 0         0 return;
1234             }
1235 10 100       28 my $comment = $extra{SWAP} ? "$lhs != $rhs" : "$lhs == $rhs";
1236 10         110 my $pred = $self->_get_predicate($comment, %extra);
1237 10         27 my $literal = qr/^\d+$/;
1238 10 50 33     199 if ($lhs !~ $literal and $rhs !~ $literal) {
    50 33        
    50 33        
1239             # lhs and rhs are variables
1240 0         0 $rhs = uc $rhs;
1241 0         0 $lhs = uc $lhs;
1242 0         0 return << "...";
1243             \tbcf STATUS, Z
1244             \tmovf $rhs, W
1245             \txorwf $lhs, W
1246             \tbtfss STATUS, Z
1247             $pred
1248             ...
1249             } elsif ($rhs !~ $literal and $lhs =~ $literal) {
1250             # rhs is variable and lhs is a literal
1251 0         0 $rhs = uc $rhs;
1252 0         0 $lhs = sprintf "0x%02X", $lhs;
1253 0         0 return << "...";
1254             \tbcf STATUS, Z
1255             \tmovf $rhs, W
1256             \txorlw $lhs
1257             \tbtfss STATUS, Z ;; $comment
1258             $pred
1259             ...
1260             } elsif ($rhs =~ $literal and $lhs !~ $literal) {
1261             # rhs is a literal and lhs is a variable
1262 10         26 $lhs = uc $lhs;
1263 10         32 $rhs = sprintf "0x%02X", $rhs;
1264 10         62 return << "...";
1265             \tbcf STATUS, Z
1266             \tmovf $lhs, W
1267             \txorlw $rhs
1268             \tbtfss STATUS, Z ;; $comment
1269             $pred
1270             ...
1271             } else {
1272             # both rhs and lhs are literals
1273 0 0       0 my $res = $lhs == $rhs ? 1 : 0;
1274 0         0 return $self->_get_predicate_literals("$lhs == $rhs => $res", $res, %extra);
1275             }
1276             }
1277              
1278             sub op_lt {
1279 1     1 0 3 my ($self, $lhs, $rhs, %extra) = @_;
1280 1 50       3 return unless $self->doesroles(qw(Operators Chip));
1281 1 50       4 unless (exists $self->registers->{STATUS}) {
1282 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
1283 0         0 return;
1284             }
1285 1         4 my $pred = $self->_get_predicate("$lhs < $rhs", %extra);
1286 1         3 my $literal = qr/^\d+$/;
1287 1 50 33     17 if ($lhs !~ $literal and $rhs !~ $literal) {
    50 33        
    0 0        
1288             # lhs and rhs are variables
1289 0         0 $rhs = uc $rhs;
1290 0         0 $lhs = uc $lhs;
1291 0         0 return << "...";
1292             \t;; perform check for $lhs < $rhs or $rhs > $lhs
1293             \tbcf STATUS, C
1294             \tmovf $rhs, W
1295             \tsubwf $lhs, W
1296             \tbtfsc STATUS, C ;; W($rhs) > F($lhs) => C = 0
1297             $pred
1298             ...
1299             } elsif ($rhs !~ $literal and $lhs =~ $literal) {
1300             # rhs is variable and lhs is a literal
1301 1         2 $rhs = uc $rhs;
1302 1         4 $lhs = sprintf "0x%02X", $lhs;
1303 1         8 return << "...";
1304             \t;; perform check for $lhs < $rhs or $rhs > $lhs
1305             \tbcf STATUS, C
1306             \tmovf $rhs, W
1307             \tsublw $lhs
1308             \tbtfsc STATUS, C ;; W($rhs) > k($lhs) => C = 0
1309             $pred
1310             ...
1311             } elsif ($rhs =~ $literal and $lhs !~ $literal) {
1312             # rhs is a literal and lhs is a variable
1313 0         0 $lhs = uc $lhs;
1314 0         0 $rhs = sprintf "0x%02X", $rhs;
1315 0         0 return << "...";
1316             \t;; perform check for $lhs < $rhs or $rhs > $lhs
1317             \tbcf STATUS, C
1318             \tmovlw $rhs
1319             \tsubwf $lhs, W
1320             \tbtfsc STATUS, C ;; W($rhs) > F($lhs) => C = 0
1321             $pred
1322             ...
1323             } else {
1324             # both rhs and lhs are literals
1325 0 0       0 my $res = $lhs < $rhs ? 1 : 0;
1326 0         0 return $self->_get_predicate_literals("$lhs < $rhs => $res", $res, %extra);
1327             }
1328             }
1329              
1330             sub op_ge {
1331 1     1 0 3 my ($self, $lhs, $rhs, %extra) = @_;
1332 1 50       3 return unless $self->doesroles(qw(Operators Chip));
1333 1 50       7 unless (exists $self->registers->{STATUS}) {
1334 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
1335 0         0 return;
1336             }
1337 1         6 my $pred = $self->_get_predicate("$lhs >= $rhs", %extra);
1338 1         3 my $literal = qr/^\d+$/;
1339 1 50 33     14 if ($lhs !~ $literal and $rhs !~ $literal) {
    50 33        
    0 0        
1340             # lhs and rhs are variables
1341 0         0 $rhs = uc $rhs;
1342 0         0 $lhs = uc $lhs;
1343 0         0 return << "...";
1344             \t;; perform check for $lhs >= $rhs or $rhs <= $lhs
1345             \tbcf STATUS, C
1346             \tmovf $rhs, W
1347             \tsubwf $lhs, W
1348             \tbtfss STATUS, C ;; W($rhs) <= F($lhs) => C = 1
1349             $pred
1350             ...
1351             } elsif ($rhs !~ $literal and $lhs =~ $literal) {
1352             # rhs is variable and lhs is a literal
1353 1         1 $rhs = uc $rhs;
1354 1         4 $lhs = sprintf "0x%02X", $lhs;
1355 1         9 return << "...";
1356             \t;; perform check for $lhs >= $rhs or $rhs <= $lhs
1357             \tbcf STATUS, C
1358             \tmovf $rhs, W
1359             \tsublw $lhs
1360             \tbtfss STATUS, C ;; W($rhs) <= k($lhs) => C = 1
1361             $pred
1362             ...
1363             } elsif ($rhs =~ $literal and $lhs !~ $literal) {
1364             # rhs is a literal and lhs is a variable
1365 0         0 $lhs = uc $lhs;
1366 0         0 $rhs = sprintf "0x%02X", $rhs;
1367 0         0 return << "...";
1368             \t;; perform check for $lhs >= $rhs or $rhs <= $lhs
1369             \tbcf STATUS, C
1370             \tmovlw $rhs
1371             \tsubwf $lhs, W
1372             \tbtfss STATUS, C ;; W($rhs) <= F($lhs) => C = 1
1373             $pred
1374             ...
1375             } else {
1376             # both rhs and lhs are literals
1377 0 0       0 my $res = $lhs >= $rhs ? 1 : 0;
1378 0         0 return $self->_get_predicate_literals("$lhs >= $rhs => $res", $res, %extra);
1379             }
1380             }
1381              
1382             sub op_ne {
1383 4     4 0 32 my ($self, $lhs, $rhs, %extra) = @_;
1384 4         17 return $self->op_eq($lhs, $rhs, %extra, SWAP => 1);
1385             }
1386              
1387             sub op_le {
1388 1     1 0 8 my ($self, $lhs, $rhs, %extra) = @_;
1389             # we swap the lhs/rhs stuff instead of using SWAP
1390 1         9 return $self->op_ge($rhs, $lhs, %extra);
1391             }
1392              
1393             sub op_gt {
1394 1     1 0 7 my ($self, $lhs, $rhs, %extra) = @_;
1395             # we swap the lhs/rhs stuff instead of using SWAP
1396 1         5 return $self->op_lt($rhs, $lhs, %extra);
1397             }
1398              
1399             sub op_and {
1400 1     1 0 9 my ($self, $lhs, $rhs, %extra) = @_;
1401 1 50       4 return unless $self->doesroles(qw(Operators Chip));
1402 1 50       4 unless (exists $self->registers->{STATUS}) {
1403 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
1404 0         0 return;
1405             }
1406 1         5 my ($pred, %labels) = $self->_get_predicate("$lhs && $rhs", %extra);
1407 1         8 my $literal = qr/^\d+$/;
1408 1 50 33     12 if ($lhs !~ $literal and $rhs !~ $literal) {
    0 0        
    0 0        
1409             # lhs and rhs are variables
1410 1         3 $rhs = uc $rhs;
1411 1         2 $lhs = uc $lhs;
1412 1         10 return << "...";
1413             \t;; perform check for $lhs && $rhs
1414             \tbcf STATUS, Z
1415             \tmovf $lhs, W
1416             \tbtfss STATUS, Z ;; $lhs is false if it is set else true
1417             \tgoto $labels{FALSE}
1418             \tmovf $rhs, W
1419             \tbtfss STATUS, Z ;; $rhs is false if it is set else true
1420             $pred
1421             ...
1422             } elsif ($rhs !~ $literal and $lhs =~ $literal) {
1423             # rhs is variable and lhs is a literal
1424 0         0 $rhs = uc $rhs;
1425 0         0 $lhs = sprintf "0x%02X", $lhs;
1426 0         0 return << "...";
1427             \t;; perform check for $lhs && $rhs
1428             \tbcf STATUS, Z
1429             \tmovlw $lhs
1430             \txorlw 0x00 ;; $lhs ^ 0 will set the Z bit
1431             \tbtfss STATUS, Z ;; $lhs is false if it is set else true
1432             \tgoto $labels{FALSE}
1433             \tmovf $rhs, W
1434             \tbtfss STATUS, Z ;; $rhs is false if it is set else true
1435             $pred
1436             ...
1437             } elsif ($rhs =~ $literal and $lhs !~ $literal) {
1438             # rhs is a literal and lhs is a variable
1439 0         0 $lhs = uc $lhs;
1440 0         0 $rhs = sprintf "0x%02X", $rhs;
1441 0         0 return << "...";
1442             \t;; perform check for $lhs && $rhs
1443             \tbcf STATUS, Z
1444             \tmovlw $rhs
1445             \txorlw 0x00 ;; $rhs ^ 0 will set the Z bit
1446             \tbtfss STATUS, Z ;; $rhs is false if it is set else true
1447             \tgoto $labels{FALSE}
1448             \tmovf $lhs, W
1449             \tbtfss STATUS, Z ;; $lhs is false if it is set else true
1450             $pred
1451             ...
1452             } else {
1453             # both rhs and lhs are literals
1454 0 0 0     0 my $res = ($lhs && $rhs) ? 1 : 0;
1455 0         0 return $self->_get_predicate_literals("$lhs && $rhs => $res", $res, %extra);
1456             }
1457             }
1458              
1459             sub op_or {
1460 1     1 0 8 my ($self, $lhs, $rhs, %extra) = @_;
1461 1 50       6 return unless $self->doesroles(qw(Operators Chip));
1462 1 50       5 unless (exists $self->registers->{STATUS}) {
1463 0         0 carp "The STATUS register does not exist for the chip ", $self->type;
1464 0         0 return;
1465             }
1466 1         5 my ($pred, %labels) = $self->_get_predicate("$lhs || $rhs", %extra);
1467 1         4 my $literal = qr/^\d+$/;
1468 1 50 33     10 if ($lhs !~ $literal and $rhs !~ $literal) {
    0 0        
    0 0        
1469             # lhs and rhs are variables
1470 1         2 $rhs = uc $rhs;
1471 1         2 $lhs = uc $lhs;
1472 1         9 return << "...";
1473             \t;; perform check for $lhs || $rhs
1474             \tbcf STATUS, Z
1475             \tmovf $lhs, W
1476             \tbtfss STATUS, Z ;; $lhs is false if it is set else true
1477             \tgoto $labels{TRUE}
1478             \tmovf $rhs, W
1479             \tbtfsc STATUS, Z ;; $rhs is false if it is set else true
1480             $pred
1481             ...
1482             } elsif ($rhs !~ $literal and $lhs =~ $literal) {
1483             # rhs is variable and lhs is a literal
1484 0         0 $rhs = uc $rhs;
1485 0         0 $lhs = sprintf "0x%02X", $lhs;
1486 0         0 return << "...";
1487             \t;; perform check for $lhs || $rhs
1488             \tbcf STATUS, Z
1489             \tmovlw $lhs
1490             \txorlw 0x00 ;; $lhs ^ 0 will set the Z bit
1491             \tbtfss STATUS, Z ;; $lhs is false if it is set else true
1492             \tgoto $labels{TRUE}
1493             \tmovf $rhs, W
1494             \tbtfsc STATUS, Z ;; $rhs is false if it is set else true
1495             $pred
1496             ...
1497             } elsif ($rhs =~ $literal and $lhs !~ $literal) {
1498             # rhs is a literal and lhs is a variable
1499 0         0 $lhs = uc $lhs;
1500 0         0 $rhs = sprintf "0x%02X", $rhs;
1501 0         0 return << "...";
1502             \t;; perform check for $lhs || $rhs
1503             \tbcf STATUS, Z
1504             \tmovlw $rhs
1505             \txorlw 0x00 ;; $rhs ^ 0 will set the Z bit
1506             \tbtfss STATUS, Z ;; $rhs is false if it is set else true
1507             \tgoto $labels{TRUE}
1508             \tmovf $lhs, W
1509             \tbtfsc STATUS, Z ;; $lhs is false if it is set else true
1510             $pred
1511             ...
1512             } else {
1513             # both rhs and lhs are literals
1514 0 0 0     0 my $res = ($lhs || $rhs) ? 1 : 0;
1515 0         0 return $self->_get_predicate_literals("$lhs || $rhs => $res", $res, %extra);
1516             }
1517             }
1518              
1519             sub _macro_sqrt_var {
1520 2     2   9 return << '...';
1521             ;;;;;; VIC_VAR_SQRT VARIABLES ;;;;;;
1522             VIC_VAR_SQRT_UDATA udata
1523             VIC_VAR_SQRT_VAL res 2
1524             VIC_VAR_SQRT_RES res 2
1525             VIC_VAR_SQRT_SUM res 2
1526             VIC_VAR_SQRT_ODD res 2
1527             VIC_VAR_SQRT_TMP res 2
1528             ...
1529             }
1530              
1531             sub _macro_sqrt_macro {
1532 2     2   7 return << '...';
1533             ;;;;;; Taken from Microchip PIC examples.
1534             ;;;;;; reverse of Finite Difference Squaring
1535             m_sqrt_internal macro
1536             local _m_sqrt_loop, _m_sqrt_loop_break
1537             movlw 0x01
1538             movwf VIC_VAR_SQRT_ODD
1539             clrf VIC_VAR_SQRT_ODD + 1
1540             clrf VIC_VAR_SQRT_RES
1541             clrf VIC_VAR_SQRT_RES + 1
1542             clrf VIC_VAR_SQRT_SUM
1543             clrf VIC_VAR_SQRT_SUM + 1
1544             clrf VIC_VAR_SQRT_TMP
1545             clrf VIC_VAR_SQRT_TMP + 1
1546             _m_sqrt_loop:
1547             movf VIC_VAR_SQRT_SUM + 1, W
1548             addwf VIC_VAR_SQRT_ODD + 1, W
1549             movwf VIC_VAR_SQRT_TMP + 1
1550             movf VIC_VAR_SQRT_SUM, W
1551             addwf VIC_VAR_SQRT_ODD, W
1552             movwf VIC_VAR_SQRT_TMP
1553             btfsc STATUS, C
1554             incf VIC_VAR_SQRT_TMP + 1, F
1555             movf VIC_VAR_SQRT_TMP, W
1556             subwf VIC_VAR_SQRT_VAL, W
1557             movf VIC_VAR_SQRT_TMP + 1, W
1558             btfss STATUS, C
1559             addlw 0x01
1560             subwf VIC_VAR_SQRT_VAL + 1, W
1561             btfss STATUS, C
1562             goto _m_sqrt_loop_break
1563             movf VIC_VAR_SQRT_TMP + 1, W
1564             movwf VIC_VAR_SQRT_SUM + 1
1565             movf VIC_VAR_SQRT_TMP, W
1566             movwf VIC_VAR_SQRT_SUM
1567             movlw 0x02
1568             addwf VIC_VAR_SQRT_ODD, F
1569             btfsc STATUS, C
1570             incf VIC_VAR_SQRT_ODD + 1, F
1571             incf VIC_VAR_SQRT_RES, F
1572             btfsc STATUS, Z
1573             incf VIC_VAR_SQRT_RES + 1, F
1574             goto _m_sqrt_loop
1575             _m_sqrt_loop_break:
1576             endm
1577             m_sqrt_8bit macro v1
1578             movf v1, W
1579             movwf VIC_VAR_SQRT_VAL
1580             clrf VIC_VAR_SQRT_VAL + 1
1581             m_sqrt_internal
1582             movf VIC_VAR_SQRT_RES, W
1583             endm
1584             m_sqrt_16bit macro v1
1585             movf high v1, W
1586             movwf VIC_VAR_SQRT_VAL + 1
1587             movf low v1, W
1588             movwf VIC_VAR_SQRT_VAL
1589             m_sqrt_internal
1590             movf VIC_VAR_SQRT_RES, W
1591             endm
1592             ...
1593             }
1594              
1595             sub op_sqrt {
1596 2     2 0 15 my ($self, $var1, $dummy, %extra) = @_;
1597 2         8 my $literal = qr/^\d+$/;
1598 2         4 my $code = '';
1599             #TODO: temporary only 8-bit math
1600 2 50       18 if ($var1 !~ $literal) {
    0          
1601 2         4 $var1 = uc $var1;
1602 2   50     7 my $b1 = $self->address_bits($var1) || 8;
1603             # both are variables
1604 2         9 $code .= << "...";
1605             \t;; perform sqrt($var1)
1606             \tm_sqrt_${b1}bit $var1
1607             ...
1608             } elsif ($var1 =~ $literal) {
1609 0         0 my $svar = sqrt $var1;
1610 0         0 my $var2 = sprintf "0x%02X", int($svar);
1611 0         0 $code .= << "...";
1612             \t;; sqrt($var1) = $svar -> $var2;
1613             \tmovlw $var2
1614             ...
1615             } else {
1616 0         0 carp "Warning: $var1 cannot have a square root";
1617 0         0 return;
1618             }
1619 2         10 my $macros = {
1620             m_sqrt_var => $self->_macro_sqrt_var,
1621             m_sqrt_macro => $self->_macro_sqrt_macro,
1622             };
1623 2 50       10 $code .= $self->op_assign_wreg($extra{RESULT}) if $extra{RESULT};
1624 2 50       10 return wantarray ? ($code, {}, $macros) : $code;
1625             }
1626              
1627 2     2 0 10 sub break { return 'BREAK'; }
1628 2     2 0 10 sub continue { return 'CONTINUE'; }
1629              
1630             sub store_string {
1631 2     2 0 13 my ($self, $str, $strvar, $lenvar) = @_;
1632 2         3 my $nstr = $str;
1633 2 50       7 $nstr = $str->{string} if ref $str eq 'HASH';
1634 2         2 my $label = $strvar;
1635 2 50       7 $label = $str->{name} if ref $str eq 'HASH';
1636 2         4 my ($code, $szdecl) = ('', '');
1637 2 100       6 if ($str->{empty}) {
1638 1         22 $code = "\t;; not storing an empty string\n";
1639 1         4 my $sz = $self->code_config->{string}->{size};
1640 1         3 my $len = sprintf "0x%02X", $sz;
1641 1         2 my $idxvar = $self->_get_idx_var($strvar);
1642 1         7 $szdecl = << "...";
1643             $strvar res $len; allocate memory for $strvar
1644             $idxvar res 1; index for accessing $strvar elements
1645             $lenvar equ $len; $lenvar is length of $strvar
1646             ...
1647             } else {
1648 1         7 my @bytearr = split //, $nstr;
1649 1         2 my $bytes = [(map { sprintf "0x%02X", ord($_) } @bytearr), "0x00"];
  11         16  
1650 1         4 my $len = sprintf "0x%02X", scalar(@$bytes) + 1;
1651 1         104 my $slen = sprintf "0x%02X", scalar(@$bytes);
1652 1         2 my $nstr2 = $nstr;
1653 1         2 $nstr2 =~ s/[\n]/\\n/gs;
1654 1         2 $nstr2 =~ s/[\r]/\\r/gs;
1655 1         2 $code = "\t;; storing string '$nstr2'\n";
1656 1         5 $code .= "$label:\n\taddwf PCL, F\n\tdt " . join(',', @$bytes) . "\n";
1657 1         6 $szdecl = "$strvar res $len; allocate memory for $strvar\n$lenvar equ $slen; $lenvar is length of $label\n";
1658             }
1659 2 50       12 return wantarray ? ($code, $szdecl) : $code;
1660             }
1661              
1662             sub store_array {
1663 0     0 0 0 my ($self, $arr, $arrvar, $sz, $szvar) = @_;
1664             # use db in 16-bit MCUs for 8-bit values
1665             # arrays are read-write objects
1666 0 0       0 my $arrstr = join (",", @$arr) if scalar @$arr;
1667 0 0       0 $arrstr = '0' unless $arrstr;
1668 0         0 $sz = sprintf "0x%02X", $sz;
1669             ### FIXME: this is not correct. you need to do like the string stuff
1670             return << "..."
1671             $arrvar db $arr ; array stored as accessible bytes
1672             $szvar equ $sz ; length of array $arrvar is a constant
1673             ...
1674 0         0 }
1675              
1676             sub store_table {
1677 1     1 0 7 my ($self, $table, $label, $tblsz, $tblszvar) = @_;
1678 1 50       2 return unless $self->doesrole('Chip');
1679 1 50       4 unless (exists $self->registers->{PCL}) {
1680 0         0 carp $self->type, " does not have the PCL register";
1681 0         0 return;
1682             }
1683 1         2 my $code = "$label:\n";
1684 1         2 $code .= "\taddwf PCL, F\n";
1685 1 50       2 if (scalar @$table) {
1686 1         2 foreach (@$table) {
1687 16         23 my $d = sprintf "0x%02X", $_;
1688 16         127 $code .= "\tdt $d\n";
1689             }
1690             } else {
1691             # table is empty
1692 0         0 $code .= "\tdt 0\n";
1693             }
1694 1         2 $tblsz = sprintf "0x%02X", $tblsz;
1695 1         4 my $szdecl = "$tblszvar equ $tblsz ; size of table at $label\n";
1696 1 50       8 return wantarray ? ($code, $szdecl) : $code;
1697             }
1698              
1699             sub op_tblidx {
1700 1     1 0 8 my ($self, $table, $idx, %extra) = @_;
1701 1 50       3 return unless defined $extra{RESULT};
1702 1         2 my $sz = $extra{SIZE};
1703 1         2 $idx = uc $idx;
1704 1 50       3 $sz = uc $sz if $sz;
1705 1         2 my $szcode = '';
1706             # check bounds
1707 1 50       4 $szcode = "\tandlw $sz - 1" if $sz;
1708             return << "..."
1709             \tmovwf $idx
1710             $szcode
1711             \tcall $table
1712             \tmovwf $extra{RESULT}
1713             ...
1714 1         5 }
1715              
1716             sub op_arridx {
1717 0     0 0 0 my ($self, $array, $idx, %extra) = @_;
1718             #XXX { array => $array, index => $idx, %extra };
1719             }
1720              
1721             sub op_stridx {
1722 0     0 0 0 my ($self, $string, $idx, %extra) = @_;
1723             #XXX { string => $string, index => $idx, %extra };
1724             }
1725              
1726             sub store_bytes {
1727 31     31 0 202 my ($self, $tables) = @_;
1728 31 50       92 return unless defined $tables;
1729 31 50       134 return unless $self->doesrole('Chip');
1730              
1731 31 50       110 unless (ref $tables eq 'ARRAY') {
1732 0         0 $tables = [ $tables ];
1733             }
1734 31 100       142 return '' unless scalar @$tables;
1735 3         3 my $code = '';
1736 3         9 foreach (@$tables) {
1737 5         6 my $name = $_->{name};
1738 5 50       10 next unless defined $name;
1739 5 50       15 next unless exists $_->{bytes};
1740 5 50       12 next unless ref $_->{bytes} eq 'ARRAY';
1741 5         5 my $bytes = join(',', @{$_->{bytes}});
  5         12  
1742 5 50       16 $code .= $_->{comment} . "\n" if defined $_->{comment};
1743 5         10 my $row = "$name:\n\taddwf PCL, F\n\tdt $bytes\n";
1744 5         9 $code .= $row;
1745             }
1746 3         12 return $code;
1747             }
1748              
1749             sub string_concat {
1750 0     0 0 0 return ";;;; string concatenation not implemented";
1751             }
1752              
1753             sub _op_concat_bytev {
1754 1     1   2 return << "...";
1755             m_op_concat_bytev macro dvar, dlen, didx, bvar
1756             \tlocal _op_concat_bytev_end
1757             \t;;;; check for space first and then add byte
1758             \tbanksel didx
1759             \tmovf didx, W
1760             \tbanksel VIC_VAR_ASSIGN_STRIDX
1761             \tmovwf VIC_VAR_ASSIGN_STRIDX
1762             \tmovlw dlen
1763             \tmovwf VIC_VAR_ASSIGN_STRLEN
1764             \tbcf STATUS, Z
1765             \tbcf STATUS, C
1766             \tmovf VIC_VAR_ASSIGN_STRIDX, W
1767             \tsubwf VIC_VAR_ASSIGN_STRLEN, W
1768             \t;; W == 0
1769             \tbtfsc STATUS, Z
1770             \tgoto _op_concat_bytev_end
1771             \t;; we have space, let's add byte
1772             \tbanksel dvar
1773             \tmovlw dvar
1774             \tmovwf FSR
1775             \tbanksel didx
1776             \tmovf didx, W
1777             \taddwf FSR, F
1778             \tbanksel bvar
1779             \tmovf bvar, W
1780             \tmovwf INDF
1781             \tbanksel didx
1782             \tincf didx, F
1783             _op_concat_bytev_end:
1784             \tnop ;; no space left
1785             \tendm
1786             ...
1787             }
1788              
1789             sub byte_concat {
1790 1     1 0 2 my $self = shift;
1791 1         1 my $dvar = shift;
1792 1         2 my $svar = shift;
1793 1         4 $svar = uc $svar;
1794 1         2 my ($code, $funcs, $macros) = ('', {}, {});
1795 1 50 33     8 if (ref $dvar eq 'HASH' and $dvar->{type} eq 'string') {
1796 1         2 my $dname = $dvar->{name};
1797 1         2 my $idxvar = $self->_get_idx_var($dname);
1798 1         1 my $dlen = $dvar->{size};
1799 1         3 $macros->{m_op_assign_var} = $self->_op_assign_str_var;
1800 1         4 $macros->{m_op_concat_bytev} = $self->_op_concat_bytev($dname, $dlen, $idxvar, $svar);
1801 1         5 $code = "\tm_op_concat_bytev $dname, $dlen, $idxvar, $svar\n";
1802             } else {
1803 0         0 carp $dvar->{name} . " is not a string. Concatenation not valid\n";
1804 0         0 return;
1805             }
1806 1 50       4 return wantarray ? ($code, $funcs, $macros) : $code;
1807             }
1808              
1809             sub op_cat_assign {
1810 1     1 0 5 my $self = shift;
1811 1         2 my ($var1, $var2) = @_;
1812 1 50       3 if (ref $var2 eq 'HASH') {
1813 0         0 return $self->string_concat(@_);
1814             } else {
1815 1         3 return $self->byte_concat(@_);
1816             }
1817             }
1818              
1819             1;
1820             __END__