#!/usr/bin/perl

@rem = '
@echo off
c:\perl5\bin\perl %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
goto endofperl
@rem ' if @rem;

#
# Read a file in BIN loader format.
sub readBin {
  local($file, *core) = @_;
  #
  # Open the input file in binary mode and read it in.
  open(INPUT, $file) || die "$file: $!";
  binmode(INPUT);
  @core = ();

  @core = (); $loc = $store = undef;
  $field = 0;
  while (read(INPUT, $top, 1)) {
    $top = unpack("C", $top);
    if ($top & 0200) {	# Leader or Trailer
      undef $loc; # Expect location counter next
      warn "Unexpected leader" if defined $store;
      next;
    }
    # Check parity for the byte.
    $parity = 0;
    $byte = $top;
    while ($byte) {
      $parity = !$parity;
      $byte = $byte & ($byte-1);
    }
    warn "parity error $top" unless $parity;
    if (defined($store)) {
      $store = ($store << 6) + ($top & 077);
      if (defined $loc) {
        $core[$field*4096+$loc] = $store;
printf STDERR "%04o ", $store;
        $loc = ($loc + 1) & 07777;
      } else {
        $loc = $store;
printf STDERR "\n%04o)", $store;
      }
      $store = undef;
    } else {
      $store = $top & 077;
    }
  }
  close(INPUT);
printf STDERR "\n";
}

&readBin($ARGV[0], *core);

open(STDOUT, ">foo.pal") || die "foo.pal: $!";
#
# Pass 1:
# Scan the program and remember which locations are used as data, subroutines,
# or possible branch targets.
@ref = ();
$DREF = 1; # A direct data reference ("Dxxxx")
$IREF = 2; # An indirect reference ("Pxxxx")
$LREF = 4; # A direct branch reference ("Lxxxx")
$RREF = 8; # Return reference (JMP I xxxx target)
$SREF = 16; # A JMS reference (possible "Sxxxx")
# Kludge: location zero is a subroutine (ISR), if included.
$ref[0000] = $SREF|$DREF|$RREF if defined $core[0000];
foreach ($loc = 0; $loc <= $#core; $loc++) {
  next unless defined $core[$loc];
  $op = $core[$loc] >> 9;
  # Note: Direct EA is always in the current field!
  $ea = $loc & 070000;
  $ea += $core[$loc] & 0177;
  $ea += $loc & 07600 if $core[$loc] & 0200; # Page bit set
  $ind = $core[$loc] & 0400; # Indirect reference
  if ($op <= 3) {
    #
    # Data reference implied by effective address
    if ($ind) {
      $ref[$ea] |= $IREF;
      $ea = $core[$ea];
      # Flag non-zero referent as a DREF
      $ref[$ea] |= $DREF if $ea;
    } else {
      $ref[$ea] |= $DREF;
    }
  } elsif ($op == 4) {
    #
    # Subroutine reference implied by effective address
    if ($ind) {
      $ref[$ea] |= $IREF;
      $ea = $core[$ea];
    }
    # Kludge: Qualify the target -- it should contain 0 or $ea.
    next unless ($core[$ea] == 0)  || ($core[$ea] == $ea);
    # Mark the entry point as a possible entry point and as data.
    $ref[$ea] |= $SREF|$DREF;
  } elsif ($op == 5) {
    #
    # Branch reference implied by effective address
    if ($ind) {
      $ref[$ea] |= $IREF|$RREF;
      $ea = $core[$ea];
      $ref[$ea] |= $LREF if $ea;
    } else {
      $ref[$ea] |= $LREF;
    }
  }
}

#
# Use $ref[] flags to compute the label, if any for a given EA.
sub ref {
  local($ea) = @_;
  local($oea) = sprintf("%05o", $ea);
  # If it's a target of a JMS and a return, it's a subroutine.
  return "S".$oea if ($ref[$ea] & ($SREF|$RREF)) == ($SREF|$RREF);
  # If it's a pointer to code or data, label it a pointer.
  return "P".$oea if $ref[$ea] & $IREF;
  # If it's the target of a branch, label it as code
  return "L".$oea if $ref[$ea] & $LREF;
  # If it's the target of a data instruction, label it as data.
  return "D".$oea if $ref[$ea] & $DREF;
  # Otherwise, return null label.
  return "";
}


#
# Pass 2:
# Print the disassembly with labels where needed.
$org = -1; $fld = -1;
@mri = ("AND", "TAD", "ISZ", "DCA", "JMS", "JMP");
foreach ($loc = 0; $loc <= ($#core|07777); $loc++) {
  $name = &ref($loc);
  if (!defined $core[$loc]) {
    printf "\n$name=%04o", $loc if $name;
    next;
  }
  $fld = -1 if ($loc & 07777) == 0; # Force FIELD on field boundaries
  if ($fld != ($loc>>12)) {
     printf "\n\n\tFIELD\t%o", $loc >> 12;
  }
  $fld = $loc >> 12;
  $org = -1 if ($loc & 0177) == 0; # Force ORG on page boundaries
  if ($loc != $org) {
     printf "\n\n\t*%04o", $loc & 07777;
  }
  $org = $loc + 1;
  print "\n";
  $octal = 0;
  if ($name) {
    #
    # This location has a label.
    print $name.",";
    $oea = sprintf("%05o", $loc);
    if ($name =~ /^[DS]$oea$/) {
      #
      # Data label -- skip disassembly and output octal
      printf "\t%04o", $core[$loc];
      next;
    }
    if ($name ne "L".$oea) {
      #
      # Address label -- skip disassembly and output symbol name
      $name = &ref($core[$loc]);
      if ($name) {
        print "\t".$name;
      } else {
        printf "\t%04o", $core[$loc];
      }
      next;
    }
  }
  #
  # Disassemble as an instruction.
  $op = $core[$loc] >> 9;
  print "\t";
  if ($op <= 5) {
    #
    # Operation refences memory
    # Note: Direct EA is always in the current field!
    $ea = $loc & 070000;
    $ea += $core[$loc] & 0177;
    $ea += $loc & 07600 if $core[$loc] & 0200; # Page bit set
    if (($ea < 0200) &&  ($core[$loc] & 0200)) {
      # Assembler never generates on-page references to page 0,
      # so just output octal.
      printf "\t%04o", $core[$loc];
      next;
    }
    $ind = $core[$loc] & 0400; # Indirect reference
    print $mri[$op], " ";
    print "I " if $ind;
    $oea = &ref($ea);
    print $oea if $oea;
    printf "%04o", $ea unless $oea;
  } elsif ($op == 6) {
    $op = $core[$loc];
    if (($op & 07770) == 06000) {
      #
      # Interrupt Control
      print "IOT"  if ($op & 0007) == 00;
      print "ION"  if ($op & 0007) == 01;
      print "IOF"  if ($op & 0007) == 02;
      # These have mnemonics, but the assembler doesn't know them.
      print "6003" if ($op & 0007) == 03;
      print "6004" if ($op & 0007) == 04;
      print "6005" if ($op & 0007) == 05;
      print "6006" if ($op & 0007) == 06;
      print "6007" if ($op & 0007) == 07;
      next;
    }
    if (($op & 07770) == 06010) {
      #
      # High Speed Reader
      print "RSF " if ($op & 0001);
      print "RRB " if ($op & 0002);
      print "RFC " if ($op & 0004);
      printf "%04o", $op if ($op & 0007) == 0000;
      next;
    }
    if (($op & 07770) == 06030) {
      #
      # Teletype keyboard
      print "KSF " if ($op & 0001);
      print "KCC"  if ($op & 0006) == 0002;
      print "KRS"  if ($op & 0006) == 0004;
      print "KRB"  if ($op & 0006) == 0006;
      printf "%04o", $op if ($op & 0007) == 0000;
      next;
    }
    if (($op & 07770) == 06040) {
      #
      # Teletype printer
      print "TSF " if ($op & 0001);
      print "TCF"  if ($op & 0006) == 0002;
      print "TPC"  if ($op & 0006) == 0004;
      print "TLS"  if ($op & 0006) == 0006;
      printf "%04o", $op if ($op & 0007) == 0000;
      next;
    }
    if (($op & 07700) == 06200) {
      #
      # CIF, CDF, etc.
      if ($op & 07) {
        if (($op & 07) && (($op & 07) < 04)) {
          print "CDF " if $op & 01;
          print "CIF " if $op & 02;
          print (($op & 070) >> 3);
          next;
        }
        if (($op & 070) < 050) {
          @RxF = ("6204", "RDF", "RIF", "RIB", "RMF");
          print $RxF[($op & 070) >> 3];
          next;
        }
      }
      printf "%04o", $op;
      next;
    }
#   if (($op & 07770) == 06100) {
#     #
#     # Memory Parity, Power Fail
#     print "SMP " if ($op & 0001);
#     print "SPL " if ($op & 0002);
#     print "CMP " if ($op & 0004);
#     printf "%04o", $op if ($op & 0007) == 0000;
#     next;
#   }
    printf "%04o", $op;
    next;
  } else {
    $op = $core[$loc];
    if (($op & 0400) == 0000) {
      #
      # Group 1 -- shifts, clears, complements
      # These are clearest when printed in chronological order.
      # The timing is model dependent, with the PDP-8I having the
      # strictest ordering.
      print "NOP"  if ($op & 0377) == 0000;
      print "CLA " if ($op & 0200); # T1
      print "CLL " if ($op & 0100); # T1
      print "CML " if ($op & 0020); # T2
      print "CMA " if ($op & 0041) == 040; # T2
      print "RAL " if ($op & 0006) == 004; # T3
      print "RTL " if ($op & 0006) == 006; # T3
      print "RAR " if ($op & 0012) == 010; # T3
      print "RTR " if ($op & 0012) == 012; # T3
      print "BSW " if ($op & 0016) == 002; # T3
      print "IAC"  if ($op & 0041) == 001; # T4
      print "CIA"  if ($op & 0041) == 041; # T2, T4
      next;
    } elsif (($op & 0401) == 0400) {
      #
      # Group 2 -- Skips, halt, read switches
      # These are clearest when printed in chronological order.
      # The timing here is not model dependent.
      print "7400"  if ($op & 0377) == 0000;
      print "7600 " if ($op & 0377) == 0200; # Renders as "7600 CLA"
      print "SKP "  if ($op & 0170) == 0010; # T1
      print "SZA "  if ($op & 0050) == 0040; # T1
      print "SNA "  if ($op & 0050) == 0050; # T1
      print "SMA "  if ($op & 0110) == 0100; # T1
      print "SPA "  if ($op & 0110) == 0110; # T1
      print "SNL "  if ($op & 0030) == 0020; # T1
      print "SZL "  if ($op & 0030) == 0030; # T1
      print "CLA "  if ($op & 0200); # T2
      print "OSR "  if ($op & 0004); # T3
      print "HLT"   if ($op & 0002); # T4
      next;
    } else {
      #
      # Group 3 -- Extended Arithmetic Unit
      printf "%04o", $op;
    }
  }
}
printf "\n\$\n";

__END__
:endofperl