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 => {T => 2},
 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 ($expr eq 'NIL') {
 121                         return [LIST => 0]
 122                 }
 123                 if (!exists $self->{symbol_map}{$expr}) {
 124                         $self->{symbol_map}{$expr} = $self->{nsymbols};
 125                         $self->{nsymbols}++;
 126                         push @{$self->{symbols}}, $expr;
 127                 }
 128                 [SYMBOL => $self->{symbol_map}{$expr}]
 129         } elsif (consp $expr) {
 130                 [LIST => $self->process_quoted($expr->cdr), $self->process_quoted($expr->car)]
 131         } else {
 132                 croak 'argument to process_quoted is not a scalar, cons, or nil: ', Dumper($expr);
 133         }
 134 }
 135
 136 sub process_proc {
 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)
 140 }
 141
 142 sub rest_of_funcall {
 143         my ($self, $func, $args) = @_;
 144         if (!defined $args) {
 145                 $func
 146         } else {
 147                 [MORE => $self->rest_of_funcall($func, $args->cdr), $args->car]
 148         }
 149 }
 150
 151 sub process_funcall {
 152         my ($self, $func_name, $func_args, $env) = @_;
 153         my $prim_idx = firstidx { uc $_ eq uc $func_name } @PRIMOPS;
 154         my $processed_args =
 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";
 159                 }
 160                 [CALL => $self->rest_of_funcall([uc $func_name, 0], $processed_args->cdr), $processed_args->car]
 161         } else {
 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]
 164         }
 165 }
 166
 167 sub process_toplevel {
 168         my ($self, $expr, $env) = @_;
 169         if (!defined $expr) {
 170                 [LIST => 0]
 171         } elsif (scalarp $expr) {
 172                 if (looks_like_number $expr) {
 173                         $self->process_quoted($expr);
 174                 } elsif (uc $expr eq 'T') {
 175                         [SYMBOL => 2]
 176                 } elsif (uc $expr eq 'NIL') {
 177                         [LIST => 0]
 178                 } else {
 179                         my $position = position $expr, $env;
 180                         if (defined $position) {
 181                                 [VAR => -1 - $position]
 182                         } else {
 183                                 croak "Variable $expr not in environment";
 184                         }
 185                 }
 186         } else {
 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]
 200                 } else {
 201                         $self->process_funcall($expr->car, $expr->cdr, $env)
 202                 }
 203         }
 204 }
 205
 206 sub compile_sexp {
 207         my ($self, $expr) = @_;
 208         $self->process_toplevel($expr, undef)
 209 }
 210
 211 sub compile_string {
 212         my ($self, $string) = @_;
 213         my $sexp = Data::SExpression->new(
 214                 {fold_lists => 0, use_symbol_class => 1}
 215         );
 216         my $expr = $sexp->read($string);
 217         $self->compile_sexp($expr)
 218 }
 219
 220 1;
 221 __END__
 222
 223 =encoding utf-8
 224
 225 =head1 NAME
 226
 227 App::Scheme79asm::Compiler - compile Lisp code to SIMPLE assembly
 228
 229 =head1 SYNOPSIS
 230
 231   use App::Scheme79asm;
 232   use App::Scheme79asm::Compiler;
 233   use Data::SExpression qw/cons/;
 234
 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);
 240   $asm->finish;
 241   $asm->print_verilog
 242
 243 =head1 DESCRIPTION
 244
 245 This module takes Lisp code and compiles it to the format that
 246 L<App::Scheme79asm> wants it to be.
 247
 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>.
 253
 254 =head1 AUTHOR
 255
 256 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 257
 258 =head1 COPYRIGHT AND LICENSE
 259
 260 Copyright (C) 2018 by Marius Gavrilescu
 261
 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.
 265
 266
 267 =cut