#!/usr/bin/perl -w

=head1 NAME

detads - decompile TADS 2 .GAM files

=head1 SYNOPSIS

B<detads> [B<-c>] [B<-s> I<file>] I<file>

=head1 DESCRIPTION

detads is a Perl script which (mostly) decompiles TADS 2 game files.
The decompiled TADS 2 source code is printed to stdout.

=head1 OPTIONS

=over 4

=item B<-c>

Decompile for the more C-like syntax (activated by #pragma C+ in
TADS source).  Default is to decompile for the default syntax.

=item B<-s> I<file>

Input a symbols file.  The I<file> is a Perl script which can set
several global variables, which control the names given to identifiers.
For example:

    $objs[23] = 'redHerring';
    $objs[35] = 'myFunction';
    $props[312] = 'dontAnnoyMe';
    $propArgs[312] = ['actor', 'maxAnnoyance'];
    $actions[40] = 'Sneezeat';

Note that it is not necessary (or desirable) to set names for builtin
properties, objects and functions used directly by the builtin parser,
or action methods (such as verDoSneezeat or doSneezeat in the above
example).

=item I<file>

The TADS game file to be decompiled.

=back

=head1 BUGS

Sometimes, because values don't get popped off the runtime stack in
certain situations, the decompiler outputs errors.  For example:

    f: function(arg1) {
        local local1, local2;

        g(arg1 + local1);
        // ERROR: nonempty stack
        // local1 := 1
        ...
    }

This comes from the code:

    f: function(arg1) {
        local local1 := 1, local2;

        g(arg1 + local1);
        ...
    }

Similarly, output such as:

    local3 := 4;
    // ERROR: nonempty stack
    // local2 := foo;
    // local1 := 0;
    while (local1 < 10) {
        ...
        local1++;
    }

comes from the code:

    for (local1 := 0, local2 := foo, local3 := 4; local1 < 10; local1++) {
        ...
    }

Objects and functions will almost certainly not be output in the order
they were defined in the original source code.

The decompiler cannot detect `for' statements (as hinted above), or
`modify' or `replace' directives.

=head1 COPYRIGHT AND LICENSE

Copyright 2003 by Daniel Schepler.

This program is free software; you may redistribute it and/or modify
it under the terms of the GNU General Public License, version 2 or
later.

=head1 AUTHOR

Daniel Schepler <schepler@math.berkeley.edu>

=cut

use Fcntl qw(SEEK_SET);
use integer;

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

# 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 valueStr($$$) {
  my $block = shift;
  my $pos = shift;
  my $type = shift;

  if ($type == DAT_NUMBER) {
      return (ord4($block, $pos), $pos + 4);
  }
  elsif ($type == DAT_OBJECT || $type == DAT_FNADDR) {
      return (($type == DAT_FNADDR ? "&" : "") . objStr(ord2($block, $pos)),
	      $pos + 2);
  }
  elsif ($type == DAT_PROPNUM) {
      return ("&" . propStr(ord2($block, $pos)), $pos + 2);
  }
  elsif ($type == DAT_SSTRING || $type == DAT_DSTRING) {
      my ($str, $newpos) = stringStr($block, $pos,
				     $type == DAT_SSTRING ? "'" : '"');
      return ($str, $newpos);
  }
  elsif ($type == DAT_LIST) {
      my ($str, $newpos) = listStr($block, $pos);
      return ($str, $newpos);
  }
  elsif ($type == DAT_NIL) {
      return ("nil", $pos);
  }
  elsif ($type == DAT_TRUE) {
      return ("true", $pos);
  }
  else {
      warn "Unexpected data type: $type";
      return ("", length($block));
  }
}

sub listStr($$) {
  my $block = shift;
  my $pos = shift;
  my $result = "[";

  my $len = ord2($block, $pos);
  my $endpos = $pos + $len;
  my $str;

  $pos += 2;
  while ($pos < $endpos) {
    my $type = ord1($block, $pos);
    $pos++;
    ($str, $pos) = valueStr($block, $pos, $type);
    $result .= $str;
    $result .= ", " if $pos < $endpos;
  }
  $result .= "]";
  return ($result, $endpos);
}

@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 propStr($) {
  my $n = shift;

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

@objs = ();

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

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

sub builtinStr($) {
    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) {
    return "builtin$n";
  }
  else {
    return $builtins[$n];
  }
}

@propArgs = (undef, undef, undef, undef, undef, undef,
	     undef, undef, undef, undef,
	     ['actor', 'prep', 'iobj'], # doDefault
	     ['actor', 'prep'], # ioDefault
	     undef, undef, undef,
	     ['actor', 'verb', 'dobj', 'prep', 'iobj'], # roomAction
	     ['verb', 'dobj', 'prep', 'iobj'], # actorAction
	     undef, undef, undef, undef,
	     ['actor', 'obj', 'seqno'], # validDo
	     ['actor', 'obj', 'seqno'], # validIo
	     ['verbosity'],	# lookAround
	     ['verb'],	# roomCheck
	     undef, undef,
	     ['vantage'],	# isVisible
	     ['actor', 'dolist', 'iolist', 'prep'], # cantReach
	     undef, undef,
	     ['actor'],	# action
	     ['actor', 'prep', 'iobj'], # validDoList
	     ['actor', 'prep', 'dobj'], # validIoList
	     ['actor', 'verb', 'dobj', 'prep'], # iobjGen
	     ['actor', 'verb', 'iobj', 'prep'], # dobjGen
	     ['prep'],	# rejectMultiDobj
	     ['dest'],	# moveInto
	     undef, undef, undef, undef, undef, undef, undef, undef,
	     ['num'],		# anyvalue
	     ['actor', 'verb', 'num'], # newNumbered
	     undef,
	     ['actor', 'prep', 'iobj', 'wordlist'], # parseUnknownDobj
	     ['actor', 'prep', 'iobj', 'wordlist'], # parseUnknownIobj
	     ['actor', 'prep', 'iobj', 'prep'], # dobjCheck
	     ['actor', 'prep', 'iobj', 'prep'], # iobjCheck
	     ['actor', 'dobj', 'prep', 'iobj'], # verbAction
	     ['actor', 'prep', 'iobj', 'verprop', 'wordlist', 'objlist',
	       'flaglist', 'numberWanted', 'isAmbiguous', 'silent'],
				# disambigDobj
	     ['actor', 'prep', 'dobj', 'verprop', 'wordlist', 'objlist',
	       'flaglist', 'numberWanted', 'isAmbiguous', 'silent'],
				# disambigIobj
	     ['show', 'current_index', 'count', 'multi_flags'], # prefixdesc
	     undef
);
@funcArgs = ();

sub localStr($$) {
    my $num = shift;
    my $propNum = shift;	# Negative for function

    if ($num < 0) {
	my $argList = ($propNum < 0 ? $funcArgs[-$propNum] :
		       $propArgs[$propNum]);
	if (defined $argList && -1 - $num <= $#{$argList}) {
	    return $argList->[-1 - $num];
	}
	else {
	    return "arg" . (-$num);
	}
    }
    else {
	return "local$num";
    }
}

sub stringStr($$$) {
    my $block = shift;
    my $pos = shift;
    my $delim = shift;

    my $strlen = ord2($block, $pos);
    my $str = substr($block, $pos + 2, $strlen - 2);
    $str =~ s/$delim/\\$delim/g;
    return ($delim . $str . $delim, $pos + $strlen);
}

sub indentStr($) {
    my $level = shift;
    return ("\t" x ($level / 2)) . ("    " x ($level % 2));
}

sub funcArgs($) {
    my $num = shift;
    return "" if $num == 0;

    my @args = splice(@stack, -$num);
    splice(@precstack, -$num);
    return "(" . join(", ", reverse(@args)) . ")";
}

# The possible precedence levels:
# 14: atoms (numbers or symbols)
# 13: . []; function calls
# 12: ++ --
# 11: unary operators (-, not, ~, delete, new)
# 10: * / %
# 9: + -
# 8: << >>
# 7: comparisons
# 6: &
# 5: ^
# 4: |
# 3: and
# 2: or
# 1: ?:
# 0: assignments

sub doBinaryOp($$) {
    my $op = shift;
    my $prec = shift;

    my $arg2 = pop(@stack);
    $arg2 = "($arg2)" if pop(@precstack) <= $prec;
    my $arg1 = pop(@stack);
    $arg1 = "($arg1)" if pop(@precstack) < $prec;

    push(@stack, "$arg1 $op $arg2");
    push(@precstack, $prec);
}

sub doUnaryOp($$) {
    my $op = shift;
    my $prec = shift;

    my $arg = pop(@stack);
    $arg = "($arg)" if pop(@precstack) < $prec;

    push(@stack, "$op $arg");
    push(@precstack, $prec);
}

sub checkStack($) {
    my $indentLevel = shift;
    my $nonempty = 0;

    foreach my $elt (@stack) {
	$nonempty = 1 unless $elt eq "*SAYEXPR*";
    }
    if ($nonempty) {
	if ($#lines == -1) {
	    push(@lines, "");
	    push(@labels, -1);
	}
	$lines[$#lines] .= "\n" . indentStr($indentLevel) .
	    "// ERROR: nonempty stack";
	while ($#stack >= 0) {
	    $elt = pop(@stack);
	    pop(@precstack);
	    next if $elt eq "*SAYEXPR*";
	    $lines[$#lines] .= "\n" . indentStr($indentLevel) .
		"// $elt";
	}
    }
    else {
	@stack = ();
    }
}

$cmode = 0;

sub decompileBlock {
    my $block = shift;
    my $propNum = shift;
    my $startpos = shift;
    my $endpos = shift;
    my $breakLabel = shift;
    my $continueLabel = shift;
    my $indentLevel = shift;

    my $pos = $startpos;
    my $reachable = 1;
    my $linepos = $pos;
    while ($pos < $endpos || ($endpos == -1 &&
			      ($reachable || $pos <= $maxLabel))) {
	my $opcode = ord1($block, $pos);
	my $str;

	# Only a few opcodes don't fall through to the next
	$reachable = 1;
	$pos++;
	if ($opcode == 1) {	# pushnum
	    push(@stack, ord4($block, $pos));
	    push(@precstack, 14);
	    $pos += 4;
	}
	elsif ($opcode == 2) {	# pushobj
	    push(@stack, objStr(ord2($block, $pos)));
	    push(@precstack, 14);
	    $pos += 2;
	}
	elsif ($opcode == 3) {	# neg
	    doUnaryOp("-", 11);
	}
	elsif ($opcode == 4) {	# not
	    doUnaryOp("not", 11);
	}
	elsif ($opcode == 5) {	# add
	    doBinaryOp("+", 9);
	}
	elsif ($opcode == 6) {	# sub
	    doBinaryOp("-", 9);
	}
	elsif ($opcode == 7) {	# mul
	    doBinaryOp("*", 10);
	}
	elsif ($opcode == 8) {	# div
	    doBinaryOp("/", 10);
	}
	elsif ($opcode == 9) {	# and
	    doBinaryOp($cmode ? "&&" : "and", 3);
	}
	elsif ($opcode == 10) {	# or
	    doBinaryOp($cmode ? "||" : "or", 2);
	}
	elsif ($opcode == 11) {	# eq
	    doBinaryOp($cmode ? "==" : "=", 7);
	}
	elsif ($opcode == 12) {	# ne
	    doBinaryOp($cmode ? "!=" : "<>", 7);
	}
	elsif ($opcode == 13) {	# gt
	    doBinaryOp(">", 7);
	}
	elsif ($opcode == 14) {	# ge
	    doBinaryOp(">=", 7);
	}
	elsif ($opcode == 15) {	# lt
	    doBinaryOp("<", 7);
	}
	elsif ($opcode == 16) {	# le
	    doBinaryOp("<=", 7);
	}
	elsif ($opcode == 17) {	# call
	    my $obj = objStr(ord2($block, $pos + 1));
	    push(@stack, $obj . funcArgs(ord1($block, $pos)));
	    $stack[$#stack] .= "()" if ord1($block, $pos) == 0;
	    push(@precstack, 13);
	    $pos += 3;
	}
	elsif ($opcode == 18) {	# getp
	    my $prop = propStr(ord2($block, $pos + 1));
	    my $obj = pop(@stack);
	    $obj = "($obj)" if pop(@precstack) < 13;
	    push(@stack, "$obj.$prop" . funcArgs(ord1($block, $pos)));
	    push(@precstack, 13);
	    $pos += 3;
	}
	elsif ($opcode == 20) {	# getlcl
	    my $num = ord2s($block, $pos);
	    $pos += 2;
	    push(@stack, localStr($num, $propNum));
	    push(@precstack, 14);
	}
	elsif ($opcode == 22) {	# return
	    $pos += 2;
	    $reachable = 0;

	    # Check to see if it will be the last; if so, don't bother
	    # printing the statement
	    if ($endpos != -1 || $pos <= $maxLabel) {
		push(@lines, indentStr($indentLevel) . "return;");
	    }
	    # But do make the label available for the top-level
	    # decompile, in case it's needed
	    push(@labels, $linepos);
	    $linepos = $pos;
	    checkStack($indentLevel);
	}
	elsif ($opcode == 23) {	# retval
	    $pos += 2;
	    $reachable = 0;

	    push(@lines, indentStr($indentLevel) . "return " .
		 pop(@stack) . ";");
	    pop(@precstack);
	    push(@labels, $linepos);
	    $linepos = $pos;
	    checkStack($indentLevel);
	}
	elsif ($opcode == 25) {	# discard
	    my $expr = pop(@stack);
	    pop(@precstack);

	    unless ($expr eq "*SAYEXPR*") { # See "builtin" case below
		push(@lines, indentStr($indentLevel) . "$expr;");
		push(@labels, $linepos);
	    }
	    $linepos = $pos;
	    checkStack($indentLevel);
	}
	elsif ($opcode == 26) {	# jmp
	    my $dest = $pos + ord2s($block, $pos);
	    $pos += 2;

	    if ($dest == $breakLabel) {
		push(@lines, indentStr($indentLevel) . "break;");
	    }
	    elsif ($dest == $continueLabel) {
		push(@lines, indentStr($indentLevel) . "continue;");
	    }
	    else {
		push(@lines, indentStr($indentLevel) . "goto label$dest;");
		$labelNeeded{$dest} = 1;
		$maxLabel = $dest if $dest > $maxLabel;
	    }

	    push(@labels, $linepos);
	    $linepos = $pos;
	    checkStack($indentLevel);
	}
	elsif ($opcode == 27) {	# jf
	    my $dest = $pos + ord2s($block, $pos);
	    $pos += 2;

	    if ($dest < $startpos || ($endpos != -1 && $dest > $endpos)) {
		# Oops, it's a jump outside this block
		push(@lines, indentStr($indentLevel) . "if (not (" .
		     pop(@stack) . ")) goto label$dest;");
		pop(@precstack);
		push(@labels, $linepos);
		$labelNeeded{$dest} = 1;
		$maxLabel = $dest if $dest > $maxLabel;
		$linepos = $pos;
		checkStack($indentLevel);
	    }
	    elsif (ord1($block, $dest - 3) == 26 && # jmp
		($dest - 2) + ord2s($block, $dest - 2) == $linepos) {
		# A while statement
		push(@lines, indentStr($indentLevel) .
		     "while (" . pop(@stack) . ") {");
		pop(@precstack);
		push(@labels, $linepos);

		decompileBlock($block, $propNum, $pos, $dest - 3,
			       $dest, $linepos, $indentLevel + 1);

		push(@lines, indentStr($indentLevel) . "}");
		push(@labels, $dest - 3);

		$pos = $dest;
		$linepos = $pos;
		checkStack($indentLevel);
	    }
	    elsif ($dest > $pos + 3 && # Decompile "if (cond) break;" correctly
		   ord1($block, $dest - 3) == 26 &&
		   ord2s($block, $dest - 2) > 0 &&
		   ($endpos == -1 ||
		    ($dest - 2) + ord2s($block, $dest - 2) <= $endpos)) {
		# An if/else statement -- or ?: expression
		my $endElse = $dest - 2 + ord2s($block, $dest - 2);
		my $cond = pop(@stack);
		my $condprec = pop(@precstack);

		if ($linepos == $startpos && $endElse == $endpos &&
		    $#lines >= 0 && $lines[$#lines] eq
		    (indentStr($indentLevel - 1) . "} else {")) {
		    # Contract to "else if (...)" -- the contents of
		    # an else statement shouldn't be a ?: expression
		    # without even a discard
		    $lines[$#lines] = indentStr($indentLevel - 1) .
			"} else if ($cond) {";
		    decompileBlock($block, $propNum, $pos, $dest - 3,
				   $breakLabel, $continueLabel,
				   $indentLevel);
		    checkStack($indentLevel);
		    push(@lines, indentStr($indentLevel - 1) . "} else {");
		    push(@labels, $dest - 3);

		    decompileBlock($block, $propNum, $dest, $endElse,
				   $breakLabel, $continueLabel,
				   $indentLevel);
		    # The outer decompile will provide the }
		    $linepos = $endElse;
		    checkStack($indentLevel);
		}
		else {
		    push(@lines, indentStr($indentLevel) .
			 "if ($cond) {");
		    push(@labels, $linepos);

		    my $oldline = $#lines;
		    decompileBlock($block, $propNum, $pos, $dest - 3,
				   $breakLabel, $continueLabel,
				   $indentLevel + 1);
		    if ($#lines == $oldline) {
			# No output -- assume it's a ?: expression
			pop(@lines); # Remove "if" line
			pop(@labels);
			$cond = "($cond)" if $condprec <= 1;

			my $trueexpr = pop(@stack);
			$trueexpr = "($trueexpr)" if pop(@precstack) <= 1;

			decompileBlock($block, $propNum, $dest, $endElse,
				       $breakLabel, $continueLabel,
				       $indentLevel + 1);
			my $falseexpr = pop(@stack);
			$falseexpr = "($falseexpr)" if pop(@precstack) <= 1;

			push(@stack, "$cond ? $trueexpr : $falseexpr");
			push(@precstack, 1);
		    }
		    else {
			checkStack($indentLevel);
			push(@lines, indentStr($indentLevel) .
			     "} else {");
			push(@labels, $dest - 3);

			decompileBlock($block, $propNum, $dest, $endElse,
				       $breakLabel, $continueLabel,
				       $indentLevel + 1);
			$lines[$#lines] .= "\n" . indentStr($indentLevel) .
			    "}";
			$linepos = $endElse;
			checkStack($indentLevel);
		    }
		}

		$pos = $endElse;
	    }
	    else {
		# A plain if statement
		if ($linepos == $startpos && $dest == $endpos &&
		    $#lines >= 0 && $lines[$#lines] eq
		    (indentStr($indentLevel - 1) . "} else {")) {
		    # Contract to "else if (...)"
		    $lines[$#lines] = indentStr($indentLevel - 1) .
			"} else if (" . pop(@stack) . ") {";
		    pop(@precstack);
		    checkStack($indentLevel);

		    decompileBlock($block, $propNum, $pos, $dest,
				   $breakLabel, $continueLabel,
				   $indentLevel);
		    # The outer decompile will provide the }
		}
		else {
		    push(@lines, indentStr($indentLevel) .
			 "if (" . pop(@stack) . ") {");
		    pop(@precstack);
		    push(@labels, $linepos);
		    checkStack($indentLevel);

		    decompileBlock($block, $propNum, $pos, $dest,
				   $breakLabel, $continueLabel,
				   $indentLevel + 1);

		    $lines[$#lines] .= "\n" . indentStr($indentLevel) . "}";
		}
		$pos = $dest;
		$linepos = $pos;
		checkStack($indentLevel);
	    }
	}
	elsif ($opcode == 28) {	# pushself
	    push(@stack, "self");
	    push(@precstack, 14);
	}
	elsif ($opcode == 29) {	# say
	    ($str, $pos) = stringStr($block, $pos, '"');
	    # Try to combine with a previous string ending with
	    # printing an expression
	    if ($#lines >= 0 && substr($lines[$#lines], -4) eq '>>";') {
		$lines[$#lines] = substr($lines[$#lines], 0, -2) .
		    substr($str, 1) . ";";
	    }
	    else {
		push(@lines, indentStr($indentLevel) . "$str;");
		push(@labels, $linepos);
	    }
	    $linepos = $pos;
	}
	elsif ($opcode == 30) {	# builtin
	    # Special case: say with 2 arguments is used to implement
	    # "<< expr >>".  The pop of the result isn't reliable, so
	    # push a special token.
	    if (builtinStr(ord2($block, $pos + 1)) eq "say" &&
		ord1($block, $pos) == 2) {
		my $expr = pop(@stack);
		pop(@precstack);
		pop(@stack);	# Usually nil for second argument
		pop(@precstack);

		# Try to combine with a previous string
		if ($#lines >= 0 && substr($lines[$#lines], -2) eq '";') {
		    $lines[$#lines] = substr($lines[$#lines], 0, -2) .
			"<< $expr >>\";";
		}
		else {
		    push(@lines, indentStr($indentLevel) .
			 "\"<< $expr >>\";");
		    push(@labels, $linepos);
		}
		push(@stack, "*SAYEXPR*");
		push(@precstack, 14);
	    }
	    else {
		push(@stack, builtinStr(ord2($block, $pos + 1)) .
		     funcArgs(ord1($block, $pos)));
		$stack[$#stack] .= "()" if ord1($block, $pos) == 0;
		push(@precstack, 13);
	    }
	    $pos += 3;
	}
	elsif ($opcode == 31) {	# pushstr
	    my $str;
	    ($str, $pos) = stringStr($block, $pos, "'");
	    push(@stack, $str);
	    push(@precstack, 14);
	}
	elsif ($opcode == 32) {	# pushlst
	    my $str;
	    ($str, $pos) = listStr($block, $pos);
	    push(@stack, $str);
	    push(@precstack, 14);
	}
	elsif ($opcode == 33) {	# pushnil
	    push(@stack, "nil");
	    push(@precstack, 14);
	}
	elsif ($opcode == 34) {	# pushtrue
	    push(@stack, "true");
	    push(@precstack, 14);
	}
	elsif ($opcode == 35) {	# pushfn
	    push(@stack, "&" . objStr(ord2($block, $pos)));
	    push(@precstack, 14);
	    $pos += 2;
	}
	elsif ($opcode == 40) {	# ptrgetp
	    my $prop = pop(@stack);
	    pop(@precstack);	# It needs parentheses in all cases
	    my $obj = pop(@stack);
	    $obj = "($obj)" if pop(@precstack) < 13;

	    push(@stack, "$obj.($prop)" . funcArgs(ord1($block, $pos)));
	    push(@precstack, 13);
	    $pos++;
	}
	elsif ($opcode == 41) {	# pass
	    my $prop = propStr(ord2($block, $pos));
	    $pos += 2;
	    push(@lines, indentStr($indentLevel) . "pass $prop;");
	    push(@labels, $linepos);
	    $linepos = $pos;
	    checkStack($indentLevel);
	}
	elsif ($opcode == 42) {	# exit
	    push(@lines, indentStr($indentLevel) . "exit;");
	    push(@labels, $linepos);
	    $linepos = $pos;
	    checkStack($indentLevel);
	}
	elsif ($opcode == 43) {	# abort
	    push(@lines, indentStr($indentLevel) . "abort;");
	    push(@labels, $linepos);
	    $linepos = $pos;
	    checkStack($indentLevel);
	}
	elsif ($opcode == 44) {	# askdo
	    push(@lines, indentStr($indentLevel) . "askdo;");
	    push(@labels, $linepos);
	    $linepos = $pos;
	    checkStack($indentLevel);
	}
	elsif ($opcode == 45) {	# askio
	    push(@lines, indentStr($indentLevel) . "askio(" .
		 propStr(ord2($block, $pos)) . ");");
	    push(@labels, $linepos);
	    $pos += 2;
	    $linepos = $pos;
	    checkStack($indentLevel);
	}
	elsif ($opcode == 46) {	# expinh
	    push(@stack, "inherited " . objStr(ord2($block, $pos + 3)) .
		 "." . propStr(ord2($block, $pos + 1)) .
		 funcArgs(ord1($block, $pos)));
	    push(@precstack, 13);
	    $pos += 5;
	}
	elsif ($opcode == 59) {	# jt
	    # Used to implement a do/while statement
	    my $dest = $pos + ord2s($block, $pos);
	    $pos += 2;
	    if ($dest >= $pos || $dest < $startpos) {
		# Oops, it's a jump forward or to before this block...
	      noline:
		push(@lines, indentStr($indentLevel) . "if (" .
		     pop(@stack) . ") goto label$dest;");
		pop(@precstack);
		push(@labels, $linepos);
		$labelNeeded{$dest} = 1;
		$linepos = $pos;
		checkStack($indentLevel);
	    }
	    else {
		# Search for the beginning
		my $line = 0;
		$line++ while ($line < $#labels && $labels[$line] < $dest);
		goto noline unless $labels[$line] == $dest;
		my $cond = pop(@stack);
		pop(@precstack);

		# Delete everything inside the block, and do it over
		splice(@lines, $line);
		splice(@labels, $line);
		decompileBlock($block, $propNum, $dest, $linepos,
			       $pos, $linepos, $indentLevel + 1);

		$lines[$line] = indentStr($indentLevel) . "do {\n" .
		    $lines[$line];
		push(@lines, indentStr($indentLevel) . "} while ($cond);");
		push(@labels, $linepos);
		$linepos = $pos;
		checkStack($indentLevel);
	    }
	}
	elsif ($opcode == 60) {	# getpself
	    my $prop = propStr(ord2($block, $pos + 1));
	    push(@stack, "self.$prop" . funcArgs(ord1($block, $pos)));
	    push(@precstack, 13);
	    $pos += 3;
	}
	elsif ($opcode == 62) {	# getpobj
	    my $obj = objStr(ord2($block, $pos + 1));
	    my $prop = propStr(ord2($block, $pos + 3));
	    push(@stack, "$obj.$prop" . funcArgs(ord1($block, $pos)));
	    push(@precstack, 13);
	    $pos += 5;
	}
	elsif ($opcode == 64) {	# index
	    my $arg2 = pop(@stack);
	    pop(@precstack);
	    my $arg1 = pop(@stack);
	    $arg1 = "($arg1)" if pop(@precstack) < 13;
	    push(@stack, $arg1 . "[" . $arg2 . "]");
	    push(@precstack, 13);
	}
	elsif ($opcode == 67) {	# pushpn
	    push(@stack, "&" . propStr(ord2($block, $pos)));
	    push(@precstack, 14);
	    $pos += 2;
	}
	elsif ($opcode == 68) {	# jst
	    # Used to implement an || operation; call decompileBlock
	    # recursively to get the other argument
	    my $dest = $pos + ord2s($block, $pos);
	    $pos += 2;
	    decompileBlock($block, $propNum, $pos, $dest,
			   $breakLabel, $continueLabel, $indentLevel);

	    doBinaryOp($cmode ? "||" : "or", 2);

	    $pos = $dest;
	}
	elsif ($opcode == 69) {	# jsf
	    # Used to implement an && operation; call decompileBlock
	    # recursively to get the other argument
	    my $dest = $pos + ord2s($block, $pos);
	    $pos += 2;
	    decompileBlock($block, $propNum, $pos, $dest,
			   $breakLabel, $continueLabel, $indentLevel);

	    doBinaryOp($cmode ? "&&" : "and", 3);

	    $pos = $dest;
	}
	elsif ($opcode == 71) {	# inherit
	    my $prop = propStr(ord2($block, $pos + 1));
	    push(@stack, "inherited.$prop" .
		 funcArgs(ord1($block, $pos)));
	    push(@precstack, 13);
	    $pos += 3;
	}
	elsif ($opcode == 74) {	# cons
	    my @args = splice(@stack, -ord2($block, $pos));
	    splice(@precstack, -ord2($block, $pos));

	    push(@stack, "[" . join(", ", reverse(@args)) . "]");
	    push(@precstack, 14);
	    $pos += 2;
	}
	elsif ($opcode == 75) {	# switch
	    my $swtable = $pos + ord2s($block, $pos);
	    $pos += 2;

	    my $swlen = ord2($block, $swtable);
	    my $swpos = $swtable + 2;
	    my @swcases = ();
	    my @swdests = ();
	    for (my $i = 0; $i < $swlen; $i++) {
		my $str;
		my $swopcode = ord1($block, $swpos);
		$swpos++;

		if ($swopcode == 1) { # pushint
		    $str = ord4($block, $swpos);
		    $swpos += 4;
		}
		elsif ($swopcode == 2) { # pushobj
		    $str = objStr(ord2($block, $swpos));
		    $swpos += 2;
		}
		elsif ($swopcode == 31) { # pushstr
		    ($str, $swpos) = stringStr($block, $swpos, "'");
		}
		else {
		    die "Unimplemented or invalid opcode $swopcode for switch";
		}
		push(@swcases, $str);
		push(@swdests, $swpos + ord2s($block, $swpos));
		$swpos += 2;
	    }
	    push(@swdests, $swpos + ord2s($block, $swpos)); # default
	    $swpos += 2;

	    push(@lines, indentStr($indentLevel) . "switch (" .
		 pop(@stack) . ") {");
	    pop(@precstack);
	    push(@labels, $linepos);
	    checkStack($indentLevel);
	    for (my $i = 0; $i <= $#swcases; $i++) {
		$lines[$#lines] .= "\n" . indentStr($indentLevel) .
		    "case $swcases[$i]:";
		if ($swdests[$i + 1] > $swtable) {
		    decompileBlock($block, $propNum,
				   $swdests[$i], $swtable - 3,
				   $swpos, $continueLabel, $indentLevel + 1);
		}
		elsif ($swdests[$i + 1] > $swdests[$i]) {
		    decompileBlock($block, $propNum,
				   $swdests[$i], $swdests[$i + 1],
				   $swpos, $continueLabel, $indentLevel + 1);
		}
		checkStack($indentLevel);
	    }

	    if ($swdests[$#swdests] < $swtable) {
		$lines[$#lines] .= "\n" . indentStr($indentLevel) .
		    "default:";
		decompileBlock($block, $propNum,
			       $swdests[$#swdests], $swtable - 3,
			       $swpos, $continueLabel, $indentLevel + 1);
		# $swtable - 3 skips the implicit "break" statement
		checkStack($indentLevel);
	    }

	    $lines[$#lines] .= "\n" . indentStr($indentLevel) . "}";
	    $pos = $swpos;
	    $linepos = $pos;
	}
	elsif ($opcode == 76) {	# argc
	    push(@stack, "argc");
	    push(@precstack, 14);
	}
	elsif ($opcode == 83) {	# mod
	    doBinaryOp("%", 10);
	}
	elsif ($opcode == 84) {	# band
	    doBinaryOp("&", 6);
	}
	elsif ($opcode == 85) {	# bor
	    doBinaryOp("|", 4);
	}
	elsif ($opcode == 86) {	# xor
	    doBinaryOp("^", 5);
	}
	elsif ($opcode == 87) {	# bnot
	    doUnaryOp("~", 11);
	}
	elsif ($opcode == 88) {	# shl
	    doBinaryOp("<<", 8);
	}
	elsif ($opcode == 89) {	# shr
	    doBinaryOp(">>", 8);
	}
	elsif ($opcode == 90) {	# new
	    doUnaryOp("new", 11);
	}
	elsif ($opcode == 91) {	# delete
	    doUnaryOp("delete", 11);
	}
	elsif (($opcode & 0xc0) == 0xc0) { # Assignment
	    my $ext = 0;
	    if (($opcode & 0x1c) == 0x1c) {
		$ext = ord1($block, $pos);
		$pos++;
	    }

	    my $dest;
	    if (($opcode & 3) == 0) {
		my $num = ord2s($block, $pos);
		$pos += 2;
		$dest = localStr($num, $propNum);
	    }
	    elsif (($opcode & 3) == 1) {
		my $prop = propStr(ord2s($block, $pos));
		$pos += 2;
		my $obj = pop(@stack);
		$obj = "($obj)" if pop(@precstack) < 13;
		$dest = "$obj.$prop";
	    }
	    elsif (($opcode & 3) == 2) {
		my $index = pop(@stack);
		pop(@precstack);
		my $list = pop(@stack);
		$list = "($list)" if pop(@precstack) < 13;
		$dest = $list . "[" . $index . "]";
	    }
	    elsif (($opcode & 3) == 3) {
		my $prop = pop(@stack);
		pop(@precstack);
		my $obj = pop(@stack);
		$obj = "($obj)" if pop(@precstack) < 13;
		$dest = "$obj.($prop)";
	    }

	    if (($opcode & 0x1c) == 0x14 || ($opcode & 0x1c) == 0x18) {
		my $op = (($opcode & 0x1c) == 0x14 ? "++" : "--");
		if ($opcode & 0x20) {
		    push(@stack, "$op$dest");
		}
		else {
		    push(@stack, "$dest$op");
		}
		push(@precstack, 12);
	    }
	    else {
		my $op;
		$op = ($cmode ? "=" : ":=") if ($opcode & 0x1c) == 0x00;
		$op = "+=" if ($opcode & 0x1c) == 0x04;
		$op = "-=" if ($opcode & 0x1c) == 0x08;
		$op = "*=" if ($opcode & 0x1c) == 0x0c;
		$op = "/=" if ($opcode & 0x1c) == 0x10;
		$op = "%=" if $ext == 1;
		$op = "&=" if $ext == 2;
		$op = "|=" if $ext == 3;
		$op = "^=" if $ext == 4;
		$op = "<<=" if $ext == 5;
		$op = ">>=" if $ext == 6;
		my $val = pop(@stack);

		if (substr($val, 0, 10) eq "*NEWLIST* ") {
		    push(@stack, substr($val, 10));
		    # Keep same precedence
		}
		else {
		    pop(@precstack);
		    # Assignment is lowest precedence, and right associative
		    push(@stack, "$dest $op $val");
		    push(@precstack, 0);
		}
	    }

	    # Mark a list assignment for the later assignment back
	    # into the appropriate lvalue
	    if (($opcode & 3) == 2) {
		$stack[$#stack] = "*NEWLIST* $stack[$#stack]";
	    }
	}
	else {
	    print join("\n", @lines), "\n";
	    die "Unimplemented or invalid opcode $opcode";
	}
    }
    push(@labels, $pos) if $endpos == -1;
}

sub decompile($$) {
    my $block = shift;
    my $propNum = shift;

    my $pos = 0;
    if (ord1($block, $pos) == 77) { # chkargc
	my $numargs = ord1($block, $pos + 1);
	unless ($numargs == 0) {
	    print "(";
	    for (my $i = 1; $i <= ($numargs & 127); $i++) {
		print localStr(-$i, $propNum);
		print ", " if $i < ($numargs & 127);
	    }
	    print ", " if $numargs > 128;
	    print "..." if $numargs >= 128;
	    print ")";
	}
	$pos += 2;
    }
    print " =" if $propNum > 0;
    print " {\n";
    if (ord1($block, $pos) == 24) { # enter
	my $numlocals = ord2($block, $pos + 1);
	unless ($numlocals == 0) {
	    print indentStr($propNum > 0 ? 2 : 1), "local ";
	    for (my $i = 1; $i <= $numlocals; $i++) {
		print localStr($i, $propNum);
		print ", " if $i < $numlocals;
	    }
	    print ";\n\n";
	}
	$pos += 3;
    }

    # Preliminary setup
    %labelNeeded = ();
    @lines = ();
    @labels = ();
    @stack = ();
    @precstack = ();
    $maxLabel = 0;
    decompileBlock($block, $propNum, $pos, -1, -1, -1, $propNum > 0 ? 2 : 1);

    for (my $i = 0; $i <= $#lines; $i++) {
	my $label = $labels[$i];
	print "label$label:\n" if $labelNeeded{$label};
	print $lines[$i], "\n";
    }

    my $label = $labels[$#lines + 1];
    print "label$label:\n" if $labelNeeded{$label};
    print indentStr($propNum > 0 ? 1 : 0), "}";
}

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

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

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 $prop = ord2($block, $pos);
	my $str;
	($str, $pos) = stringStr($block, $pos + 2, "'");
	print "formatstring $str ", propStr($prop), ";\n";
    }
    print "\n";
}

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

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

    my $pos = 0;
    my $i = 0;
    my $str;

    while ($pos < $len) {
	print "compoundWord" if $i % 3 == 0;
	($str, $pos) = stringStr($block, $pos, "'");
	print " $str";
	print ";\n" if $i % 3 == 2;
	$i++;
    }
    print "\n";
}

sub printSpecwords($$$) {
    my $block = shift;
    my $pos = shift;
    my $flags = shift;

    my $i = 0, $result = 0;;

    print "    ";
    while (substr($block, $pos, 1) eq $flags) {
	print " = " if $i > 0;
	$strlen = ord1($block, $pos + 1);
	$str = substr($block, $pos + 2, $strlen);
	$str =~ s/\'/\\\'/g;
	print "'$str'";
	$pos += $strlen + 2;
	$result += $strlen + 2;
	$i++;
    }
    return $result;
}

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

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

    my $pos = 0;

    print "specialWords\n";
    foreach $c ('O', ',', '.', 'A', 'B', 'X', 'N', 'P', 'I', 'T',
		'M', 'R', 'Y') {
	$pos += printSpecwords($block, $pos, $c);
	print ",\n" unless $c eq 'Y';
	print ";\n\n" if $c eq 'Y';
    }
}

$actnum = 0;
@actions = ();

sub assignVerb($$$$) {
    my $verIoProp = shift;
    my $ioProp = shift;
    my $verDoProp = shift;
    my $doProp = shift;

    unless (defined $props[$doProp]) {
	my $actname = $actions[$actnum] || ("Action$actnum");
	$actnum++;
	$props[$verDoProp] = "verDo$actname";
	$propArgs[$verDoProp] =
	  ($verIoProp != 0 ? ['actor', 'iobj'] : ['actor']);;
	$props[$doProp] = "do$actname";
	$propArgs[$doProp] = $propArgs[$verDoProp];
	if ($verIoProp != 0) {
	    $props[$verIoProp] = "verIo$actname";
	    $propArgs[$verIoProp] = ['actor'];
	    $props[$ioProp] = "io$actname";
	    $propArgs[$ioProp] = ['actor', 'dobj'];
	}
    }
}

@objblocks = ();
@objtypes = ();

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

    read($FH, $block, $len);

    # Search for tpl2 properties; and while we're at it, save the
    # decoded object data
    my $pos = 0;

    while ($pos < $len) {
	my $type = ord1($block, $pos);
	my $n = ord2($block, $pos + 1);
	my $sizeuse = ord2($block, $pos + 5);
	my $objblock = decode(substr($block, $pos + 7, $sizeuse));
	$objblocks[$n] = $objblock;
	$objtypes[$n] = $type;

	if ($type == 2) {
	    my $flags = ord2($objblock, 2);
	    my $nsc = ord2($objblock, 4);
	    my $nprop = ord2($objblock, 6);
	    my $pos = 14 + 2 * $nsc;
	    $pos += 2 * $nprop if $flags & 2;

	    for (my $i = 0; $i < $nprop; $i++) {
		my $type = ord1($objblock, $pos + 2);
		my $size = ord2($objblock, $pos + 3);

		if ($type == DAT_TPL2) {
		    my $num = ord1($objblock, $pos + 6);
		    my $intpos = $pos + 7;
		    for (my $j = 0; $j < $num; $j++) {
			assignVerb(ord2($objblock, $intpos + 2),
				   ord2($objblock, $intpos + 4),
				   ord2($objblock, $intpos + 6),
				   ord2($objblock, $intpos + 8));
			$intpos += 16;
		    }
		}
		$pos += 6 + $size;
	    }
	}
	$pos += 7 + $sizeuse;
    }
}

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

    my @reqnames = ("Me", "takeVerb", "strObj", "numObj", "pardon",
		    "againVerb", "init", "preparse", "parseError",
		    "commandPrompt", "parseDisambig", "parseError2",
		    "parseDefault", "parseAskobj", "preparseCmd",
		    "parseAskobjActor", "parseErrorParam", "commandAfterRead",
		    "initRestore", "parseUnknownVerb", "parseNounPhrase",
		    "postAction", "endCommand", "preCommand",
		    "parseAskobjIndirect");
    my @reqargs = (undef, undef, undef, undef, undef, undef, undef,
		   ['cmd'],	# preparse
		   ['num', 'str'], # parseError
		   ['type'],	# commandPrompt
		   ['nameString', 'objList'], # parseDisambig
		   ['verb', 'dobj', 'prep', 'iobj'], # parseError2
		   ['obj', 'prep'], # parseDefault
		   ['verb'],	# parseAskobj
		   ['wordList'], # preparseCmd
		   ['actor', 'verb'], # parseAskobjActor
		   ['num', 'str'], # parseErrorParam
		   ['type'],	# commandAfterRead
		   undef,
		   ['actor', 'wordlist', 'typelist', 'errnum'],
				# parseUnknownVerb
		   ['wordlist', 'typelist', 'currentIndex',
		    'complainOnNoMatch', 'isActorCheck'], # parseNounPhrase
		   ['actor', 'verb', 'dobj', 'prep', 'iobj', 'status'],
				# postAction
		   ['actor', 'verb', 'dobj_list', 'prep', 'iobj', 'status'],
				# endCommand
		   ['actor', 'verb', 'dobj_list', 'prep', 'iobj'],
				# preCommand
		   ['actor', 'verb', 'prep', 'objectList']
				# parseAskobjIndirect
		  );

    foreach my $i (0..$#reqnames) {
	my $name = $reqnames[$i];
	my $args = $reqargs[$i];

	return if $len <= 0;
	my $obj = read2($FH);
	if ($obj != 65535) {
	    $objs[$obj] = $name;
	    $funcArgs[$obj] = $args if defined $args;
	}
	$len -= 2;
    }
}

@vocab = ();

sub preprocessVOC(*$) {
    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);

	unless ($classflg & 2) { # Skip if inherited
	    $block = decode($block);
	    my $str = substr($block, 0, $len1);
	    $str .= " " . substr($block, $len1, $len2) if $len2 != 0;
	    $str =~ s/\'/\\\'/g;

	    # Construct references as needed
	    $vocab[$objnum] = [] unless defined $vocab[$objnum];
	    $vocab[$objnum]->[$prpnum] = []
		unless defined $vocab[$objnum]->[$prpnum];

	    push(@{$vocab[$objnum]->[$prpnum]}, "'$str'");
	}
	$pos += 10 + $len1 + $len2;
    }
}

sub dumpObj($$) {
    my $block = shift;
    my $n = shift;

    my $flags = ord2($block, 2);
    my $nsc = ord2($block, 4);
    print "class " if $flags & 1;
    print objStr($n), ": ";
    for (my $i = 0; $i < $nsc; $i++) {
	print ", " if $i > 0;
	print objStr(ord2($block, 14 + 2 * $i));
    }
    print "object" if $nsc == 0;
    print "\n";

    # Dump vocabulary
    if (defined $vocab[$n]) {
	for (my $i = 0; $i <= $#{$vocab[$n]}; $i++) {
	    next unless defined $vocab[$n]->[$i];
	    print indentStr(1), propStr($i), " = ",
	    join(" ", @{$vocab[$n]->[$i]}), "\n";
	}
    }

    my $nprop = ord2($block, 6);
    my $pos = 14 + 2 * $nsc;
    $pos += 2 * $nprop if $flags & 2;

    for (my $i = 0; $i < $nprop; $i++) {
	my $num = ord2($block, $pos);
	my $type = ord1($block, $pos + 2);
	my $size = ord2($block, $pos + 3);

	if ($type == DAT_CODE) {
	    print indentStr(1), propStr($num);
	    decompile(substr($block, $pos + 6, $size), $num);
	    print "\n";
	}
	elsif ($type == DAT_SYN) {
	    my $synType = substr(propStr($num), 0, 2);
	    if ($synType eq 'do' || $synType eq 'io') {
		print "    ", $synType, "Synonym('",
		substr(propStr(ord2($block, $pos + 6)), 2), "') = '",
		substr(propStr($num), 2), "'\n";
	    }
	}
	elsif ($type == DAT_REDIR) {
	    my $synType = substr(propStr($num), 0, 2);
	    if ($synType eq 'do' || $synType eq 'io') {
		print "    ", propStr($num), " -> ",
		objStr(ord2($block, $pos + 6)), "\n";
	    }
	}
	elsif ($type == DAT_TPL2) {
	    my $num = ord1($block, $pos + 6);
	    my $intpos = $pos + 7;

	    for (my $j = 0; $j < $num; $j++) {
		if (ord2($block, $intpos + 2) != 0) {
		    print "    ioAction";
		}
		else {
		    print "    doAction";
		}
		print "(", objStr(ord2($block, $intpos)), ")"
		    if ord2($block, $intpos) != 65535;
		print " = '";
		# Strip off the 'do' from the doAction property name
		print substr(propStr(ord2($block, $intpos + 8)), 2), "'\n";
		$intpos += 16;
	    }
	}
	elsif ($type != DAT_DEMAND) {
	    my ($str) = valueStr($block, $pos + 6, $type);
	    print "    ", propStr($num), " = $str\n";
	}
	$pos += 6 + $size;
    }
    print ";\n";
}

for (;;) {
    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);
    }
    elsif ($#ARGV >= 0 && $ARGV[0] eq '-c') {
	$cmode = 1;
	shift(@ARGV);
    }
    else {
	last;
    }
}
if ($#ARGV != 0) {
    die "Usage: detads [-s symbols] [-c] 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);

print "#pragma C+;\n\n" if $cmode;

for (;;) {
    $namelen = read1(GAM);
    read(GAM, $name, $namelen);
    $nextofs = read4(GAM);
    $curofs = tell(GAM);
    $sectlen = $nextofs - $curofs;
    last if $name eq '$EOF';

    processXSI(GAM, $sectlen) if $name eq 'XSI';
    preprocessOBJ(GAM, $sectlen) if $name eq 'OBJ';
    preprocessREQ(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';
    preprocessVOC(GAM, $sectlen) if $name eq 'VOC';

    seek(GAM, $nextofs, SEEK_SET);
}

close(GAM);

for ($n = 0; $n <= $#objblocks; $n++) {
    next unless defined $objblocks[$n];
    if ($objtypes[$n] == 1) {
	print objStr($n), ": function";
	decompile($objblocks[$n], -$n);
	print "\n";
    }
    elsif ($objtypes[$n] == 2) {
	dumpObj($objblocks[$n], $n);
    }
    else {
	die "Unsupported object type $objtypes[$n]";
    }
}