#!/usr/bin/perl -w

use Fcntl qw(SEEK_SET);
use integer;

# Extract information from within a TADS GAM file

sub ord1($;$) {
  my $str = shift;
  my $ofs = shift || 0;

  return ord(substr($str, $ofs));
}

sub read1(*) {
  my $FH = shift;

  return ord(getc($FH));
}

sub ord2($;$) {
  my $str = shift;
  my $ofs = shift || 0;
  my $c1 = ord1($str, $ofs);
  my $c2 = ord1($str, $ofs + 1);

  return ($c2 << 8) | $c1;
}

sub ord2s($;$) {
  my $str = shift;
  my $ofs = shift || 0;
  my $result = ord2($str, $ofs);
  $result -= 0x10000 if ($result >= 0x8000);
  return $result;
}

sub read2(*) {
  my $FH = shift;
  my $str;

  read($FH, $str, 2);
  return ord2($str);
}

sub ord4($;$) {
  my $str = shift;
  my $ofs = shift || 0;

  my $c1 = ord1($str, $ofs);
  my $c2 = ord1($str, $ofs + 1);
  my $c3 = ord1($str, $ofs + 2);
  my $c4 = ord1($str, $ofs + 3);
  $c4 -= 256 if ($c4 >= 128);	# In case of a signed value

  return ($c4 << 24) | ($c3 << 16) | ($c2 << 8) | $c1;
}

sub read4(*) {
  my $FH = shift;
  my $str;

  read($FH, $str, 4);
  return ord4($str);
}

$xorseed = 0x3f;
$xorinc = 0x40;

sub decode($) {
  my $block = shift;

  return $block unless ($crypt);

  my $len = length($block);
  my $mask = $xorseed;
  my $maskstr;

  for (my $i = 0; $i < $len; $i++) {
    $maskstr .= chr($mask);
    $mask = ($mask + $xorinc) % 256;
  }

  return $block ^ $maskstr;
}

sub hexl($) {
  my $block = shift;

  local *HEXL;
  open(HEXL, "|/usr/lib/xemacs-21.4.8/i386-debian-linux/hexl");
  print HEXL $block;
  close HEXL;
}

sub sigend($) {
  print "(END REACHED)";
  return shift;
}

# Datatype numbers
sub DAT_NUMBER() { return 1; }
sub DAT_OBJECT() { return 2; }
sub DAT_SSTRING() { return 3; }
sub DAT_BASEPTR() { return 4; }
sub DAT_NIL() { return 5; }
sub DAT_CODE() { return 6; }
sub DAT_LIST() { return 7; }
sub DAT_TRUE() { return 8; }
sub DAT_DSTRING() { return 9; }
sub DAT_FNADDR() { return 10; }
sub DAT_TPL() { return 11; }
sub DAT_PROPNUM() { return 13; }
sub DAT_DEMAND() { return 14; }
sub DAT_SYN() { return 15; }
sub DAT_REDIR() { return 16; }
sub DAT_TPL2() { return 17; }

# Print a value, returning the length it occupied
sub printValue($$$) {
  my $block = shift;
  my $pos = shift;
  my $type = shift;
  my $lenleft = length($block) - $pos;

  if ($type == DAT_NUMBER) {
    return sigend($lenleft) if ($lenleft < 4);
    print ord4($block, $pos);
    return 4;
  }
  elsif ($type == DAT_OBJECT || $type == DAT_FNADDR) {
    print "&" if ($type == DAT_FNADDR);
    return sigend($lenleft) if ($lenleft < 2);
    printObj(ord2($block, $pos));
    return 2;
  }
  elsif ($type == DAT_SSTRING || $type == DAT_DSTRING) {
    return sigend($lenleft) if ($lenleft < 2);
    my $strlen = ord2($block, $pos);
    # Check for valid string length
    return sigend($lenleft) if ($strlen > $lenleft || $strlen < 2);
    my $delim = "\"";
    $delim = "'" if ($type == DAT_SSTRING);
    print $delim, substr($block, $pos + 2, $strlen - 2), $delim;
    return $strlen;
  }
  elsif ($type == DAT_NIL) {
    print "nil";
    return 0;
  }
  elsif ($type == DAT_LIST) {
    return sigend($lenleft) if ($lenleft < 2);
    my $listlen = ord2($block, $pos);
    # Check for valid list length
    return sigend($lenleft) if ($listlen > $lenleft || $listlen < 2);
    printList(substr($block, $pos, $listlen));
    return $listlen;
  }
  elsif ($type == DAT_TRUE) {
    print "true";
    return 0;
  }
  elsif ($type == DAT_PROPNUM) {
    return sigend($lenleft) if ($lenleft < 2);
    print "&";
    printProp(ord2($block, $pos));
    return 2;
  }
  else {
    print "Unexpected data type: $type\n";
    return $lenleft;
  }
}

sub printList($) {
  my $block = shift;

  print "[";
  my $pos = 2;
  my $len = ord2($block);
  return sigend(length($block)) if ($len > length($block) || $len < 2);
  while ($pos < $len) {
    my $type = ord1($block, $pos);
    $pos++;
    $pos += printValue($block, $pos, $type);
    print " " if ($pos < $len);
  }
  print "]";
  return $len;
}

# Define operand type values
sub OPBYTE() { return 1; }
sub OPWORD() { return 2; }
sub OPQUAD() { return 3; }
sub OPOBJ() { return 4; }
sub OPFUNC() { return 5; }
sub OPPROP() { return 6; }
sub OPRET() { return 7; }
sub OPLABEL() { return 8; }
sub OPDSTR() { return 9; }
sub OPBIF() { return 10; }
sub OPSSTR() { return 11; }
sub OPLIST() { return 12; }
sub OPSWITCH() { return 13; }	# Switch table
sub OPLINE() { return 14; }	# Debugger line record
sub OPFRAME() { return 15; }	# Local variable frame record

# Print an operand, returning the number of bytes it occupied
sub printOperand($$$) {
  my $block = shift;
  my $pos = shift;
  my $type = shift;
  my $lenleft = length($block) - $pos;

  if ($type == OPBYTE) {
    return sigend($lenleft) if ($lenleft < 1);
    print ord1($block, $pos);
    return 1;
  }
  elsif ($type == OPWORD || $type == OPRET) {
    return sigend($lenleft) if ($lenleft < 2);
    print ord2s($block, $pos);
    return 2;
  }
  elsif ($type == OPQUAD) {
    return printValue($block, $pos, DAT_NUMBER);
  }
  elsif ($type == OPOBJ || $type == OPFUNC) {
    return printValue($block, $pos, DAT_OBJECT);
  }
  elsif ($type == OPPROP) {
    return sigend($lenleft) if ($lenleft < 2);
    printProp(ord2($block, $pos));
    return 2;
  }
  elsif ($type == OPLABEL || $type == OPSWITCH) {
    return sigend($lenleft) if ($lenleft < 2);
    print $pos + ord2s($block, $pos);
    return 2;
  }
  elsif ($type == OPDSTR) {
    return printValue($block, $pos, DAT_DSTRING);
  }
  elsif ($type == OPSSTR) {
    return printValue($block, $pos, DAT_SSTRING);
  }
  elsif ($type == OPBIF) {
    return sigend($lenleft) if ($lenleft < 2);
    printBuiltin(ord2($block, $pos));
    return 2;
  }
  elsif ($type == OPLIST) {
    return printValue($block, $pos, DAT_LIST);
  }
  elsif ($type == OPLINE) {
    return sigend($lenleft) if ($lenleft < 1);
    my $linelen = ord1($block, $pos);
    return sigend($lenleft) if ($linelen > $lenleft || $linelen < 1);
    print "line record (", $linelen, " bytes)";
    return $linelen;
  }
  elsif ($type == OPFRAME) {
    return sigend($lenleft) if ($lenleft < 2);
    my $framelen = ord2($block, $pos);
    return sigend($lenleft) if ($framelen > $lenleft || $framelen < 2);
    print "frame record (", $framelen, " bytes)";
    return $framelen;
  }
  else {
    print "This shouldn't happen: unknown operand type ", $type, "\n";
    die;
  }
}

@props = (undef, "doAction", "verb", "noun", "adjective", "preposition",
	  "article", "plural", "sdesc", "thedesc", "doDefault",
	  "ioDefault", "ioAction", "location", "value",
	  "roomAction", "actorAction", "contents", "tpl",
	  "prepDefault", "verActor", "validDo", "validIo",
	  "lookAround", "roomCheck", "statusLine", "locationOK",
	  "isVisible", "cantReach", "isHim", "isHer", "action",
	  "validDoList", "validIoList", "iobjGen", "dobjGen",
	  "nilPrep", "rejectMultiDobj", "moveInto", "construct",
	  "destruct", "validActor", "preferredActor", "isEquivalent",
	  "adesc", "multisdesc", "tpl2", "anyvalue",
	  "newNumbered", "unknown", "parseUnknownDobj",
	  "parseUnknownIobj", "dobjCheck", "iobjCheck", "verbAction",
	  "disambigDobj", "disambigIobj", "prefixdesc", "isThem");

sub printProp($) {
  my $n = shift;

  if ($n == 0) {
    print "noprop";
  }
  elsif ($n > 0 && defined $props[$n]) {
    print $props[$n];
  }
  else {
    print "prop", $n;
  }
}

@objs = ();

sub printObj($) {
  my $n = shift;

  if ($n == 65535) {
    print "nullobj";
  }
  elsif (defined $objs[$n]) {
    print $objs[$n];
  }
  else {
    print "obj", $n;
  }
}

sub printBuiltin($) {
  my $n = shift;
  my @builtins = ("say", "car", "cdr", "length", "randomize", "rand",
		  "substr", "cvtstr", "cvtnum", "upper", "lower",
		  "caps", "find", "getarg", "datatype", "setdaemon",
		  "setfuse", "setversion", "notify", "unnotify",
		  "yorn", "remfuse", "remdaemon", "incturn", "quit",
		  "save", "restore", "logging", "input", "setit",
		  "askfile", "setscore", "firstobj", "nextobj",
		  "isclass", "restart", "debugTrace", "undo", "defined",
		  "proptype", "outhide", "runfuses", "rundaemons",
		  "gettime", "getfuse", "intersect", "inputkey",
		  "objwords", "addword", "delword", "getwords",
		  "nocaps", "skipturn", "clearscreen", "firstsc",
		  "verbinfo", "fopen", "fclose", "fwrite", "fread",
		  "fseek", "fseekeof", "ftell", "outcapture",
		  "systemInfo", "morePrompt", "parserSetMe",
		  "parserGetMe", "reSearch", "reGetGroup", "inputevent",
		  "timeDelay", "setOutputFilter", "execCommand",
		  "parserGetObj", "parseNounList", "parserTokenize",
		  "parserGetTokTypes", "parserDictLookup",
		  "parserResolveObjects", "parserReplaceCommand",
		  "exitobj", "inputdialog", "resourceExists");

  if ($n < 0 || $n > $#builtins) {
    print "invalid builtin $n";
  }
  else {
    print $builtins[$n];
  }
}

@opcodes =
  ([],
   ["pushnum", OPQUAD],
   ["pushobj", OPOBJ],
   ["neg"],
   ["not"],
   ["add"],
   ["sub"],
   ["mul"],
   ["div"],
   ["and"],
   ["or"],
   ["eq"],
   ["ne"],
   ["gt"],
   ["ge"],
   ["lt"],
   ["le"],
   ["call", OPBYTE, OPFUNC],
   ["getp", OPBYTE, OPPROP],
   ["getpdata", OPBYTE, OPPROP],
   ["getlcl", OPWORD],
   ["ptrgetpdata", OPBYTE],
   ["return", OPRET],
   ["retval", OPRET],
   ["enter", OPWORD],
   ["discard"],
   ["jmp", OPLABEL],
   ["jf", OPLABEL],
   ["pushself"],
   ["say", OPDSTR],
   ["builtin", OPBYTE, OPBIF],
   ["pushstr", OPSSTR],
   ["pushlst", OPLIST],
   ["pushnil"],
   ["pushtrue"],
   ["pushfn", OPFUNC],
   ["getpselfdata", OPBYTE, OPPROP],
   [],
   ["ptrcall", OPBYTE],
   ["ptrinh", OPBYTE],
   ["ptrgetp", OPBYTE],
   ["pass", OPPROP],
   ["exit"],
   ["abort"],
   ["askdo"],
   ["askio", OPOBJ],
   ["expinh", OPBYTE, OPPROP, OPOBJ],
   ["expinhptr", OPBYTE, OPOBJ],
   ["calld", OPBYTE, OPFUNC],
   ["getpd", OPBYTE, OPPROP],
   ["builtind", OPBYTE, OPBIF],
   ["je", OPLABEL],
   ["jne", OPLABEL],
   ["jgt", OPLABEL],
   ["jge", OPLABEL],
   ["jlt", OPLABEL],
   ["jle", OPLABEL],
   ["jnand", OPLABEL],
   ["jnor", OPLABEL],
   ["jt", OPLABEL],
   ["getpself", OPBYTE, OPPROP],
   ["getpslfd", OPBYTE, OPPROP],
   ["getpobj", OPBYTE, OPOBJ, OPPROP],
   ["getpobjd", OPBYTE, OPOBJ, OPPROP],
   ["index"],
   [],
   [],
   ["pushpn", OPPROP],
   ["jst", OPLABEL],
   ["jsf", OPLABEL],
   ["jmpd", OPLABEL],
   ["inherit", OPBYTE, OPPROP],
   ["callext", OPBYTE, OPWORD],
   ["dbgret"],
   ["cons", OPBYTE],
   ["switch", OPSWITCH],
   ["argc"],
   ["chkargc", OPBYTE],
   ["line", OPLINE],
   ["frame", OPFRAME],
   ["bp", OPLINE],
   ["getdblcl", OPWORD, OPWORD, OPWORD],
   ["getpptrself", OPBYTE],
   ["mod"],
   ["band"],
   ["bor"],
   ["xor"],
   ["bnot"],
   ["shl"],
   ["shr"],
   ["new"],
   ["delete"]);

sub disasm($) {
  my $block = shift;

  my @switches;
  my $pos = 0, $len = length($block);
  my $numswitches = -1;		# Number of switch table entries left,
				# -1 means not in switch table
  # (It's this way so that switch tables with only a default get
  # disassembled correctly.)

  while ($pos < $len) {
    print $pos, "\t";

    # The one case where we're not pointed at an opcode: the end of
    # a switch table
    if ($numswitches == 0) {
      print "default\t-> ";
      $pos += printOperand($block, $pos, OPLABEL);
      $numswitches = -1;
      print "\n", $pos, "\t";
    }
    if ($#switches >= 0 && $pos == $switches[0]) {
      print "Switch table\n";
      $numswitches = ord2($block, $pos);
      $pos += 2;
      shift @switches;
    }
    else {
      my $opc = ord1($block, $pos);
      $pos++;
      if ($opc >= 1 && $opc <= $#opcodes) {
	my @opcdata = @{$opcodes[$opc]};
	if ($#opcdata < 0) {
	  print "Invalid opcode $opc\n";
	  last;
	}
	print $opcdata[0], "\t";
	for (my $i = 1; $i <= $#opcdata; $i++) {
	  # Handle operand to switch
	  if ($opcdata[$i] == OPSWITCH) {
	    @switches = sort(@switches, $pos + ord2s($block, $pos));
	  }

	  $pos += printOperand($block, $pos, $opcdata[$i]);
	  print ", " if ($i < $#opcdata);
	}
      }
      elsif (($opc & 0xc0) == 0xc0) { # Assignment
	print "assign\t";

	my $ext = 0;
	if (($opc & 0x1c) == 0x1c) {
	  $ext = ord1($block, $pos);
	  $pos++;
	}
	if (($opc & 3) == 0) {
	  print "local ", ord2($block, $pos);
	  $pos += 2;
	} elsif (($opc & 3) == 1) {
	  print "property ";
	  printProp(ord2($block, $pos));
	  $pos += 2;
	} elsif (($opc & 3) == 2) {
	  print "list";
	} else {
	  print "property pointer";
	}

	print " :=" if (($opc & 0x1c) == 0x00);
	print " +=" if (($opc & 0x1c) == 0x04);
	print " -=" if (($opc & 0x1c) == 0x08);
	print " *=" if (($opc & 0x1c) == 0x0c);
	print " /=" if (($opc & 0x1c) == 0x10);
	print " ++" if (($opc & 0x1c) == 0x14);
	print " --" if (($opc & 0x1c) == 0x18);
	print " %=" if ($ext == 1);
	print " &=" if ($ext == 2);
	print " |=" if ($ext == 3);
	print " ^=" if ($ext == 4);
	print " <<=" if ($ext == 5);
	print " >>=" if ($ext == 6);

	if (($opc & 0x1c) == 0x14 || ($opc & 0x1c) == 0x18) {
	  if ($opc & 0x20) {
	    print " pre";
	  }
	  else {
	    print " post";
	  }
	}
	else {
	  print " and discard" if ($opc & 0x20);
	}
      }
      else {
	print "Invalid opcode ", $opc, "\n";
	last;
      }

      if ($numswitches >= 0) {
	print "\t-> ";
	$pos += printOperand($block, $pos, OPLABEL);
	$numswitches--;
      }
      print "\n";
    }
  }
}

sub processXSI(*$) {
  my $FH = shift;

  $xorseed = read1($FH);
  $xorinc = read1($FH);

  print "  xorseed = ", $xorseed, ", xorinc = ", $xorinc, "\n";
}

sub processOBJ(*$) {
  my $FH = shift;
  my $len = shift;

  while ($len > 0) {
    my $type = read1($FH);
    my $n = read2($FH);
    my $size = read2($FH);
    my $use = read2($FH);
    print "  Object ";
    printObj($n);
    print ":\n    Type $type";
    print " (function)" if ($type == 1);
    print " (object)" if ($type == 2);
    print " (extern)" if ($type == 10);
    print "\n    Size $size\n";
    print "    Size used $use\n";

    my $block;
    read($FH, $block, $use);
    $block = decode($block);

    if ($type == 1) {
      disasm($block);
    }
    else {
      print "    Workspace ", ord2($block, 0), "\n";
      print "    Flags ", ord2($block, 2), "\n";
      print "    Free ", ord2($block, 8), "\n";
      print "    Reset ", ord2($block, 10), "\n";
      print "    Static ", ord2($block, 12), "\n";
      print "    Superclasses:";
      my $n = ord2($block, 4);
      for (my $i = 0; $i < $n; $i++) {
	print " ";
	printObj(ord2($block, 14 + 2 * $i));
      }
      print "\n";

      my $flags = ord2($block, 2);
      my $nprop = ord2($block, 6);

      my $pos = 14 + 2 * $n;

      if ($flags & 2) {
	# Skip the index table if present
	$pos += 2 * $nprop;
      }

      for (my $i = 0; $i < $nprop; $i++) {
	my $num = ord2($block, $pos);
	my $type = ord1($block, $pos + 2);
	my $size = ord2($block, $pos + 3);
	print "    Property ";
	printProp($num);
	print ":\n";
	print "      Datatype ", $type, "\n";
	print "      Size ", $size, "\n";
	print "      Flags ", ord1($block, $pos + 5), "\n";

	if ($type == DAT_CODE) {	# code
	  disasm(substr($block, $pos + 6, $size));
	}
	elsif ($type == DAT_DEMAND) {
	  print "      implicit contents list\n";
	}
	elsif ($type == DAT_SYN) {	# property synonym
	  print "      synonym to property ";
	  printProp(ord2($block, $pos + 6));
	  print "\n";
	}
	elsif ($type == DAT_REDIR) {	# redirection to another object
	  print "      redirection to object ";
	  printObj(ord2($block, $pos + 6));
	  print "\n";
	}
	elsif ($type == DAT_TPL2) {	# tpl2
	  my $i = ord1($block, $pos + 6);
	  my $intpos = $pos + 7;

	  for (my $j = 0; $j < $i; $j++) {
	    print "      preposition ";
	    printObj(ord2($block, $intpos));
	    print ":\n        verIoVerb ";
	    printProp(ord2($block, $intpos + 2));
	    print "\n        ioVerb ";
	    printProp(ord2($block, $intpos + 4));
	    print "\n        verDoVerb ";
	    printProp(ord2($block, $intpos + 6));
	    print "\n        doVerb ";
	    printProp(ord2($block, $intpos + 8));
	    print "\n        flags ", ord1($block, $intpos + 10), "\n";
	    $intpos += 16;
	  }
	}
	else {
	  print "      ";
	  printValue($block, $pos + 6, $type);
	  print "\n";
	}
	$pos += 6 + $size;
      }
    }
    $len -= $use + 7;
  }
}

sub processFST(*$) {
  my $FH = shift;
  my $len = shift;

  while ($len > 0) {
    my $type = read1($FH);
    my $n = read2($FH);
    my $size = read2($FH);
    my $use = read2($FH);
    my $ofs = read4($FH);
    print "  Object ";
    printObj($n);
    print ":\n    Type $type";
    print " (function)" if ($type == 1);
    print " (object)" if ($type == 2);
    print " (extern)" if ($type == 10);
    print "\n    Size $size\n";
    print "    Size used $use\n";
    print "    Offset $ofs\n";
    $len -= 11;
  }
}

sub processINH(*$) {
  my $FH = shift;
  my $len = shift;

  while ($len > 0) {
    my $flag = read1($FH);
    my $n = read2($FH);
    my $loc = read2($FH);
    my $ilc = read2($FH);
    my $i = read2($FH);
    print "  Object ";
    printObj($n);
    print ":\n    Flags $flag\n";
    print "    Loc ";
    printObj($loc);
    print "\n    Ilc ";
    printObj($ilc);
    print "\n    Superclasses:";
    for (my $j = 0; $j < $i; $j++) {
      print " ";
      printObj(read2($FH));
    }
    print "\n";
    $len -= (9 + 2 * $i);
  }
}

sub processREQ(*$) {
  my $FH = shift;
  my $len = shift;

  my @reqnames = ("Me", "takeVerb", "strObj", "numObj", "pardon",
		  "againVerb", "init", "preparse", "parseError",
		  "cmdPrompt", "parseDisambig", "parseError2",
		  "parseDefault", "parseAskobj", "preparseCmd",
		  "parseAskobjActor", "parseErrorParam", "commandAfterRead",
		  "initRestore", "parseUnknownVerb", "parseNounPhrase",
		  "postAction", "endCommand", "preCommand",
		  "parseAskobjIndirect");

  foreach $name(@reqnames) {
    return if ($len <= 0);
    print "  $name: "; printObj(read2($FH)); print "\n";
    $len -= 2;
  }
}

sub processFMTSTR(*$) {
  my $FH = shift;
  my $len = shift;

  my $block;
  $len = read2($FH);
  read($FH, $block, $len);
  $block = decode($block);

  my $pos = 0;
  while ($pos < $len) {
    my $strlen = ord2($block, $pos + 2);
    print "  ", substr($block, $pos + 4, $strlen - 2), " -> ";
    printProp(ord2($block, $pos));
    print "\n";
    $pos += $strlen + 2;
  }
}

sub processCMPD(*$) {
  my $FH = shift;
  my $len = shift;

  my $block;
  $len = read2($FH);
  read($FH, $block, $len);
  $block = decode($block);

  my $pos = 0, $i = 0;

  while ($pos < $len) {
    my $thislen = ord2($block, $pos);
    print "  " if ($i % 3 == 0);
    print substr($block, $pos + 2, $thislen - 2);
    print " " if ($i % 3 == 0);
    print " => " if ($i % 3 == 1);
    print "\n" if ($i % 3 == 2);
    $i++;
    $pos += $thislen;
  }
  print "\n" unless ($i % 3 == 0);
}

sub processSPECWORD(*$) {
  my $FH = shift;
  my $len = shift;

  my $block;
  $len = read2($FH);
  read($FH, $block, $len);
  $block = decode($block);

  my $pos = 0;
  while ($pos < $len) {
    $flags = ord1($block, $pos);
    $strlen = ord1($block, $pos + 1);
    print "  ", substr($block, $pos + 2, $strlen),
      ", flags ", $flags, "\n";
    $pos += $strlen + 2;
  }
}

sub processVOC(*$) {
  my $FH = shift;
  my $len = shift;

  my $pos = 0;

  while ($pos < $len) {
    my $len1 = read2($FH);
    my $len2 = read2($FH);
    my $prpnum = read2($FH);
    my $objnum = read2($FH);
    my $classflg = read2($FH);

    my $block;
    read($FH, $block, $len1 + $len2);
    $block = decode($block);
    print "  ", substr($block, 0, $len1);
    print " ", substr($block, $len1, $len2) if ($len2 != 0);

    print "\n    Prpnum: ";
    printProp($prpnum);
    print "\n    Object: ";
    printObj($objnum);
    print "\n    Class flags: $classflg\n";

    $pos += 10 + $len1 + $len2;
  }
}

if ($#ARGV >= 1 && $ARGV[0] eq '-s') {
  unless ($return = do $ARGV[1]) {
    warn "couldn't parse file: $@" if $@;
    warn "couldn't do $ARGV[1]: $!" unless defined ($return);
    warn "couldn't run $ARGV[1]" unless $return;
  }
  splice(@ARGV, 0, 2);
}
if ($#ARGV != 0) {
  die "Usage: untads [-s symbols] file.gam\n";
}

open(GAM, $ARGV[0]) || die("Couldn't find file $ARGV[0]");
# Assume for now that it is a TADS game; skip to the header flags
seek(GAM, 20, SEEK_SET);
$flags = read1(GAM);
$crypt = $flags & 8;
seek(GAM, 48, SEEK_SET);

for (;;) {
  $namelen = read1(GAM);
  read(GAM, $name, $namelen);
  $nextofs = read4(GAM);
  $curofs = tell(GAM);
  $sectlen = $nextofs - $curofs;
  if ($name eq '$EOF') {
    print "\$EOF marker\n";
    close GAM;
    exit(0);
  }
  print "Section $name: $sectlen bytes ($curofs to $nextofs)\n";

  processXSI(GAM, $sectlen) if ($name eq 'XSI');
  processOBJ(GAM, $sectlen) if ($name eq 'OBJ');
  processFST(GAM, $sectlen) if ($name eq 'FST');
  processINH(GAM, $sectlen) if ($name eq 'INH');
  processREQ(GAM, $sectlen) if ($name eq 'REQ');
  processFMTSTR(GAM, $sectlen) if ($name eq 'FMTSTR');
  processCMPD(GAM, $sectlen) if ($name eq 'CMPD');
  processSPECWORD(GAM, $sectlen) if ($name eq 'SPECWORD');
  processVOC(GAM, $sectlen) if ($name eq 'VOC');

  seek(GAM, $nextofs, SEEK_SET);
}