File Coverage

blib/lib/App/Scheme79asm/Compiler.pm
Criterion Covered Total %
statement 116 116 100.0
branch 44 44 100.0
condition n/a
subroutine 27 27 100.0
pod 0 15 0.0
total 187 202 92.5


line stmt bran cond sub pod time code
1             package App::Scheme79asm::Compiler;
2              
3 1     1   72301 use 5.014000;
  1         9  
4 1     1   4 use strict;
  1         1  
  1         24  
5 1     1   5 use warnings;
  1         2  
  1         41  
6              
7             our $VERSION = '1.000';
8              
9 1     1   6 use Carp qw/croak/;
  1         1  
  1         47  
10 1     1   485 use Data::Dumper qw/Dumper/;
  1         6010  
  1         71  
11 1     1   7 use Scalar::Util qw/looks_like_number/;
  1         2  
  1         43  
12              
13 1     1   6 use Data::SExpression qw/cons consp scalarp/;
  1         2  
  1         7  
14 1     1   497 use List::MoreUtils qw/firstidx/;
  1         10180  
  1         5  
15              
16             our @PRIMOPS = qw/car cdr cons atom progn reverse-list/;
17              
18 20     20 0 489 sub make_symbol { Data::SExpression::Symbol->new(shift) }
19              
20             # types
21             our $LIST = make_symbol 'LIST';
22             our $SYMBOL = make_symbol 'SYMBOL';
23             our $VAR = make_symbol 'VAR';
24             # no need for closures
25             our $PROC = make_symbol 'PROC';
26             our $IF = make_symbol 'IF';
27             our $CALL = make_symbol 'CALL';
28             # no need for quoted constants
29              
30             # primitives
31             our $MORE = make_symbol 'MORE';
32             our $FUNCALL = make_symbol 'FUNCALL';
33              
34             BEGIN {
35 1     1   1002 *cons = *Data::SExpression::cons;
36 1         3 *consp = *Data::SExpression::consp;
37 1         1085 *scalarp = *Data::SExpression::scalarp;
38             }
39              
40             # list processing routines
41             sub append {
42 30     30 0 462 my ($expr, $rest) = @_;
43 30 100       47 if (defined $expr) {
44 20         272 cons $expr->car, append($expr->cdr, $rest)
45             } else {
46 10         19 $rest
47             }
48             }
49              
50             sub mapcar (&@);
51              
52             sub mapcar (&@) {
53 41     41 0 138 my ($block, $expr) = @_;
54 41 100       63 if (defined $expr) {
55 24         28 my $result;
56 24         26 do {
57 24         346 local $_ = $expr->car;
58 24         105 $result = $block->()
59             };
60 24     10   418 cons $result, mapcar { $block->($_) } $expr->cdr
  10         18  
61             } else {
62             undef
63 17         35 }
64             }
65              
66             sub revacc {
67 14     14 0 230 my ($expr, $acc) = @_;
68 14 100       24 if (defined $expr) {
69 8         118 revacc ($expr->cdr, cons($expr->car, $acc))
70             } else {
71 6         17 $acc
72             }
73             }
74              
75             sub rev {
76 6     6 0 11 my ($expr) = @_;
77 6         13 revacc $expr, undef;
78             }
79              
80             sub positionacc {
81 37     37 0 123 my ($expr, $list, $acc) = @_;
82 37 100       530 if (!defined $list) {
    100          
83             undef
84 1         3 } elsif ($list->car eq $expr) {
85 16         1023 $acc
86             } else {
87 20         1484 positionacc($expr, $list->cdr, $acc + 1)
88             }
89             }
90              
91             sub position {
92 17     17 0 29 my ($expr, $list) = @_;
93 17         30 positionacc $expr, $list, 0
94             }
95             # end list processing routines
96              
97             sub new {
98 28     28 0 111 my ($class) = @_;
99 28         114 my %self = (
100             symbols => ['', '', 'T'],
101             nsymbols => 3,
102             symbol_map => {T => 2},
103             );
104 28         104 bless \%self, $class;
105             }
106              
107             sub process_quoted {
108 48     48 0 3658 my ($self, $expr) = @_;
109 48 100       116 if (!defined $expr) { # nil
    100          
    100          
110 9         131 [$LIST => 0]
111             } elsif (scalarp $expr) {
112 25         142 $expr = uc $expr;
113 25 100       411 if ($expr eq 'NIL') {
114 1         5 return [$LIST => 0]
115             }
116 24 100       68 if (!exists $self->{symbol_map}{$expr}) {
117 22         40 $self->{symbol_map}{$expr} = $self->{nsymbols};
118 22         31 $self->{nsymbols}++;
119 22         28 push @{$self->{symbols}}, $expr;
  22         53  
120             }
121 24         188 [$SYMBOL => $self->{symbol_map}{$expr}]
122             } elsif (consp $expr) {
123 13         328 [$LIST => $self->process_quoted($expr->cdr), $self->process_quoted($expr->car)]
124             } else {
125 1         17 croak 'argument to process_quoted is not a scalar, cons, or nil: ', Dumper($expr);
126             }
127             }
128              
129             sub process_proc {
130 6     6 0 15 my ($self, $func_name, $func_args, $func_body, $env) = @_;
131 6         13 my $new_env = append cons($func_name, rev $func_args), $env;
132 6         143 $self->process_toplevel($func_body, $new_env)
133             }
134              
135             sub rest_of_funcall {
136 28     28 0 616 my ($self, $func, $args) = @_;
137 28 100       47 if (!defined $args) {
138 16         225 $func
139             } else {
140 12         162 [$MORE => $self->rest_of_funcall($func, $args->cdr), $args->car]
141             }
142             }
143              
144             sub process_funcall {
145 17     17 0 356 my ($self, $func_name, $func_args, $env) = @_;
146 17     59   86 my $prim_idx = firstidx { uc $_ eq uc $func_name } @PRIMOPS;
  59         1130  
147             my $processed_args =
148 17     24   551 mapcar { $self->process_toplevel($_, $env) } $func_args;
  24         63  
149 17 100       299 if ($prim_idx > -1) {
150 13 100       31 if (!defined $processed_args) {
151 1         4 croak "Cannot call primitive $func_name with no arguments";
152             }
153 12         28 [$CALL => $self->rest_of_funcall([make_symbol(uc $func_name), 0], $processed_args->cdr), $processed_args->car]
154             } else {
155 4         9 my $final_args = append $processed_args, cons ($self->process_toplevel($func_name, $env), undef);
156 4         107 [$CALL => $self->rest_of_funcall([$FUNCALL => 0], $final_args->cdr), $final_args->car]
157             }
158             }
159              
160             sub process_toplevel {
161 68     68 0 16991 my ($self, $expr, $env) = @_;
162 68 100       162 if (!defined $expr) {
    100          
163 2         24 [$LIST => 0]
164             } elsif (scalarp $expr) {
165 25 100       173 if (looks_like_number $expr) {
    100          
    100          
166 2         5 $self->process_quoted($expr);
167             } elsif (uc $expr eq 'T') {
168 4         292 [$SYMBOL => 2]
169             } elsif (uc $expr eq 'NIL') {
170 2         224 [$LIST => 0]
171             } else {
172 17         1695 my $position = position $expr, $env;
173 17 100       30 if (defined $position) {
174 16         95 [$VAR => -1 - $position]
175             } else {
176 1         3 croak "Variable $expr not in environment";
177             }
178             }
179             } else {
180 41         777 my $func = uc $expr->car;
181 41 100       1518 if ($func eq 'QUOTE') {
    100          
    100          
182 14         205 $self->process_quoted($expr->cdr->car)
183             } elsif ($func eq 'LAMBDA') {
184 6         94 my $func_name = $expr->cdr->car;
185 6         214 my $func_args = $expr->cdr->cdr->car;
186 6         213 my $func_body = $expr->cdr->cdr->cdr->car; ## no critic (ProhibitLongChainsOfMethodCalls)
187 6         152 [$PROC => $self->process_proc($func_name, $func_args, $func_body, $env)]
188             } elsif ($func eq 'IF') {
189             my ($if_cond, $if_then, $if_else) =
190 4         56 map { $self->process_toplevel($_, $env) }
  12         340  
191             ($expr->cdr->car, $expr->cdr->cdr->car, $expr->cdr->cdr->cdr->car); ## no critic (ProhibitLongChainsOfMethodCalls)
192 4         95 [$IF => [$LIST => $if_else, $if_then], $if_cond]
193             } else {
194 17         243 $self->process_funcall($expr->car, $expr->cdr, $env)
195             }
196             }
197             }
198              
199             sub compile_sexp {
200 10     10 0 19 my ($self, $expr) = @_;
201 10         24 $self->process_toplevel($expr, undef)
202             }
203              
204             sub compile_string {
205 10     10 0 21 my ($self, $string) = @_;
206 10         32 my $sexp = Data::SExpression->new(
207             {fold_lists => 0, use_symbol_class => 1}
208             );
209 10         1046 my $expr = $sexp->read($string);
210 10         14486 $self->compile_sexp($expr)
211             }
212              
213             1;
214             __END__