#!/usr/bin/perl -w

# DLIFE assembler.
# By Richard W.M. Jones.
#
# $Id: dlife_asm.pl,v 1.1 2002/04/05 14:40:26 rich Exp $

use strict;

use Getopt::Long;

my $help;

GetOptions ("help|?" => \$help);

if ($help)
  {
    print STDERR "dlife_asm.pl [--help] file.dla [file.dla [...]]\n";
    exit 1;
  }

# Read input file(s) and assemble each one. Each input file has the
# form ``filename.dla'' and we will write a file called ``filename.dlo''.
foreach my $filename (@ARGV)
  {
    my $output = $filename . ".dlo";

    if ($filename =~ m/(.*)\.dla$/)
      {
	$output = $1 . ".dlo";
      }

    open FILE, "<$filename" or die "$filename: $!";
    open OUT, ">$output" or die "$output: $!";

    while (<FILE>)
      {
	# Remove terminating CRs and LFs.
	s/[\n\r]+//;

	# Ignore blank lines and comments.
	s/;.*$//;
	s/^[ \t]*$//;
	next if m/^$/;

	# Parse the instruction.
	parse_insn ($_);
      }

    close FILE;
    print OUT "\n";
    close OUT;
  }

sub parse_insn
  {
    my $insn = shift;

    # Trim leading and trailing whitespace.
    $insn =~ s/^[ \t]+//g;
    $insn =~ s/[ \t]+$//g;

    # Leading label?
    if ($insn =~ m/^([01]+):(.*)$/)
      {
	my $label = $1;
	my $rest = $2;

	foreach (split //, $label)
	  {
	    if (m/0/) { print OUT "00" }
	    if (m/1/) { print OUT "01" }
	  }

	parse_insn ($rest);
	return;
      }

    # IFZ instruction prefix?
    if ($insn =~ m/^IFZ[ \t]+(.*)$/i)
      {
	my $rest = $1;

	print OUT "07\n";

	parse_insn ($rest);
	return;
      }
    # Empty instruction?
    elsif ($insn =~ m/^$/)
      {
	return;
      }
    # Other instruction?
    elsif ($insn =~ m/^NOP0$/i)
      {
	print OUT "00\n";
      }
    elsif ($insn =~ m/^NOP1$/i)
      {
	print OUT "01\n";
      }
    elsif ($insn =~ m/^INC[ \t]+A$/i)
      {
	print OUT "02\n";
      }
    elsif ($insn =~ m/^DEC[ \t]+A$/i)
      {
	print OUT "03\n";
      }
    elsif ($insn =~ m/^SHL[ \t]+A$/i)
      {
	print OUT "04\n";
      }
    elsif ($insn =~ m/^FINDB[ \t](.*)$/i)
      {
	print OUT "08\n";
	parse_pattern ($1);
      }
    elsif ($insn =~ m/^FINDF[ \t](.*)$/i)
      {
	print OUT "09\n";
	parse_pattern ($1);
      }
    elsif ($insn =~ m/^MALLOC$/i)
      {
	print OUT "0A\n";
      }
    elsif ($insn =~ m/^DIVIDE$/i)
      {
	print OUT "0B\n";
      }
    elsif ($insn =~ m/^MOVE[ \t]+\[I\],A$/i)
      {
	print OUT "0C\n";
      }
    elsif ($insn =~ m/^MOVE[ \t]+A,\[I\]$/i)
      {
	print OUT "0D\n";
      }
    elsif ($insn =~ m/^DMOVE[ \t]+\[I\],A$/i)
      {
	print OUT "0E\n";
      }
    elsif ($insn =~ m/^DMOVE[ \t]+A,\[I\]$/i)
      {
	print OUT "0F\n";
      }
    elsif ($insn =~ m/^XOR[ \t]+([ABIP]),([ABIP])$/i)
      {
	my $reg1 = reg2bin ($1);
	my $reg2 = reg2bin ($2);

	printf OUT ("%02X\n", 16 + ($reg2 << 2) + $reg1);
      }
    elsif ($insn =~ m/^PUSH[ \t]+([ABIP])$/i)
      {
	my $reg = reg2bin ($1);

	printf OUT ("%02X\n", 32 + $reg);
      }
    elsif ($insn =~ m/^POP[ \t]+([ABIP])$/i)
      {
	my $reg = reg2bin ($1);

	printf OUT ("%02X\n", 36 + $reg);
      }
    # Instruction set macros.
    elsif ($insn =~ m/MOVE[ \t]+([ABIP]),([ABIP])$/i)
      {
	my $reg1 = reg2bin ($1);
	my $reg2 = reg2bin ($2);

	printf OUT ("%02X", 32 + $reg1); # PUSH reg1
	printf OUT ("%02X\n", 36 + $reg2); # POP reg2
      }
    elsif ($insn =~ m/SWAP[ \t]+([ABIP]),([ABIP])$/i)
      {
	my $reg1 = reg2bin ($1);
	my $reg2 = reg2bin ($2);

	printf OUT ("%02X", 16 + ($reg2 << 2) + $reg1); # XOR reg1, reg2
	printf OUT ("%02X", 16 + ($reg1 << 2) + $reg2); # XOR reg2, reg1
	printf OUT ("%02X", 16 + ($reg2 << 2) + $reg1); # XOR reg1, reg2
	printf OUT ("%02X\n", 16 + ($reg1 << 2) + $reg2); # XOR reg2, reg1
      }
    elsif ($insn =~ m/ZERO[ \t]+([ABIP])$/i)
      {
	my $reg = reg2bin ($1);

	printf OUT ("%02X\n", 16 + ($reg << 2) + $reg); # XOR reg, reg
      }
    elsif ($insn =~ m/ADD[ \t]+([0-9]+),A$/i)
      {
	my $n = $1;

	for (my $i = 0; $i < $n; ++$i)
	  {
	    print OUT "02";
	  }
	print OUT "\n";
      }
    elsif ($insn =~ m/MOVE[ \t]+([0-9]+),A$/i)
      {
	my $n = $1;

	print OUT "10";		# XOR A,A
	while ($n > 0)
	  {
	    if (($n & 1) == 1)
	      {
		print OUT "0402"; # SHL A; INC A
	      }
	    else
	      {
		print OUT "04"; # SHL A
	      }
	    $n >>= 1;
	  }
	print OUT "\n";
      }
    elsif ($insn =~ m/LOAD[ \t]+([0-9]+),A$/i)
      {
	my $n = $1;

	print OUT "222124";	# PUSH I; PUSH B; POP A
	for (my $i = 0; $i < $n * 2; ++$i)
	  {
	    print OUT "02";	# INC A
	  }
	print OUT "20260E26\n";	# PUSH A; POP I; DMOVE [I],A; POP I
      }
    elsif ($insn =~ m/STORE[ \t]+A,([0-9]+)$/i)
      {
	my $n = $1;

	print OUT "22202124";	# PUSH I; PUSH A; PUSH B; POP A
	for (my $i = 0; $i < $n * 2; ++$i)
	  {
	    print OUT "02";	# INC A
	  }
	print OUT "2026240F26\n"; # PUSH A; POP I; POP A; DMOVE A,[I]; POP I
      }
    elsif ($insn =~ m/^JMP[ \t]+I$/i)
      {
	print OUT "2227\n";	# PUSH I; POP P
      }
    elsif ($insn =~ m/^JMPF[ \t](.*)$/i)
      {
	print OUT "09";		# FINDF
	parse_pattern ($1);
	print OUT "2227\n";	# PUSH I; POP P
      }
    elsif ($insn =~ m/^JMPB[ \t](.*)$/i)
      {
	print OUT "08";		# FINDB
	parse_pattern ($1);
	print OUT "2227\n";	# PUSH I; POP P
      }
    elsif ($insn =~ m/^JMPZF[ \t](.*)$/i)
      {
	print OUT "09";		# FINDF
	parse_pattern ($1);
	print OUT "22072726\n";	# PUSH I; IFZ POP P; POP I
      }
    elsif ($insn =~ m/^JMPZB[ \t](.*)$/i)
      {
	print OUT "08";		# FINDB
	parse_pattern ($1);
	print OUT "22072726\n";	# PUSH I; IFZ POP P; POP I
      }
    elsif ($insn =~ m/^CALLF[ \t](.*)$/i)
      {
	print OUT "2309";	# PUSH P; FINDF
	parse_pattern ($1);
	print OUT "2227\n";	# PUSH I; POP P
      }
    elsif ($insn =~ m/^CALLB[ \t](.*)$/i)
      {
	print OUT "2308";	# PUSH P; FINDB
	parse_pattern ($1);
	print OUT "2227\n";	# PUSH I; POP P
      }
    elsif ($insn =~ m/^RET[ \t]+([0-9]+)$/i)
      {
	my $n = $1;
	print OUT "24";		# POP A
	for (my $i = 0; $i < $n + 3; ++$i)
	  {
	    print OUT "02";	# INC A
	  }
	print OUT "2027\n";	# PUSH A; POP P
      }
    elsif ($insn =~ m/^DB[ \t]+([0-9]+)$/i)
      {
	my $n = $1;
	for (my $i = 0; $i < $n; ++$i)
	  {
	    print OUT "FF";
	  }
	print OUT "\n";
      }
    elsif ($insn =~ m/^DW[ \t]+([0-9]+)$/i)
      {
	my $n = $1;
	for (my $i = 0; $i < $n * 2; ++$i)
	  {
	    print OUT "FF";
	  }
	print OUT "\n";
      }
    else
      {
	die "$insn: unknown instruction";
      }
  }

sub parse_pattern
  {
    my $pattern = shift;

    if ($pattern =~ m/^([01]+)$/)
      {
	foreach (split //, $1)
	  {
	    if (m/0/) { print OUT "00" }
	    if (m/1/) { print OUT "01" }
	  }
      }
    elsif ($pattern =~ m/^~([01]+)$/) # Complemented pattern.
      {
	foreach (split //, $1)
	  {
	    if (m/0/) { print OUT "01" }
	    if (m/1/) { print OUT "00" }
	  }
      }
    else
      {
	die "$pattern: unrecognized pattern argument";
      }
  }

sub reg2bin
  {
    my $reg = shift;

    if (uc($reg) eq "A") { return 0 }
    elsif (uc($reg) eq "B") { return 1 }
    elsif (uc($reg) eq "I") { return 2 }
    elsif (uc($reg) eq "P") { return 3 }
    else
      {
	die "$reg: unknown register name";
      }
  }