]>
iEval git - app-scheme79asm.git/blob - Compiler.pm
bf03eea81f8259dd7e748047a7c9eaccc8416bc2
1 package App
::Scheme79asm
::Compiler
;
6 use parent qw
/Exporter/;
8 our @EXPORT_OK = qw
/pretty_print/;
12 use Data
::Dumper qw
/Dumper/;
13 use Scalar
::Util qw
/looks_like_number/;
15 use Data
::SExpression qw
/cons consp scalarp/;
16 use List
::MoreUtils qw
/firstidx/;
18 our @PRIMOPS = qw
/car cdr cons atom progn reverse-list/;
21 *cons
= *Data
::SExpression
::cons
;
22 *consp
= *Data
::SExpression
::consp
;
23 *scalarp
= *Data
::SExpression
::scalarp
;
26 # list processing routines
28 my ($expr, $rest) = @_;
30 cons
$expr->car, append
($expr->cdr, $rest)
39 my ($block, $expr) = @_;
43 local $_ = $expr->car;
46 cons
$result, mapcar
{ $block->($_) } $expr->cdr
53 my ($expr, $acc) = @_;
55 revacc
($expr->cdr, cons
($expr->car, $acc))
67 my ($expr, $list, $acc) = @_;
70 } elsif ($list->car eq $expr) {
73 positionacc
($expr, $list->cdr, $acc + 1)
78 my ($expr, $list) = @_;
79 positionacc
$expr, $list, 0
86 } elsif (scalarp
$expr) {
88 } elsif (ref $expr eq 'ARRAY') {
89 '(' . join (' ', map { pretty_print
($_) } @
$expr). ')'
93 my $acc = '(' . pretty_print
($car);
94 while (defined $cdr) {
97 $acc .= ' ' . pretty_print
($car);
102 # end list processing routines
107 symbols
=> ['', '', 'T'],
111 bless \
%self, $class;
115 my ($self, $expr) = @_;
116 if (!defined $expr) { # nil
118 } elsif (scalarp
$expr) {
120 if (!exists $self->{symbol_map
}{$expr}) {
121 $self->{symbol_map
}{$expr} = $self->{nsymbols
};
123 push @
{$self->{symbols
}}, $expr;
125 [SYMBOL
=> $self->{symbol_map
}{$expr}]
126 } elsif (consp
$expr) {
127 [LIST
=> $self->process_quoted($expr->cdr), $self->process_quoted($expr->car)]
129 croak
'argument to process_quoted is not a scalar, cons, or nil: ', Dumper
($expr);
134 my ($self, $func_name, $func_args, $func_body, $env) = @_;
135 my $new_env = append cons
($func_name, rev
$func_args), $env;
136 $self->process_toplevel($func_body, $new_env)
139 sub rest_of_funcall
{
140 my ($self, $func, $args) = @_;
141 if (!defined $args) {
144 [MORE
=> $self->rest_of_funcall($func, $args->cdr), $args->car]
148 sub process_funcall
{
149 my ($self, $func_name, $func_args, $env) = @_;
150 my $prim_idx = firstidx
{ uc $_ eq uc $func_name } @PRIMOPS;
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";
157 [CALL
=> $self->rest_of_funcall([uc $func_name, 0], $processed_args->cdr), $processed_args->car]
159 my $final_args = append
$processed_args, cons
($self->process_toplevel($func_name, $env), undef);
160 [CALL
=> $self->rest_of_funcall([FUNCALL
=> 0], $final_args->cdr), $final_args->car]
164 sub process_toplevel
{
165 my ($self, $expr, $env) = @_;
166 if (!defined $expr) {
168 } elsif (scalarp
$expr) {
169 if (looks_like_number
$expr) {
170 $self->process_quoted($expr);
171 } elsif (uc $expr eq 'T') {
173 } elsif (uc $expr eq 'NIL') {
176 my $position = position
$expr, $env;
177 if (defined $position) {
178 [VAR
=> -1 - $position]
180 croak
"Variable $expr not in environment";
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;
190 my $func_body = $expr->cdr->cdr->cdr->car; ## no critic (ProhibitLongChainsOfMethodCalls)
191 [PROC
=> $self->process_proc($func_name, $func_args, $func_body, $env)]
192 } elsif ($func eq 'IF') {
193 my ($if_cond, $if_then, $if_else) =
194 map { $self->process_toplevel($_, $env) }
195 ($expr->cdr->car, $expr->cdr->cdr->car, $expr->cdr->cdr->cdr->car); ## no critic (ProhibitLongChainsOfMethodCalls)
196 [IF
=> [LIST
=> $if_else, $if_then], $if_cond]
198 $self->process_funcall($expr->car, $expr->cdr, $env)
204 my ($self, $expr) = @_;
205 $self->process_toplevel($expr, undef)
209 my ($self, $string) = @_;
210 my $sexp = Data
::SExpression
->new(
211 {fold_lists
=> 0, use_symbol_class
=> 1}
213 my $expr = $sexp->read($string);
214 $self->compile_sexp($expr)
224 App::Scheme79asm::Compiler - compile Lisp code to SIMPLE assembly
228 use App::Scheme79asm;
229 use App::Scheme79asm::Compiler;
230 use Data::SExpression qw/cons/;
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);
242 This module takes Lisp code and compiles it to the format that
243 L<App::Scheme79asm> wants it to be.
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>.
253 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
255 =head1 COPYRIGHT AND LICENSE
257 Copyright (C) 2018 by Marius Gavrilescu
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.
This page took 0.066916 seconds and 3 git commands to generate.