| 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 |