{ Very simple script interpreter.  Not useful by itself, but a jumping
  off point for a more useful interpreter.

  programmer: Greg Savin (gsavin@cs.pdx.edu)

  As written it takes input from a file named 'test' and interprets the
    file.

  Language:

  A script is one or more statements separated by semicolons.
  A statement is either an assignment, a WRITELN statement, a FOR statement,
    or a compound statement.
  WRITELN can't handle any formatting information, just vars and constants.
  All variables are of type "real" and are implicitly declared upon their
    first use.  Uninitialized variables have the value zero.
  Assignments, for statements, compound statements have the same syntax
    as their Pascal equivalents.
  An expression is either a simple constant or a variable name (there
    are no expression operators)


  Sample script:

  for i := 1 to 5 do begin
    a := i;
    writeln(a,i);
  end;

}

uses Objects;

type
  PSymbol = ^TSymbol;
  TSymbol = Record
    Key : PString;
    Value : Real;
    Next : PSymbol;
  end;

  TSymTab = Object
    Head : PSymbol;
    constructor Init;
    destructor Done;
    function Lookup(const Key : String) : PSymbol;
    function Install(const Key : String) : PSymbol;
  end;

var
  SymTab : TSymTab;

constructor TSymtab.Init;
begin
  Head := nil;
end;

destructor TSymtab.Done;
var P : PSymbol;
begin
  while Head <> nil do begin
    P := Head;
    Head := Head^.Next;
    if P^.Key <> nil then
      DisposeStr(P^.Key);
    Dispose(P);
  end;
end;

function TSymTab.Lookup(const Key : String) : PSymbol;
var
  P : PSymbol;
begin
  Lookup := nil;
  P := Head;
  while P <> nil do begin
    if P^.Key^ = Key then begin
      Lookup := P;
      exit;
    end;
    P := P^.Next;
  end;
end;

function TSymTab.Install(const Key : String) : PSymbol;
var
  P : PSymbol;
begin
  P := Lookup(Key);
  if P = nil then begin
    new(P);
    P^.Key := newstr(Key);
    P^.Value := 0.0;
    P^.Next := Head;
    Head := P;
  end;

  Install := P;
end;

type
  Token = ( tVAR, tCONST, tSEQ, tFOR, tASSIGN, tWRITELN, tTO, tDO,
            tBEGIN, tEND, tCOMMA, tSEMICOLON, tLPAREN, tRPAREN, tEOF );

  PTree = ^TTree;
  TTree = record
    case Kind: Token of
      tVAR : ( Sym : PSymbol );
      tCONST : ( Value : Real );
      tSEQ,tASSIGN,tWRITELN : ( Left, Right : PTree );
      tFOR : ( Expr, Low, High, Stmt : PTree);
  end;

function MakeVar( Sym : PSymbol ) : Ptree;
var
  P : Ptree;
begin
  new(P);
  P^.Kind := tVAR;
  P^.Sym := Sym;
  MakeVar := P;
end;

function MakeConst(Value : Real) : Ptree;
var P : Ptree;
begin
  New(P);
  P^.Kind := tCONST;
  P^.Value := Value;
  MakeConst := P;
end;

function MakeBinaryNode( Kind : Token; Left, Right : Ptree) : Ptree;
var P : Ptree;
begin
  New(P);
  P^.Kind := Kind;
  P^.Left := Left;
  P^.Right := Right;
  MakeBinaryNode := P;
end;

function MakeFor ( Expr, Low, High, Stmt : Ptree) : Ptree;
var P : Ptree;
begin
  New(P);
  P^.Kind := tFOR;
  P^.Expr := Expr;
  P^.Low := Low;
  P^.High := High;
  P^.Stmt := Stmt;
  MakeFor := P;
end;

type
  KeyString = Record
                 Str : String[7];
                 Tok : Token;
              end;

const
  NumKeyWords = 6;
  KeyWords : Array[1..NumKeyWords] of KeyString = (
     (Str:'FOR'; Tok:tFOR),
     (Str:'TO'; Tok:tTO),
     (Str:'WRITELN'; Tok:tWRITELN),
     (Str:'DO'; Tok:tDO),
     (Str:'BEGIN'; Tok:tBEGIN),
     (Str:'END'; Tok:tEND) );

var
  InFile : File of Char;
  BackChar : Char;

const
  Line : Integer = 1;

var
  Lookahead : Token;

  LexVal : record
     case Token of
       tVAR: ( sval : string);
       tCONST : ( rval : real );
  end;

const
  HaveBackChar : Boolean = False;
  EOF = char(-1);



procedure error(const msg : string);
begin
  write('Error (line ', Line, ') :');
  writeln(msg);
  halt;
end;


function GetChar : Char;
var
  ch : char;
begin
  if HaveBackChar then begin
    HaveBackChar := False;
    GetChar := BackChar;
    exit;
  end;
  {$I-}
  Read(InFile, ch);
  {$I+}
  ch := upcase(ch); { make it case insensitive }
  if ioresult = 0 then
    GetChar := ch
  else
    GetChar := EOF;
end;


procedure PutBackChar(Ch : Char);
begin
  BackChar := Ch;
  HaveBackChar := True;
end;

function IsAlpha(Ch : Char) : Boolean;
begin
  IsAlpha := Ch in ['A'..'Z','a'..'z'];
end;

function IsDigit(Ch : Char) : Boolean;
begin
  IsDigit := Ch in ['0'..'9'];
end;

function IsSpace(Ch : Char) : Boolean;
begin
  IsSpace := Ch in [' ', #9, #10, #11, #12, #13];
end;

function NextToken : Token;
var
  ch : char;
  Code : integer;
  Rval : real;
  i : integer;
begin
  ch := GetChar;

  if IsSpace(ch) then
    while IsSpace(ch) do begin
      if ch = #13 then
        Inc(Line);
      ch := GetChar;
    end;

  if ch = EOF then
    NextToken := tEOF
  else if ch = '(' then
    NextToken := tLPAREN
  else if ch = ')' then
    NextToken := tRPAREN
  else if ch = ',' then
    NextToken := tCOMMA
  else if ch = ';' then
    NextToken := tSEMICOLON
  else if IsAlpha(ch) then begin
    LexVal.sval := '';
    while IsAlpha(ch) do begin
      LexVal.sval := LexVal.sval + ch;
      ch := GetChar;
    end;
    PutBackChar(ch);
    { see if a keyword or variable }
    NextToken := tVAR;
    for i := 1 to NumKeyWords do
      if KeyWords[i].str = LexVal.sval then
         NextToken := KeyWords[i].Tok;
  end
  else if IsDigit(ch) then begin
    LexVal.sval := '';
    while IsDigit(ch) or (ch = '.') do begin
      LexVal.sval := LexVal.sval + ch;
      ch := GetChar;
    end;
    PutBackChar(ch);
    Val(Lexval.sval, rval, code);
    if code <> 0 then
      error('error in constant constant');
    Lexval.rval := rval;
    NextToken := tCONST;
  end
  else if ch = ':' then begin
    ch := GetChar;
    if ch = '=' then
      NextToken := tASSIGN
    else
      error('syntax error');
  end
  else error('syntax error');
end;

procedure match(T : Token);
begin
  if Lookahead = T then
    Lookahead := NextToken
  else
    error('syntax error');
end;


function Statement : Ptree; forward;
function WriteStatement : Ptree; forward;
function ForStatement : Ptree; forward;
function AssignStatement : Ptree; forward;

function Expression : Ptree;
begin
  if Lookahead = tCONST then begin
    Expression := MakeConst(LexVal.rval);
    match(tCONST)
  end
  else if Lookahead = tVAR then begin
    Expression := MakeVar( Symtab.Install(Lexval.sval) );
    match(tVAR)
  end
  else error('error in expression');
end;

function CompoundStatement : PTree;
var P : Ptree;
    NewStmt : Ptree;
begin
  P := nil;
  match(tBEGIN);
  if Lookahead <> tEND then begin
    P := Statement;
    while Lookahead <> tEND do begin
      match(tSEMICOLON);
      NewStmt := Statement;
      if NewStmt <> nil then
        P := MakeBinaryNode(tSEQ, P, NewStmt);
    end;
  end;
  match(tEND);
  CompoundStatement := P;
end;

function ForStatement : Ptree;
var
  Exp, Low, High, Stmt : Ptree;
  P : Ptree;
begin
  match(tFOR);
  Exp := expression;
  if Exp^.Kind <> tVAR then
    error('Variable expected after FOR');
  match(tASSIGN);
  Low := expression;
  match(tTO);
  High := expression;
  match(tDO);
  Stmt := statement;
  ForStatement := makefor ( exp, low, high, Stmt);
end;


function Statement : PTree;
begin
  case Lookahead of
    tFOR : Statement := ForStatement;
    tWRITELN : Statement := WriteStatement;
    tBEGIN : Statement := CompoundStatement;
    tVAR, tCONST : Statement := AssignStatement;
    tSEMICOLON, tEND : Statement := nil;
    else error('error in statement');
  end;
end;


function WriteStatement : Ptree;
var
  Writechain : Ptree;
begin
  Writechain := nil;
  match(tWRITELN);
  if Lookahead = tLPAREN then begin
    match(tLPAREN);
    Writechain := expression;
    while Lookahead = tCOMMA do begin
      match(tCOMMA);
      Writechain := MakeBinaryNode(tSEQ, Writechain, expression);
    end;
    match(tRPAREN);
  end;

  WriteStatement := MakeBinaryNode( tWRITELN, Writechain, nil);
end;


function AssignStatement : Ptree;
var
  Left, Right : Ptree;
begin
  Left := expression;
  if Left^.Kind <> tVAR then
    error('Variable expected on left side of assignment');
  match(tASSIGN);
  Right := expression;

  AssignStatement := MakeBinaryNode(tASSIGN, Left, Right);
end;


procedure DumpTree( P : Ptree; Depth : integer);
var i : integer;
begin
  for i := 1 to depth do
    write(' ');
  if P = nil then
    writeln('(nil)')
  else if P^.Kind = tCONST then
    writeln( 'CONST: ', P^.Value : 0 : 2)
  else if P^.Kind = tVAR then
    writeln( 'VAR: ', P^.Sym^.Key^ )
  else if P^.Kind = tSEQ then begin
    writeln( 'SEQ' );
    DumpTree(P^.Left, Depth+1);
    Dumptree(P^.Right, Depth + 1);
  end
  else if P^.Kind = tASSIGN then begin
    writeln('ASSIGN');
    DumpTree(P^.Left, Depth+1);
    Dumptree(P^.Right, Depth + 1);
  end
  else if P^.Kind = tFOR then begin
    writeln('FOR');
    DumpTree(P^.Expr, Depth+1);
    DumpTree(P^.Low, Depth+1);
    Dumptree(P^.High, Depth + 1);
    DumpTree(P^.Stmt, Depth+1);
  end
  else if P^.Kind = tWRITELN then begin
    writeln('WRITELN');
    DumpTree(P^.Left, Depth+1);
  end;
end;



function Value(P : Ptree) : Real;
begin
  if P^.Kind = tCONST then
    Value := P^.Value
  else if P^.Kind = tVAR then
    Value := P^.Sym^.Value
  else
    writeln('something is wrong in "value"');
end;


procedure DoWrite( P : Ptree);
begin
  if p = nil then exit;

  if P^.Kind = tSEQ then begin
    DoWrite(P^.Left);
    DoWrite(P^.Right);
  end
  else begin
    write( Value(P): 0 : 2 );
    write(' ');
  end;
end;

procedure Interpret(P : Ptree);
var i : integer;
begin
  if P = nil then exit;
  case P^.Kind of
    tSEQ:
      begin
        Interpret(P^.Left);
        Interpret(P^.Right);
      end;
    tFOR:
      For i := Trunc(Value(P^.Low)) to Trunc(Value(P^.High)) do begin
          P^.Expr^.Sym^.Value := i;
          Interpret(P^.Stmt);
      end;
    tASSIGN:
      P^.Left^.Sym^.Value := Value(P^.Right);
    tWRITELN:
      begin
        DoWrite(P^.left);
        writeln;
      end;
  end;
end;


procedure FreeTree(P : Ptree);
begin
  if P^.Kind in [tSEQ, tASSIGN] then begin
    FreeTree(P^.Left);
    FreeTree(P^.Right);
  end
  else if P^.Kind = tWRITELN then
    FreeTree(P^.Left)
  else if P^.Kind = tFOR then begin
    FreeTree(P^.Expr);
    FreeTree(P^.Low);
    FreeTree(P^.High);
    FreeTree(P^.Stmt);
  end;
  Dispose(P);
end;


var
  Script : Ptree;
  NewStmt : Ptree;

begin
  Assign(Infile, 'test');
  Reset(infile);
  Symtab.Init;
  Lookahead := NextToken;
  Script := statement;
  while Lookahead <> tEOF do begin
    NewStmt := Statement;
    if NewStmt <> nil then
      Script := makeBinaryNode(tSEQ, Script, NewStmt);
    if Lookahead = tSEMICOLON then
      match(tSEMICOLON);
  end;

  { To debug tree:
    DumpTree(Script,0);
  }

  Interpret(Script);
  FreeTree(Script);
  Symtab.Done;
end.