#! /usr/bin/perl

# Work out where various BCPL structures are in compiled code

# Needs list of globals and some initial locations (global table,
# some fixed routines).  Currently hardwired

#    1735    00F(       +2456   #00004630    LDX   0  2456 
#0123456789012345678901234567890123456789012345678901234567890

open GLOBALS, "zz-globals" or die;

# Location of global table, found by inspection of compiled code:

my $G1 = 1735;
my $LASTG = 0;

while (<GLOBALS>) {
	chomp;
	my ($g,$f,$d) = split;
	$G{$g} = $f;
	$LASTG = $g if $g > $LASTG;
}

$LASTG += $G1 - 1;

close GLOBALS;


# Guess that literals come after global table, before code

my $LITS = $LASTG + 1;
my $LITE = 8388607;


# Initial symbol table:

my %SYM = (16736 => "%BSAVE", 13861 => "%BKORE", 13849 => "%BSWITCHON",
	13841 => "%BFINISH", 16766 => "%BRETURN");

my $SYM = "L0000";
my $STR = "S0000";


# First pass through code, identify labels and so on

while (<STDIN>) {
	chomp;

	my $addr = substr($_,0,8) + 0;
	my $content = substr($_,17,11) + 0;
	my $op = substr($_,44,5);
	my $arg = substr($_,53,11);

	# Below the global table we find constant strings:

	if ($addr > 64 && $addr < $G1) {

		my $pos = tell STDIN;
	
		my ($val, $len, $a, $b) = chars ($content);
		my @data = ($val);

		# Validate string -- length must be good and all
		# characters must be valid ASCII

		$len = ord $len;
		goto fail unless $len;
		goto fail unless ascii ($a);
		my $string = $a;
		if (--$len) {
			goto fail unless ascii ($b);
			$string .= $b;
			--$len;
		}
		else {
			goto fail if ord $b;
		}

		while ($len) {
			my ($val, @c) = chars ();
			push @data, $val;
			my $i;
			for ($i = 0; $i < 3; ++$i) {
				goto fail unless ascii ($c[$i]);
				$string .= $c[$i];
				last unless --$len;
			}
			unless ($len) {
				for (++$i;$i < 3; ++$i) {
					goto fail if ord $c[$i];
				}
			}
		}

		# String looks good, save in symbol table

		my @lines;

		$SYM{$addr} = [ ++$STR, '"' . substr ($string, 0, 20) . '"', \@lines ] ;

		push @lines, sprintf "%-5s          %-24s [ %d \"%s\"\n", $STR, $data[0], $addr, substr ($string, 0, 20);;
		for (my $i = 1; $i < @data; ++$i) {
			$string = substr ($string, 20);
			push @lines, sprintf "               %-24s [ \"%s\"\n", $data[$i],
				substr ($string, 0, 20);
		}

		next;

		# If the string fails validation then treat as ordinary
		# data

	    fail:
		seek STDIN, $pos, 0;
	}

	if ($addr >= $G1 && $addr <= $LASTG) {
		# Add globals to symbol table
		my $g = $addr - $G1 + 1;
		if ($content > $LASTG && $content < $LITE) {
			$LITE = $content;
		}
		$SYM{$content} = ++$SYM if $content > $LITE;
		$SYM{$addr} = [ "G$g", $G{$g} ];
	}
	elsif ($addr > $LITS && $addr < $LITE) {
		# Save possible literal to symbol table
		$SYM{$addr} = "'$content'" if $content;	# Assume no literal for zero
	}
	if ($arg =~ /^\d+$/ && $arg > $LASTG) {
		# save possible label to symbol table
		$SYM{$arg} = ++$SYM unless $SYM{$arg};
	}
}

seek STDIN, 0,0;

# Second pass, output code

while (<STDIN>) {
	chomp;
	my $addr = substr($_,0,8) + 0;
	my $content = substr($_,17,11) + 0;
	my $op = substr($_,44,5);
	my $reg = substr ($_, 50, 2);
	my $arg = substr($_,53,11);

	my $label = $SYM{$addr} // "";

	# Do we have a label on this address?

	if (ref $label) {
		my $dest = $SYM{$content};

		# Is contents reference to a label?
		if ($dest) {
			$dest = "/$dest";
		}
		else {
			$dest = $content;
		}
		printf "%-5s          %-24s [ %s\n",
			$label->[0], $dest, $label->[1];
			
	} 
	elsif ($label =~ /^'/) {
		# This is maybe a literal
		printf "               %-24s [ %s\n", $content, $addr;
	}
	else {
		my $comment = "";

		if (my $a = $SYM{$arg}) {
			if (ref $a) {
				# cope with strings
				$comment .= " " . $a->[1];
				$arg = $a->[0];

				if (substr ($arg, 0, 1) eq 'S') {
					print "#LOWER\n";
					for (@{$a->[2]}) {
						print;
					}
					print "#PROGRAM\n";
				}
			}
			else {
				$comment .= "  " . $arg;
				$arg = $a;
			}
		}

		if ($op =~ /\d+/) {
			$op = "";
			$reg = "";
			$arg = $content;
		}

		# output labelled instruction
		printf "%-5s %-5s %-2s %-24s [ %5s %s%s\n", 
			$label, $op, $reg, $arg, $addr, $content, $comment;

		if ($content == -1) {

			# May have function name

			my $pos = tell STDIN;

			my ($val, $len, $a, $b) = chars ();
			my @data = ($val);

			$len = ord $len;
			goto fail unless $len;
			goto fail unless good ($a);
			my $string = $a;
			if (--$len) {
				goto fail unless good ($b);
				$string .= $b;
				--$len;
			}
			else {
				goto fail if ord $b;
			}

			while ($len) {
				my ($val, @c) = chars ();
				push @data, $val;
				my $i;
				for ($i = 0; $i < 3; ++$i) {
					goto fail unless good ($c[$i]);
					$string .= $c[$i];
					last unless --$len;
				}
				unless ($len) {
					for (++$i;$i < 3; ++$i) {
						goto fail if ord $c[$i];
					}
				}
			}

			# We have a function name

			printf "               %-24s [ \"%s\"\n", $data[0], $string;
			for (my $i = 1; $i < @data; ++$i) {
				printf "               %-24s\n", $data[$i];
			}

			next;

			# It wasn't a function name, treat as ordinary data
		    fail:
			seek STDIN, $pos, 0;
		}
	}
}


# Extract 8 bit bytes 

sub chars () {
	my $content = shift;

	unless (defined $content) {
		my $line = <>;
		$content = substr($line,17,11) + 0;
	}

	my @ret = ($content);

	for (my $i = 16; $i >= 0; $i -= 8) {
		push @ret, chr (($content >> $i) & 255);
	}

	@ret;
}


# Check ascii character is a valid identifier character

sub good {
	my $ch = shift;

	($ch ge 'A' && $ch le 'Z') ||
	($ch ge 'a' && $ch le 'z') ||
	($ch ge '0' && $ch le '9') ||
	$ch eq '.';
}


# Check character is valid ascii, replacing non-printables
# with escape sequences.

sub ascii {
	my $ch = $_[0];

	if ($ch eq '*') {
		$ch = '**';
	}
	elsif ($ch eq '"') {
		$ch = '*"';
	}
	elsif ($ch eq "\n") {
		$ch = "*N";
	}
	elsif ($ch eq "\r") {
		$ch = "*R";
	}
	elsif ($ch eq "\f") {
		$ch = "*P";
	}
	elsif ($ch eq "\b") {
		$ch = "*B";
	}
	elsif ($ch eq "\t") {
		$ch = "*T";
	}

	if ($ch ge "\x20" && $ch le "\x7e") {
		$_[0] = $ch;
		return $ch;
	}
}

