Skip to content
Permalink
Branch: master
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
executable file 423 lines (342 sloc) 10.9 KB
#!/usr/bin/perl -w
use utf8;
# Modern Perl
use strict;
use warnings;
sub say { print "$_\n" for @_; }
use Getopt::Long;
# Command line options
my $help;
my $verbose;
my $debug;
my $obj_out = "";
my $raw;
my $pc;
GetOptions(
'help|h' => \$help,
'obj|o=s' => \$obj_out,
'verbose|v' => \$verbose,
'debug' => \$debug,
'raw|r' => \$raw,
'pc|p=s' => \$pc,
);
if ($obj_out && scalar @ARGV != 2) {
say "Object output requires two files\!";
}
if ($help || !scalar @ARGV || (!$debug && !$verbose && !$raw && !$obj_out)) {
my ($name) = $0 =~ /([^\/]+$)/;
say "Simple assembler";
say " usage:";
say " $name [option]... [file]...";
say " options:";
say " -h --help Show this screen.";
say " -o --obj=FILE Generate binary file output.";
say " Must specify two files.";
say " -v --verbose Verbose output signals in a human readable format.";
say " -r --raw Outputs raw binary data.";
say " -p --pc Specify PC for 2nd program, in hex.";
exit;
}
our %labels;
our %constants;
# Evaluate an operator statement, like val*2+1
sub evaluate {
my ($def, $linenum) = @_;
my @pieces = split /[-+*\/]/, $def;
say "Evaluating: $def" if $debug;
for my $piece (@pieces) {
# Remove whitespace
$piece = trim ($piece);
# Remove parenthesis
$piece =~ /^\(*(.*?)\)*$/;
$piece = $1;
# Ignore empty and all numbers
next if $piece =~ /^\d*$/;
# Read a label
if ($piece =~ /^([A-Z0-9]{0,8})[A-Z0-9]*$/i) {
my $label = $1;
if (exists $labels{$label}) {
# Addresses to labels are relative to the line of code
my $relative = $labels{$label} - $linenum;
# Surround negative values with parenthesis
$relative = "($relative)" if $relative < 0;
$def =~ s/$piece/$relative/;
}
elsif (exists $constants{$label}) {
# Substitute the label with it's value
$def =~ s/$piece/$constants{$label}/;
}
else {
die "Compile error, no label '$label' in scope.";
}
}
else {
die "Syntax error, label expected ner '$piece'";
}
}
say "eval '$def'" if $debug;
my $value = eval $def;
die "Error: Malformed operator '$def' $@" if $@;
return $value;
}
my $out;
if ($obj_out) {
open $out, '>', $obj_out or die "Couldn't open file $obj_out $!";
binmode $out;
my ($p1, $p2) = @ARGV;
parse ($p1);
if ($pc) {
$pc = hex $pc;
}
else {
# We have 8192 lines, PC1 will be at 0 so generate a random number
# between 100 and 8091
$pc = int(rand(7991)) + 100;
}
# Convert to bin and pad up to 16 bits
my $pc_bin = "000" . dec2bin ($pc, 13);
print $out pack ("B16", $pc_bin);
if ($raw) {
say $pc_bin;
}
elsif ($verbose) {
my $hex = bin2hex ($pc_bin);
say "\n$pc_bin " . join (" ", $hex =~ /../g) . " ; Player 2 PC\n";
}
parse ($p2);
}
else {
parse ($_) for @ARGV;
}
sub parse {
my ($src) = @_;
open my $in, '<', $src or die "Couldn't open file $src $!";
# Store line of code here when processing
my @code;
my $codeline = 0;
while (my $line = <$in>) {
chomp $line;
# Ignore empty lines
next if $line =~ /^\s*$/;
# Remove comments, will always match
my ($code, $comment) = $line =~ /^([^;]*);?(.*)/;
# Don't parse a full comment line
next if !$code;
# Match a constant
if ($code =~ /^
([A-Z0-9]{0,8}) # Label necessary
[A-Z0-9]* # Only catch first 8 chars
\s+
equ # Constant instr mnemonic
\s+
([-+*\/()A-Z0-9\s+]+) # Definition
/xi)
{
push (@code, $code);
}
# Match up a line of redcode
elsif ($code =~ /^(?:
([A-Z0-9]{0,8})? # Label, not necessary
[A-Z0-9]* # Only catch first 8 chars
\s+
)?
([A-Z0-9]+) # Mnemonic
(?:\.[A-Z0-9]+)? # Throw away postfix mod if there is any
\s+
([^,]+) # A operand
(?: # B op not mandatory
\s*,\s* # , delimited
([^,]+) # B operand
)?
/xi)
{
my ($label, $instr, $a_op, $b_op) = ($1, $2, $3, $4);
$b_op = "0" if !$b_op;
# Log label
if ($label) {
$labels{$label} = $codeline;
say "L: $label = $codeline" if $debug;
}
$codeline++;
push (@code, $code);
}
# Match end
elsif ($code =~ /^\s*end/i) {
last;
}
else {
die "Syntax error.";
}
}
my $bin_output = "";
# Print line numbers
my $codeline_bin = dec2bin ($codeline, 16);
if ($raw) {
say $codeline_bin;
}
elsif ($verbose) {
my $hex = bin2hex ($codeline_bin);
say "$codeline_bin " . join (" ", $hex =~ /../g) . " ; Number of rows ($codeline) $src\n";
say " pad OP A B pad A op pad B op";
}
# Start from -1 as we incr in the beginning
$codeline = -1;
for my $code (@code) {
# Match a constant
if ($code =~ /^
([A-Z0-9]{0,8}) # Label necessary
[A-Z0-9]* # Only catch first 8 chars
\s+
equ # Constant instr mnemonic
\s+
([-+*\/()A-Z0-9\s+]+) # Definition
/xi)
{
my ($label, $def) = ($1, $2);
# Evaluate
my $value = evaluate $def, $codeline;
# And insert
$constants{$label} = $value;
say "C: $label = $def ($value)" if $debug;
}
# Match up a line of redcode
elsif ($code =~ /^(?:
([A-Z0-9]{0,8})? # Label, not necessary
[A-Z0-9]* # Only catch first 8 chars
\s+
)?
([A-Z0-9]+) # Mnemonic
(?:\.[A-Z0-9]+)? # Throw away postfix mod if there is any
\s+
([^,]+) # A operand
(?: # B op not mandatory
\s*,\s* # , delimited
([^,]+) # B operand
)?
/xi)
{
my ($label, $instr, $a_op, $b_op) = ($1, $2, $3, $4);
$b_op = "0" if !$b_op;
$codeline++;
my %types = (
'#' => "01", # Immediate
'@' => "10", # Indirect
'<' => "11", # Pre-decrement indirect
);
# Default
my $a_mod = "00"; # Direct
my $b_mod = "00";
my $a_type = "";
my $b_type = "";
# Fetch adress modes
if ($a_op =~ /^([#@<])(.*)/) {
my ($op, $rest) = ($1, $2);
$a_mod = $types{$op};
$a_type = $op;
$a_op = $rest;
}
if ($b_op =~ /^([#@<])(.*)/) {
my ($op, $rest) = ($1, $2);
$b_mod = $types{$op};
$b_type = $op;
$b_op = $rest;
}
my $a_val = evaluate $a_op, $codeline;
my $b_val = evaluate $b_op, $codeline;
my $a_bin = dec2bin ($a_val, 13);
my $b_bin = dec2bin ($b_val, 13);
my %instr_codes = (
DAT => '0000',
MOV => '0001',
ADD => '0010',
SUB => '0011',
JMP => '0100',
JMZ=> '0101',
JMN => '0110',
CMP => '0111',
SLT => '1000',
DJN => '1001',
SPL => '1010',
);
if (!exists $instr_codes{uc($instr)}) {
say "Code: $code";
die "Instr '$instr' does not exist!";
}
my $instr_code = $instr_codes{uc($instr)};
my $op_bin = "00000000$instr_code$a_mod$b_mod";
my $a_op_bin = "000$a_bin";
my $b_op_bin = "000$b_bin";
# Output
if ($debug) {
say "I: $instr $a_mod $b_mod $a_val $b_val";
}
if ($raw) {
say "$op_bin$a_op_bin$b_op_bin";
}
elsif ($verbose) {
my $line = "$op_bin$a_op_bin$b_op_bin";
my $hex = bin2hex ($line);
# Pretty output, split binary into sections
# split up hex values into pairs and add code as comment
say "00000000 $instr_code $a_mod $b_mod 000 $a_bin 000 $b_bin " .
join (" ", ($hex =~ /../g)) .
" ; $instr $a_type $a_op($a_val) $b_type $b_op($b_val)";
}
$bin_output .= "$op_bin$a_op_bin$b_op_bin";
}
# Match end
elsif ($code =~ /^\s*end/) {
last;
}
else {
say "Couldn't match: $code";
die "Syntax error.";
}
}
if ($obj_out) {
# Output object values
print $out pack ("B16", $codeline_bin);
my $val = pack ("B" . 48 * ($codeline + 1), $bin_output);
print $out $val;
}
}
if ($obj_out) {
close $out;
my $size = (stat $obj_out)[7];
say "Wrote $size bytes to $obj_out";
}
sub trim {
my $string = shift;
$string =~ s/^\s+//;
$string =~ s/\s+$//;
return $string;
}
# With a specified length
sub dec2bin {
my ($dec, $l) = @_;
my $bin = unpack("B32", pack("N", $dec));
# Force to length
if (length($bin) < $l) {
$bin = '0' x ($l - length($bin)) . $bin;
}
elsif (length($bin) > $l) {
# Truncate from the back so 00 1111 1111 -> 1111 1111
$bin = substr $bin, -$l;
}
return $bin;
}
sub dec2hex {
my $d = shift;
my $h = sprintf ("%x", $d);
return $h;
}
sub hex2bin {
my $h = shift;
my $hlen = length($h);
my $blen = $hlen * 4;
return unpack("B$blen", pack("H$hlen", $h));
}
sub bin2hex {
my $b = shift;
return unpack("H*", pack("B*", $b));
}
You can’t perform that action at this time.