]>
iEval git - app-scheme79asm.git/blob - lib/App/Scheme79asm/Compiler.pm
1 package App
::Scheme79asm
::Compiler
;
6 use parent qw
/Exporter/;
8 our @EXPORT_OK = qw
/pretty_print/;
9 our $VERSION = '0.005';
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'],
109 symbol_map
=> {T
=> 2},
111 bless \
%self, $class;
115 my ($self, $expr) = @_;
116 if (!defined $expr) { # nil
118 } elsif (scalarp
$expr) {
120 if ($expr eq 'NIL') {
123 if (!exists $self->{symbol_map
}{$expr}) {
124 $self->{symbol_map
}{$expr} = $self->{nsymbols
};
126 push @
{$self->{symbols
}}, $expr;
128 [SYMBOL
=> $self->{symbol_map
}{$expr}]
129 } elsif (consp
$expr) {
130 [LIST
=> $self->process_quoted($expr->cdr), $self->process_quoted($expr->car)]
132 croak
'argument to process_quoted is not a scalar, cons, or nil: ', Dumper
($expr);
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)
142 sub rest_of_funcall
{
143 my ($self, $func, $args) = @_;
144 if (!defined $args) {
147 [MORE
=> $self->rest_of_funcall($func, $args->cdr), $args->car]
151 sub process_funcall
{
152 my ($self, $func_name, $func_args, $env) = @_;
153 my $prim_idx = firstidx
{ uc $_ eq uc $func_name } @PRIMOPS;
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";
160 [CALL
=> $self->rest_of_funcall([uc $func_name, 0], $processed_args->cdr), $processed_args->car]
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]
167 sub process_toplevel
{
168 my ($self, $expr, $env) = @_;
169 if (!defined $expr) {
171 } elsif (scalarp
$expr) {
172 if (looks_like_number
$expr) {
173 $self->process_quoted($expr);
174 } elsif (uc $expr eq 'T') {
176 } elsif (uc $expr eq 'NIL') {
179 my $position = position
$expr, $env;
180 if (defined $position) {
181 [VAR
=> -1 - $position]
183 croak
"Variable $expr not in environment";
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]
201 $self->process_funcall($expr->car, $expr->cdr, $env)
207 my ($self, $expr) = @_;
208 $self->process_toplevel($expr, undef)
212 my ($self, $string) = @_;
213 my $sexp = Data
::SExpression
->new(
214 {fold_lists
=> 0, use_symbol_class
=> 1}
216 my $expr = $sexp->read($string);
217 $self->compile_sexp($expr)
227 App::Scheme79asm::Compiler - compile Lisp code to SIMPLE assembly
231 use App::Scheme79asm;
232 use App::Scheme79asm::Compiler;
233 use Data::SExpression qw/cons/;
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);
245 This module takes Lisp code and compiles it to the format that
246 L<App::Scheme79asm> wants it to be.
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>.
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.088446 seconds and 5 git commands to generate.