]>
iEval git - app-scheme79asm.git/blob - lib/App/Scheme79asm/Compiler.pm
a30d9dde4d00fdff904d2096c0d1deffd7e46990
1 package App
::Scheme79asm
::Compiler
;
7 our $VERSION = '1.000';
10 use Data
::Dumper qw
/Dumper/;
11 use Scalar
::Util qw
/looks_like_number/;
13 use Data
::SExpression qw
/cons consp scalarp/;
14 use List
::MoreUtils qw
/firstidx/;
16 our @PRIMOPS = qw
/car cdr cons atom progn reverse-list/;
18 sub make_symbol
{ Data
::SExpression
::Symbol
->new(shift) }
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
31 our $MORE = make_symbol
'MORE';
32 our $FUNCALL = make_symbol
'FUNCALL';
35 *cons
= *Data
::SExpression
::cons
;
36 *consp
= *Data
::SExpression
::consp
;
37 *scalarp
= *Data
::SExpression
::scalarp
;
40 # list processing routines
42 my ($expr, $rest) = @_;
44 cons
$expr->car, append
($expr->cdr, $rest)
53 my ($block, $expr) = @_;
57 local $_ = $expr->car;
60 cons
$result, mapcar
{ $block->($_) } $expr->cdr
67 my ($expr, $acc) = @_;
69 revacc
($expr->cdr, cons
($expr->car, $acc))
81 my ($expr, $list, $acc) = @_;
84 } elsif ($list->car eq $expr) {
87 positionacc
($expr, $list->cdr, $acc + 1)
92 my ($expr, $list) = @_;
93 positionacc
$expr, $list, 0
95 # end list processing routines
100 symbols
=> ['', '', 'T'],
102 symbol_map
=> {T
=> 2},
104 bless \
%self, $class;
108 my ($self, $expr) = @_;
109 if (!defined $expr) { # nil
111 } elsif (scalarp
$expr) {
113 if ($expr eq 'NIL') {
116 if (!exists $self->{symbol_map
}{$expr}) {
117 $self->{symbol_map
}{$expr} = $self->{nsymbols
};
119 push @
{$self->{symbols
}}, $expr;
121 [$SYMBOL => $self->{symbol_map
}{$expr}]
122 } elsif (consp
$expr) {
123 [$LIST => $self->process_quoted($expr->cdr), $self->process_quoted($expr->car)]
125 croak
'argument to process_quoted is not a scalar, cons, or nil: ', Dumper
($expr);
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)
135 sub rest_of_funcall
{
136 my ($self, $func, $args) = @_;
137 if (!defined $args) {
140 [$MORE => $self->rest_of_funcall($func, $args->cdr), $args->car]
144 sub process_funcall
{
145 my ($self, $func_name, $func_args, $env) = @_;
146 my $prim_idx = firstidx
{ uc $_ eq uc $func_name } @PRIMOPS;
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";
153 [$CALL => $self->rest_of_funcall([make_symbol
(uc $func_name), 0], $processed_args->cdr), $processed_args->car]
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]
160 sub process_toplevel
{
161 my ($self, $expr, $env) = @_;
162 if (!defined $expr) {
164 } elsif (scalarp
$expr) {
165 if (looks_like_number
$expr) {
166 $self->process_quoted($expr);
167 } elsif (uc $expr eq 'T') {
169 } elsif (uc $expr eq 'NIL') {
172 my $position = position
$expr, $env;
173 if (defined $position) {
174 [$VAR => -1 - $position]
176 croak
"Variable $expr not in environment";
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]
194 $self->process_funcall($expr->car, $expr->cdr, $env)
200 my ($self, $expr) = @_;
201 $self->process_toplevel($expr, undef)
205 my ($self, $string) = @_;
206 my $sexp = Data
::SExpression
->new(
207 {fold_lists
=> 0, use_symbol_class
=> 1}
209 my $expr = $sexp->read($string);
210 $self->compile_sexp($expr)
220 App::Scheme79asm::Compiler - compile Lisp code to SIMPLE assembly
224 use App::Scheme79asm;
225 use App::Scheme79asm::Compiler;
226 use Data::SExpression qw/cons/;
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);
238 This module takes Lisp code and compiles it to the format that
239 L<App::Scheme79asm> wants it to be.
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
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.
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.
256 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
258 =head1 COPYRIGHT AND LICENSE
260 Copyright (C) 2018 by Marius Gavrilescu
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.
This page took 0.083568 seconds and 4 git commands to generate.