#!/usr/local/bin/perl -w

# This is an Unlambda debugger written in Perl
# Copyright (C) 1999 by Jean Marot <jean.marot@ens.fr>

#    This program is free software; you can redistribute it and/or modify
#    it under the terms of either:
#
#	a) the GNU General Public License as published by the Free
#	Software Foundation; either version 2, or (at your option) any
#	later version, or
#
#	b) the "Artistic License" which comes with this Kit.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either
#    the GNU General Public License or the Artistic License for more details.
#
#    You should have received a copy of the Artistic License with this
#    Kit, in the file named "Artistic".  If not, I'll be glad to provide one.
#
#    You should also have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software Foundation,
#    Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.

# debugger commands:
#  r run
#  s step
#  t print current tree
#  cn print continuation n
#  o print output
#  q quit
#  istr add str to input (\n is added iff str is empty)
#  ?i prints input not read yet
#  !i simulates EOF on input
#  ?c prints the current character

use strict;
use Term::ReadLine;
my $term=new Term::ReadLine 'unlambda step-by-step evaluator';
select($term->OUT || "STDOUT"); $|=1;

open('SOURCE', $ARGV[0]) || die("Can't open sourcefile");
undef $/; my $source=<SOURCE>; $/='';
close 'SOURCE';
my $root=parse($source);
$root->{"parent"}="subroot";
show_tree($root, "");
my $output='';
my $input='';
my $input_eof=0;
my $current_char=undef;

my $current=$root;
my $cpos='';
my $cont_number=0;
my $finished=0;

while ($current ne "subroot" && $finished==0)
{ my $cmd=$term->readline('> ');
  last if ($cmd eq "q");
  if ($cmd eq "r")
  { while ($current ne "subroot")
    { eval_step(0);
    }
  }
  eval_step(1) if ($cmd eq "s");
  show_tree($root, "") if ($cmd eq "t");
  print $output."\n" if ($cmd eq "o");
#  $current->{"content"}="zoinx!" if ($cmd=~/^z/);
#  check_tree_consistency($root, 'r') if ($cmd=~/^check/);
  if ($cmd=~/^i(.*)$/)
  { if ($input_eof==1)
    { print "Can't add characters to input after EOF\n";
    }
    elsif ($1 eq '')
    { print "cr added to input\n";
      $input.="\n";
    }
    else
    { print "'$1' added to input\n";
      $input.=$1;
    }
  }
  if ($cmd eq "?i")
  { print "Input left to be read: $input\n";
    print "EOF\n" if ($input_eof==1);
  }
  if ($cmd eq "!i")
  { if ($input_eof==1)
    { print "Input has already been ended\n";
    }
    else
    { print "EOF on input\n";
      $input_eof=1;
    }
  }
  if ($cmd eq "?c")
  { if (defined $current_char)
    { print "Current character is $current_char\n";
    }
    else
    { print "No current character\n";
    }
  }
  if ($cmd=~/^c(\d+)$/)
  { if ($1>$cont_number)
    { print "Continuation $1 has not been defined yet\n";
    }
    elsif ($1!=0)
    { my $c=seek_continuation($root, $1);
      if (defined $c)
      { print "cont$1: ";
        show_tree($c->{"croot"}, " " x length("cont$1: "));
      }
      else
      { print "Continuation $1 is no longer referenced\n";
      }
    }
  }
}
print "Evalation of program ended.\n";
exit;

sub check_tree_consistency
{ my ($root, $cpos)=@_;
  if ($root->{"status"} ne "resolved" && $root->{"content"} eq "`")
  { print "zoinx tor $cpos !\n" unless $root->{"operator"}->{"parent"}==$root;
    print "zoinx and $cpos !\n" unless $root->{"operand"}->{"parent"}==$root;
    check_tree_consistency($root->{"operator"}, $cpos.'0');
    check_tree_consistency($root->{"operand"}, $cpos.'1');
  }
}

sub eval_step
{ my $sbs=shift(@_);
  my $done=0;
  while ($done==0)
  { $done=1;
    my $c=$current->{"content"};
    if ($c eq 's')
    { $current->{"status"}="resolved";
      $current->{"content"}="substify";
    }
    elsif ($c eq 'k')
    { $current->{"status"}="resolved";
      $current->{"content"}="constify";
    }
    elsif ($c eq 'i')
    { $current->{"status"}="resolved";
      $current->{"content"}="id";
    }
    elsif ($c eq 'v')
    { $current->{"status"}="resolved";
      $current->{"content"}="voider";
    }
    elsif ($c eq 'r')
    { $current->{"status"}="resolved";
      $current->{"content"}="id_cr";
    }
    elsif ($c=~/^\.(.)$/)
    { $current->{"status"}="resolved";
      $current->{"content"}="id_print_$1";
    }
    elsif ($c eq 'c')
    { $current->{"status"}="resolved";
      $current->{"content"}="call/cc";
    }
    elsif ($c eq 'd')
    { $current->{"status"}="resolved";
      $current->{"content"}="promise";
    }
    elsif ($c eq 'e')
    { $current->{"status"}="resolved";
      $current->{"content"}="end";
    }
    elsif ($c eq '@')
    { $current->{"status"}="resolved";
      $current->{"content"}="read_char";
    }
    elsif ($c eq '|')
    { $current->{"status"}="resolved";
      $current->{"content"}="current_char";
    }
    elsif ($c=~/^\?(.)$/)
    { $current->{"status"}="resolved";
      $current->{"content"}="test_if_$1";
    }
    elsif ($c eq '`')
    { if ($current->{"operator"}->{"status"} eq "unresolved")
      { $current=$current->{"operator"};
	$cpos.='0';
	$done=0;
      }
      elsif ($current->{"operator"}->{"status"} eq "resolved" && $current->{"operator"}->{"content"} eq "promise")
      { print "promise operator found, evaluation of operand delayed\n" if $sbs;
        my $p=$current->{"parent"};
        %$current=%{$current->{"operand"}};
        fix_lineage($current);
        $current->{"status"}="delayed";
        $current->{"parent"}=$p; 
      }
      elsif ($current->{"operand"}->{"status"} eq "unresolved")
      { $current=$current->{"operand"};
	$cpos.='1';
	$done=0;
      }
      elsif ($current->{"operator"}->{"status"} eq "delayed")
      { $current=$current->{"operator"};
        $cpos.='0';
        $current->{"status"}="unresolved";
        print "resuming delayed evaluation\n" if $sbs;
      }
      else
      { my $extra='';
        if ($sbs)
        { print "eval "; printfunc($current->{"operator"});
          print " "; printfunc($current->{"operand"});
          print "\n  => ";
        }
        my $f=$current->{"operator"}->{"content"};
	if ($f=~/^id/ || $f eq "end")
	{ my $p=$current->{"parent"};
	  %$current=%{$current->{"operand"}};
	  fix_lineage($current);
          $current->{"parent"}=$p;
	  if ($f eq "id_cr")
	  { $output.="\n"; $extra="output cr"; print "\n" unless $sbs;
	  }
	  elsif ($f=~/^id_print_(.)$/s)
	  { $output.=$1; $extra="output $1"; print $1 unless $sbs;
	  }
          elsif ($f eq "end")
          { $extra="evaluation terminated"; $finished=1;
          }
	}
	elsif ($f eq "voider")
	{ $current->{"content"}="voider";
	  undef $current->{"operator"};
          destroy($current->{"operand"});
          undef $current->{"operand"};
          $current->{"status"}="resolved";
	}
	elsif ($f eq "constify")
	{ $current->{"content"}="const";
	  undef $current->{"operator"};
          $current->{"arg1"}=$current->{"operand"};
	  undef $current->{"operand"};
          undef $current->{"arg1"}->{"parent"};
          $current->{"status"}="resolved";
	}
	elsif ($f eq "const")
	{ my $p=$current->{"parent"};
	  destroy($current->{"operand"});
          %$current=%{$current->{"operator"}->{"arg1"}};
          fix_lineage($current);
          $current->{"parent"}=$p;
	}
	elsif ($f eq "substify")
	{ $current->{"content"}="subst1";
	  $current->{"arg1"}=$current->{"operand"};
	  undef $current->{"operand"};
          undef $current->{"operator"};
          undef $current->{"arg1"}->{"parent"};
          $current->{"status"}="resolved";
	}
	elsif ($f eq "subst1")
	{ $current->{"content"}="subst2";
	  $current->{"arg1"}=$current->{"operator"}->{"arg1"};
	  $current->{"arg2"}=$current->{"operand"};
	  undef $current->{"operator"};
          undef $current->{"operand"};
          undef $current->{"arg2"}->{"parent"};
          $current->{"status"}="resolved";
	}
	elsif ($f eq "subst2")
	{ print "tree rearranged for substitution\n" if $sbs;
          my $newop=copy_tree($current->{"operand"});
          my $sub1={"status"=>"unresolved",
		    "content"=>"`",
		    "operator"=>$current->{"operator"}->{"arg1"},
		    "operand"=>$current->{"operand"},
		    "parent"=>$current};
	  fix_lineage($sub1);
          my $sub2={"status"=>"unresolved",
		    "content"=>"`",
		    "operator"=>$current->{"operator"}->{"arg2"},
		    "operand"=>$newop,
		    "parent"=>$current};
	  fix_lineage($sub2);
          $current->{"status"}="unresolved";
	  $current->{"content"}="`";
	  $current->{"operator"}=$sub1;
	  $current->{"operand"}=$sub2;
	}
	elsif ($f eq "call/cc")
	{ $cont_number++;
          print "tree rearranged for call/cc;\t\t<<<CONT$cont_number>>>\n" if $sbs;
          $current->{"status"}="resolved";
          $current->{"content"}="pending call/cc return";
          my $cc=current_continuation($root, $cpos);
	  my $cont={"status"=>"resolved",
		    "content"=>"continuation",
		    "cont"=>$cc,
		    "number"=>$cont_number,
		    "parent"=>$current};
	  $current->{"status"}="unresolved";
	  $current->{"content"}="`";
          $current->{"operator"}=$current->{"operand"};
          $current->{"operand"}=$cont;
	}
        elsif ($f eq "continuation")
        { print "resumed evaluation at <cont".$current->{"operator"}->{"number"}.">; returned " if $sbs;
          my $arg=$current->{"operand"};
          my $croot=$current->{"operator"}->{"cont"}->{"croot"};
          my $cpos=$current->{"operator"}->{"cont"}->{"cpos"};
          undef $current->{"operator"}->{"cont"};
          undef $current->{"operator"}->{"parent"};
          undef $current->{"operand"}->{"parent"};
          undef $current->{"operator"}; undef $current->{"operand"};
          $current->{"content"}="unlinked";
          destroy($root);
          $current=$root=$croot;
          for $c (split(//, $cpos))
          { $current=($c eq "0")?($current->{"operator"}):($current->{"operand"});
          }
          my $p=$current->{"parent"};
          %$current=%$arg;
          fix_lineage($current);
          $current->{"parent"}=$p;
        }
        elsif ($f eq "read_char")
        { if ($input eq '')
          { if ($input_eof)
            { undef $current_char;
              undef %{$current->{"operator"}};
              $current->{"operator"}=$current->{"operand"};
              $current->{"operand"}={"status"=>"resolved",
                                     "content"=>"voider"};
              print "EOF - no char read\n" if $sbs;
            }
            else
            { print "char wanted ! not evalled\n" if $sbs;
            }
          }
          else
          { $current_char=substr($input,0,1);
            $input=substr($input,1);
            undef %{$current->{"operator"}};
            $current->{"operator"}=$current->{"operand"};
            $current->{"operand"}={"status"=>"resolved",
                                   "content"=>"id"};
            print "read $current_char\n" if $sbs;
          }
        }
        elsif ($f eq "current_char")
        { undef %{$current->{"operator"}};
	  $current->{"operator"}=$current->{"operand"};
	  if (defined $current_char)
	  { $current->{"operand"}={"status"=>"resolved",
				   "content"=>"id_print_$current_char"};
	    print "current character: $current_char\n" if $sbs;
	  }
	  else
	  { $current->{"operand"}={"status"=>"resolved",
				   "content"=>"voider"};
	    print "no current character\n" if $sbs;
	  }
        }
        elsif ($f=~/^test_if_(.)$/s)
        { undef %{$current->{"operator"}};
          $current->{"operator"}=$current->{"operand"};
          if (defined $current_char && $current_char eq $1)
          { $current->{"operand"}={"status"=>"resolved",
                                   "content"=>"id"};
            print "test succeeded\n" if $sbs;
          }
          else
          { $current->{"operand"}={"status"=>"resolved",
                                   "content"=>"voider"};
            print "test failed\n" if $sbs;
          }
        }
	if ($current->{"status"} eq "resolved" && $sbs)
	{ printfunc($current); print "\t$extra\n";
	}   
	elsif ($current->{"status"} eq "delayed" && $sbs)
	{ print "delayed branch\t$extra\n";
        }
      }
    }
    if ($c ne "`" && $sbs)
    { print "eval $c\n  => ".$current->{"content"}."\n";
    }
    if ($current->{"status"} ne "unresolved")
    { $cpos=substr($cpos,0, length($cpos)-1);
      $current=$current->{"parent"};
    }
  }
}

sub destroy
{ my $root=shift(@_);
  if ($root->{"status"} eq "resolved")
  { if ($root->{"content"} eq "const" || $root->{"content"} eq "subst1")
    { destroy($root->{"arg1"});
    }
    elsif ($root->{"content"} eq "subst2")
    { destroy($root->{"arg1"});
      destroy($root->{"arg2"});
    }
    elsif ($root->{"content"} eq "continuation")
    { destroy($root->{"cont"}->{"croot"});
      undef %{$root->{"cont"}};
    }
  }
  elsif ($root->{"content"} eq "`")
  { destroy($root->{"operator"});
    destroy($root->{"operand"});
  }
  undef %$root;
}

sub fix_lineage
{ my $current=shift(@_);
  if ($current->{"status"} ne "resolved" && $current->{"content"} eq "`")
  { $current->{"operator"}->{"parent"}=$current;
    $current->{"operand"}->{"parent"}=$current;
  }
}

sub parse
{ my $source=shift(@_);
  $source=~s/\#.*?$//mg;
  my @tokens=();
  my $i=0;
  while ($i<length($source))
  { my $c=substr($source, $i++, 1);
    if ($c=~/[\`skivrcd|\@e]/)
    { push @tokens, $c;
    }
    elsif ($c=~/[.?]/)
    { $c.=substr($source, $i++, 1);
      push @tokens, $c;
    }
  }
  my @stack=();
  while (my $t=pop(@tokens))
  { if ($t eq '`')
    { my $newnode={"status"=>"unresolved", "content"=>'`', "operator"=>pop(@stack), "operand"=>pop(@stack)};
      $newnode->{"operator"}->{"parent"}=$newnode;
      $newnode->{"operand"}->{"parent"}=$newnode;
      push @stack, $newnode;
    }
    else

    { push @stack, {"status"=>"unresolved", "content"=>$t};
    }
  }
  return pop(@stack);
}

sub show_tree
{ my ($root, $prefix)=@_;
  if ($root->{"status"} eq "unresolved")
  { if ($root->{"content"} eq '`')
    { print '`-';
      show_tree($root->{"operator"}, $prefix."| ");
      print $prefix.'\-';
      show_tree($root->{"operand"}, $prefix."  ");
    }
    else
    { print $root->{"content"}."\n";
    }
  }
  elsif ($root->{"status"} eq "delayed")
  { if ($root->{"content"} eq '`')
    { print '(d)`-';
      show_tree($root->{"operator"}, $prefix."   | ");
      print $prefix.'   \-';
      show_tree($root->{"operand"}, $prefix."     ");
    }
    else
    { print "(d)".$root->{"content"}."\n";
    }
  }
  elsif ($root->{"status"} eq "resolved")
  { printfunc($root); print "\n";
  }
}

sub printfunc
{ my $node=shift(@_);
  if ($node->{"status"} eq "delayed")
  { print"[delayed]";
  }
  elsif ($node->{"content"} eq "subst1")
  { print "substify(";
    printfunc($node->{"arg1"});
    print ",-)";
  }
  elsif ($node->{"content"} eq "subst2")
  { print "substify(";
    printfunc($node->{"arg1"});
    print ",";
    printfunc($node->{"arg2"});
    print ")";
  }
  elsif ($node->{"content"} eq "const")
  { print "const(";
    printfunc($node->{"arg1"});
    print ")";
  }
  elsif ($node->{"content"} eq "continuation")
  { print "<cont".$node->{"number"}.">";
  }
  else
  { print $node->{"content"};
  }
}

sub current_continuation
{ my ($root, $cpos)=@_;
  my $continuation=copy_tree($root);
  return {"croot"=>$continuation, "cpos"=>$cpos};
}

sub copy_tree
{ my $root=shift(@_);
  my %node=%$root;
  if ($node{"status"} eq "resolved")
  { if ($node{"content"} eq 'const' || $node{"content"} eq 'subst1')
    { $node{"arg1"}=copy_tree($node{"arg1"});
      $node{"arg1"}->{"parent"}=\%node;
    }
    elsif ($node{"content"} eq 'subst2')
    { $node{"arg1"}=copy_tree($node{"arg1"});
      $node{"arg1"}->{"parent"}=\%node;
      $node{"arg2"}=copy_tree($node{"arg2"});
      $node{"arg2"}->{"parent"}=\%node;
    }
    elsif ($node{"content"} eq 'continuation')
    { my %cont=%{$node{"cont"}};
      $cont{"croot"}=copy_tree($cont{"croot"});
      $node{"cont"}=\%cont;
    }
  }
  elsif ($node{"content"} eq "`")
  { $node{"operator"}=copy_tree($node{"operator"});
    $node{"operator"}->{"parent"}=\%node;
    $node{"operand"}=copy_tree($node{"operand"});
    $node{"operand"}->{"parent"}=\%node;
  }
  return \%node;
}

sub seek_continuation
{ my ($node, $n)=@_;
  my $result=undef;
  if ($node->{"status"} eq "resolved" && $node->{"content"} eq "continuation" && $node->{"number"} eq $n)
  { return $node->{"cont"};
  }
  elsif ($node->{"status"} eq "resolved")
  { if ($node->{"content"} eq "continuation")
    { $result=seek_continuation($node->{"cont"}->{"croot"}, $n);
    }
    elsif ($node->{"content"} eq "const" || $node->{"content"} eq "subst1")
    { $result=seek_continuation($node->{"arg1"}, $n);
    }
    elsif ($node->{"content"} eq "subst2")
    { $result=seek_continuation($node->{"arg1"}, $n);
      $result=seek_continuation($node->{"arg2"}, $n) unless defined $result;
    }
  }
  elsif ($node->{"content"} eq "`")
  { $result=seek_continuation($node->{"operator"}, $n);
    $result=seek_continuation($node->{"operand"}, $n) unless defined $result;
  }
  return $result;
}