=head1 NAME

#!/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 <[email protected]>

=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]";
}
}