Make compiler output actually compatible with assembler

diff --git a/lib/App/Scheme79asm.pm b/lib/App/Scheme79asm.pm
index 9b82af6b48acc40233c010736fc9c17f430fed57..f76b834ea6c463ae7b4a03dce6baaf097612a358 100644 (file)
--- a/lib/App/Scheme79asm.pm
+++ b/lib/App/Scheme79asm.pm
@@ -70,11 +70,9 @@ sub process {
 
        die 'Computed addr is not a number: ', Dumper($addr), "\n" unless looks_like_number $addr;
 
-       if (ref $type eq 'Data::SExpression::Symbol') {
+       if (!looks_like_number $type) {
                die "No such type: $type\n" unless exists $TYPES{$type};
                $type = $TYPES{$type};
-       } elsif (!looks_like_number $type) {
-               die "Type is not a number or symbol: $type\n"
        }
 
        $addr += (1 << $self->{addr_bits}) if $addr < 0;

diff --git a/lib/App/Scheme79asm/Compiler.pm b/lib/App/Scheme79asm/Compiler.pm
index 9a28e1cea69fbe23eb331e5262d23f21dcd8cc74..f4762623584a2e34e8a6adb5d63eed69d1642429 100644 (file)
--- a/lib/App/Scheme79asm/Compiler.pm
+++ b/lib/App/Scheme79asm/Compiler.pm
@@ -114,7 +114,7 @@ sub new {
 sub process_quoted {
        my ($self, $expr) = @_;
        if (!defined $expr) { # nil
-               [list => 0]
+               [LIST => 0]
        } elsif (scalarp $expr) {
                $expr = uc $expr;
                if (!exists $self->{symbol_map}{$expr}) {
@@ -122,9 +122,9 @@ sub process_quoted {
                        $self->{nsymbols}++;
                        push @{$self->{symbols}}, $expr;
                }
-               [symbol => $self->{symbol_map}{$expr}]
+               [SYMBOL => $self->{symbol_map}{$expr}]
        } elsif (consp $expr) {
-               [list => $self->process_quoted($expr->cdr), $self->process_quoted($expr->car)]
+               [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);
        }
@@ -132,7 +132,7 @@ sub process_quoted {
 
 sub process_proc {
        my ($self, $func_name, $func_args, $func_body, $env) = @_;
-       my $new_env = append $env, (cons $func_name, rev $func_args);
+       my $new_env = append cons($func_name, rev $func_args), $env;
        $self->process_toplevel($func_body, $new_env)
 }
 
@@ -141,7 +141,7 @@ sub rest_of_funcall {
        if (!defined $args) {
                $func
        } else {
-               [more => $self->rest_of_funcall($func, $args->cdr), $args->car]
+               [MORE => $self->rest_of_funcall($func, $args->cdr), $args->car]
        }
 }
 
@@ -154,28 +154,28 @@ sub process_funcall {
                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]
+               [CALL => $self->rest_of_funcall([uc $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]
+               [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]
+               [LIST => 0]
        } elsif (scalarp $expr) {
                if (looks_like_number $expr) {
                        $self->process_quoted($expr);
                } elsif (uc $expr eq 'T') {
-                       [symbol => 2]
+                       [SYMBOL => 2]
                } elsif (uc $expr eq 'NIL') {
-                       [list => 0]
+                       [LIST => 0]
                } else {
                        my $position = position $expr, $env;
                        if (defined $position) {
-                               [var => -1 - $position]
+                               [VAR => -1 - $position]
                        } else {
                                croak "Variable $expr not in environment";
                        }
@@ -188,12 +188,12 @@ sub process_toplevel {
                        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)]
+                       [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]
+                       [IF => [LIST => $if_else, $if_then], $if_cond]
                } else {
                        $self->process_funcall($expr->car, $expr->cdr, $env)
                }
@@ -234,6 +234,7 @@ App::Scheme79asm::Compiler - compile Lisp code to SIMPLE assembly
   my $string = '(reverse-list 2 1)';
   my $assembly_sexp = $compiler->compile_string($string);
   $asm->process($assembly_sexp);
+  $asm->finish;
   $asm->print_verilog
 
 =head1 DESCRIPTION

diff --git a/t/Compiler.t b/t/Compiler.t
index a73e3418b94b48d0f0e3e1ec6faf4b079999fee7..d8f93a56f09078b3d63b45d8c54549b712663e97 100644 (file)
--- a/t/Compiler.t
+++ b/t/Compiler.t
@@ -24,14 +24,14 @@ sub is_toplevel {
        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_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))))';
+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))))';