From 8ff4c670a59a17d4bbfd852fdb9f4cbb871c21d8 Mon Sep 17 00:00:00 2001 From: Marius Gavrilescu Date: Sat, 17 Mar 2018 22:50:54 +0200 Subject: [PATCH] Add compiler --- MANIFEST | 2 + lib/App/Scheme79asm.pm | 7 + lib/App/Scheme79asm/Compiler.pm | 263 ++++++++++++++++++++++++++++++++ t/Compiler.t | 37 +++++ 4 files changed, 309 insertions(+) create mode 100644 lib/App/Scheme79asm/Compiler.pm create mode 100644 t/Compiler.t diff --git a/MANIFEST b/MANIFEST index 6f8aef8..bcf5fe1 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4,4 +4,6 @@ MANIFEST README scheme79asm t/App-Scheme79asm.t +t/Compiler.t lib/App/Scheme79asm.pm +lib/App/Scheme79asm/Compiler.pm diff --git a/lib/App/Scheme79asm.pm b/lib/App/Scheme79asm.pm index 19e249c..18a68c8 100644 --- a/lib/App/Scheme79asm.pm +++ b/lib/App/Scheme79asm.pm @@ -315,6 +315,13 @@ Parse a sequence of S-expressions and lay it out in memory. Can be called multiple times to lay out multiple sequences of S-expressions one after another. +=item $asm->B(I<$sexp>) + +Given an already-parsed sexp (meaning a +L object), lay it out in memory. +Can be called multiple times to lay out multiple sequences of +S-expressions one after another. + =item $asm->B Move the last pointer to position 5, and put the free pointer at diff --git a/lib/App/Scheme79asm/Compiler.pm b/lib/App/Scheme79asm/Compiler.pm new file mode 100644 index 0000000..9a28e1c --- /dev/null +++ b/lib/App/Scheme79asm/Compiler.pm @@ -0,0 +1,263 @@ +package App::Scheme79asm::Compiler; + +use 5.014000; +use strict; +use warnings; +use parent qw/Exporter/; + +our @EXPORT_OK = qw/pretty_print/; +our $VERSION = 0.004; + +use Carp qw/croak/; +use Data::Dumper qw/Dumper/; +use Scalar::Util qw/looks_like_number/; + +use Data::SExpression qw/cons consp scalarp/; +use List::MoreUtils qw/firstidx/; + +our @PRIMOPS = qw/car cdr cons atom progn reverse-list/; + +BEGIN { + *cons = *Data::SExpression::cons; + *consp = *Data::SExpression::consp; + *scalarp = *Data::SExpression::scalarp; +} + +# list processing routines +sub append { + my ($expr, $rest) = @_; + if (defined $expr) { + cons $expr->car, append($expr->cdr, $rest) + } else { + $rest + } +} + +sub mapcar (&@); + +sub mapcar (&@) { + my ($block, $expr) = @_; + if (defined $expr) { + my $result; + do { + local $_ = $expr->car; + $result = $block->() + }; + cons $result, mapcar { $block->($_) } $expr->cdr + } else { + undef + } +} + +sub revacc { + my ($expr, $acc) = @_; + if (defined $expr) { + revacc ($expr->cdr, cons($expr->car, $acc)) + } else { + $acc + } +} + +sub rev { + my ($expr) = @_; + revacc $expr, undef; +} + +sub positionacc { + my ($expr, $list, $acc) = @_; + if (!defined $list) { + undef + } elsif ($list->car eq $expr) { + $acc + } else { + positionacc($expr, $list->cdr, $acc + 1) + } +} + +sub position { + my ($expr, $list) = @_; + positionacc $expr, $list, 0 +} + +sub pretty_print { + my ($expr) = @_; + if (!defined $expr) { + '()' + } elsif (scalarp $expr) { + "$expr" + } elsif (ref $expr eq 'ARRAY') { + '(' . join (' ', map { pretty_print($_) } @$expr). ')' + } else { + my $cdr = $expr->cdr; + my $car = $expr->car; + my $acc = '(' . pretty_print($car); + while (defined $cdr) { + $car = $cdr->car; + $cdr = $cdr->cdr; + $acc .= ' ' . pretty_print($car); + } + $acc . ')' + } +} +# end list processing routines + +sub new { + my ($class) = @_; + my %self = ( + symbols => ['', '', 'T'], + nsymbols => 3, + symbol_map => {} + ); + bless \%self, $class; +} + +sub process_quoted { + my ($self, $expr) = @_; + if (!defined $expr) { # nil + [list => 0] + } elsif (scalarp $expr) { + $expr = uc $expr; + if (!exists $self->{symbol_map}{$expr}) { + $self->{symbol_map}{$expr} = $self->{nsymbols}; + $self->{nsymbols}++; + push @{$self->{symbols}}, $expr; + } + [symbol => $self->{symbol_map}{$expr}] + } elsif (consp $expr) { + [list => $self->process_quoted($expr->cdr), $self->process_quoted($expr->car)] + } else { + croak 'argument to process_quoted is not a scalar, cons, or nil: ', Dumper($expr); + } +} + +sub process_proc { + my ($self, $func_name, $func_args, $func_body, $env) = @_; + my $new_env = append $env, (cons $func_name, rev $func_args); + $self->process_toplevel($func_body, $new_env) +} + +sub rest_of_funcall { + my ($self, $func, $args) = @_; + if (!defined $args) { + $func + } else { + [more => $self->rest_of_funcall($func, $args->cdr), $args->car] + } +} + +sub process_funcall { + my ($self, $func_name, $func_args, $env) = @_; + my $prim_idx = firstidx { uc $_ eq uc $func_name } @PRIMOPS; + my $processed_args = + mapcar { $self->process_toplevel($_, $env) } $func_args; + if ($prim_idx > -1) { + if (!defined $processed_args) { + croak "Cannot call primitive $func_name with no arguments"; + } + [call => $self->rest_of_funcall([lc $func_name, 0], $processed_args->cdr), $processed_args->car] + } else { + my $final_args = append $processed_args, cons ($self->process_toplevel($func_name, $env), undef); + [call => $self->rest_of_funcall([funcall => 0], $final_args->cdr), $final_args->car] + } +} + +sub process_toplevel { + my ($self, $expr, $env) = @_; + if (!defined $expr) { + [list => 0] + } elsif (scalarp $expr) { + if (looks_like_number $expr) { + $self->process_quoted($expr); + } elsif (uc $expr eq 'T') { + [symbol => 2] + } elsif (uc $expr eq 'NIL') { + [list => 0] + } else { + my $position = position $expr, $env; + if (defined $position) { + [var => -1 - $position] + } else { + croak "Variable $expr not in environment"; + } + } + } else { + my $func = uc $expr->car; + if ($func eq 'QUOTE') { + $self->process_quoted($expr->cdr->car) + } elsif ($func eq 'LAMBDA') { + my $func_name = $expr->cdr->car; + my $func_args = $expr->cdr->cdr->car; + my $func_body = $expr->cdr->cdr->cdr->car; + [proc => $self->process_proc($func_name, $func_args, $func_body, $env)] + } elsif ($func eq 'IF') { + my ($if_cond, $if_then, $if_else) = + map { $self->process_toplevel($_, $env) } + ($expr->cdr->car, $expr->cdr->cdr->car, $expr->cdr->cdr->cdr->car); + [if => [list => $if_else, $if_then], $if_cond] + } else { + $self->process_funcall($expr->car, $expr->cdr, $env) + } + } +} + +sub compile_sexp { + my ($self, $expr) = @_; + $self->process_toplevel($expr, undef) +} + +sub compile_string { + my ($self, $string) = @_; + my $sexp = Data::SExpression->new( + {fold_lists => 0, use_symbol_class => 1} + ); + my $expr = $sexp->read($string); + $self->compile_sexp($expr) +} + +1; +__END__ + +=encoding utf-8 + +=head1 NAME + +App::Scheme79asm::Compiler - compile Lisp code to SIMPLE assembly + +=head1 SYNOPSIS + + use App::Scheme79asm; + use App::Scheme79asm::Compiler; + use Data::SExpression qw/cons/; + + my $asm = App::Scheme79asm->new; + my $compiler = App::Scheme79asm::Compiler->new; + my $string = '(reverse-list 2 1)'; + my $assembly_sexp = $compiler->compile_string($string); + $asm->process($assembly_sexp); + $asm->print_verilog + +=head1 DESCRIPTION + +This module takes Lisp code and compiles it to the format that +L wants it to be. + +The two main methods are B(I<$sexp>) which compiles an +already-parsed sexp to assembly format, and +B(I<$string>) which compiles a string to assembly +format. The assembly format is a L object that can +be passed to App::Scheme79asm->B. + +=head1 AUTHOR + +Marius Gavrilescu, Emarius@ieval.roE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2018 by Marius Gavrilescu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.24.3 or, +at your option, any later version of Perl 5 you may have available. + + +=cut diff --git a/t/Compiler.t b/t/Compiler.t new file mode 100644 index 0000000..a73e341 --- /dev/null +++ b/t/Compiler.t @@ -0,0 +1,37 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use Test::More tests => 11; +BEGIN { use_ok('App::Scheme79asm::Compiler', qw/pretty_print/) }; + +sub is_sexp { + my ($expr, $expected, $name) = @_; + is pretty_print($expr), $expected, $name; +} + +sub to_sexp { + my ($string) = @_; + scalar Data::SExpression->new({fold_lists => 0, use_symbol_class => 1})->read($string) +} + +sub new { + App::Scheme79asm::Compiler->new; +} + +sub is_toplevel { + my ($string, $expected) = @_; + is_sexp new->process_toplevel(to_sexp $string), $expected, "process_toplevel $string"; +} + +is_sexp new->process_quoted(to_sexp '5'), '(symbol 3)', 'process_quoted 5'; +is_sexp new->process_quoted(to_sexp '()'), '(list 0)', 'process_quoted ()'; +is_sexp new->process_quoted(to_sexp '(5 foo)'), '(list (list (list 0) (symbol 3)) (symbol 4))', 'process_quoted (5 foo)'; +is_sexp new->process_quoted(to_sexp '(((5)))'), '(list (list 0) (list (list 0) (list (list 0) (symbol 3))))', 'process_quoted (((5)))'; + +is_toplevel '(quote 5)', '(symbol 3)'; +is_toplevel '(if t \'(2 3) \'x)', '(if (list (symbol 5) (list (list (list 0) (symbol 3)) (symbol 4))) (symbol 2))'; +is_toplevel '(car \'(1 2))', '(call (car 0) (list (list (list 0) (symbol 3)) (symbol 4)))'; +is_toplevel '(lambda id (x) x)', '(proc (var -2))'; +is_toplevel '((lambda id (x) x) 5)', '(call (more (funcall 0) (proc (var -2))) (symbol 3))'; +is_toplevel '(lambda append (x y) (if (atom x) y (cons (car x) (append (cdr x) y))))', '(proc (if (list (call (more (cons 0) (call (more (more (funcall 0) (var -1)) (var -2)) (call (cdr 0) (var -3)))) (call (car 0) (var -3))) (var -2)) (call (atom 0) (var -3))))'; -- 2.39.5