[Fdcil-cvs] dev/miracle2k/exercises/interpreter .cvsignore,NONE,1.1 Cradle.pas,NONE,1.1 SymbolTable.pas,NONE,1.1 test2.bdsproj,NONE,1.1 test2.cfg,NONE,1.1 test2.dpr,NONE,1.1

[Michael E. <mir...@us...>]

Update of /cvsroot/fdcil/dev/miracle2k/exercises/interpreter
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv21362/miracle2k/exercises/interpreter

Added Files:
	.cvsignore Cradle.pas SymbolTable.pas test2.bdsproj test2.cfg 
	test2.dpr 
Log Message:
interpreter test program

--- NEW FILE: .cvsignore ---
*.exe
*.dcuil
*.rsp
*.pdb
Model
--- NEW FILE: Cradle.pas ---
unit Cradle;

interface

uses
  SysUtils;

var
  Input: string;
  Curr: Integer;

  Look: char;

procedure GetChar;
procedure Error (s: string);
procedure Abort(s: string);
procedure Expected(s: string);
procedure Match(x: char);
function IsAlpha(c: char): boolean;
function IsDigit(c: char): boolean;
function IsAlNum(c: char): boolean;
function IsAddOp(c: char): boolean;
function IsWhite ( c : char ): boolean ;
procedure SkipWhite;
function GetName: string;
function GetNum: Integer;
procedure Emit(s: string);
procedure EmitLn(s: string);
procedure ReadCommand;

implementation

procedure GetChar;
begin
  Inc(Curr);
  if Curr <= Length(Input) then
    Look := Input[Curr]
  else
    Look := #0;
end;

procedure Error(s: string);
begin
  WriteLn(^G, 'Error: ', s);
end;

procedure Abort(s: string);
begin
  Error(s);
  raise Exception.Create;
end;

procedure Expected(s: string);
begin
  if s = #0 then
    Abort('Invalid characters at end of input')
  else
    Abort ( s + ' was expected.');
end;

procedure Match(x: char);
begin
  if Look = x then begin
    GetChar;
    SkipWhite;
  end
  else
    Expected(x);
end ;

function IsAlpha(c: char): boolean;
begin
  IsAlpha := UpperCase(c)[1] in [ 'A'..'Z' ] ;
end;

function IsDigit(c: char): boolean;
begin
  IsDigit := c in [ '0'..'9' ] ;
end;

function IsAlNum(c: char): boolean;
begin
  IsAlNum := IsAlpha(c) or IsDigit(c) ;
end ;

function IsAddOp(c: char): boolean;
begin
  Result := c in ['+', '-'];
end;

function IsWhite ( c : char ): boolean ;
begin
  Result := c in [ ' ' , #9 ] ;
end;

procedure SkipWhite;
begin
  while IsWhite(Look) do GetChar;
end;

function GetName: string;
var
  Token: string;
begin
  Token := '';
  if not IsAlpha (Look) then Expected('Name');
  while IsAlpha(Look) do begin
    Token := Token + UpperCase(Look);
    GetChar;
  end;
  Result := Token;
  SkipWhite;
end;

function GetNum: Integer;
begin
  if not IsDigit ( Look ) then Expected ('Integer');
  while IsDigit ( Look ) do begin
    Result := 10 * Result + Ord( Look ) - Ord( '0' );
    GetChar;
    SkipWhite;
  end;
end;

procedure Emit(s: string);
begin
  Write(#9 + s);
end;

procedure EmitLn(s: string);
begin
  Emit(s);
  Writeln;
end;

procedure ReadCommand;
begin
  Readln(Input);
  Curr := 0;
  GetChar;
  SkipWhite;
end;

end.

--- NEW FILE: test2.cfg ---
-$A-
-$B-
-$C+
-$D+
-$E-
-$F-
-$G+
-$H+
-$I+
-$J-
-$K-
-$L+
-$M-
-$N+
-$O+
-$P+
-$Q-
-$R-
-$S-
-$T-
-$U-
-$V+
-$W-
-$X+
-$YD
-$Z1
-cg
-vn
-AWinTypes=Borland.Vcl.Windows;WinProcs=Borland.Vcl.Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
-NSBorland.Vcl
-H+
-W+
-M
-$M4096,1048576
-K$00400000
-LU""

--- NEW FILE: SymbolTable.pas ---
unit SymbolTable;

interface

uses
  SysUtils, Classes;

type
  TTableRow = record
    SymbolName: string;
    SymbolValue: Integer;
  end;

var
  Table: TList = nil;

procedure InitTable;
procedure FreeTable;
function SymbolByName(Name: string): TTableRow;
procedure AddSymbol(Name: string; Value: Integer);
procedure SetSymbol(Symbol: string; Value: Integer);

implementation

procedure InitTable;
begin
  Table := TList.Create;
end;

procedure FreeTable;
begin
  if Table <> nil then
    Table.Free;
end;

function SymbolByName(Name: string): TTableRow;
var
  i: integer;
  Found: boolean;
begin
  Found := False;
  for i := 0 to Table.Count - 1 do
    if TTableRow(Table[i]).SymbolName = Name then
    begin
      Found := True;
      Result := TTableRow(Table[i]);
      break;
    end;

  if not Found then
    raise Exception.Create('Symbol ' + Name + ' does not exist!');
end;

procedure AddSymbol(Name: string; Value: Integer);
var
  Row: TTableRow;
begin
  Row.SymbolName := Name;
  Row.SymbolValue := Value;
  Table.Add(Row)
end;

procedure SetSymbol(Symbol: string; Value: Integer);
var
  Row: TTableRow;
begin
  try
    Row := SymbolByName(Symbol);
    Row.SymbolValue := Value;
  except
    AddSymbol(Symbol, Value);
  end;
end;

initialization

finalization
  FreeTable;

end.

--- NEW FILE: test2.dpr ---
program test2;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Cradle in 'Cradle.pas',
  SymbolTable in 'SymbolTable.pas';

function Expression: Integer; forward;

procedure Ident;
var
  Name: string;
begin
  Name := GetName;
  if Look = '(' then begin
    Match('('); Match(')');
    Emitln('BSR ' + Name);
  end
  else
    EmitLn ('MOVE ' + GetName + '(PC), D0')
end;

function Factor: Integer;
begin
  if Look = '(' then
  begin
    Match('(');
    Result := Expression;
    Match(')');
  end
  else if IsAlpha(Look) then
    Result := SymbolByName(GetName).SymbolValue
  else
    Result := GetNum;
end;

procedure Division;
begin
  Match('/');
  Factor;
  EmitLn('MOVE (SP) + , D1') ;
  EmitLn('DIVS D1, D0') ;
end;

procedure Multiply;
begin
  Match('*');
  Factor;
  Emitln('MULS (SP)+, D0');
end;

function Term: Integer;
begin
  Result := Factor;
  while Look in ['*', '/'] do
    case Look of
      '*': begin
             Match('*');
             Result := Result * Factor;
           end;
      '/': begin
             Match('/');
             Result := Result div Factor;
           end;
    end;
end;

procedure Add;
begin
  Match('+');
  Term;
  Emitln('ADD (SP)+, D0');
end;

procedure Substract;
begin
  Match('-');
  Term;
  Emitln('SUB (SP)+, D0');
  Emitln('NEG D0');
end;

function Expression: Integer;
begin
  if IsAddOp(Look) then
    Result := 0
  else
    Result := Term;

  while IsAddOp(Look) do
    case Look of
      '+': begin
             Match('+');
             Result := Result + Term;
           end;
      '-': begin
             Match('-');
             Result := Result - Term;
           end;
    end;
end;

procedure Assignment;
var
  Name: string;
begin
  Name := GetName;
  Match('=');
  SetSymbol(Name, Expression);
end;

procedure Query;
var
  Name: string;
begin
  Match('?');
  Name := GetName;
  try
    Writeln(SymbolByName(Name).SymbolValue.ToString());
  except
    on E: Exception do
        Error(E.Message);
  end;
end;

begin
  Writeln('Usage: {var}={expression}  |  ?{var}');
  InitTable;
  repeat
    try
      ReadCommand;
      case Look of
        '?': Query;
        '.': Exit;
        '0'..'9': Writeln(Expression.ToString())
        else Assignment;
      end;
      Match(#0);
    except end;
  until False;

  Readln;
end.

--- NEW FILE: test2.bdsproj ---
(This appears to be a binary file; contents omitted.)