Actually make assembler work

diff --git a/lib/App/Scheme79asm.pm b/lib/App/Scheme79asm.pm
index ec0ada330f9acad8b5fbff73e2b538bf8bca1de6..e0bec36c64c32388335bd625fbacf63b36c6b0ed 100644 (file)
--- a/lib/App/Scheme79asm.pm
+++ b/lib/App/Scheme79asm.pm
@@ -4,6 +4,7 @@ use 5.014000;
 use strict;
 use warnings;
 
+use Data::Dumper qw/Dumper/;
 use Data::SExpression qw/consp scalarp/;
 use Scalar::Util qw/looks_like_number/;
 
@@ -12,33 +13,60 @@ our $VERSION = '0.001';
 our %TYPES = (
        LIST => 0,
        SYMBOL => 1,
+       NUMBER => 1,
        VAR => 2,
        VARIABLE => 2,
        CLOSURE => 3,
        PROC => 4,
        PROCEDURE => 4,
+       IF => 5,
        COND => 5,
        CONDITIONAL => 5,
        CALL => 6,
-       FUNCALL => 6,
        QUOTE => 7,
        QUOTED => 7,
+
+       MORE => 0,
+       CAR => 1,
+       CDR => 2,
+       CONS => 3,
+       ATOM => 4,
+       PROGN => 5,
+       MAKELIST => 6,
+       FUNCALL => 7,
 );
 
 *consp = *Data::SExpression::consp;
 *scalarp = *Data::SExpression::scalarp;
 
 sub process {
-       my ($self, $sexp) = @_;
-       die "Toplevel is not a cons: $sexp\n " unless consp($sexp);
-       my $type = $sexp->car;
-       my $addr = $sexp->cdr;
+       my ($self, $sexp, $location) = @_;
+       die 'Toplevel is not a list: ', Dumper($sexp), "\n" unless ref $sexp eq 'ARRAY';
+       my ($type, @addrs) = @$sexp;
+       my $addr;
+
+       die 'Type of toplevel is not atom: '. Dumper($type), "\n" unless scalarp($type);
+
+       if (@addrs > 1) {
+               $addr = $self->{freeptr} + 1;
+               $self->{freeptr} += @addrs;
+               $self->process($addrs[$_], $addr + $_) for 0 .. $#addrs;
+       } else {
+               $addr = $addrs[0];
+       }
+
+       $addr = $self->process($addr) if ref $addr eq 'ARRAY';
+       die 'Addr of toplevel is not atom: ', Dumper($addr), "\n" unless scalarp($addr);
 
-       die "Type of toplevel is not atom: $type\n" unless scalarp($type);
-       $addr = $self->process($addr) if consp($addr);
-       die "Addr of toplevel is not atom: $addr\n" unless scalarp($addr);
+       unless (looks_like_number $addr) { # is symbol
+               unless (exists $self->{symbols}{$addr}) {
+                       $self->{symbols}{$addr} = $self->{nsymbols};
+                       $self->{nsymbols}++;
+               }
+               $addr = $self->{symbols}{$addr}
+       }
 
-       die "Computed addr is not a number: $addr\n" unless looks_like_number $addr;
+       die 'Computed addr is not a number: ', Dumper($addr), "\n" unless looks_like_number $addr;
 
        if (ref $type eq 'Data::SExpression::Symbol') {
                die "No such type: $type\n" unless exists $TYPES{$type};
@@ -50,14 +78,17 @@ sub process {
        die "Type too large: $type\n" unless $type < (1 << $self->{type_bits});
        die "Addr too large: $addr\n" unless $addr < (1 << $self->{addr_bits});
        my $result = ($type << $self->{addr_bits}) + $addr;
-       $self->{freeptr}++;
-       $self->{memory}[$self->{freeptr}] = $result;
-       $self->{freeptr}
+       unless ($location) {
+               $self->{freeptr}++;
+               $location = $self->{freeptr}
+       }
+       $self->{memory}[$location] = $result;
+       $location
 }
 
 sub parse {
        my ($self, $string) = @_;
-       my $ds = Data::SExpression->new({symbol_case => 'up', use_symbol_class => 1, fold_lists => 0});
+       my $ds = Data::SExpression->new({symbol_case => 'up', use_symbol_class => 1, fold_lists => 1});
 
        my $sexp;
        while () {
@@ -80,6 +111,9 @@ sub new {
        $args{addr_bits} //= 8;
        $args{freeptr} //= 6;
        $args{memory} //= [0, 0, (1<<$args{addr_bits}), (1<<$args{addr_bits}), 0, 0, 0];
+       $args{symbols}{NIL} = 0;
+       $args{symbols}{T} = 1;
+       $args{nsymbols} = 2;
        bless \%args, $class
 }