#!/usr/bin/perl
# This is just another little language for Parrot
# urmc - 2003 (c) by Marcus Thiesen
# <marcus@cpan.org>
# This code is under the GPL

## See if we can do pasm:

use warnings;
use strict;

use Getopt::Long;
use FindBin;
use lib "$FindBin::RealBin/../../lib";
use Parrot::Config;
use Time::HiRes qw(time);

use vars qw($filename
	    $compile
	    $opti
	    $silent);

$opti = 1; # more a debug flag

my $parrot = "$FindBin::RealBin$PConfig{slash}..$PConfig{slash}..$PConfig{slash}parrot$PConfig{exe}";

sub filename {
    my $arg = shift;
    if (-e $arg) {
	$filename = $arg;
    }
}

GetOptions("compile"    => \$compile,
	   "silent"     => \$silent,
	   "<>"         => \&filename
	   );

my $version = "0.3";
my @pasm =
    ("## Compiled by urmc $version\n",
     "## 2003 (c) by Marcus Thiesen\n",
     "## <marcus\@cpan.org> \n\n",
     "_MAIN:\n",
     "\tgetstdin P0 #filehandle to STDIN\n",
     );

my $lp = qr/\s*(\d+)\s*\:/; #line prefix (1:)
my (%lines, %jtarget);      # tcount lines and jump targets
my $out;                    # save the output registers name

my @source;
if ($filename) {
    open SOURCE, $filename or die "Can't get sourcefile $filename :$!\n";
    @source = <SOURCE>;
    close SOURCE; ### if gnu would hear that... :-)
} else {
    die "$0 <file>\n"
}

sub warning{
    return if $silent;
    my ($warning, $linenr) = @_;
    print STDERR "WARNING: $warning is not standard URM at line $linenr\n";
}

### memory managment:

my $stackcount = 0;
my %look_tbl;
my %reg_tbl;
my %lra_tbl;

for my $i (0..31) { $reg_tbl{$i} = 0; }

# for debugging purposes
sub dump_tables{
    print "\$stackcount:\t $stackcount\n";

    print "reg_tbl:\n";
    map { print "$_\t => $reg_tbl{$_}\n"} sort { $a <=> $b } keys %reg_tbl;

    print "look_tbl:\n";
    map { print "$_\t => $look_tbl{$_}\n"} sort { $a <=> $b } keys %look_tbl;

    print "lra_tbl:\n";
}

sub mmu{
    my $name = shift;

    ## lookup the register
    if ((defined $look_tbl{$name}) &&
	($look_tbl{$name} =~ /^I(\d+)/)) {
	return $1;
    }

    ## if not on stack: get a free one
    foreach my $reg (sort {$a <=> $b} keys %reg_tbl) {
	unless ($reg_tbl{$reg}) {
	    $reg_tbl{$reg} = $name;
	    my $time = time();
	    $lra_tbl{$time} = $reg;
	    $look_tbl{$name} = "I$reg";
	    return $reg;
	}
    }

    ### no free registers left or on stack
    # on stack
    if (defined $look_tbl{$name}) {
	# get last recently allocated:
	my @times = sort { $a <=> $b } keys %lra_tbl;
	my $time = shift @times;

	my $old = $lra_tbl{"$time"};
	die "\$old undefined\n" unless defined $old;
	delete $lra_tbl{$time};
	# save register nr $old on stack
	push @pasm, "\tsave I$old\n";
	$look_tbl{$reg_tbl{$old}} = $stackcount;
	$reg_tbl{$old} = 0;
	$stackcount++;


	# get requested register from stack
	$stackcount--;
	my $nr_on_stack = ($stackcount - $look_tbl{$name}) - 1;
	my $rotate_more =  $stackcount - 1 - $nr_on_stack - 1;

	for my $i (0..$nr_on_stack) {
	    push @pasm,  "\trotate_up $stackcount\n";
	}
	push @pasm, "\trestore I$old\n";
	for my $i (0..$rotate_more) {
	    push @pasm,  "\trotate_up $stackcount\n";
	}


#	push @pasm, "\tlookback I$old, $nr_on_stack\n";

	$look_tbl{$name} = "I$old";
	$lra_tbl{time()} = $old;
	$reg_tbl{$old} = "$name";

	return $old;
    }

    # no free register left
    # free one and call yourself
    # get last recently allocated:
    my @times = sort { $a <=> $b } keys %lra_tbl;
    my $time = shift @times;
    my $old = $lra_tbl{"$time"};
    delete $lra_tbl{$time};
    # save register nr $old on stack
    push @pasm, "\tsave I$old\n";
    $look_tbl{$reg_tbl{$old}} = $stackcount;
    $reg_tbl{$old} = 0;
    $stackcount++;
    return mmu($name);
}

### The parser
foreach my $line (@source) {
    next unless defined $line;
    next if $line =~ /^\#/; #comments and spacy lines
    next if $line =~ /^\s+$/;
    $line =~ s/\#.+//; # stip in line comments;
    chomp $line;
    #parse in(r1,r2,...)
    if ($line =~ /\s*in\(/) {
	while ($line =~ /(r(\d+))/g) {
	    my $rn = "I" . (mmu $2);
	    push @pasm, "\t#get input for $1\n";
	    push @pasm, "\tprint \"$1: \"\n";
	    push @pasm, "\treadline S0, P0\n";
	    push @pasm, "\tset $rn, S0\n";
	}
	next;
    }
    #parse out(r3)
    elsif ($line =~ /\s*out\(r(\d+)\)/) {
	$out = $1;
	next;
    }
    #parse 0: r3 <- 0
    elsif ($line =~ /$lp\s*r(\d+)\s*<-\s*(\d+)\s*$/o) {
	$lines{$1} = 1;
	if ($3 != 0) {
	    local $opti = 0;
	    warning("Assigning not 0 to a register", $1);
	}
	## parrot does the work for us....
	if ($opti <= 1) {
	push @pasm, "L$1:\n";
	push @pasm, "\tset I" . (mmu($2)) . ", $3\t\#$line\n";
	next;
        }
    }
    #parse 3: if r2 = 0 goto 7
    elsif ($line =~ /$lp\s*if\sr(\d+)\s*=\s*0\s*goto\s*(\d+)/o) {
	$lines{$1} = 1;
	push @pasm, "L$1:\n";
	push @pasm, "\teq I" . (mmu $2) . ", 0, L$3\t\#$line\n";
	$jtarget{$3} = 1;
	next;
    }
    elsif ($line =~ /^inline_pasm:/) {
	$line =~ s/^inline_pasm://;
	push @pasm, $line . "\n";
	next;
    }
    #parse 4: r2 <- r2 +|- 1
    elsif ($line =~
	   /$lp\s*r(\d+)\s*<-\s*r(\d+)\s*(\+|-)\s*(?:(r(\d+))|(\d+))/o ) {
	$lines{$1} = 1;
	if ($2 != $3) {
	    warning("Assigning one register to another", $1);
	}
	my $rn3;
	if (defined $6) {
	    warning("Assigning sum of two registers", $1);
	    $rn3 = "I" . (mmu $6);
	}
	elsif ((defined $6) && ($6 != 1)) {
	    warning("Adding more than one", $1);
	}

	push @pasm, "L$1:\n";
	my $rn1 = "I" . (mmu $2);
	my $rn2 = "I" . (mmu $3);
	$rn3 = 1 unless defined $rn3;
	if ($4 eq "+") {
	    push @pasm, "\tadd $rn1, $rn2, $rn3\t\#$line\n";
	} else {
	    push @pasm, "\tsub $rn1, $rn2, $rn3\t\#$line\n";
	}
	next;
    }
    #parse 5: goto 5
    elsif ($line =~ /$lp\s*goto\s*(\d+)/) {
	$lines{$1} = 1;
	push @pasm, "L$1:\n";
	push @pasm, "\tbranch L$2\t\#$line\n";
	$jtarget{$2} = 1;
	next;
    }
    else {
	die "SYNTAX ERROR:\n$line\nCan't parse line\n";
    }

}

my @newpasm;

## clean up the labels
if ($opti > 0) {
    for my $line (@pasm) {
	if ($line =~ /^L(\d+)/) {
	    push @newpasm, $line if exists $jtarget{$1};
	    next;
	}
	push @newpasm, $line;
    }
    @pasm = @newpasm;
}

if (scalar %jtarget) {
    foreach my $key (keys %jtarget) {
	next if exists $lines{$key};
	if (defined $out) {
	    $out = mmu($out);
	    push @pasm, "L$key:\n";
	    push @pasm, "\tprint I$out\n";
	    push @pasm, "\tprint \"\\n\"\n";
	}
	push @pasm, "\tend\n";
    }
} else {
    if (defined $out) {
	$out = mmu($out);
	push @pasm, "\tprint I$out\n";
	push @pasm, "\tprint \"\\n\"\n";
	push @pasm, "end\n";
    }
}

if ($compile) {
    $filename =~ s/\.urm/.pasm/;
    open OUT, ">$filename";
    print OUT @pasm;
    close OUT;
    } else {
	$filename = ".$$." . time() . ".pasm" ;
	open OUT, ">$filename";
	print OUT @pasm;
	close OUT;
	system ("$parrot $filename");
	unlink $filename;
}


