source: branches/xpascal/Parser.pas

unit Parser;

interface

uses
  Classes, SysUtils, Tokenizer, Source;

type

  { TParser }

  TParser = class
  private
    FOnError: TErrorEvent;
    procedure TokenizerError(Pos: TPoint; Text: string);
    procedure InitSystemBlock(Block: TBlock);
  protected
    Tokenizer: TTokenizer;
    function ParseProgram(SystemBlock: TBlock; out Prog: TProgram): Boolean; virtual;
  public
    Source: string;
    Prog: TProgram;
    procedure Parse;
    procedure Error(Text: string);
    constructor Create;
    destructor Destroy; override;
    property OnError: TErrorEvent read FOnError write FOnError;
  end;


implementation

resourcestring
  SCannotParseProgram = 'Cannot parse program.';

{ TParser }

procedure TParser.TokenizerError(Pos: TPoint; Text: string);
begin
  if Assigned(FOnError) then
    FOnError(Pos, Text);
end;

procedure TParser.InitSystemBlock(Block: TBlock);
var
  I: Integer;
  TypeBoolean: TType;
  TypeString: TType;
  TypeInteger: TType;
begin
  TypeBoolean := Block.Types.AddNew('Boolean');
  with TypeBoolean do begin
    ValueClass := TValueBoolean;
    with Functions.AddNew('_Assign') do begin
      Params.AddNew('Source', TypeBoolean);
      ResultType := TypeBoolean;
    end;
    with Functions.AddNew('_Equal') do begin
      Params.AddNew('A', TypeBoolean);
      Params.AddNew('B', TypeBoolean);
      ResultType := TypeBoolean;
    end;
    with Functions.AddNew('_NotEqual') do begin
      Params.AddNew('A', TypeBoolean);
      Params.AddNew('B', TypeBoolean);
      ResultType := TypeBoolean;
    end;
    with Functions.AddNew('_Not') do begin
      Params.AddNew('A', TypeBoolean);
      ResultType := TypeBoolean;
    end;
  end;
  TypeString := Block.Types.AddNew('string');
  with TypeString do begin
    ValueClass := TValueString;
    with Functions.AddNew('_Assign') do begin
      Params.AddNew('Source', TypeString);
      ResultType := TypeString;
    end;
    with Functions.AddNew('_Add') do begin
      Params.AddNew('A', TypeString);
      Params.AddNew('B', TypeString);
      ResultType := TypeString;
    end;
    with Functions.AddNew('_Equal') do begin
      Params.AddNew('A', TypeString);
      Params.AddNew('B', TypeString);
      ResultType := TypeBoolean;
    end;
    with Functions.AddNew('_NotEqual') do begin
      Params.AddNew('A', TypeString);
      Params.AddNew('B', TypeString);
      ResultType := TypeBoolean;
    end;
  end;
  TypeInteger := Block.Types.AddNew('Integer');
  with TypeInteger do begin
    ValueClass := TValueInteger;
    with Functions.AddNew('_Assign') do begin
      Params.AddNew('Source', TypeInteger);
      ResultType := TypeInteger;
    end;
    with Functions.AddNew('_Add') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeInteger;
    end;
    with Functions.AddNew('_Sub') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeInteger;
    end;
    with Functions.AddNew('_Mul') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeInteger;
    end;
    with Functions.AddNew('_IntDiv') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeInteger;
    end;
    with Functions.AddNew('_Mod') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeInteger;
    end;
    with Functions.AddNew('_Equal') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeBoolean;
    end;
    with Functions.AddNew('_NotEqual') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeBoolean;
    end;
    with Functions.AddNew('_Lesser') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeBoolean;
    end;
    with Functions.AddNew('_Higher') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeBoolean;
    end;
    with Functions.AddNew('_LesserOrEqual') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeBoolean;
    end;
    with Functions.AddNew('_HigherOrEqual') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeBoolean;
    end;
    with Functions.AddNew('_Shr') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeInteger;
    end;
    with Functions.AddNew('_Shl') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeInteger;
    end;
    with Functions.AddNew('_And') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeInteger;
    end;
    with Functions.AddNew('_Or') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeInteger;
    end;
    with Functions.AddNew('_Xor') do begin
      Params.AddNew('A', TypeInteger);
      Params.AddNew('B', TypeInteger);
      ResultType := TypeInteger;
    end;
  end;
  with Block.Functions.AddNew('IntToStr') do begin
    InternalName := 'IntToStr';
    Params.AddNew('Value', TypeInteger);
    ResultType := TypeString;
  end;
  with Block.Functions.AddNew('StrToInt') do begin
    InternalName := 'StrToInt';
    Params.AddNew('Value', TypeString);
    ResultType := TypeInteger;
  end;
  with Block.Functions.AddNew('BoolToStr') do begin
    InternalName := 'BoolToStr';
    Params.AddNew('Value', TypeBoolean);
    ResultType := TypeString;
  end;
  with Block.Functions.AddNew('StrToBool') do begin
    InternalName := 'StrToBool';
    Params.AddNew('Value', TypeString);
    ResultType := TypeBoolean;
  end;
  with Block.Procedures.AddNew('WriteLn') do begin
    InternalName := 'WriteLn';
    Params.AddNew('Text', TypeString);
  end;
  with Block.Procedures.AddNew('Write') do begin
    InternalName := 'Write';
    Params.AddNew('Text', TypeString);
  end;
  with Block.Procedures.AddNew('ReadLn') do begin
    InternalName := 'ReadLn';
    with Params.AddNew('Text', TypeString) do
      Kind := pkVar;
  end;
  with Block.Procedures.AddNew('Read') do begin
    InternalName := 'Read';
    with Params.AddNew('Text', TypeString) do
      Kind := pkVar;
  end;

  for I := 0 to Block.Functions.Count - 1 do
    Block.Functions[I].InitVariables;
  for I := 0 to Block.Procedures.Count - 1 do
    Block.Procedures[I].InitVariables;
end;

function TParser.ParseProgram(SystemBlock: TBlock; out Prog: TProgram): Boolean;
begin
  Result := False;
end;

procedure TParser.Parse;
var
  NewProg: TProgram;
  SystemBlock: TBlock;
begin
  Tokenizer.Source := Source;
  Tokenizer.Init;
  SystemBlock := TBlock.Create;
  InitSystemBlock(SystemBlock);
  if ParseProgram(SystemBlock, NewProg) then begin
    Prog := NewProg;
  end else Tokenizer.Error(SCannotParseProgram);
end;

procedure TParser.Error(Text: string);
begin
  if Assigned(FOnError) then
    FOnError(Tokenizer.Pos.Pos, Text);
end;

constructor TParser.Create;
begin
  Tokenizer := TTokenizer.Create;
  Tokenizer.OnError := TokenizerError;
end;

destructor TParser.Destroy;
begin
  FreeAndNil(Tokenizer);
  inherited;
end;

end.