#!/usr/bin/env perl
# Copyright (c) 2005 Kanru Chen
#
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the "Software"),
# to deal in the Software without restriction, including without limitation
# the rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Software, and to permit persons to whom the
# Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included
# in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
# OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
# ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
# OTHER DEALINGS IN THE SOFTWARE.

use strict;

my @lineCache;
my %symtable;
my $line = 0;
my $loc = 0;
my $start = 0;
my $plength;
my %ins = (
	ADD => {code => 0x18, type => 3},
	ADDF => {code => 0x58, type => 3},
	ADDR => {code => 0x90, type => 2},
		AND => {code => 0x40, type => 3},
	CLEAR => {code => 0xB4, type => 2},
	COMP => {code => 0x28, type => 3},
	COMPF => {code => 0x88, type => 3},
	COMPR => {code => 0xA0, type => 2},
	DIV => {code => 0x24, type => 3},
	DIVF => {code => 0x64, type => 3},
	DIVR => {code => 0x9C, type => 2},
	FIX => {code => 0xC4, type => 1},
	FLOAT => {code => 0xC0, type => 1},
	HIO => {code => 0xF4, type => 1},
	J => {code => 0x3C, type => 3},
	JEQ => {code => 0x30, type => 3},
	JGT => {code => 0x34, type => 3},
	JLT => {code => 0x38, type => 3},
	JSUB => {code => 0x48, type => 3},
	LDA => {code => 0x00, type => 3},
	LDB => {code => 0x68, type => 3},
	LDCH => {code => 0x50, type => 3},
	LDF => {code => 0x70, type => 3},
	LDL => {code => 0x08, type => 3},
	LDS => {code => 0x6C, type => 3},
	LDT => {code => 0x74, type => 3},
	LDX => {code => 0x04, type => 3},
	LPS => {code => 0xD0, type => 3},
	MUL => {code => 0x20, type => 3},
	MULF => {code => 0x60, type => 3},
	MULR => {code => 0x98, type => 2},
	NORM => {code => 0xC8, type => 1},
		OR => {code => 0x44, type => 3},
	RD => {code => 0xD8, type => 3},
	RMO => {code => 0xAC, type => 2},
	RSUB => {code => 0x4C, type => 3},
	SHIFTL => {code => 0xA4, type => 2},
	SHIFTR => {code => 0xA8, type => 2},
	SIO => {code => 0xF0, type => 1},
	SSK => {code => 0xEC, type => 3},
	STA => {code => 0x0C, type => 3},
	STB => {code => 0x78, type => 3},
	STCH => {code => 0x54, type => 3},
	STF => {code => 0x80, type => 3},
	STI => {code => 0xD4, type => 3},
	STL => {code => 0x14, type => 3},
	STS => {code => 0x7C, type => 3},
	STSW => {code => 0xE8, type => 3},
	STT => {code => 0x84, type => 3},
	STX => {code => 0x10, type => 3},
	SUB => {code => 0x1C, type => 3},
	SUBR => {code => 0x94, type => 2},
	SVC => {code => 0xB0, type => 2},
	TD => {code => 0xE0, type => 3},
	TIO => {code => 0xF8, type => 1},
	TIX => {code => 0x2C, type => 3},
	TIXR => {code => 0xB8, type => 2},
	WD => {code => 0xDC, type => 3},
);

sub readline {
	$line++;
	chomp;
	return if /^\s*$/;
	return if /^\s*\./;
	m/(^\w*)\s+(.*)$/;
	my $label = $1;
	my $other = $2;
	&error("*** missing instruction ***\n") if !defined $other;
	my @st = split /\s+/, $other;
	if($other =~ /^.*c'(.*)'/) {
		$st[1] = "c'$1'";
	}
	return ($label, $st[0], $st[1]);
}

sub error {
	my $err = shift;
	print STDERR "At line $line\n";
	print STDERR "$err";
	exit 1;
}

sub pass1 {
	my $f = shift;
	while(<$f>) {
		my @st = &readline;
		if(@st) {
			if ($line == 1 && $st[1] eq "START") {
				# First line
				$loc = hex($st[2]);
				$start = $loc;
				push @lineCache, {loc => $loc, label => $st[0], opcode => $st[1], operand => defined $st[2] ? $st[2] : ""};
				next;
			}
			# Otherwise, record the line information.
			push @lineCache, {loc => $loc, label => $st[0], opcode => $st[1], operand => defined $st[2] ? $st[2] : ""};
			if ($st[0] ne "") {
				# If have label.
				if (defined $symtable{$st[0]}) {
					# Already defined this label.
					&error("*** duplicate symbol ***\nPrevious defined at line $symtable{$st[0]}{first}\n");
				} else {
					$symtable{$st[0]} = { loc => $loc, first => $line };
				}
			}
			last if $st[1] eq "END";
			if ($st[1] =~ s/\+(.*)/$1/) {
				# SIC/XE instruction
				# Format 4
				if (exists $ins{$st[1]} and $ins{$st[1]}{type} == 3) {
					$loc += 4;
				} else {
					&error("*** wrong type of opcode ***\n");
				}
			} elsif (exists $ins{$st[1]}) {
				$loc += $ins{$st[1]}{type};
			} elsif ($st[1] eq "WORD") {
				$loc += 3;
			} elsif ($st[1] eq "RESW") {
				&error("*** missing operand ***\n") if !defined $st[2];
				$loc += 3 * $st[2];
			} elsif ($st[1] eq "RESB") {
				&error("*** missing operand ***\n") if !defined $st[2];
				&error("*** operand need to be number ***\n")
				if !($st[2] =~ /^[0-9]+$/);
				$loc += $st[2];
			} elsif ($st[1] eq "BYTE") {
				&error("*** missing operand ***\n") if !defined $st[2];
				if ($st[2] =~ m/[xX]'(\w+)'/) {
					$loc += (length $1) % 2 == 0 ? (length $1) / 2 :
					&error("*** wrong byte number ***\n");
				} elsif ($st[2] =~ m/[cC]'(.*)'/) {
					$loc += length $1;
				} else {
					&error("*** unknow operand $st[2] ***\n");
				}
			} elsif ($st[1] eq "BASE") {
			} else {
				&error("*** unknow instruction ***\n");
			}
		}
	}
	$plength = $loc - $start;
}

sub dump {
	for my $k (sort {$symtable{$a}{loc} cmp $symtable{$b}{loc}} keys %symtable) {
		printf "%04X %s\n", $symtable{$k}{loc}, $k;
	}
	printf "%X\n", $loc;
}

sub dumpObj {
	my @record;
	my %text;
	my ($isindex, $indirect, $immediate, $base);
	$text{len} = 0;
	for my $s (@lineCache) {
		($isindex, $indirect, $immediate) = (0, 0, 0);
		$isindex = 1 if $s->{operand} =~ s/(.*?),[xX]/$1/;
		$indirect = 1 if $s->{operand} =~ s/@(.*)/$1/;
		$immediate = 1 if $s->{operand} =~ s/#(.*)/$1/;
		if ($s->{opcode} eq "START") {
			# First line.
			push @record, sprintf "H%-6s%06X%06X", $s->{label}, $start, $plength;
			next;
		}
		$text{loc} = sprintf ("T%06X", $s->{loc}) if $text{len} == 0;
		if ($s->{opcode} ne "END") {
			if ($s->{opcode} =~ s/\+(.*)/$1/) {
				# Format 4
				if (exists $ins{$s->{opcode}}) {
					my $addr = 0;
					my $code = $ins{$s->{opcode}}{code};
					if (exists $symtable{$s->{operand}}) {
						$addr = $symtable{$s->{operand}}{loc};
					} else {
						$addr = $s->{operand};
					}
					$addr |= 0x800000 if $isindex;
					$addr |= 0x100000; #Extended, format 4
					$code |= 0x03;
					$code ^= 0x01 if $indirect;
					$code ^= 0x02 if $immediate;
					$text{obj} .= sprintf "%02X%06X", $code, $addr;
					$text{len} += 4;
				}
			} elsif (exists $ins{$s->{opcode}} and $ins{$s->{opcode}}{type} == 1) {
				# Format 1
				$text{obj} .= sprintf "%02X", $ins{$s->{opcode}}{code};
				$text{len} += 1;
			} elsif (exists $ins{$s->{opcode}} and $ins{$s->{opcode}}{type} == 2) {
				# Format 2
				if ($s->{operand} =~ /([AXLBST])(,([AXLBST]))?/) {
					my %t = (A => 0, X => 1, L => 2, B => 3, S => 4, T => 5);
					my ($a, $b) = (0, 0);
					$a = $t{$1};
					$b = $t{$3} if defined $3;
					$text{obj} .= sprintf "%02X%X%X", $ins{$s->{opcode}}{code}, $a, $b;
					$text{len} += 2;
				} else {
					$line = "$s->{opcode} $s->{operand}";
					&error("*** Unsupported Register ***\n");
				}
			} elsif ($s->{opcode} eq "RSUB") {
				$text{obj} .= sprintf "%02X%04X", $ins{$s->{opcode}}{code} | 0x3, 0;
				$text{len} += 3;
			} elsif (exists $ins{$s->{opcode}}) {
				# Format 3
				my $mode = 0;
				my $addr = 0;
				my $code = $ins{$s->{opcode}}{code};
				if (exists $symtable{$s->{operand}}) {
					$addr = $symtable{$s->{operand}}{loc};
				} else {
					$addr = $s->{operand};
				}
				unless ($addr eq $s->{operand}) {
					my $pc = $addr - $s->{loc} - 3;
					if ($pc >= -2048 and $pc <= 2047) {
						$addr = $pc;
						$mode |= 0x2;
					} elsif ($base) {
						my $b = $addr - $base;
						if ($b >= 0) {
							$addr = $b;
							$mode |= 0x4;
						} else {
							$line = "$s->{opcode} $s->{operand}";
							&error("*** Please Use Format 4 Instead\n");
						}
					} else {
						$line = "$s->{opcode} $s->{operand}";
						&error("*** Please Use Format 4 Instead\n");
					}
				}
				$mode |= 0x8 if $isindex;
				$code |= 0x03;
				$code ^= 0x01 if $indirect;
				$code ^= 0x02 if $immediate;
				if ($addr < 0) {
					$addr = substr(sprintf("%X", $addr), 5);
				} else {
					$addr = sprintf("%03X", $addr);
				}
				$text{obj} .= sprintf "%02X%X%s", $code, $mode, $addr;
				$text{len} += 3;
			} elsif ($s->{opcode} eq "BYTE") {
				if ($s->{operand} =~ m/[xX]'(\w+)'/) {
					$text{obj} .= $1;
					$text{len} += (length $1) / 2;
				} elsif ($s->{operand} =~ m/[cC]'(.*)'/) {
					$text{len} += length $1;
					my @t = split //, $1;
					for my $ch (@t) {
						$text{obj} .= sprintf "%02X", ord($ch);
					}
				} 
			} elsif ($s->{opcode} eq "WORD") {
				$text{obj} .= sprintf "%06X", $s->{operand};
				$text{len} += 3;
			} elsif ($s->{opcode} =~ /(RESW|RESB)/) {
				push @record, sprintf "$text{loc}%02X$text{obj}", $text{len} if $text{len} != 0;
				$text{len} = 0;
				$text{obj} = "";
			} elsif ($s->{opcode} eq "BASE") {
				$base = $symtable{$s->{operand}}{loc};
			}
			if ($text{len} >= 30) {
				push @record, sprintf "$text{loc}%02X$text{obj}", $text{len};
				$text{len} = 0;
				$text{obj} = "";
			}
		} else {
			push @record, sprintf "$text{loc}%02X$text{obj}", $text{len} if $text{len} != 0;
			push @record, sprintf "E%06X", $symtable{$s->{operand}}{loc};
		}
	}
	for my $r (@record) {
		print "$r\n";
	}
}

sub main {
	my $file;
	if (defined $ARGV[0]) {
		$file = $ARGV[0];
	} else {
		$file = "SRCFILE";
	}
	open my $f, "<$file" or die "Can't open file $file: $!\n";

	&pass1($f);
	#&dump;
	&dumpObj;
}

&main;