lib/App/Scheme79asm/Compiler.pm

   1 package App::Scheme79asm::Compiler;
   2
   3 use 5.014000;
   4 use strict;
   5 use warnings;
   6 use parent qw/Exporter/;
   7
   8 our @EXPORT_OK = qw/pretty_print/;
   9 our $VERSION = '0.005';
  10
  11 use Carp qw/croak/;
  12 use Data::Dumper qw/Dumper/;
  13 use Scalar::Util qw/looks_like_number/;
  14
  15 use Data::SExpression qw/cons consp scalarp/;
  16 use List::MoreUtils qw/firstidx/;
  17
  18 our @PRIMOPS = qw/car cdr cons atom progn reverse-list/;
  19
  20 BEGIN {
  21         *cons    = *Data::SExpression::cons;
  22         *consp   = *Data::SExpression::consp;
  23         *scalarp = *Data::SExpression::scalarp;
  24 }
  25
  26 # list processing routines
  27 sub append {
  28         my ($expr, $rest) = @_;
  29         if (defined $expr) {
  30                 cons $expr->car, append($expr->cdr, $rest)
  31         } else {
  32                 $rest
  33         }
  34 }
  35
  36 sub mapcar (&@);
  37
  38 sub mapcar (&@) {
  39         my ($block, $expr) = @_;
  40         if (defined $expr) {
  41                 my $result;
  42                 do {
  43                         local $_ = $expr->car;
  44                         $result = $block->()
  45                 };
  46                 cons $result, mapcar { $block->($_) } $expr->cdr
  47         } else {
  48                 undef
  49         }
  50 }
  51
  52 sub revacc {
  53         my ($expr, $acc) = @_;
  54         if (defined $expr) {
  55                 revacc ($expr->cdr, cons($expr->car, $acc))
  56         } else {
  57                 $acc
  58         }
  59 }
  60
  61 sub rev {
  62         my ($expr) = @_;
  63         revacc $expr, undef;
  64 }
  65
  66 sub positionacc {
  67         my ($expr, $list, $acc) = @_;
  68         if (!defined $list) {
  69                 undef
  70         } elsif ($list->car eq $expr) {
  71                 $acc
  72         } else {
  73                 positionacc($expr, $list->cdr, $acc + 1)
  74         }
  75 }
  76
  77 sub position {
  78         my ($expr, $list) = @_;
  79         positionacc $expr, $list, 0
  80 }
  81
  82 sub pretty_print {
  83         my ($expr) = @_;
  84         if (!defined $expr) {
  85                 '()'
  86         } elsif (scalarp $expr) {
  87                 "$expr"
  88         } elsif (ref $expr eq 'ARRAY') {
  89                 '(' . join (' ', map { pretty_print($_) } @$expr). ')'
  90         } else {
  91                 my $cdr = $expr->cdr;
  92                 my $car = $expr->car;
  93                 my $acc = '(' . pretty_print($car);
  94                 while (defined $cdr) {
  95                         $car = $cdr->car;
  96                         $cdr = $cdr->cdr;
  97                         $acc .= ' ' . pretty_print($car);
  98                 }
  99                 $acc . ')'
 100         }
 101 }
 102 # end list processing routines
 103
 104 sub new {
 105         my ($class) = @_;
 106         my %self = (
 107                 symbols => ['', '', 'T'],
 108                 nsymbols => 3,
 109                 symbol_map => {},
 110         );
 111         bless \%self, $class;
 112 }
 113
 114 sub process_quoted {
 115         my ($self, $expr) = @_;
 116         if (!defined $expr) { # nil
 117                 [LIST => 0]
 118         } elsif (scalarp $expr) {
 119                 $expr = uc $expr;
 120                 if (!exists $self->{symbol_map}{$expr}) {
 121                         $self->{symbol_map}{$expr} = $self->{nsymbols};
 122                         $self->{nsymbols}++;
 123                         push @{$self->{symbols}}, $expr;
 124                 }
 125                 [SYMBOL => $self->{symbol_map}{$expr}]
 126         } elsif (consp $expr) {
 127                 [LIST => $self->process_quoted($expr->cdr), $self->process_quoted($expr->car)]
 128         } else {
 129                 croak 'argument to process_quoted is not a scalar, cons, or nil: ', Dumper($expr);
 130         }
 131 }
 132
 133 sub process_proc {
 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)
 137 }
 138
 139 sub rest_of_funcall {
 140         my ($self, $func, $args) = @_;
 141         if (!defined $args) {
 142                 $func
 143         } else {
 144                 [MORE => $self->rest_of_funcall($func, $args->cdr), $args->car]
 145         }
 146 }
 147
 148 sub process_funcall {
 149         my ($self, $func_name, $func_args, $env) = @_;
 150         my $prim_idx = firstidx { uc $_ eq uc $func_name } @PRIMOPS;
 151         my $processed_args =
 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";
 156                 }
 157                 [CALL => $self->rest_of_funcall([uc $func_name, 0], $processed_args->cdr), $processed_args->car]
 158         } else {
 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]
 161         }
 162 }
 163
 164 sub process_toplevel {
 165         my ($self, $expr, $env) = @_;
 166         if (!defined $expr) {
 167                 [LIST => 0]
 168         } elsif (scalarp $expr) {
 169                 if (looks_like_number $expr) {
 170                         $self->process_quoted($expr);
 171                 } elsif (uc $expr eq 'T') {
 172                         [SYMBOL => 2]
 173                 } elsif (uc $expr eq 'NIL') {
 174                         [LIST => 0]
 175                 } else {
 176                         my $position = position $expr, $env;
 177                         if (defined $position) {
 178                                 [VAR => -1 - $position]
 179                         } else {
 180                                 croak "Variable $expr not in environment";
 181                         }
 182                 }
 183         } else {
 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]
 197                 } else {
 198                         $self->process_funcall($expr->car, $expr->cdr, $env)
 199                 }
 200         }
 201 }
 202
 203 sub compile_sexp {
 204         my ($self, $expr) = @_;
 205         $self->process_toplevel($expr, undef)
 206 }
 207
 208 sub compile_string {
 209         my ($self, $string) = @_;
 210         my $sexp = Data::SExpression->new(
 211                 {fold_lists => 0, use_symbol_class => 1}
 212         );
 213         my $expr = $sexp->read($string);
 214         $self->compile_sexp($expr)
 215 }
 216
 217 1;
 218 __END__
 219
 220 =encoding utf-8
 221
 222 =head1 NAME
 223
 224 App::Scheme79asm::Compiler - compile Lisp code to SIMPLE assembly
 225
 226 =head1 SYNOPSIS
 227
 228   use App::Scheme79asm;
 229   use App::Scheme79asm::Compiler;
 230   use Data::SExpression qw/cons/;
 231
 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);
 237   $asm->finish;
 238   $asm->print_verilog
 239
 240 =head1 DESCRIPTION
 241
 242 This module takes Lisp code and compiles it to the format that
 243 L<App::Scheme79asm> wants it to be.
 244
 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>.
 250
 251 =head1 AUTHOR
 252
 253 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 254
 255 =head1 COPYRIGHT AND LICENSE
 256
 257 Copyright (C) 2018 by Marius Gavrilescu
 258
 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.
 262
 263
 264 =cut