cas

#!/usr/bin/perl
#
# Assembler for Warren's crazy small CPU.
# (c) 2017 Warren Toomey, GPL3.
use strict;
use warnings;
use Data::Dumper;

use constant {
    RAMwrite => 0x8000,    # Active low
    Asel     => 0x4000,
    Bload    => 0x2000,    # Active low
    Aload    => 0x1000,    # Active low
    PCincr   => 0x0800,
    ALUdadd  => 0x0000,
    ALUdsub  => 0x0100,
    ALUand   => 0x0200,
    ALUor    => 0x0300,
    ALUxor   => 0x0400,
    ALUinca  => 0x0500,
    ALUbflags => 0x0600,
    ALUzero  => 0x0700,
    ALUadd   => 0x4000,	   # We borrow Asel for the upper ALU ops
    ALUsub   => 0x4100,
    ALUpassa => 0x4200,
    ALUpassb => 0x4300,
    ALUmullo => 0x4400,
    ALUmulhi => 0x4500,
    ALUdiv   => 0x4600,
    ALUmod   => 0x4700,
};

my $debug   = 0;           # Print debugging information
my $linenum = 0;           # Line number being parsed
my $PC      = 0;           # Program counter
my $nopcode = PCincr;      # NOP control lines
my @ROM;                   # Storage for final machine code
my @Line;		   # Array of whole lines from input file
my @Linenum;		   # Line number for each line in @Line

# Some control lines are active low. Set an initial bitfield
# with these lines high. Then flip all the active lines
my $offlines = RAMwrite + Aload + Bload;

# Hash of instructions and their control lines
my %Inst = (
    LCA   => PCincr + Aload,                          # Load constant into A
    LCB   => PCincr + Bload,                          # Load constant into B
    LMA   => PCincr + Aload + Asel,                   # Load B from RAM
    LMB   => PCincr + Bload + Asel,                   # Load B from RAM
    ADDM  => PCincr + ALUadd + RAMwrite,              # Store A + B into RAM
					# Store A + B into RAM and also into A
    ADDMA => PCincr + ALUadd + RAMwrite + Aload,
					# Store A + B into RAM and also into B
    ADDMB => PCincr + ALUadd + RAMwrite + Bload,
    SUBM  => PCincr + ALUsub + RAMwrite,              # Store A - B into RAM
    ANDM  => PCincr + ALUand + RAMwrite,              # Store A & B into RAM
    ORM   => PCincr + ALUor + RAMwrite,               # Store A | B into RAM
    XORM  => PCincr + ALUxor + RAMwrite,              # Store A ^ B into RAM
    DADDM => PCincr + ALUdadd + RAMwrite,             # BCD   A + B into RAM
    DSUBM => PCincr + ALUdsub + RAMwrite,             # BCD   A - B into RAM
    ZEROM => PCincr + ALUzero + RAMwrite,             # Store zero into RAM
    LMULM => PCincr + ALUmullo + RAMwrite,            # Store A * B (low nibble) into RAM
    HMULM => PCincr + ALUmulhi + RAMwrite,            # Store A * B (hi nibble) into RAM
    DIVM =>  PCincr + ALUdiv + RAMwrite,              # Store A / B into RAM
    MODM =>  PCincr + ALUmod + RAMwrite,              # Store A % B into RAM
    SMA   => PCincr + ALUpassa + RAMwrite,            # Store A into RAM
    SMIA  => PCincr + ALUinca + RAMwrite,             # Store A + 1 into RAM
    CLC   => PCincr + ALUzero + RAMwrite,             # Clear carry
    SMB   => PCincr + ALUpassb + RAMwrite,            # Store B into RAM
    TAB   => PCincr + ALUpassa + RAMwrite + Bload,    # Transfer A to B
    TBA   => PCincr + ALUpassb + RAMwrite + Aload,    # Transfer B to B
    NOP   => PCincr,                                  # No operation
    DBG	  => PCincr + ALUdsub,			      # NOP, print debug info in csim
    BRK	  => PCincr + ALUand,			      # NOP, break to single step in csim
    DMP	  => PCincr + ALUor,			      # NOP, dump RAM in csim
    EQU   => PCincr,                                  # Treated as NOP
			        # Display A and B, load A & B with constant
    DAB   => PCincr + Aload + Bload,                 
          			# Display A and B, load A & B from memory
    DMAB   => PCincr + Aload + Bload + Asel,
    TBF   => PCincr + ALUbflags + RAMwrite,	      # Copy B to flags
    JMP   => 0,                                       # Jump always
    JNS   => 0,                                       # Jump if N set
    JZS   => 0,                                       # Jump if Z set
    JVS   => 0,                                       # Jump if V set
    JCS   => 0,                                       # Jump if C set
    JNC   => 0,                                       # Jump if N clear
    JZC   => 0,                                       # Jump if Z clear
    JVC   => 0,                                       # Jump if V clear
    JCC   => 0,                                       # Jump if C clear
    JEQ   => 0,                                       # Jump if equal to zero
    JNE   => 0,                                       # Jump if not equal to 0
    JLT   => 0,                                       # Jump if less than zero
    JGT   => 0,                                       # Jump if greater than 0
    JLE   => 0,                                       # Jump if <= zero
    JGE   => 0,                                       # Jump if >= zero
);

# Hash of jump instructions and the NZVC combinations on which to jump
my %JCond = (
    JZS => [ 0x4, 0x5, 0x6, 0x7, 0xc, 0xd, 0xe, 0xf ],
    JEQ => [ 0x4, 0x5, 0x6, 0x7, 0xc, 0xd, 0xe, 0xf ],
    JVS => [ 0x2, 0x3, 0x6, 0x7, 0xa, 0xb, 0xe, 0xf ],
    JCS => [ 0x1, 0x3, 0x5, 0x7, 0x9, 0xb, 0xd, 0xf ],
    JLE => [ 0x4, 0x5, 0x6, 0x7, 0x8, 0x9, 0xa, 0xb, 0xc, 0xd, 0xe, 0xf ],
    JLT => [ 0x8, 0x9, 0xa, 0xb, 0xc, 0xd, 0xe, 0xf ],
    JNS => [ 0x8, 0x9, 0xa, 0xb, 0xc, 0xd, 0xe, 0xf ],
    JGT => [ 0x0, 0x1, 0x2, 0x3 ],
    JGE => [ 0x0, 0x1, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7 ],
    JNC => [ 0x0, 0x1, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7 ],
    JZC => [ 0x0, 0x1, 0x2, 0x3, 0x8, 0x9, 0xa, 0xb ],
    JVC => [ 0x0, 0x1, 0x4, 0x5, 0x8, 0x9, 0xc, 0xd ],
    JNE => [ 0x0, 0x1, 0x2, 0x3, 0x8, 0x9, 0xa, 0xb ],
    JCC => [ 0x0, 0x2, 0x4, 0x6, 0x8, 0xa, 0xc, 0xe ]
);

# Hash of labels
my %Label;

# List of NZVC values that match each NZVC string
my %NZVC_List;


#### FUNCTIONS ####

# Generate the values for the %NZVC_List
sub generate_nzvc_values
{
  # Yes this is hideously slow code. Is there a better way?
  my @Nlist; my @Zlist; my @Vlist; my @Clist;

  for ( my $nzvcvalue = 0 ; $nzvcvalue <= 0xf ; $nzvcvalue ++ ) {
    if ($nzvcvalue & 0x8) { @Nlist= ('N', ''); } else { @Nlist= ('n', ''); }
    if ($nzvcvalue & 0x4) { @Zlist= ('Z', ''); } else { @Zlist= ('z', ''); }
    if ($nzvcvalue & 0x2) { @Vlist= ('V', ''); } else { @Vlist= ('v', ''); }
    if ($nzvcvalue & 0x1) { @Clist= ('C', ''); } else { @Clist= ('c', ''); }

    foreach my $n (@Nlist) {
      foreach my $z (@Zlist) {
        foreach my $v (@Vlist) {
          foreach my $c (@Clist) {
	    my $nzvcstring= $n . $z . $v . $c;
	    push(@{ $NZVC_List{$nzvcstring} }, $nzvcvalue);
	  }
	}
      }
    }
  }

# Debug: print them all out
#  foreach my $s (sort(keys(%NZVC_List))) {
#    print("$s:");
#    foreach my $val (@{ $NZVC_List{$s} }) {
#      printf(" %x", $val);
#    }
#    print("\n");
#  }
}

# Given a label or a non-string literal, return its value.
# Allows decimal, octal if leading 0, hex if leading 0x.
# Allows ~ as first character to invert.
# Allows - as first character to negate.
# Returns an 8-bit positive value or a 4-bit negative value.
sub getValue {
    my $arg = $_[0];
    die("null argument in getValue\n") if ( !defined($arg) );

    # Label
    return($Label{$arg}) if ( defined( $Label{$arg} ) );

    my ($negate, $invert, $value)= (0,0,0);

    # Find any leading ~ or -character
    my $lookforleadchar=1;
    while ($lookforleadchar) {
      if ($arg =~ m{^\~(.*)}) { $invert=1; $lookforleadchar=1; $arg= $1; next; }
      if ($arg =~ m{^\-(.*)}) { $negate=1; $lookforleadchar=1; $arg= $1; next; }
      $lookforleadchar=0;
    }

    # Otherwise some form of literal
    if ( $arg =~ m{^0x?[0-9A-Fa-f]+$} ) {
      # Octal or hexadecimal number
      $value= oct($arg);
    } elsif ( $arg =~ m{^\d+$} ) {
      # Decimal number
      $value= $arg;
    } elsif ( $arg =~ m{^'(.)'} ) {
      # Literal character
      $value= ord($1);
    } else {
      die("Unrecognised literal or label: $_[0]\n");
    }

    $value= -$value if ($negate);
    $value= 0xff ^ $value if ($invert);
    return( ($value < 0) ? $value & 0xf : $value & 0xff );
}

# Given a line, return an array of information. The first element is the
# label on the line, or undef. All remaining elements are array references
# to instructions. Each instruction has an opcode, an optional operand and
# an optional set of flags. Any missing optional item is undef if not present.
#
# Line format is an optional label with a colon, whitespace. and then one
# or more instructions. Instructions are separated by vertical vars, which
# may have whitespace on either side. Each instruction is one or more words
# separated by whitespace. Words are flags (optional), opcode, operand (optional).
sub parse_line {
    my $line = shift;
    my $label;
    my @return_list;

    # Find and remove the label
    if ( $line =~ m{^(\S+):(.*)} ) {
        $label = $1; $line  = $2;
    }

    # Save the label
    push( @return_list, $label );

    # Find all the instructions
    foreach my $instruction ( split( m{\|}, $line ) ) {

        # Trim leading and trailing whitespace
        $instruction =~ s{^\s+}{};
        $instruction =~ s{\s+$}{};
        my $flags;

        # Split the instruction into three words
        my (@wordlist) = split( m{\s+}, $instruction, 3 );

        # If first word has the flags format, remove it
        if ( $wordlist[0] =~ m{^[NZVCnzvc]+$} ) {
            $flags = shift(@wordlist);
        }

        # Get the opcode and operand
        my ( $opcode, $operand ) = @wordlist;

        # Error check
        die("Missing opcode on line $linenum\n") if ( !defined($opcode) );
        die("Unknown opcode $opcode on line $linenum\n")
          if ( !defined( $Inst{$opcode} ) );

        # Push the parsed instruction
        push( @return_list, [ $flags, $opcode, $operand ] );
    }
    return (@return_list);
}

# Given an array of arrayrefs representing the instructions
# at this PC position, parse it and fill in the ROM values
sub parse_instruction {

  # Fill all 16 instructions with NOPs, in case the only
  # instruction is a conditional jump instruction
  foreach my $nzvc (0 .. 0xf) {
      $ROM[ ($nzvc << 8) + $PC ] = $offlines ^ $nopcode;
  }

  my $position= -1;			# It is incremented immediately below
  foreach my $instruction (@_) {	# Deal with each instruction at this PC
    $position++;

    # Break into the flags, the opcode and the address
    my ( $flags, $op, $addr ) = @{$instruction};

    # If no address, assume 255 as a temp location
    $addr = 255 if ( !defined($addr) );

    # Get the 16-bit value to place into the ROM
    my $addrval = getValue($addr);
    my $romval  = $Inst{$op} + $addrval;

    if ($debug) {
      if ($position) { print(", "); } else { print("\t"); }
      printf("%s %s %3s %04x", $flags || "", $op, $addr, $offlines ^ $romval );
    }
    if ( $debug == 2 ) {
        my $ramwrite = ( ( $romval & RAMwrite ) == RAMwrite ) ? 1 : 0;
        print("\t");
        print("RAMwrite ") if ($ramwrite);
        print("Asel ")     if ( ( $romval & Asel ) == Asel );
        print("Bload ")    if ( ( $romval & Bload ) == Bload );
        print("Aload ")    if ( ( $romval & Aload ) == Aload );
        print("ALUdadd ")  if ( $ramwrite && ( $romval & 0x4700 ) == ALUdadd );
        print("ALUdsub ")  if ( $ramwrite && ( $romval & 0x4700 ) == ALUdsub );
        print("ALUand ")   if ( $ramwrite && ( $romval & 0x4700 ) == ALUand );
        print("ALUor ")    if ( $ramwrite && ( $romval & 0x4700 ) == ALUor );
        print("ALUxor ")   if ( $ramwrite && ( $romval & 0x4700 ) == ALUxor );
        print("ALUinca ")  if ( $ramwrite && ( $romval & 0x4700 ) == ALUinca );
        print("ALUbflags ")  if ( $ramwrite && ($romval & 0x4700 )== ALUbflags);
        print("ALUzero ")  if ( $ramwrite && ( $romval & 0x4700 ) == ALUzero );
        print("ALUpassa ") if ( $ramwrite && ( $romval & 0x4700 ) == ALUpassa );
        print("ALUpassb ") if ( $ramwrite && ( $romval & 0x4700 ) == ALUpassb );
        print("ALUadd ")   if ( $ramwrite && ( $romval & 0x4700 ) == ALUadd );
        print("ALUsub ")   if ( $ramwrite && ( $romval & 0x4700 ) == ALUsub );
        print("ALUmullo ")   if ( $ramwrite && ( $romval & 0x4700 )== ALUmullo);
        print("ALUmulhi ")   if ( $ramwrite && ( $romval & 0x4700 )== ALUmulhi);
        print("ALUdiv ")   if ( $ramwrite && ( $romval & 0x4700 ) == ALUdiv );
        print("ALUmod ")   if ( $ramwrite && ( $romval & 0x4700 ) == ALUmod );
    }

    # See if this is a conditional jump instruction. If so,
    # only set the matching NZVC positions with the instruction
    if ( defined( $JCond{$op} )) {
      foreach my $nzvc (@{ $JCond{$op} }) {
#printf("PC %x posn $nzvc op $op $addr (cond)\n", $PC);
        $ROM[ ($nzvc << 8) + $PC ] = $offlines ^ $romval;
      }
      next;		# Don't process any positions now
    }

    # If we have flags, set the instruction in the matching NZVC positions
    if (defined($flags)) {
      # Check that the flags are legitimate
      die("unrecognised flags $flags on line $linenum\n")
					if ( !defined($NZVC_List{$flags}) );
      foreach my $nzvc (@{ $NZVC_List{$flags} }) {
#printf("PC %x posn $nzvc op $op $addr (flags $flags) %x\n", $PC, $romval);
        $ROM[ ($nzvc << 8) + $PC ] = $offlines ^ $romval;
      }
      next;		# Don't process any positions now
    }

    # Not a conditional instruction, so it must be a positional.
    # For any position >0, just do one instruction position
    if ($position) {
#printf("PC %x posn $position op $op $addr\n", $PC);
        $ROM[ ($position << 8) + $PC ] = $offlines ^ $romval;
	next;
    }

    # Otherwise, fill all 16 instruction positions
    foreach my $nzvc (0 .. 0xf) {
        $ROM[ ($nzvc << 8) + $PC ] = $offlines ^ $romval;
#printf("PC %x posn $nzvc op $op $addr (default) %x\n", $PC, $romval);
    }
  }
}

#### MAIN PROGRAM ####

# Enable debugging
while ( ( @ARGV >= 1 ) && ( $ARGV[0] ) eq "-d" ) {
    $debug++; shift(@ARGV);
}

# Give usage
die("Usage: $0 [-d] infile\n") if ( @ARGV != 1 );

# Generate the NZVC string to values list
generate_nzvc_values();

# Read in the instructions
my $l="";			# Input line, accumulates continuing lines
$linenum=0;
open( my $IN, "<", $ARGV[0] ) || die("Cannot read $ARGV[0]: $!\n");
while (<$IN>) {
    chomp; $linenum++;
    s{#.*}{};     		# Lose comments
    s{^\s+}{};    		# Lose leading whitespace
    s{\s+$}{};    		# Lose trailing whitespace
    $l= $l . $_;		# Append to any continuing line
    next if ($l=~ m{^$});    	# Ignore empty lines
    if ($l=~ m{^(.*)\\$}) {	# If line ends with a \
      $l= $1; next;		# trim it off and loop back now
    }
    push( @Line, $l );  	# Save the completed line and its line number
    push( @Linenum, $linenum );
    $l=""; 			# Reset for next line
}
close($IN);

# First pass: find the labels
$PC      = 0;
foreach my $i (0 .. (@Line - 1)) {
    my $line= $Line[$i];
    $linenum= $Linenum[$i];
    my ( $label, @instlist ) = parse_line($line);

    # Get reference to the first instruction on the line
    my $inst1 = $instlist[0];

    # Save location of label
    if ($label) {

        # An EQU defines the value of this label
        if ( defined($inst1) && ( $inst1->[1] eq "EQU" ) ) {
            $Label{$label} = getValue($inst1->[2]); next;
        }

        # Otherwise the label's value is the PC's value
        $Label{$label} = $PC;

        # Don't increment the PC if there was no instruction
        next if ( !defined($inst1) );
    }
    $PC++;
    die("Out of instruction space!\n") if ($PC > 0x100);
}

#print Dumper(\%Label);

# Second pass: assemble
$PC      = 0;
foreach my $i (0 .. (@Line - 1)) {
    my $line= $Line[$i];
    $linenum= $Linenum[$i];

    # Get the instructions on this line
    my ( $label, @instlist ) = parse_line($line);

    # Get reference to the first instruction
    my $inst1 = $instlist[0];

    # Skip the line if there is no operand or if the operand is EQU
    next if ( !defined($inst1) );
    next if ( $inst1->[1] eq "EQU" );

    printf("%02x:", $PC) if ($debug);

    # Parse each instruction on the line
    parse_instruction(@instlist);

    $PC++;
    print("\n") if ($debug);
}

# Write out the ROMs
open( my $OUT, ">", "botrom.rom" ) || die("Can't write to botrom.rom: $!\n");
print( $OUT "v2.0 raw\n" );
for my $i ( 0 .. ( 2**12 - 1 ) ) {
    my $val = $ROM[$i] ? $ROM[$i] & 0xff : 0;
    printf( $OUT "%02x ", $val );
    print( $OUT "\n" ) if ( ( $i % 16 ) == 15 );
    print( $OUT " " )  if ( ( $i % 16 ) == 7 );
}
close($OUT);

open( $OUT, ">", "toprom.rom" ) || die("Can't write to toprom.rom: $!\n");
print( $OUT "v2.0 raw\n" );
for my $i ( 0 .. ( 2**12 - 1 ) ) {
    my $val = $ROM[$i] ? $ROM[$i] >> 8 : 0;
    printf( $OUT "%02x ", $val );
    print( $OUT "\n" ) if ( ( $i % 16 ) == 15 );
    print( $OUT " " )  if ( ( $i % 16 ) == 7 );
}

# Create an image for real ROMs
open( $OUT, ">", "botrom.img" ) || die("Can't write to botrom.img: $!\n");
for my $i ( 0 .. ( 2**13 - 1 ) ) {
    my $val = $ROM[$i] ? $ROM[$i] & 0xff : 0;
    my $c = pack( 'C', $val );
    print( $OUT $c );
}
close($OUT);

open( $OUT, ">", "toprom.img" ) || die("Can't write to toprom.img: $!\n");
for my $i ( 0 .. ( 2**13 - 1 ) ) {
    my $val = $ROM[$i] ? $ROM[$i] >> 8 : 0;
    my $c = pack( 'C', $val );
    print( $OUT $c );
}
close($OUT);

exit(0);