X-Git-Url: http://git.ieval.ro/?a=blobdiff_plain;f=lib%2FApp%2FScheme79asm.pm;h=c971c2cd2930905b25f284aef796d6934a135b6c;hb=34073a4a81787bd2934f5a82ab6ef7ed261c9451;hp=ec0ada330f9acad8b5fbff73e2b538bf8bca1de6;hpb=509643aa72045d0554141ef9f133788a6eee61e4;p=app-scheme79asm.git

diff --git a/lib/App/Scheme79asm.pm b/lib/App/Scheme79asm.pm
index ec0ada3..c971c2c 100644
--- 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,62 @@ 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];
+	}
 
-	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);
+	$addr = $self->process($addr) if ref $addr eq 'ARRAY';
+	die 'Addr of toplevel is not atom: ', Dumper($addr), "\n" unless scalarp($addr);
 
-	die "Computed addr is not a number: $addr\n" unless looks_like_number $addr;
+	my ($comment_type, $comment_addr) = ($type, $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: ', 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 +80,18 @@ 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;
+	$self->{comment}[$location] = "$comment_type $comment_addr";
+	$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 () {
@@ -70,6 +104,7 @@ sub parse {
 sub finish {
 	my ($self) = @_;
 	$self->{memory}[5] = $self->{memory}[$self->{freeptr}];
+	$self->{comment}[5] = $self->{comment}[$self->{freeptr}];
 	$self->{memory}[4] = $self->{freeptr};
 	delete $self->{memory}[$self->{freeptr}]
 }
@@ -80,6 +115,10 @@ 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;
+	$args{comment} = ['(cdr part of NIL)', '(car part of NIL)', '(cdr part of T)', '(car part of T)', '(free storage pointer)', '', '(result of computation)'];
 	bless \%args, $class
 }
 
@@ -88,14 +127,19 @@ sub print {
 	$fh //= \*STDOUT;
 
 	my $bits = $self->{type_bits} + $self->{addr_bits};
+	my $index_length = length $#{$self->{memory}};
+	my $index_format = '%' . $index_length . 'd';
 	for my $index (0 .. $#{$self->{memory}}) {
 		my $val = $self->{memory}[$index];
+		my $comment = $self->{comment}[$index];
 		if ($index == 4) {
 			$val = "${bits}'d$val"
 		} else {
 			$val = $val ? sprintf "%d'b%0${bits}b", $bits, $val : '0';
 		}
-		say $fh "mem[$index] <= $val;"
+		my $spaces = ' ' x ($bits + 5 - (length $val));
+		$index = sprintf $index_format, $index;
+		say $fh "mem[$index] <= $val;$spaces // $comment"
 	}
 }