]> iEval git - app-scheme79asm.git/blame - lib/App/Scheme79asm/Compiler.pm
Bump version and update Changes
[app-scheme79asm.git] / lib / App / Scheme79asm / Compiler.pm
CommitLineData
8ff4c670
MG
1package App::Scheme79asm::Compiler;
2
3use 5.014000;
4use strict;
5use warnings;
8ff4c670 6
296bac97 7our $VERSION = '1.000';
8ff4c670
MG
8
9use Carp qw/croak/;
10use Data::Dumper qw/Dumper/;
11use Scalar::Util qw/looks_like_number/;
12
13use Data::SExpression qw/cons consp scalarp/;
14use List::MoreUtils qw/firstidx/;
15
16our @PRIMOPS = qw/car cdr cons atom progn reverse-list/;
17
0fea28cb
MG
18sub make_symbol { Data::SExpression::Symbol->new(shift) }
19
20# types
21our $LIST = make_symbol 'LIST';
22our $SYMBOL = make_symbol 'SYMBOL';
23our $VAR = make_symbol 'VAR';
24# no need for closures
25our $PROC = make_symbol 'PROC';
26our $IF = make_symbol 'IF';
27our $CALL = make_symbol 'CALL';
28# no need for quoted constants
29
30# primitives
31our $MORE = make_symbol 'MORE';
32our $FUNCALL = make_symbol 'FUNCALL';
33
8ff4c670
MG
34BEGIN {
35 *cons = *Data::SExpression::cons;
36 *consp = *Data::SExpression::consp;
37 *scalarp = *Data::SExpression::scalarp;
38}
39
40# list processing routines
41sub append {
42 my ($expr, $rest) = @_;
43 if (defined $expr) {
44 cons $expr->car, append($expr->cdr, $rest)
45 } else {
46 $rest
47 }
48}
49
50sub mapcar (&@);
51
52sub 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
66sub revacc {
67 my ($expr, $acc) = @_;
68 if (defined $expr) {
69 revacc ($expr->cdr, cons($expr->car, $acc))
70 } else {
71 $acc
72 }
73}
74
75sub rev {
76 my ($expr) = @_;
77 revacc $expr, undef;
78}
79
80sub 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
91sub position {
92 my ($expr, $list) = @_;
93 positionacc $expr, $list, 0
94}
8ff4c670
MG
95# end list processing routines
96
97sub 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
107sub 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
129sub 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
135sub 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
144sub 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
160sub 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
199sub compile_sexp {
200 my ($self, $expr) = @_;
201 $self->process_toplevel($expr, undef)
202}
203
204sub 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
2131;
214__END__
215
216=encoding utf-8
217
218=head1 NAME
219
220App::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
238This module takes Lisp code and compiles it to the format that
239L<App::Scheme79asm> wants it to be.
240
241The two main methods are B<compile_sexp>(I<$sexp>) which compiles an
242already-parsed sexp to assembly format, and
243B<compile_string>(I<$string>) which compiles a string to assembly
b3270ee0
MG
244format.
245
246The assembly format is a sexp. These functions return an
247already-parsed sexp (an arrayref like the ones returned by
248L<Data::SExpression>'s B<read> method). This arrayref can be passed
249directly to L<App::Scheme79asm>'s B<process> method.
250
251If a string representation of the sexp is required, it can be obtained
252by calling the B<dump_sexp> function in L<Data::Dump::Sexp> with such an arrayref.
8ff4c670
MG
253
254=head1 AUTHOR
255
256Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
257
258=head1 COPYRIGHT AND LICENSE
259
260Copyright (C) 2018 by Marius Gavrilescu
261
262This library is free software; you can redistribute it and/or modify
263it under the same terms as Perl itself, either Perl version 5.24.3 or,
264at your option, any later version of Perl 5 you may have available.
265
266
267=cut
This page took 0.049001 seconds and 4 git commands to generate.