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