#! /usr/bin/perl -w

use strict;

# Massage output from disassembler to make BCPL
# strings easier to undestand

# 01234567890123456789012345678901234567890123456789
# #PROGRAM       XXXX99/%BEXECUTE(DBM,15AM)
# #LOWER         COMMON/%BGLOBALVEC/
# L37            0                        [ 4H0000
# L36            0                        [ 4H0000
# L27            0                        [ 4H0000
#                /L25                     [ %BCOMMUNE+12
#                0                        [ 4H0000
#                0                        [ 4H0000
#                0                        [ 4H0000

my $STATE = "";
my $GLOBAL = 0;
my $LAST_GLOBAL = 0;

my %SYM;

while (<STDIN>) {

	if (/^#LOWER         COMMON\/%BGLOBALVEC\//) {
		$STATE = "%BGLOBALVEC";
		print;
		next;
	}

	if (/^#LOW/) {
		$STATE = "#LOWER";
		print;
		next;
	}

	if (/^#PRO/) {
		$STATE = "#PROGRAM";
		print;
		next;
	}

	if (/^#UPP/) {
		$STATE = "#UPPER";
		print;
		next;
	}

	if (/^#END/) {
		$STATE = "";
		$GLOBAL = 0;
		$LAST_GLOBAL = 0;
		%SYM = ();
		print;
		next;
	}

	if (/^#/) {
		print;
		next;
	}

	chomp;

	my $label = substr ($_, 0, 15);
	my $val = substr ($_, 15, 25);
	my $cmt = length > 40 ? substr ($_, 40) : "";

	$label =~ s/\s+$//;
	$val =~ s/\s+$//;
	$cmt =~ s/\s+$//;

	# Clean up globalvec dec

	if ($STATE eq '%BGLOBALVEC') {

		if ($label ne '') {
			if ($LAST_GLOBAL < $GLOBAL) {
				printf "               U%d(%d)\n",
					$LAST_GLOBAL, $GLOBAL - $LAST_GLOBAL;
			}
			$SYM {$label} = "G$GLOBAL";
			if ($val eq '0') {
				$_ = (' ' x 15) . 'G' . $GLOBAL . "\n";
			}
			else {
				$_ = sprintf ("G%-14s%-25s%s\n",
						$GLOBAL, $val, $cmt);
			}
			$LAST_GLOBAL = $GLOBAL + 1;
			print;
		}
		elsif ($val ne '0') {
			if ($LAST_GLOBAL < $GLOBAL) {
				printf "               U%d(%d)\n",
					$LAST_GLOBAL, $GLOBAL - $LAST_GLOBAL;
			}
			$SYM {$label} = sprintf "G%-14s", $GLOBAL;
			$_ = sprintf ("G%-14s%-25s%s\n",
					$GLOBAL, $val, $cmt);
			$LAST_GLOBAL = $GLOBAL + 1;
			print;
		}

		++$GLOBAL;
		next;
	}

	if ($STATE eq '#LOWER' || $STATE eq '#PROGRAM') {
		if ($SYM{$val}) {
			substr ($_, 15, 25) = sprintf "%-25s", $SYM{$val};
			print $_, "\n";
			next;
		}
		elsif ($val =~ /^\// && $SYM{substr ($val,1)}) {
			substr ($_, 15, 25) = sprintf "/%-24s",
				$SYM{substr ($val,1)};
			print $_, "\n";
			next;
		}
	}

	if ($STATE eq '#LOWER' && $label) {
		# maybe string 

		my $here = tell STDIN;

		my ($a, $b, $c) = chars ($_);

		goto fail unless $a; 

		goto fail unless ord $a;

		my @lines;
		push @lines, $_;

		my $len = ord $a;

		goto fail unless ascii ($b);
		my $string = $b;

		if (--$len) {
			goto fail unless ascii ($c);
			$string .= $c;
			--$len;
		}
		else {
			goto fail unless $c eq "\0";
		}

		while ($len) {
			$_ = <>;
			goto fail unless /^\s/;
			chomp;
			push @lines, $_;
			my @c = chars ($_)
				or goto fail;
			my $i;
			for ($i = 0; $i < 3; ++$i) {
				goto fail unless ascii ($c[$i]);
				$string .= $c[$i];
				last unless --$len;
			}
			for (++$i; $i < 3; ++$i) {
				goto fail unless $c[$i] eq "\0";
			}
		}

		for (@lines) {
			substr ($_, 42) = '"' . substr ($string, 0, 20) . '"';
			substr ($string, 0, 20) = "";
			print $_, "\n";
		}

		next;
		
	    fail:
		seek STDIN, $here, 0;
	}

	if ($STATE eq '#PROGRAM' && $label eq '' && $val eq '-1') {

		my $prev = $_;

		my $here = tell STDIN;

		$_ = <>;

		my ($a, $b, $c) = chars ($_);

		goto fail unless $a; 

		goto fail unless ord $a;

		my @lines;
		push @lines, (((ord ($a) << 8) + ord $b) << 8) + ord $c;

		my $len = ord $a;

		# Allow 1st 2 chars in ASCII to cope with special
		# case of "%%"

		goto fail unless ascii ($b);
		my $string = $b;

		if (--$len) {
			goto fail unless ascii ($c);
			$string .= $c;
			--$len;
		}
		else {
			goto fail unless $c eq "\0";
		}

		while ($len) {
			$_ = <>;
			goto fail unless /^\s/;
			chomp;
			my @c = chars ($_)
				or goto fail;
			push @lines, (((ord ($c[0]) << 8) + ord $c[1]) << 8) + ord $c[2];
			my $i;
			for ($i = 0; $i < 3; ++$i) {
				goto fail unless ident ($c[$i]);
				$string .= $c[$i];
				last unless --$len;
			}
			for (++$i; $i < 3; ++$i) {
				goto fail unless $c[$i] eq "\0";
			}
		}

		printf "%15s%d\n", "", -1;

		for (@lines) {
			printf "%15s%-25d[ \"%s\"\n", "", $_, 
				substr ($string, 0, 20);
			substr ($string, 0, 20) = "";
		}

		next;
		
	    fail:
		$_ = $prev;
		seek STDIN, $here, 0;
	}

	print $_, "\n";
	next;
}


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";
	}

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


sub chars {
	my $line = shift;
	my $val = val ($line)
		or return;
	my @ret;

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

	@ret;
}


my %ICL;

BEGIN {
	my $ICL = '0123456789:;<=>?'.
          " !\"#\xa3%&'()*+,-./".
          '@ABCDEFGHIJKLMNO'.
          'PQRSTUVWXYZ[$]^_';

	my %map;
	for (my $i = 0; $i < 64; ++$i) {
        	$ICL {substr $ICL, $i, 1} = $i;
	}
}


sub val {
	my $line = shift;
	return unless length $line >= 43 && substr ($line,42,2) eq '4H';
	my $chars = substr ($line, 44) . '    ';
	my $val = 0;
	for (my $i = 0; $i < 4; ++$i) {
		my $ch = substr ($chars, $i, 1);
		$ch = $ICL {$ch};
		$val = ($val << 6) + $ch;
	}

	$val;
}

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

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

