]>
Commit | Line | Data |
---|---|---|
8ff4c670 MG |
1 | package App::Scheme79asm::Compiler; |
2 | ||
3 | use 5.014000; | |
4 | use strict; | |
5 | use warnings; | |
8ff4c670 | 6 | |
296bac97 | 7 | our $VERSION = '1.000'; |
8ff4c670 MG |
8 | |
9 | use Carp qw/croak/; | |
10 | use Data::Dumper qw/Dumper/; | |
11 | use Scalar::Util qw/looks_like_number/; | |
12 | ||
13 | use Data::SExpression qw/cons consp scalarp/; | |
14 | use List::MoreUtils qw/firstidx/; | |
15 | ||
16 | our @PRIMOPS = qw/car cdr cons atom progn reverse-list/; | |
17 | ||
0fea28cb MG |
18 | 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 | ||
8ff4c670 MG |
34 | BEGIN { |
35 | *cons = *Data::SExpression::cons; | |
36 | *consp = *Data::SExpression::consp; | |
37 | *scalarp = *Data::SExpression::scalarp; | |
38 | } | |
39 | ||
40 | # list processing routines | |
41 | sub append { | |
42 | my ($expr, $rest) = @_; | |
43 | if (defined $expr) { | |
44 | cons $expr->car, append($expr->cdr, $rest) | |
45 | } else { | |
46 | $rest | |
47 | } | |
48 | } | |
49 | ||
50 | sub mapcar (&@); | |
51 | ||
52 | sub mapcar (&@) { | |
53 | my ($block, $expr) = @_; | |
54 | if (defined $expr) { | |
55 | my $result; | |
56 | do { | |
57 | local $_ = $expr->car; | |
58 | $result = $block->() | |
59 | }; | |
60 | cons $result, mapcar { $block->($_) } $expr->cdr | |
61 | } else { | |
62 | undef | |
63 | } | |
64 | } | |
65 | ||
66 | sub revacc { | |
67 | my ($expr, $acc) = @_; | |
68 | if (defined $expr) { | |
69 | revacc ($expr->cdr, cons($expr->car, $acc)) | |
70 | } else { | |
71 | $acc | |
72 | } | |
73 | } | |
74 | ||
75 | sub rev { | |
76 | my ($expr) = @_; | |
77 | revacc $expr, undef; | |
78 | } | |
79 | ||
80 | sub positionacc { | |
81 | my ($expr, $list, $acc) = @_; | |
82 | if (!defined $list) { | |
83 | undef | |
84 | } elsif ($list->car eq $expr) { | |
85 | $acc | |
86 | } else { | |
87 | positionacc($expr, $list->cdr, $acc + 1) | |
88 | } | |
89 | } | |
90 | ||
91 | sub position { | |
92 | my ($expr, $list) = @_; | |
93 | positionacc $expr, $list, 0 | |
94 | } | |
8ff4c670 MG |
95 | # end list processing routines |
96 | ||
97 | sub new { | |
98 | my ($class) = @_; | |
99 | my %self = ( | |
100 | symbols => ['', '', 'T'], | |
101 | nsymbols => 3, | |
2aba73d5 | 102 | symbol_map => {T => 2}, |
8ff4c670 MG |
103 | ); |
104 | bless \%self, $class; | |
105 | } | |
106 | ||
107 | sub process_quoted { | |
108 | my ($self, $expr) = @_; | |
109 | if (!defined $expr) { # nil | |
0fea28cb | 110 | [$LIST => 0] |
8ff4c670 MG |
111 | } elsif (scalarp $expr) { |
112 | $expr = uc $expr; | |
2aba73d5 | 113 | if ($expr eq 'NIL') { |
0fea28cb | 114 | return [$LIST => 0] |
2aba73d5 | 115 | } |
8ff4c670 MG |
116 | if (!exists $self->{symbol_map}{$expr}) { |
117 | $self->{symbol_map}{$expr} = $self->{nsymbols}; | |
118 | $self->{nsymbols}++; | |
119 | push @{$self->{symbols}}, $expr; | |
120 | } | |
0fea28cb | 121 | [$SYMBOL => $self->{symbol_map}{$expr}] |
8ff4c670 | 122 | } elsif (consp $expr) { |
0fea28cb | 123 | [$LIST => $self->process_quoted($expr->cdr), $self->process_quoted($expr->car)] |
8ff4c670 MG |
124 | } else { |
125 | croak 'argument to process_quoted is not a scalar, cons, or nil: ', Dumper($expr); | |
126 | } | |
127 | } | |
128 | ||
129 | sub process_proc { | |
130 | my ($self, $func_name, $func_args, $func_body, $env) = @_; | |
ab8f838f | 131 | my $new_env = append cons($func_name, rev $func_args), $env; |
8ff4c670 MG |
132 | $self->process_toplevel($func_body, $new_env) |
133 | } | |
134 | ||
135 | sub rest_of_funcall { | |
136 | my ($self, $func, $args) = @_; | |
137 | if (!defined $args) { | |
138 | $func | |
139 | } else { | |
0fea28cb | 140 | [$MORE => $self->rest_of_funcall($func, $args->cdr), $args->car] |
8ff4c670 MG |
141 | } |
142 | } | |
143 | ||
144 | sub process_funcall { | |
145 | my ($self, $func_name, $func_args, $env) = @_; | |
146 | my $prim_idx = firstidx { uc $_ eq uc $func_name } @PRIMOPS; | |
147 | my $processed_args = | |
148 | mapcar { $self->process_toplevel($_, $env) } $func_args; | |
149 | if ($prim_idx > -1) { | |
150 | if (!defined $processed_args) { | |
151 | croak "Cannot call primitive $func_name with no arguments"; | |
152 | } | |
0fea28cb | 153 | [$CALL => $self->rest_of_funcall([make_symbol(uc $func_name), 0], $processed_args->cdr), $processed_args->car] |
8ff4c670 MG |
154 | } else { |
155 | my $final_args = append $processed_args, cons ($self->process_toplevel($func_name, $env), undef); | |
0fea28cb | 156 | [$CALL => $self->rest_of_funcall([$FUNCALL => 0], $final_args->cdr), $final_args->car] |
8ff4c670 MG |
157 | } |
158 | } | |
159 | ||
160 | sub process_toplevel { | |
161 | my ($self, $expr, $env) = @_; | |
162 | if (!defined $expr) { | |
0fea28cb | 163 | [$LIST => 0] |
8ff4c670 MG |
164 | } elsif (scalarp $expr) { |
165 | if (looks_like_number $expr) { | |
166 | $self->process_quoted($expr); | |
167 | } elsif (uc $expr eq 'T') { | |
0fea28cb | 168 | [$SYMBOL => 2] |
8ff4c670 | 169 | } elsif (uc $expr eq 'NIL') { |
0fea28cb | 170 | [$LIST => 0] |
8ff4c670 MG |
171 | } else { |
172 | my $position = position $expr, $env; | |
173 | if (defined $position) { | |
0fea28cb | 174 | [$VAR => -1 - $position] |
8ff4c670 MG |
175 | } else { |
176 | croak "Variable $expr not in environment"; | |
177 | } | |
178 | } | |
179 | } else { | |
180 | my $func = uc $expr->car; | |
181 | if ($func eq 'QUOTE') { | |
182 | $self->process_quoted($expr->cdr->car) | |
183 | } elsif ($func eq 'LAMBDA') { | |
184 | my $func_name = $expr->cdr->car; | |
185 | my $func_args = $expr->cdr->cdr->car; | |
1756f229 | 186 | my $func_body = $expr->cdr->cdr->cdr->car; ## no critic (ProhibitLongChainsOfMethodCalls) |
0fea28cb | 187 | [$PROC => $self->process_proc($func_name, $func_args, $func_body, $env)] |
8ff4c670 MG |
188 | } elsif ($func eq 'IF') { |
189 | my ($if_cond, $if_then, $if_else) = | |
190 | map { $self->process_toplevel($_, $env) } | |
1756f229 | 191 | ($expr->cdr->car, $expr->cdr->cdr->car, $expr->cdr->cdr->cdr->car); ## no critic (ProhibitLongChainsOfMethodCalls) |
0fea28cb | 192 | [$IF => [$LIST => $if_else, $if_then], $if_cond] |
8ff4c670 MG |
193 | } else { |
194 | $self->process_funcall($expr->car, $expr->cdr, $env) | |
195 | } | |
196 | } | |
197 | } | |
198 | ||
199 | sub compile_sexp { | |
200 | my ($self, $expr) = @_; | |
201 | $self->process_toplevel($expr, undef) | |
202 | } | |
203 | ||
204 | sub compile_string { | |
205 | my ($self, $string) = @_; | |
206 | my $sexp = Data::SExpression->new( | |
207 | {fold_lists => 0, use_symbol_class => 1} | |
208 | ); | |
209 | my $expr = $sexp->read($string); | |
210 | $self->compile_sexp($expr) | |
211 | } | |
212 | ||
213 | 1; | |
214 | __END__ | |
215 | ||
216 | =encoding utf-8 | |
217 | ||
218 | =head1 NAME | |
219 | ||
220 | App::Scheme79asm::Compiler - compile Lisp code to SIMPLE assembly | |
221 | ||
222 | =head1 SYNOPSIS | |
223 | ||
224 | use App::Scheme79asm; | |
225 | use App::Scheme79asm::Compiler; | |
226 | use Data::SExpression qw/cons/; | |
227 | ||
228 | my $asm = App::Scheme79asm->new; | |
229 | my $compiler = App::Scheme79asm::Compiler->new; | |
230 | my $string = '(reverse-list 2 1)'; | |
231 | my $assembly_sexp = $compiler->compile_string($string); | |
232 | $asm->process($assembly_sexp); | |
ab8f838f | 233 | $asm->finish; |
8ff4c670 MG |
234 | $asm->print_verilog |
235 | ||
236 | =head1 DESCRIPTION | |
237 | ||
238 | This module takes Lisp code and compiles it to the format that | |
239 | L<App::Scheme79asm> wants it to be. | |
240 | ||
241 | The two main methods are B<compile_sexp>(I<$sexp>) which compiles an | |
242 | already-parsed sexp to assembly format, and | |
243 | B<compile_string>(I<$string>) which compiles a string to assembly | |
b3270ee0 MG |
244 | format. |
245 | ||
246 | The assembly format is a sexp. These functions return an | |
247 | already-parsed sexp (an arrayref like the ones returned by | |
248 | L<Data::SExpression>'s B<read> method). This arrayref can be passed | |
249 | directly to L<App::Scheme79asm>'s B<process> method. | |
250 | ||
251 | If a string representation of the sexp is required, it can be obtained | |
252 | by calling the B<dump_sexp> function in L<Data::Dump::Sexp> with such an arrayref. | |
8ff4c670 MG |
253 | |
254 | =head1 AUTHOR | |
255 | ||
256 | Marius Gavrilescu, E<lt>marius@ieval.roE<gt> | |
257 | ||
258 | =head1 COPYRIGHT AND LICENSE | |
259 | ||
260 | Copyright (C) 2018 by Marius Gavrilescu | |
261 | ||
262 | This library is free software; you can redistribute it and/or modify | |
263 | it under the same terms as Perl itself, either Perl version 5.24.3 or, | |
264 | at your option, any later version of Perl 5 you may have available. | |
265 | ||
266 | ||
267 | =cut |