source: trunk/UMainForm.pas

unit UMainForm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TMemoryType = (mtProgram, mtData, mtEEPROM);

  TModuleType = (mdProgram, mdUnit, mdLibrary, mdPackage);

  TInstruction = (inNone, inJump, inConditionalJump, inExpressionEvaluation,
    inReturn);

  TNodeType = (ntNone, ntVariable, nTFunction, ntConstant, ntOperator);

  TValue = array of Byte;

  TCompiler = class;
  TCommonBlock = class;
  TTypeList = class;
  TConstantList = class;
  TVariableList = class;
  TFunctionList = class;
  TExpression = class;
  TOperationList = class;
  TFunction = class;

  TDevice = class
    Family: string;
    Memory: array[TMemoryType] of Integer;
  end;

  TCommonBlock = class
    Name: string;
    Parent: TCommonBlock;
    Constants: TConstantList;
    Types: TTypeList;
    Variables: TVariableList;
    Methods: TFunctionList;
    Operations: TOperationList;
    procedure AllocateMemory;
    constructor Create; virtual;
    destructor Destroy; override;
    procedure ParseDefinitions(Compiler: TCompiler);
    function ParseExpression(Compiler: TCompiler): TExpression;
    procedure ParseProgramCode(Compiler: TCompiler);
    procedure ParseOperation(Compiler: TCompiler);
    procedure GenerateAssembler(Compiler: TCompiler; LabelPrefix: string);
    procedure CheckReferences;
  end;

  TType = class
    Parent: TTypeList;
    Name: string;
    Size: Integer;
    UsedType: TType;
    procedure Parse(Compiler: TCompiler);
  end;

  TTypeList = class(TList)
    Parent: TCommonBlock;
    procedure Parse(Compiler: TCompiler);
    function Search(Name: string): TType;
  end;

  TConstant = class
    Name: string;
    ValueType: TType;
    Value: TValue;
    procedure Parse(Compiler: TCompiler);
  end;

  TConstantList = class(TList)
    Parent: TCommonBlock;
    function Search(Name: string): TConstant;
    procedure Parse(Compiler: TCompiler);
  end;

  TVariable = class
    Name: string;
    ValueType: TType;
    Value: TValue;
    procedure Parse(Compiler: TCompiler);
  end;

  TVariableList = class(TList)
    Parent: TCommonBlock;
    procedure Parse(Compiler: TCompiler);
    function Search(Name: string): TVariable;
  end;

  TExpression = class
    NodeType: TNodeType;
    Variable: TVariable;
    Method: TFunction;
    Value: TValue;
    OperatorName: string;
    SubItems: TList; // TList<TExpression>
    Associated: Boolean;
    constructor Create;
    destructor Destroy; override;
    procedure GenerateAssembler(Compiler: TCompiler; LabelPrefix: string);
  end;

  TOperation = class
    Instruction: TInstruction;
    ExpressionTree: TExpression;
    GotoAddress: Integer;
    Negative: Boolean;
    Referenced: Boolean;
  end;

  TOperationList = class(TList)

  end;

  TFunction = class(TCommonBlock)
    Parameters: TList; // TList<TParameter>
    ResultType: TType;
    constructor Create; override;
    destructor Destroy; override;
    procedure Parse(Compiler: TCompiler);
  end;

  TFunctionList = class(TList)
    Parent: TCommonBlock;
    procedure Parse(Compiler: TCompiler);
    function Search(Name: string): TFunction;
  end;

  TModule = class(TCommonBlock)
    ModuleType: TModuleType;
    UsedModules: TList; // TList<TModule>
    constructor Create; override;
    destructor Destroy; override;
    procedure Parse(Compiler: TCompiler);
  private
    procedure ParseUnit(Compiler: TCompiler);
    procedure ParseProgram(Compiler: TCompiler);
    procedure Clear;
  end;

  TProgram = class
    Device: TDevice;
    Modules: TList; // TList<TModule>
    constructor Create;
    destructor Destroy; override;
    procedure Parse(Compiler: TCompiler);
    procedure AllocateMemory;
    procedure GenerateAssembler(Compiler: TCompiler);
  end;

  TAssemblerLine = class
    LabelName: string;
    Instruction: string;
    Operand1: string;
    Operand2: string;
    SourceCode: string;
    function AsString: string;
  end;

  TCompiler = class
  private
    SourceCode: TStringList;
    CodePosition: Integer;
    AssemblyCode: TList; // TList<TAssemblerLine>
    ProgramCode: TProgram;
    procedure ErrorMessage(Text: string);
    function IsAlphanumeric(Character: Char): Boolean;
    function NextCode(Shift: Boolean = False): string;
    function ReadCode: string;
    procedure Expect(Code: string);
    function IsWhiteSpace(Character: Char): Boolean;
    function IsAlphabetic(Character: Char): Boolean;
    function IsIdentificator(Text: string): Boolean;
    function IsKeyword(Text: string): Boolean;
    function IsOperator(Text: string): Boolean;
    procedure GenerateAssemblyCode;
    procedure AddInstruction(LabelName, Instruction, Operand1, Operand2: string);
  public
    constructor Create;
    procedure Compile(SourceCode: TStrings);
    destructor Destroy; override;
  end;

  TMainForm = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Memo2: TMemo;
    Memo3: TMemo;
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    Compiler: TCompiler;
  end;

const
  KeyWords: array[0..37] of string = ('program', 'unit', 'uses', 'begin', 'end',
    'type', 'const', 'var', 'array', 'record', 'absolute', 'virtual', 'class',
    'set', 'private', 'public', 'interface', 'implementation', 'finalization',
    'initialization', 'for', 'while', 'if', 'case', 'of', 'pointer',
    'object', 'packed', 'procedure', 'function', 'to', 'do', 'downto', 'repeat',
    'until', 'then', 'asm', 'else');
  Operators: array[0..22] of string = ('@', 'not', '*', 'and', '/', 'shl',
    'shr', 'as', 'div', 'mod', 'or', 'xor', '-', '+', '=', '>', '<', '<>', '<=',
     '>=', 'is', 'in', ':=');

var
  MainForm: TMainForm;

implementation

{$R *.dfm}

procedure TMainForm.Button1Click(Sender: TObject);
var
  I: Integer;
begin
  Compiler.Compile(Memo1.Lines);
  Memo2.Clear;
  for I := 0 to Compiler.AssemblyCode.Count - 1 do
    Memo2.Lines.Add(TAssemblerLine(Compiler.AssemblyCode[I]).AsString);
end;

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Memo1.Lines.SaveToFile('Example.pas');
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  Compiler := TCompiler.Create;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  Compiler.Destroy;
end;

procedure TMainForm.FormShow(Sender: TObject);
var
  I: Integer;
begin
  Memo1.Lines.LoadFromFile('Example.pas');
  Compiler.Compile(Memo1.Lines);
  Memo2.Clear;
  for I := 0 to Compiler.AssemblyCode.Count - 1 do
    Memo2.Lines.Add(TAssemblerLine(Compiler.AssemblyCode[I]).AsString);

end;

{ TCompiler }

procedure TCompiler.AddInstruction(LabelName, Instruction, Operand1,
  Operand2: string);
var
  NewLine: TAssemblerLine;
begin
  NewLine := TAssemblerLine.Create;
  AssemblyCode.Add(NewLine);
  NewLine.LabelName := LabelName;
  NewLine.Instruction := Instruction;
  NewLine.Operand1 := Operand1;
  NewLine.Operand2 := Operand2;
end;

procedure TCompiler.Compile(SourceCode: TStrings);
begin
  MainForm.Memo3.Clear;
  Self.SourceCode.Assign(SourceCode);
  CodePosition := 1;
  ProgramCode.Parse(Self);
  ProgramCode.AllocateMemory;
  AssemblyCode.Clear;
  GenerateAssemblyCode;
end;

constructor TCompiler.Create;
begin
  SourceCode := TStringList.Create;
  AssemblyCode := TList.Create;
  ProgramCode := TProgram.Create;
end;

destructor TCompiler.Destroy;
begin
  ProgramCode.Free;
  AssemblyCode.Free;
  SourceCode.Free;
end;

procedure TCompiler.ErrorMessage(Text: string);
begin
  //ShowMessage(Text);
  MainForm.Memo3.Lines.Add(Text);
end;

procedure TCompiler.Expect(Code: string);
begin
  if NextCode <> Code then begin
    ErrorMessage('Expected ' + Code + ' but ' + NextCode + ' found.');
  end;
  ReadCode;
end;

procedure TCompiler.GenerateAssemblyCode;
begin
  ProgramCode.GenerateAssembler(Self);
end;

function TCompiler.IsAlphabetic(Character: Char): Boolean;
begin
  Result := (Character in ['a'..'z']) or (Character in ['A'..'Z']);
end;

function TCompiler.IsAlphanumeric(Character: Char): Boolean;
begin
  Result := IsAlphabetic(Character) or (Character in ['0'..'9']);
end;

function TCompiler.IsKeyword(Text: string): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I := 0 to High(Keywords) do
    if Keywords[I] = Text then
      Result := True;
end;

function TCompiler.IsOperator(Text: string): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I := 0 to High(Operators) do
    if Operators[I] = Text then
      Result := True;
end;

function TCompiler.IsIdentificator(Text: string): Boolean;
var
  I: Integer;
begin
  Result := True;
  if Length(Text) = 0 then Result := False;
  if IsKeyWord(Text) then Result := False;
  if Length(Text) > 0 then
    if not (Text[1] in ['a'..'z', 'A'..'Z', '%', '_']) then
      Result := False;
  for I := 2 to Length(Text) do
    if not (Text[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_']) then
      Result := False;
end;

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

function TCompiler.NextCode(Shift: Boolean = False): string;
var
  I: Integer;
//  II: Integer;
  J: Integer;
const
  SpecChar: set of char = [';', '.', ',', ':', '(', ')', '[', ']', '+', '-', '/', '*',
    '^', '=', '<' , '>' , '@'];
  DoubleSpecChar : array[1..7] of string = (':=', '..', '<=', '>=', '<>', '+=', '-=');
begin
  Result := '';
  J := CodePosition;
  I := CodePosition;
  with SourceCode do
  while Result = '' do begin
    while IsWhiteSpace(Text[I]) do Inc(I);
    J := I;
    if Copy(Text, J, 1) = '//' then begin
      while (Text[I] <> #13) and (Text[I] <> #10) do Inc(I);
      Result := '';
    end else
    if Copy(Text, J, 1) = '{' then begin
      while (Text[I] <> '}') do Inc(I);
      Result := '';
    end else
    if Copy(Text, J, 1) = '(*' then begin
      while not((Text[I] = '*') and (Text[I + 1] = ')')) do Inc(I);
      Result := '';
    end else
    if Text[J] = '''' then begin
      I := J + 1;
      while not ((Text[I] = '''') and (Text[I + 1] <> '''')) do Inc(I);
      Inc(I);
      Result := Copy(Text, J, I - J );
    end else
    if (Text[J] in SpecChar) then begin
      if (Text[J + 1] in SpecChar) then begin
        for I := 0 to High(DoubleSpecChar) do
          if Copy(Text, J, 2) = DoubleSpecChar[I] then begin
            Result := Copy(Text, J, 2);
            Inc(J, 2);
            Break;
          end;
        I := J;
      end;
      if Result = '' then begin
        Result := Text[J];
        Inc(I);
      end;
    end else begin
      while IsAlphanumeric(Text[I]) do Inc(I);
      Result := LowerCase(Copy(Text, J, I - J));
    end;
    J := I;
  end;
  if Shift then CodePosition := J;
end;

procedure TModule.ParseUnit(Compiler: TCompiler);
begin
  with Compiler do begin
    Expect('unit');
    with TModule(ProgramCode.Modules[0]) do begin
      Name := ReadCode;
      ModuleType := mdUnit;
    end;
    Expect(';');
    //ParseInterface;
    //ParseImplementation;
  end;
end;

function TCompiler.ReadCode: string;
begin
  Result := NextCode(True);
end;

{ TFunction }

constructor TFunction.Create;
begin
  inherited;
  Parameters := TList.Create;
  ResultType := TType.Create;
end;

destructor TFunction.Destroy;
begin
  Parameters.Free;
  ResultType.Free;
  inherited;
end;

procedure TFunction.Parse(Compiler: TCompiler);
begin
  with Compiler do begin
    if NextCode = 'var' then TVariableList(Variables).Parse(Compiler)
    else if NextCode = 'const' then TConstantList(Constants).Parse(Compiler)
    else if NextCode = 'type' then TTypeList(Types).Parse(Compiler)
    else ProgramCode.Parse(Compiler);
  end;
end;

{ TProgram }

procedure TProgram.AllocateMemory;
var
  I: Integer;
begin
  for I := 0 to Modules.Count - 1 do
    TModule(Modules[I]).AllocateMemory;
end;

constructor TProgram.Create;
begin
  Device := TDevice.Create;
  Modules := TList.Create;
end;

destructor TProgram.Destroy;
begin

end;

procedure TProgram.GenerateAssembler(Compiler: TCompiler);
var
  I: Integer;
begin
  for I := 0 to Modules.Count - 1 do
    TModule(Modules[I]).GenerateAssembler(Compiler, '');
end;

procedure TProgram.Parse(Compiler: TCompiler);
var
  I: Integer;
begin
  for I := 0 to Modules.Count - 1 do
    TModule(Modules[I]).Clear;
  Modules.Clear;
  with TModule(Modules[Modules.Add(TModule.Create)]) do begin
    Name := 'main';
    with TType(Types[Types.Add(TType.Create)]) do begin
      Name := 'byte';
      Size := 1;
      UsedType := nil;
    end;
  end;
  TModule(Modules[0]).Parse(Compiler);
end;

{ TConstant }

procedure TConstant.Parse(Compiler: TCompiler);
begin

end;

{ TConstantList }

procedure TConstantList.Parse(Compiler: TCompiler);
begin
//  Compiler.Expect('const');
//  while Compiler.IsIdentificator(Compiler.NextCode) do
//    TConstant(Items[Add(TConstant.Create)]).Parse(Compiler);
end;

function TConstantList.Search(Name: string): TConstant;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (TConstant(Items[I]).Name <> Name) do Inc(I);
  if I < Count then Result := Items[I] else begin
    if Assigned(Parent.Parent) then Result := Parent.Parent.Constants.Search(Name)
      else begin
        Result := nil;
      end;
  end;
end;

{ TModule }

procedure TModule.Clear;
begin
  Variables.Clear;
  Constants.Clear;
  Methods.Clear;
  Operations.Clear;
end;

constructor TModule.Create;
begin
  inherited;
  UsedModules := TList.Create;
end;

destructor TModule.Destroy;
begin
  UsedModules.Destroy;
  inherited;
end;

procedure TModule.ParseProgram(Compiler: TCompiler);
var
  Identifier: string;
begin
  with Compiler do begin
    if NextCode = 'program' then begin
      Expect('program');
      Name := ReadCode;
      ModuleType := mdProgram;
      Expect(';');
    end else Name := '';

    // Uses section
    if NextCode = 'uses' then begin
      Identifier := ReadCode;
      while NextCode = ',' do begin
        Identifier := ReadCode;

      end;
    end;
    ParseDefinitions(Compiler);
  end;
end;

procedure TModule.Parse(Compiler: TCompiler);
begin
  with Compiler do begin
    if NextCode = 'program' then ParseProgram(Compiler)
    else if NextCode = 'unit' then ParseUnit(Compiler)
    else ParseProgram(Compiler);
  end;
end;

procedure TCommonBlock.AllocateMemory;
begin
//  for I := 0 to Variables - 1 do
    
end;

procedure TCommonBlock.CheckReferences;
var
  I: Integer;
begin
  for I := 0 to Operations.Count - 1 do
  with TOperation(Operations[I]) do begin
    if (Instruction = inJump) or (Instruction = inConditionalJump) then
      TOperation(Operations[GotoAddress]).Referenced := True;
  end;
end;

constructor TCommonBlock.Create;
begin
  Constants := TConstantList.Create;
  Constants.Parent := Self;
  Types := TTypeList.Create;
  Types.Parent := Self;
  Variables := TVariableList.Create;
  Variables.Parent := Self;
  Methods := TFunctionList.Create;
  Methods.Parent := Self;
  Operations := TOperationList.Create;
end;

destructor TCommonBlock.Destroy;
begin
  Constants.Destroy;
  Types.Destroy;
  Variables.Destroy;
  Methods.Destroy;
  Operations.Destroy;
  inherited;
end;

procedure TCommonBlock.GenerateAssembler(Compiler: TCompiler; LabelPrefix: string);
var
  I: Integer;
  LabelName: string;
begin
  with Compiler do
  for I := 0 to Operations.Count - 1 do 
  with TOperation(Operations[I]) do begin
    if Referenced then LabelName := Name + '_L' + IntToStr(I)
      else LabelName := '';
    case Instruction of
      inJump: begin
        AddInstruction(LabelName, 'JMP', Name + '_L' + IntToStr(GotoAddress), '');
      end;
      inConditionalJump: begin
        ExpressionTree.GenerateAssembler(Compiler, LabelPrefix + '_L' + IntToStr(GotoAddress));
        AddInstruction(LabelName, 'BRCS', Name + '_L' + IntToStr(GotoAddress), '');
      end;
      inExpressionEvaluation: begin
        if LabelName <> '' then AddInstruction(LabelName, '', '', '');
        ExpressionTree.GenerateAssembler(Compiler, Name + '_L' + IntToStr(GotoAddress));
      end;
      inReturn:
        AddInstruction(LabelName, 'RET', '', '');
    end;
  end;
end;

procedure TCommonBlock.ParseDefinitions(Compiler: TCompiler);
begin
  with Compiler do begin
    while NextCode <> '.' do begin
      if NextCode = 'var' then TVariableList(Variables).Parse(Compiler)
      else if NextCode = 'const' then TConstantList(Constants).Parse(Compiler)
      else if NextCode = 'type' then TTypeList(Types).Parse(Compiler)
      else begin
        ParseProgramCode(Compiler);
        Break;
      end;
    end;
  end;
end;

function TCommonBlock.ParseExpression(Compiler: TCompiler): TExpression;
var
  Identifier: string;
  NewVariable: TVariable;
  Method: TFunction;
  Constant: TConstant;
//  Brackets: Integer;
  Expressions: TList; // TList<TExpression>;
  I: Integer;
  II: Integer;
begin
  Expressions := TList.Create;
  Expressions.Add(TExpression.Create);
  with Compiler do begin
    while ((NextCode <> ';') and (NextCode <> ',') and (not IsKeyWord(NextCode))) and
      not (((NextCode = ')') or (NextCode = ']'))) do begin
        Identifier := ReadCode;
        if Identifier = '(' then begin
          with TExpression(Expressions[Expressions.Count - 1]) do begin
            SubItems[1] := ParseExpression(Compiler);
          end;
          with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do begin
            SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];
          end;
          Expect(')');
        end else
        if IsOperator(Identifier) then begin
          TExpression(Expressions[Expressions.Count - 1]).OperatorName := Identifier;
          TExpression(Expressions[Expressions.Count - 1]).NodeType := ntOperator;
        end else
        if IsIdentificator(Identifier) then begin
          NewVariable := Variables.Search(Identifier);
          if Assigned(NewVariable) then begin
            with TExpression(Expressions[Expressions.Count - 1]) do begin
              SubItems[1] := TExpression.Create;
              TExpression(SubItems[1]).NodeType := ntVariable;
              TExpression(SubItems[1]).Variable := NewVariable;
            end;
            with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do begin
              SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];
            end;
          end else begin
            Method := Methods.Search(Identifier);
            if Assigned(Method) then begin
              with TExpression(Expressions[Expressions.Count - 1]) do begin
                SubItems[1] := TExpression.Create;
                if NextCode  = '(' then               // Method with parameters
                with TExpression(SubItems[1]) do begin
                  Expect('(');
                  SubItems.Add(ParseExpression(Compiler));
                  while NextCode = ',' do begin
                    Expect(',');
                    SubItems.Add(ParseExpression(Compiler));
                  end;
                  Expect(')');
                end;
                TExpression(SubItems[1]).NodeType := nTFunction;
                TExpression(SubItems[1]).Method := Method;
              end;
              with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do begin
                SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];
              end;
            end else begin
              Constant := Constants.Search(Identifier);
              if Assigned(Constant) then begin
                with TExpression(Expressions[Expressions.Count - 1]) do begin
                  SubItems[1] := TExpression.Create;
                  TExpression(SubItems[1]).NodeType := ntConstant;
                  TExpression(SubItems[1]).Value := Constant.Value;
                end;
                with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do begin
                  SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];
                end;
              end else begin
                ErrorMessage('Neznámý identifikátor: ' + Identifier);
              end;
            end;
          end;
        end else
        begin
                with TExpression(Expressions[Expressions.Count - 1]) do begin
                  SubItems[1] := TExpression.Create;
                  TExpression(SubItems[1]).NodeType := ntConstant;

                  if Identifier[1] = '''' then begin
                    SetLength(TExpression(SubItems[1]).Value, Length(Identifier));
                    for I := 1 to Length(Identifier) do TExpression(SubItems[1]).Value[I - 1] := Byte(Identifier[I]);
                  end else begin
                    SetLength(TExpression(SubItems[1]).Value, 1);
                    TExpression(SubItems[1]).Value[0] := StrToInt(Identifier);
                  end;
                end;
                with TExpression(Expressions.Items[Expressions.Add(TExpression.Create)]) do begin
                  SubItems[0] := TExpression(Expressions[Expressions.Count - 2]).SubItems[1];
                end;
        end;
    end;

    // Build expression tree
    for II := 0 to High(Operators) do begin
      I := 1;
      while (I < Expressions.Count - 1) do begin
        if not TExpression(Expressions[I]).Associated and
          (TExpression(Expressions[I]).OperatorName = Operators[II]) then begin
            TExpression(Expressions[I]).Associated := True;
            TExpression(Expressions[I - 1]).SubItems[1] := Expressions[I];
            TExpression(Expressions[I + 1]).SubItems[0] := Expressions[I];
            Expressions.Delete(I);
          end else Inc(I);
      end;
    end;
  end;
  Result := TExpression(Expressions[0]).SubItems[1];
  TExpression(Expressions[0]).Destroy;
  TExpression(Expressions[1]).Destroy;
  Expressions.Destroy;
end;

procedure TCommonBlock.ParseOperation(Compiler: TCompiler);
var
  Identifier: string;
  Variable: TVariable;
  Method: TFunction;
  First: TOperation;
  Second: TOperation;
  StartIndex: Integer;
  LoopVaraible: TVariable;
begin
  with Compiler do begin
    if NextCode = 'begin' then ParseProgramCode(Compiler)
    else if NextCode = 'if' then begin
      Expect('if');
      with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin
        Instruction := inConditionalJump;
        ExpressionTree := ParseExpression(Compiler);
        Negative := True;
      end;
      First := Operations[Operations.Count - 1];
      Expect('then');
      ParseOperation(Compiler);
      if NextCode = 'else' then begin
        with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin
          Instruction := inJump;
        end;
        Second := Operations[Operations.Count - 1];
        First.GotoAddress := Operations.Count;
        Expect('else');
        ParseOperation(Compiler);
        Second.GotoAddress := Operations.Count;
      end else First.GotoAddress := Operations.Count;
    end
    else if NextCode = 'repeat' then begin
      Expect('repeat');
      StartIndex := Operations.Count;
      ParseOperation(Compiler);
      Expect('until');
      with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin
        Instruction := inConditionalJump;
        ExpressionTree := ParseExpression(Compiler);
        GotoAddress := StartIndex;
      end;
    end
    else if NextCode = 'while' then begin
      Expect('while');
      with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin
        Instruction := inConditionalJump;
        ExpressionTree := ParseExpression(Compiler);
      end;
      First := Operations[Operations.Count - 1];
      StartIndex := Operations.Count - 1;
      Expect('do');
      ParseOperation(Compiler);
      with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin
        Instruction := inJump;
        GotoAddress := StartIndex;
      end;
      First.GotoAddress := Operations.Count;
    end
    else if NextCode = 'for' then begin
      Expect('for');
      with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin
        Instruction := inExpressionEvaluation;
        ExpressionTree := ParseExpression(Compiler);
        if (ExpressionTree.NodeType <> ntOperator) and
          (ExpressionTree.OperatorName <> ':=') then ErrorMessage('Expected assigment in for loop');
        if TExpression(TExpression(ExpressionTree).SubItems[0]).NodeType <> ntVariable then
          ErrorMessage('Index in FOR loop have to be variable');
        LoopVaraible := TExpression(TExpression(ExpressionTree).SubItems[0]).Variable;
      end;
      Expect('to');
      with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin
        Instruction := inExpressionEvaluation;
        ExpressionTree := TExpression.Create;
        with ExpressionTree do begin
          NodeType := ntOperator;
          OperatorName := '=';
          SubItems[0] := TExpression.Create;
          with TExpression(SubItems[0]) do begin
            NodeType := ntVariable;
            Variable := LoopVaraible;
          end;
          SubItems[1] := ParseExpression(Compiler);
        end;
        Negative := True;
      end;
      First := Operations[Operations.Count - 1];
      StartIndex := Operations.Count - 1;
      Expect('do');
      ParseOperation(Compiler);
      with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin
        Instruction := inExpressionEvaluation;
        ExpressionTree := TExpression.Create;
        with ExpressionTree do begin
          NodeType := ntOperator;
          OperatorName := ':=';
          SubItems[0] := TExpression.Create;
          with TExpression(SubItems[0]) do begin
            NodeType := ntVariable;
            Variable := LoopVaraible;
          end;
          SubItems[1] := TExpression.Create;
          with TExpression(SubItems[1]) do begin
            NodeType := ntOperator;
            OperatorName := '+';
            SubItems[0] := TExpression.Create;
            with TExpression(SubItems[0]) do begin
              NodeType := ntVariable;
              Variable := LoopVaraible;
            end;
            SubItems[1] := TExpression.Create;
            with TExpression(SubItems[1]) do begin
              NodeType := ntConstant;
              SetLength(Value, 1);
              Value[0] := 1;
            end;
          end;
        end;
      end;
      with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin
        Instruction := inJump;
        GotoAddress := StartIndex;
      end;
      First.GotoAddress := Operations.Count;
    end
    else begin
      with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin
        Instruction := inExpressionEvaluation;
        ExpressionTree := ParseExpression(Compiler);
      end;
    end;
  end;
end;

procedure TCommonBlock.ParseProgramCode(Compiler: TCompiler);
begin
  with Compiler do begin
    Expect('begin');
    while NextCode <> 'end' do begin
      ParseOperation(Compiler);
      Expect(';');
    end;
    Expect('end');
    with TOperation(Operations[Operations.Add(TOperation.Create)]) do begin
      Instruction := inReturn;
    end;
  end;
  CheckReferences;
end;

{ TTypeList }

procedure TTypeList.Parse(Compiler: TCompiler);
begin
  with Compiler do begin
    Expect('type');
    while IsIdentificator(NextCode) do
      with TType(Items[Add(TType.Create)]) do begin
        Parent := Self;
        Parse(Compiler);
      end;
  end;
end;

function TTypeList.Search(Name: string): TType;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (TType(Items[I]).Name <> Name) do Inc(I);
  if I < Count then Result := Items[I] else begin
    if Assigned(Parent.Parent) then Result := Parent.Parent.Types.Search(Name)
      else begin
        Result := nil;
      end;
  end;
end;

{ TVariableList }

procedure TVariableList.Parse(Compiler: TCompiler);
var
  Identifiers: TStringList;
  NewValueType: TType;
  TypeName: string;
  VariableName: string;
  Variable: TVariable;
  I: Integer;
begin
  Identifiers := TStringList.Create;
  with Compiler do begin
    Expect('var');
    while IsIdentificator(NextCode) do begin
      VariableName := ReadCode;
      Variable := Search(VariableName);
      if not Assigned(Variable) then begin
        Identifiers.Add(VariableName);
        while NextCode = ',' do begin
          Expect(',');
          Identifiers.Add(ReadCode);
        end;
      end else ErrorMessage('Pøedefinování existující promìnné.');
      Expect(':');
      TypeName := ReadCode;
      NewValueType := Parent.Types.Search(TypeName);
      if NewValueType = nil then ErrorMessage('Typ ' + TypeName + ' nebyl definován.')
        else for I := 0 to Identifiers.Count - 1 do
          with TVariable(Items[Add(TVariable.Create)]) do begin
            Name := Identifiers[I];
            ValueType := NewValueType;
          end;
      Expect(';');
    end;
  end;
  Identifiers.Destroy;
end;

function TVariableList.Search(Name: string): TVariable;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (TVariable(Items[I]).Name <> Name) do Inc(I);
  if I < Count then Result := Items[I] else begin
    if Assigned(Parent.Parent) then Result := Parent.Parent.Variables.Search(Name)
      else begin
        Result := nil;
      end;
  end;
end;

{ TVariable }

procedure TVariable.Parse(Compiler: TCompiler);
begin
end;

{ TType }

procedure TType.Parse(Compiler: TCompiler);
begin
  with Compiler do begin
    Name := NextCode;
    Expect('=');
    UsedType := Parent.Search(NextCode);
  end;
end;

{ TFunctionList }

procedure TFunctionList.Parse(Compiler: TCompiler);
begin

end;

function TFunctionList.Search(Name: string): TFunction;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (TFunction(Items[I]).Name <> Name) do Inc(I);
  if I < Count then Result := Items[I] else begin
    if Assigned(Parent.Parent) then Result := Parent.Parent.Methods.Search(Name)
      else begin
        Result := nil;
      end;
  end;
end;

{ TExpression }

constructor TExpression.Create;
begin
  SubItems := TList.Create;
  SubItems.Count := 2;
end;

destructor TExpression.Destroy;
begin
  SubItems.Destroy;
  inherited;
end;

procedure TExpression.GenerateAssembler(Compiler: TCompiler; LabelPrefix: string);
var
  I: Integer;
begin
  with Compiler do
  case NodeType of
    ntNone: ;
    ntVariable: if Assigned(Variable) then AddInstruction('', 'GETVAR', Variable.Name, '');
    nTFunction: AddInstruction('', 'CALL', Method.Name, '');
    ntConstant: AddInstruction('', 'CONST', '', '');
    ntOperator: begin
      for I := 0 to SubItems.Count - 1 do
        TExpression(SubItems[I]).GenerateAssembler(Compiler, LabelPrefix);
      if OperatorName = '+' then AddInstruction('', 'ADD', '', '')
      else if OperatorName = '-' then AddInstruction('', 'SUB', '', '')
      else if OperatorName = '*' then AddInstruction('', 'MUL', '', '')
      else if OperatorName = '/' then AddInstruction('', 'DIV', '', '')
      else if OperatorName = 'div' then AddInstruction('', 'DIV', '', '')
      else if OperatorName = 'mod' then AddInstruction('', 'MOD', '', '')
      else if OperatorName = 'xor' then AddInstruction('', 'XOR', '', '')
      else if OperatorName = 'or' then AddInstruction('', 'OR', '', '')
      else if OperatorName = 'and' then AddInstruction('', 'AND', '', '')
      else if OperatorName = 'not' then AddInstruction('', 'NEG', '', '')
      else if OperatorName = ':=' then AddInstruction('', 'ST', '', '')
      else if OperatorName = '>' then AddInstruction('', 'CP', '', '')
      else if OperatorName = '>=' then AddInstruction('', 'CP', '', '')
      else if OperatorName = '<' then AddInstruction('', 'CP', '', '')
      else if OperatorName = '<=' then AddInstruction('', 'CP', '', '')
      else if OperatorName = '=' then AddInstruction('', 'TST', '', '')
      else if OperatorName = '<>' then AddInstruction('', 'CP', '', '');
    end;
  end;
end;

{ TAssemblerLine }

function TAssemblerLine.AsString: string;
begin
  if LabelName = '' then LabelName := #9 else
    LabelName := LabelName + ':'#9;
  if Operand2 <> '' then Operand1 := Operand1 + ', ';
  
  Result := LabelName + Instruction + ' ' + Operand1 + Operand2;
end;

end.