]> iEval git - app-scheme79asm.git/blob - lib/App/Scheme79asm/Compiler.pm
Compile T and NIL correctly
[app-scheme79asm.git] / lib / App / Scheme79asm / Compiler.pm
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.005';
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,
109 symbol_map => {T => 2},
110 );
111 bless \%self, $class;
112 }
113
114 sub process_quoted {
115 my ($self, $expr) = @_;
116 if (!defined $expr) { # nil
117 [LIST => 0]
118 } elsif (scalarp $expr) {
119 $expr = uc $expr;
120 if ($expr eq 'NIL') {
121 return [LIST => 0]
122 }
123 if (!exists $self->{symbol_map}{$expr}) {
124 $self->{symbol_map}{$expr} = $self->{nsymbols};
125 $self->{nsymbols}++;
126 push @{$self->{symbols}}, $expr;
127 }
128 [SYMBOL => $self->{symbol_map}{$expr}]
129 } elsif (consp $expr) {
130 [LIST => $self->process_quoted($expr->cdr), $self->process_quoted($expr->car)]
131 } else {
132 croak 'argument to process_quoted is not a scalar, cons, or nil: ', Dumper($expr);
133 }
134 }
135
136 sub process_proc {
137 my ($self, $func_name, $func_args, $func_body, $env) = @_;
138 my $new_env = append cons($func_name, rev $func_args), $env;
139 $self->process_toplevel($func_body, $new_env)
140 }
141
142 sub rest_of_funcall {
143 my ($self, $func, $args) = @_;
144 if (!defined $args) {
145 $func
146 } else {
147 [MORE => $self->rest_of_funcall($func, $args->cdr), $args->car]
148 }
149 }
150
151 sub process_funcall {
152 my ($self, $func_name, $func_args, $env) = @_;
153 my $prim_idx = firstidx { uc $_ eq uc $func_name } @PRIMOPS;
154 my $processed_args =
155 mapcar { $self->process_toplevel($_, $env) } $func_args;
156 if ($prim_idx > -1) {
157 if (!defined $processed_args) {
158 croak "Cannot call primitive $func_name with no arguments";
159 }
160 [CALL => $self->rest_of_funcall([uc $func_name, 0], $processed_args->cdr), $processed_args->car]
161 } else {
162 my $final_args = append $processed_args, cons ($self->process_toplevel($func_name, $env), undef);
163 [CALL => $self->rest_of_funcall([FUNCALL => 0], $final_args->cdr), $final_args->car]
164 }
165 }
166
167 sub process_toplevel {
168 my ($self, $expr, $env) = @_;
169 if (!defined $expr) {
170 [LIST => 0]
171 } elsif (scalarp $expr) {
172 if (looks_like_number $expr) {
173 $self->process_quoted($expr);
174 } elsif (uc $expr eq 'T') {
175 [SYMBOL => 2]
176 } elsif (uc $expr eq 'NIL') {
177 [LIST => 0]
178 } else {
179 my $position = position $expr, $env;
180 if (defined $position) {
181 [VAR => -1 - $position]
182 } else {
183 croak "Variable $expr not in environment";
184 }
185 }
186 } else {
187 my $func = uc $expr->car;
188 if ($func eq 'QUOTE') {
189 $self->process_quoted($expr->cdr->car)
190 } elsif ($func eq 'LAMBDA') {
191 my $func_name = $expr->cdr->car;
192 my $func_args = $expr->cdr->cdr->car;
193 my $func_body = $expr->cdr->cdr->cdr->car; ## no critic (ProhibitLongChainsOfMethodCalls)
194 [PROC => $self->process_proc($func_name, $func_args, $func_body, $env)]
195 } elsif ($func eq 'IF') {
196 my ($if_cond, $if_then, $if_else) =
197 map { $self->process_toplevel($_, $env) }
198 ($expr->cdr->car, $expr->cdr->cdr->car, $expr->cdr->cdr->cdr->car); ## no critic (ProhibitLongChainsOfMethodCalls)
199 [IF => [LIST => $if_else, $if_then], $if_cond]
200 } else {
201 $self->process_funcall($expr->car, $expr->cdr, $env)
202 }
203 }
204 }
205
206 sub compile_sexp {
207 my ($self, $expr) = @_;
208 $self->process_toplevel($expr, undef)
209 }
210
211 sub compile_string {
212 my ($self, $string) = @_;
213 my $sexp = Data::SExpression->new(
214 {fold_lists => 0, use_symbol_class => 1}
215 );
216 my $expr = $sexp->read($string);
217 $self->compile_sexp($expr)
218 }
219
220 1;
221 __END__
222
223 =encoding utf-8
224
225 =head1 NAME
226
227 App::Scheme79asm::Compiler - compile Lisp code to SIMPLE assembly
228
229 =head1 SYNOPSIS
230
231 use App::Scheme79asm;
232 use App::Scheme79asm::Compiler;
233 use Data::SExpression qw/cons/;
234
235 my $asm = App::Scheme79asm->new;
236 my $compiler = App::Scheme79asm::Compiler->new;
237 my $string = '(reverse-list 2 1)';
238 my $assembly_sexp = $compiler->compile_string($string);
239 $asm->process($assembly_sexp);
240 $asm->finish;
241 $asm->print_verilog
242
243 =head1 DESCRIPTION
244
245 This module takes Lisp code and compiles it to the format that
246 L<App::Scheme79asm> wants it to be.
247
248 The two main methods are B<compile_sexp>(I<$sexp>) which compiles an
249 already-parsed sexp to assembly format, and
250 B<compile_string>(I<$string>) which compiles a string to assembly
251 format. The assembly format is a L<Data::SExpression> object that can
252 be passed to App::Scheme79asm->B<process>.
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
This page took 0.088446 seconds and 5 git commands to generate.