source: branches/CpuSingleSize/Parser.pas

unit Parser;

interface

uses
  Classes, SysUtils;

type
  TErrorEvent = procedure (Text: string; Pos: TPoint) of object;

  TTokenKind = (tkKeyword, tkString, tkNumber, tkSpecialSymbol, tkEof, tkEol,
    tkIdentifier);

  TToken = record
    Kind: TTokenKind;
    Value: string;
    Pos: TPoint;
  end;

  { TParserPos }

  TParserPos = record
    Index: Integer;
    Pos: TPoint;
    procedure Reset;
    procedure NextChar;
    procedure NextLine;
  end;

  { TParser }

  TParser = class
  private
    FOnError: TErrorEvent;
  public
    Pos: TParserPos;
    Source: string;
    function IsDigit(Value: Char): Boolean;
    function IsSpecialSymbol(C: Char): Boolean;
    function IsAlpha(C: Char): Boolean;
    function IsAlphaNumeric(C: Char): Boolean;
    function IsWhiteSpace(C: Char): Boolean;
    function ReadNext: TToken;
    function CheckNext(Kind: TTokenKind; Value: string = ''): Boolean;
    function CheckNextKind(Kind: TTokenKind): Boolean;
    function CheckNextAndRead(Kind: TTokenKind; Value: string = ''): Boolean;
    procedure Expect(Kind: TTokenKind; Value: string = '');
    procedure Error(Text: string; Pos: TPoint);
    procedure Reset;
    constructor Create;
    property OnError: TErrorEvent read FOnError write FOnError;
  end;


implementation

{ TParserPos }

procedure TParserPos.Reset;
begin
  Index := 1;
  Pos := Point(1, 1);
end;

procedure TParserPos.NextChar;
begin
  Inc(Index);
  Inc(Pos.X);
end;

procedure TParserPos.NextLine;
begin
  Inc(Index);
  Pos.X := 1;
  Inc(Pos.Y);
end;

{ TParser }

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

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

function TParser.IsAlpha(C: Char): Boolean;
begin
  Result := (C in ['a'..'z']) or (C in ['A'..'Z']);
end;

function TParser.IsAlphaNumeric(C: Char): Boolean;
begin
  Result := IsAlpha(C) or IsDigit(C) or (C = '_');
end;

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

function TParser.ReadNext: TToken;
type
  TParserState = (psNone, psNumber, psString, psComment, psIdentifier);
var
  C: Char;
  State: TParserState;
begin
  State := psNone;
  Result.Value := '';
  while Pos.Index < Length(Source) do begin
    C := Source[Pos.Index];
    if State = psNone then begin
      if IsWhiteSpace(C) then begin
      end else
      if C = ';' then begin
        State := psComment;
      end else
      if IsAlpha(C) then begin
        Result.Pos := Pos.Pos;
        Result.Kind := tkIdentifier;
        Result.Value := C;
        State := psIdentifier;
      end else
      if IsDigit(C) then begin
        Result.Pos := Pos.Pos;
        Result.Kind := tkNumber;
        Result.Value := C;
        State := psNumber;
      end else
      if C = '''' then begin
        Result.Pos := Pos.Pos;
        Result.Kind := tkString;
        State := psString;
      end else
      if C = #13 then begin
      end else
      if C = #10 then begin
        Result.Pos := Pos.Pos;
        Result.Kind := tkEol;
        Result.Value := '';
        Pos.NextLine;
        Break;
      end else
      if IsSpecialSymbol(C) then begin
        Result.Pos := Pos.Pos;
        Result.Kind := tkSpecialSymbol;
        Result.Value := C;
        Pos.NextChar;
        Break;
      end else
        Error('Unknown character ' + C, Pos.Pos);
    end else
    if State = psIdentifier then begin
      if IsAlphaNumeric(C) then begin
        Result.Value := Result.Value + C;
      end else begin
        Break;
      end;
    end else
    if State = psComment then begin
      if (C = #10) or (C = #13) then begin
        State := psNone;
        Continue;
      end;
    end else
    if State = psNumber then begin
      if IsDigit(C) then Result.Value := Result.Value + C
      else begin
        Break;
      end;
    end else
    if State = psString then begin
      if C = '''' then begin
        Pos.NextChar;
        Break;
      end else begin
        Result.Value := Result.Value + C;
      end;
    end;
    Pos.NextChar;
  end;
  if (State = psNone) and (Pos.Index >= Length(Source)) then begin
    Result.Kind := tkEof;
    Result.Value := '';
    Result.Pos := Pos.Pos;
  end;
end;

function TParser.CheckNext(Kind: TTokenKind; Value: string = ''): Boolean;
var
  LastPos: TParserPos;
  Token: TToken;
begin
  LastPos := Pos;
  Token := ReadNext;
  Result := (Token.Kind = Kind) and (LowerCase(Token.Value) = LowerCase(Value));
  Pos := LastPos;
end;

function TParser.CheckNextKind(Kind: TTokenKind): Boolean;
var
  LastPos: TParserPos;
  Token: TToken;
begin
  LastPos := Pos;
  Token := ReadNext;
  Result := Token.Kind = Kind;
  Pos := LastPos;
end;

function TParser.CheckNextAndRead(Kind: TTokenKind; Value: string): Boolean;
var
  LastPos: TParserPos;
  Token: TToken;
begin
  LastPos := Pos;
  Token := ReadNext;
  Result := (Token.Kind = Kind) and (LowerCase(Token.Value) = LowerCase(Value));
  if not Result then Pos := LastPos;
end;

procedure TParser.Expect(Kind: TTokenKind; Value: string = '');
var
  Token: TToken;
begin
  Token := ReadNext;
  if (Token.Kind <> Kind) or (LowerCase(Token.Value) <> LowerCase(Value)) then
    Error('Expected ' + Value + ' but ' + Token.Value +' found.', Token.Pos);
end;

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

procedure TParser.Reset;
begin
  Pos.Reset;
end;

constructor TParser.Create;
begin
  Reset;
end;

end.