]> iEval git - app-scheme79asm.git/blob - lib/App/Scheme79asm/Compiler.pm
Slightly better doc
[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
7 our $VERSION = '0.005';
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
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
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 }
95 # end list processing routines
96
97 sub new {
98 my ($class) = @_;
99 my %self = (
100 symbols => ['', '', 'T'],
101 nsymbols => 3,
102 symbol_map => {T => 2},
103 );
104 bless \%self, $class;
105 }
106
107 sub process_quoted {
108 my ($self, $expr) = @_;
109 if (!defined $expr) { # nil
110 [$LIST => 0]
111 } elsif (scalarp $expr) {
112 $expr = uc $expr;
113 if ($expr eq 'NIL') {
114 return [$LIST => 0]
115 }
116 if (!exists $self->{symbol_map}{$expr}) {
117 $self->{symbol_map}{$expr} = $self->{nsymbols};
118 $self->{nsymbols}++;
119 push @{$self->{symbols}}, $expr;
120 }
121 [$SYMBOL => $self->{symbol_map}{$expr}]
122 } elsif (consp $expr) {
123 [$LIST => $self->process_quoted($expr->cdr), $self->process_quoted($expr->car)]
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) = @_;
131 my $new_env = append cons($func_name, rev $func_args), $env;
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 {
140 [$MORE => $self->rest_of_funcall($func, $args->cdr), $args->car]
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 }
153 [$CALL => $self->rest_of_funcall([make_symbol(uc $func_name), 0], $processed_args->cdr), $processed_args->car]
154 } else {
155 my $final_args = append $processed_args, cons ($self->process_toplevel($func_name, $env), undef);
156 [$CALL => $self->rest_of_funcall([$FUNCALL => 0], $final_args->cdr), $final_args->car]
157 }
158 }
159
160 sub process_toplevel {
161 my ($self, $expr, $env) = @_;
162 if (!defined $expr) {
163 [$LIST => 0]
164 } elsif (scalarp $expr) {
165 if (looks_like_number $expr) {
166 $self->process_quoted($expr);
167 } elsif (uc $expr eq 'T') {
168 [$SYMBOL => 2]
169 } elsif (uc $expr eq 'NIL') {
170 [$LIST => 0]
171 } else {
172 my $position = position $expr, $env;
173 if (defined $position) {
174 [$VAR => -1 - $position]
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;
186 my $func_body = $expr->cdr->cdr->cdr->car; ## no critic (ProhibitLongChainsOfMethodCalls)
187 [$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 map { $self->process_toplevel($_, $env) }
191 ($expr->cdr->car, $expr->cdr->cdr->car, $expr->cdr->cdr->cdr->car); ## no critic (ProhibitLongChainsOfMethodCalls)
192 [$IF => [$LIST => $if_else, $if_then], $if_cond]
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);
233 $asm->finish;
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
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.
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.072651 seconds and 5 git commands to generate.