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. The assembly format is a L<Data::SExpression> object that can
 245 be passed to App::Scheme79asm->B<process>.
 246
 247 =head1 AUTHOR
 248
 249 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 250
 251 =head1 COPYRIGHT AND LICENSE
 252
 253 Copyright (C) 2018 by Marius Gavrilescu
 254
 255 This library is free software; you can redistribute it and/or modify
 256 it under the same terms as Perl itself, either Perl version 5.24.3 or,
 257 at your option, any later version of Perl 5 you may have available.
 258
 259
 260 =cut