#!/usr/bin/perl
# 
# Copyright © 2015-2022 by Vincent Slyngstad
# 
# 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 LISTED ABOVE 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.
# 
# Except as contained in this notice, the names of the authors above
# shall not be used in advertising or otherwise to promote the sale, use
# or other dealings in this Software without prior written authorization
# from those authors.

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

#
# Display relocatable tapes used by LOADER and LIBSET.
#
# Each relocatable should have leader (0200),
# followed by a list of loader information blocks, 
# and ending in a checksum block.
#
# An information block is broken into two tape bytes.
# The high 4 bits of the first byte contain the type of the block.
# The low 4 bits are the upper nibble of a 12 bit word, when 
# taken together with the following byte as the low 8 bits.
#
# The OS/8 Language Reference Manual describes the format on
# pages 6-38 through 6-41 of the SABR description.
#

#
# Add the characters of the argument to the checksum.
sub add2sum {
  local(@bytes) = unpack("C*", $_[0]);

  foreach (@bytes) {
    $csum += $_;
  }
}

#
# Read a file in EPIC loader format.
sub readReloc {
  local($file, *core) = @_;
  #
  # Open the input file in binary mode and read it in.
  open(INPUT, $file) || die "$file: $!";
  binmode(INPUT);
  $segments = 0;
  @externs = ("");
  while (read(INPUT, $top, 1)) {
    $cmd = unpack("C", $top);
    # Ignore leader.
    next if $cmd == 0200;
    # Stop if EOF (^Z).
    last if $cmd == 0032;
    last if $cmd == 0232;
    #
    # Begining of what we hope is relocatable info.
    # COMMON is required, and must be first.
    die "no COMMON: $cmd" unless ($cmd>>4) == 012;
    die "no COMMON" unless read(INPUT, $top, 1) == 1;
    $word = unpack("C", $top);
    $csum = $cmd + $word; # Start a checksum.
    $word |= ($cmd & 017) << 8;
    $cmd = $cmd >> 4;
    printf "%04o\t%04o\tCOMMON %04o\n", $loc, $word, $word;
    # Now loop for the rest.
    while (read(INPUT, $top, 2)) {
      ($cmd, $word) = unpack("CC", $top);
      if (($cmd>>4) == 010) { # Checksum
        $word |= ($cmd & 017) << 8;
        $csum &= 07777;
        $cmd = $cmd >> 4;
        warn "Checksum %04o != %04o\n", $cmd, $csum, $word
          unless $word == $csum;
        last;
      }
      $csum += $cmd + $word;
      $word |= ($cmd & 017) << 8;
      $cmd = $cmd >> 4;
      # Always print the word?
      printf "%04o\t%04o%s", $loc++, $word, $cmd == 01? '*': ' ';
      printf "\t%04o\n", $word if $cmd == 00;
      next if $cmd == 00; # Absolute data
      printf "\tARG %04o\n", $word if $cmd == 01;
      next if $cmd == 01; # Relocatable data
      $loc--; # Didn't emit code after all
      if ($cmd == 03) {
        # External symbol definition, symbol follows.
        die "no symbol" unless read(INPUT, $top, 6) == 6;
        &add2sum($top);
        $top = pack("CCCCCC", grep($_ &= 0177, unpack("CCCCCC", $top)));
	warn "GLOBAL: $word != $loc\n" if $word != $loc;
        printf "\tGLOBAL %s\n", $top;
        next;
      }
      printf "\tREORG %04o\n", $word if $cmd == 04;
      $loc = $word if $cmd == 04;
      next if $cmd == 04; # New origin
      $loc++;
      printf "\n", $word if $cmd == 05;
      next if $cmd == 05; # CDF to current field
      printf "\tCALL  %d,%s\n", $word>>6, $externs[$word&077] if $cmd == 06;
      next if $cmd == 06; # CALL argument count and module number
      $loc--;
      if ($cmd == 017) {
        # Reference to external, symbol follows.
        die "no symbol" unless read(INPUT, $top, 6) == 6;
        &add2sum($top);
        $top = pack("CCCCCC", grep($_ &= 0177, unpack("CCCCCC", $top)));
        printf "\tEXTERN %s\n", $top;
        push(@externs, $top);
        next;
      }
      die "unknown command $cmd";
    }
  }
  close(INPUT);
  return !$segments; # Consider zero segments an error
}

&readReloc($ARGV[0]);
exit 0;

__END__
:endofperl