#!/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;

#
# Check 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;
  while (read(INPUT, $top, 1)) {
    $cmd = unpack("C", $top);
    # Ignore leader.
    next if $cmd == 0200;
    #
    # 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.
    # 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;
#printf "0%02o 0%04o\n", $cmd, $word;
#printf "0%02o 0%04o expected\n", $cmd, $csum;
        die "wrong checksum" unless $word == ($csum & 07777);
        last;
      }
      $csum += $cmd + $word;
      $word |= ($cmd & 017) << 8;
      $cmd = $cmd >> 4;
#printf "0%02o 0%04o\n", $cmd, $word;
      next if $cmd == 00; # Absolute data
      next if $cmd == 01; # Relocatable data
      if ($cmd == 03) {
        # External symbol relocation, symbol follows.
        die "no symbol" unless read(INPUT, $top, 6) == 6;
        &add2sum($top);
#printf "ref %s\n", $top;
        next;
      }
      next if $cmd == 04; # New origin
      next if $cmd == 05; # CDF to current field
      next if $cmd == 06; # CALL argument count and module number
      if ($cmd == 017) {
        # CALL reference to external, symbol follows.
        die "no symbol" unless read(INPUT, $top, 6) == 6;
        &add2sum($top);
#printf "call %s\n", $top;
        next;
      }
      die "unknown command $cmd";
    }
  }
  close(INPUT);
  return !$segments; # Consider zero segments an error
}

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

__END__
:endofperl