source: compiler/trunk/compiler.dpr

program compiler;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils, System.Classes, System.Generics.Collections;

const
  NewLine = #13#10;

type
  TStatement = class
  end;

  TBeginEnd = class(TStatement)
    Items: TObjectList<TStatement>;
    constructor Create;
    destructor Destroy; override;
  end;

  TFunctionCall = class(TStatement)
    Name: string;
  end;

  TProgram = class
    Main: TBeginEnd;
    procedure Clear;
    constructor Create;
    destructor Destroy; override;
  end;

  TCompiler = class
  private
    Functions: TStringList;
    SourcePos: Integer;
    Indentation: Integer;
    function IsAlphaNumeric(C: Char): Boolean;
    function IsSpecialSymbol(C: Char): Boolean;
    function IsWhiteSpace(C: Char): Boolean;
    function ReadNext: string;
    function CheckNext(Text: string): Boolean;
    function Expect(Text: string): Boolean;
    function ParseBeginEnd(var Block: TBeginEnd): Boolean;
    function ParseProgram(var Prog: TProgram): Boolean;
    function ParseStatement(var Statement: TStatement): Boolean;
    function ParseFunctionCall(var FuncCall: TFunctionCall): Boolean;
    procedure ErrorMsg(Text: string);
    procedure Emit(Text: string);

    procedure GenerateProgram(Prog: TProgram);
    procedure GenerateBeginEnd(BeginEnd: TBeginEnd);
    procedure GenerateStatement(Statement: TStatement);
    procedure GenerateFunctionCall(FuncCall: TFunctionCall);
    function GetInd: string;
  public
    Prog: TProgram;
    Source: string;
    Destination: string;
    procedure Compile;
    constructor Create;
    destructor Destroy; override;
  end;

{ TCompiler }

function TCompiler.CheckNext(Text: string): Boolean;
var
  P: Integer;
  Token: string;
begin
  P := SourcePos;
  Token := ReadNext;
  Result := Token = Text;
  SourcePos := P;
end;

procedure TCompiler.Compile;
begin
  SourcePos := 1;
  Destination := '';
  if Assigned(Prog) then
    FreeAndNil(Prog);
  ParseProgram(Prog);
  GenerateProgram(Prog);
end;

constructor TCompiler.Create;
begin
  Prog := TProgram.Create;
  Functions := TStringList.Create;
  Functions.Add('WriteLn');
end;

destructor TCompiler.Destroy;
begin
  FreeAndNil(Prog);
  FreeAndNil(Functions);
  inherited;
end;

procedure TCompiler.Emit(Text: string);
begin
  Destination := Destination + Text;
end;

procedure TCompiler.ErrorMsg(Text: string);
begin
  WriteLn('Error: ' + Text);
end;

function TCompiler.Expect(Text: string): Boolean;
var
  Token: string;
begin
  Token := ReadNext;
  if Token <> Text then
    ErrorMsg('Expected ' + Text + ' but ' + Token + ' found');
  Result := Token = Text;
end;

procedure TCompiler.GenerateBeginEnd(BeginEnd: TBeginEnd);
var
  I: Integer;
begin
  Emit(GetInd + 'begin' + NewLine);
  Inc(Indentation);
  for I := 0 to BeginEnd.Items.Count - 1 do begin
    GenerateStatement(BeginEnd.Items[I]);
    Emit(';' + NewLine);
  end;
  Dec(Indentation);
  Emit(GetInd + 'end');
end;

procedure TCompiler.GenerateFunctionCall(FuncCall: TFunctionCall);
begin
  Emit(GetInd + FuncCall.Name);
end;

procedure TCompiler.GenerateProgram(Prog: TProgram);
begin
  Indentation := 0;
  GenerateBeginEnd(Prog.Main);
  Emit('.' + NewLine);
end;

procedure TCompiler.GenerateStatement(Statement: TStatement);
begin
  if Statement is TBeginEnd then GenerateBeginEnd(Statement as TBeginEnd)
  else if Statement is TFunctionCall then GenerateFunctionCall(Statement as TFunctionCall)
  else ErrorMsg('Unsuported statement type');
end;

function TCompiler.GetInd: string;
begin
  REsult := StringOfChar(' ', Indentation * 2);
end;

function TCompiler.IsAlphaNumeric(C: Char): Boolean;
begin
  Result := (C in ['a'..'z']) or (C in ['A'..'Z']) or (C in ['0'..'9'])
end;

function TCompiler.IsSpecialSymbol(C: Char): Boolean;
begin
  Result := (C = ';') or (C = '.');
end;

function TCompiler.IsWhiteSpace(C: Char): Boolean;
begin
  Result := (C = ' ') or (C = #9) or (C = #10) or (C = #13);
end;

function TCompiler.ParseBeginEnd(var Block: TBeginEnd): Boolean;
var
  Statement: TStatement;
begin
  Block := nil;
  Result := False;
  if CheckNext('begin') then begin
    Block := TBeginEnd.Create;
    Expect('begin');
    while not CheckNext('end') do begin
      Statement := nil;
      if not ParseStatement(Statement) then ErrorMsg('');
      if Assigned(Statement) then
        Block.Items.Add(Statement);
    end;
    Expect('end');
    Result := True;
  end;
end;

function TCompiler.ParseProgram(var Prog: TProgram): Boolean;
begin
  Prog := TProgram.Create;
  Result := False;
  if not ParseBeginEnd(Prog.Main) then ErrorMsg('');
  Expect('.');
  Result := True;
end;

function TCompiler.ParseFunctionCall(var FuncCall: TFunctionCall): Boolean;
var
  Token: string;
  I: Integer;
begin
  FuncCall := nil;
  Result := False;
  Token := ReadNext;
  I := Functions.IndexOf(Token);
  if I <> -1 then begin
    FuncCall := TFunctionCall.Create;
    FuncCall.Name := Token;
    Result := True;
  end else ErrorMsg('Unknown command ' + Token);
end;

function TCompiler.ParseStatement(var Statement: TStatement): Boolean;
begin
  Statement := nil;
  Result := False;
  if ParseBeginEnd(TBeginEnd(Statement)) then begin
    Expect(';');
    Result := True;
  end else if not CheckNext('end') then begin
    ParseFunctionCall(TFunctionCall(Statement));
    Expect(';');
  end;
end;

function TCompiler.ReadNext: string;
var
  C: Char;
begin
  Result := '';
  while SourcePos < Length(Source) do begin
    C := Source[SourcePos];
    Inc(SourcePos);
    if (Length(Result) = 0) and IsWhiteSpace(C) then Continue;
    if IsAlphaNumeric(C) then Result := Result + C
    else if IsSpecialSymbol(C) then begin
      if Length(Result) > 0 then begin
        Dec(SourcePos);
        Break;
      end else begin
        Result := Result + C;
        Break;
      end;
    end else begin
      Dec(SourcePos);
      Break;
    end;
  end;
end;

var
  Compiler: TCompiler;
  Lines: TStringList;
{ TBeginEnd }

constructor TBeginEnd.Create;
begin
  Items := TObjectList<TStatement>.Create;
end;

destructor TBeginEnd.Destroy;
begin
  FreeAndNil(Items);
  inherited;
end;

{ TProgram }

procedure TProgram.Clear;
begin
  if Assigned(Main) then FreeAndNil(Main);
end;

constructor TProgram.Create;
begin
  Main := TBeginEnd.Create;
end;

destructor TProgram.Destroy;
begin
  FreeAndNil(Main);
  inherited;
end;

begin
  try
    { TODO -oUser -cConsole Main : Insert code here }
    Compiler := TCompiler.Create;
    Lines := TStringList.Create;
    Lines.LoadFromFile('../../Example.pas');
    Compiler.Source := Lines.Text;
    Lines.Free;
    Compiler.Compile;
    WriteLn(Compiler.Destination);
    Lines := TStringList.Create;
    Lines.Text := Compiler.Destination;
    Lines.SaveToFile('../../Example.out');
    Lines.Free;
    Compiler.Free;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.