source: trunk/Compiler/Analyzer.pas

unit Analyzer;

interface

uses
  SysUtils, Variants, Classes, Dialogs, SourceCodePascal, FileUtil,
  Generics.Collections;

type
  TErrorMessageEvent = procedure(Text: string; Position: TPoint; FileName: string) of object;
  TDebugLogEvent = procedure(Text: string) of object;

  TParserState = (psNone, psIdentifier, psConstantNumber, psConstantString,
    psOperator, psEndOfFile, psLineComment, psBlockComment1, psBlockComment2,
    psUnknown, psWhiteSpace, psConstantStringEnd, psBlockComment1First,
    psCompilerDirective, psNoneShift, psConstantHexNumber);

  TTokenType = (ttNone, ttIdentifier, ttConstantNumber, ttConstantString,
    ttOperator, ttEndOfFile, ttLineComment, ttBlockComment1, ttBlockComment2,
    ttUnknown, ttWhiteSpace, ttCompilerDirective);

  TToken = class
    Token: string;
    CodePosition: TPoint;
    TokenType: TTokenType;
  end;

  TGetSourceEvent = function (Name: string; var SourceCode: string): Boolean of object;

  { TAnalyzer }

  TAnalyzer = class
  private
    FFileName: string;
    FOnDebugLog: TDebugLogEvent;
    FOnErrorMessage: TErrorMessageEvent;
    FNextToken: string;
    FNextTokenType: TTokenType;
    FOnGetSource: TGetSourceEvent;
    FParserState: TParserState;
    PreviousChar: Char;
    CurrentChar: Char;
    TokenCodePosition: TPoint;
    LineEndingChar: Char;
    procedure GetNextToken;
  public
    SysName: string;
    Name: string;
    ProgramCode: TProgram;
    CodeStreamPosition: Integer;
    CodePosition: TPoint;
    SourceCode2: string;
    Tokens: TObjectList<TToken>;
    TokenIndex: Integer;
    constructor Create;
    destructor Destroy; override;
    function IsAlphanumeric(Character: char): boolean;
    function IsNumeric(Character: char): boolean;
    function IsHex(Character: char): boolean;
    function IsWhiteSpace(Character: char): boolean;
    function IsAlphabetic(Character: char): boolean;
    function IsIdentificator(Text: string): boolean;
    function IsKeyword(Text: string): boolean;
    function IsString(Text: string): Boolean;
    function IsOperator(Text: string): boolean;
    function ReadToken: string;
    function NextToken: string;
    function NextTokenType: TTokenType;
    procedure Expect(Code: string);
    procedure ErrorMessage(const Text: string; const Arguments: array of const;
      TokenOffset: Integer = -1);
    property OnErrorMessage: TErrorMessageEvent read FOnErrorMessage write FOnErrorMessage;
    property OnDebugLog: TDebugLogEvent read FOnDebugLog write FOnDebugLog;
    procedure Process;
    procedure Log(Text: string);
    function ParseModule(ProgramCode: TProgram): TSourceModule; virtual; abstract;
    property FileName: string read FFileName write FFileName;
    property OnGetSource: TGetSourceEvent read FOnGetSource
      write FOnGetSource;
  end;

  { TAnalyzers }

  TAnalyzers = class(TObjectList<TAnalyzer>)
    function SearchBySysName(Name: string): TAnalyzer;
    procedure LoadToStrings(Strings: TStrings);
  end;

resourcestring
  SExpectedButFound = 'Expected "%s" but "%s" found.';


implementation

{ TAnalyzers }

function TAnalyzers.SearchBySysName(Name: string): TAnalyzer;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (TAnalyzer(Items[I]).SysName <> Name) do Inc(I);
  if I < Count then Result := TAnalyzer(Items[I])
    else Result := nil;
end;

procedure TAnalyzers.LoadToStrings(Strings: TStrings);
var
  I: Integer;
begin
  try
    Strings.BeginUpdate;
    Strings.Clear;
    for I := 0 to Count - 1 do
      Strings.AddObject(TAnalyzer(Items[I]).Name, Items[I]);
  finally
    Strings.EndUpdate;
  end;
end;

{ TAnalyzer }

procedure TAnalyzer.ErrorMessage(const Text: string; const Arguments: array of const;
  TokenOffset: Integer = -1);
begin
  if Assigned(FOnErrorMessage) then
  if (TokenIndex + TokenOffset) < Tokens.Count then begin
    FOnErrorMessage(Format(Text, Arguments),
      TToken(Tokens[TokenIndex + TokenOffset]).CodePosition, FileName);
    Log('Error: ' + Format(Text, Arguments));
  end;
end;

procedure TAnalyzer.Expect(Code: string);
begin
  Log('Expect: ' + Code);
  if NextToken <> Code then begin
    ErrorMessage(SExpectedButFound, [Code, NextToken], 0);

    // Recovery: try to find nearest same code
    while (NextToken <> Code) and (NextTokenType <> ttEndOfFile) do
      ReadToken;
  end;
  ReadToken;
end;

function TAnalyzer.IsAlphabetic(Character: char): boolean;
begin
  Result := (Character in ['a'..'z']) or (Character in ['A'..'Z']);
end;

constructor TAnalyzer.Create;
begin
  Tokens := TObjectList<TToken>.Create;
  {$IFDEF windows}
  LineEndingChar := LineEnding[1];
  {$ELSE}
  LineEndingChar := LineEnding;
  {$ENDIF}
end;

destructor TAnalyzer.Destroy;
begin
  FreeAndNil(Tokens);
  inherited;
end;

function TAnalyzer.IsAlphanumeric(Character: char): boolean;
begin
  Result := IsAlphabetic(Character) or IsNumeric(Character);
end;

function TAnalyzer.IsNumeric(Character: char): boolean;
begin
  Result := Character in ['0'..'9'];
end;

function TAnalyzer.IsHex(Character: char): boolean;
begin
  Result := IsNumeric(Character) or (Character in ['A'..'F']);
end;

function TAnalyzer.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 TAnalyzer.IsString(Text: string): Boolean;
begin
  raise Exception.Create('Not implemented');
end;

function TAnalyzer.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 TAnalyzer.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 TAnalyzer.IsWhiteSpace(Character: char): boolean;
begin
  Result := (Character = ' ') or (Character = #13) or (Character = #10);
end;

procedure TAnalyzer.Process;
var
  NewToken: TToken;
begin
  CodePosition := Point(0, 1);
  CurrentChar := #0;
  PreviousChar := #0;
  FNextToken := '';
  FNextTokenType := ttNone;
  CodeStreamPosition := 1;
  Tokens.Clear;
  TokenIndex := 0;
  while CodeStreamPosition < Length(SourceCode2) do begin
    NewToken := TToken.Create;
    GetNextToken;
    NewToken.CodePosition := TokenCodePosition;
    NewToken.TokenType := FNextTokenType;
    NewToken.Token := FNextToken;
    Tokens.Add(NewToken);
  end;
end;

procedure TAnalyzer.Log(Text: string);
begin
  if Assigned(FOnDebugLog) then
    FOnDebugLog(Text);
end;

procedure TAnalyzer.GetNextToken;
var
  I: integer;
  II: integer;
  J: integer;
const
  SpecChar: set of char = [';', '.', ',', ':', '(', ')', '[', ']',
    '+', '-', '/', '*', '^', '=', '<', '>', '@'];
  DoubleSpecChar: array[0..6] of string = (':=', '..', '<=', '>=', '<>',
    '+=', '-=');
begin
  FNextToken := '';
  FNextTokenType := ttNone;
  FParserState := psNone;

    while True do begin
      if CodeStreamPosition < Length(SourceCode2) then begin
        CurrentChar := SourceCode2[CodeStreamPosition];
      end else begin
        FNextToken := '';
        FParserState := psEndOfFile;
        FNextTokenType := ttEndOfFile;
        Break;
      end;

      if (FParserState = psNone) or (FParserState = psNoneShift) then begin
        TokenCodePosition := CodePosition;
        if IsWhiteSpace(CurrentChar) then
          FParserState := psWhiteSpace
        else
        if CurrentChar = '{' then begin
          FParserState := psBlockComment1First;
        end else
        if CurrentChar = '''' then begin
          FParserState := psConstantString;
        end else
        if CurrentChar = '$' then begin
          FParserState := psConstantHexNumber;
        end else
        if CurrentChar in SpecChar then begin
          FParserState := psOperator;
          FNextToken := FNextToken + CurrentChar;
        end else
        if IsAlphabetic(CurrentChar) then begin
          FParserState := psIdentifier;
          FNextToken := FNextToken + CurrentChar;
        end else
        if IsNumeric(CurrentChar) then begin
          FPArserSTate := psConstantNumber;
          FNextToken := FNextToken + CurrentChar;
        end else FParserState := psUnknown;
      end else
      if FParserState = psLineComment then begin
        if (CurrentChar = #13) or (CurrentChar = #10) then
          FParserState := psNoneShift;
      end else
      if FParserState = psBlockComment1First then begin
        if CurrentChar = '$' then FParserState := psCompilerDirective
          else FParserSTate := psBlockComment1;
      end else
      if FParserState = psBlockComment1 then begin
        if (CurrentChar = '}') then begin
          FParserState := psNoneShift;
        end;
      end else
      if FParserState = psCompilerDirective then begin
        if (CurrentChar = '}') then begin
          FParserState := psNoneShift;
          FNextTokenType := ttCompilerDirective;
          FNextToken := '';
          //Break;
        end else FNextToken := FNextToken + CurrentChar;
      end else
      if FParserState = psBlockComment2 then begin
        if (PreviousChar = '*') and (CurrentChar = ')') then
          FParserState := psNoneShift;
      end else
      if FParserState = psConstantString then
      begin
        if (CurrentChar = '''') then begin
          FParserState := psConstantStringEnd;
        end else FNextToken := FNextToken + CurrentChar;
      end else
      if FParserState = psConstantStringEnd then
      begin
        if (CurrentChar = '''') then begin
          FParserState := psConstantString;
        end else FParserState := psNone;
        FNextTokenType := ttConstantString;
        Break;
      end else
      if FParserState = psConstantHexNumber then
      begin
        if not IsHex(CurrentChar) then begin
          FParserState := psNone;
          FNextTokenType := ttConstantNumber;
          Break;
        end else FNextToken := FNextToken + CurrentChar;
      end else
      if FParserState = psConstantNumber then
      begin
        if not IsNumeric(CurrentChar) then begin
          FParserState := psNone;
          FNextTokenType := ttConstantNumber;
          Break;
        end else FNextToken := FNextToken + CurrentChar;
      end else
      if FParserState = psOperator then
      begin
        if (CurrentChar = '*') and (PreviousChar = '(') then
        begin
          FNextToken := '';
          FParserState := psBlockComment2;
        end else
        if (CurrentChar = '/') and (PreviousChar = '/') then
        begin
          FNextToken := '';
          FParserState := psLineComment;
        end else
        if not (CurrentChar in SpecChar) then begin
          FNextTokenType := ttOperator;
          Break;
        end
        else begin
          J := 0;
          while (J < Length(DoubleSpecChar)) and
            ((PreviousChar + CurrentChar) <> DoubleSpecChar[J]) do
            Inc(J);
          if J < Length(DoubleSpecChar) then
            FNextToken := FNextToken + CurrentChar
          else begin
            FNextTokenType := ttOperator;
            Break;
          end;
        end;
      end else
      if FParserState = psIdentifier then
      begin
        if (not IsAlphanumeric(CurrentChar)) and (CurrentChar <> '_') then begin
          FNextTokenType := ttIdentifier;
          Break;
        end else FNextToken := FNextToken + CurrentChar;
      end
      else
      if FParserState = psWhiteSpace then begin
        FParserState := psNone;
      end;

      if FParserState <> psNone then begin
        // Update cursor position
        Inc(CodePosition.X);
        if (CurrentChar = LineEndingChar) then begin
          CodePosition.X := 0;
          Inc(CodePosition.Y);
        end;

        Inc(CodeStreamPosition);
        PreviousChar := CurrentChar;
      end;
    end;
end;

function TAnalyzer.ReadToken: string;
begin
  if TokenIndex < Tokens.Count then begin
    Result := TToken(Tokens[TokenIndex]).Token;
    Inc(TokenIndex);
  end else Result := '';
  Log('ReadCode: ' + Result);
end;

function TAnalyzer.NextToken: string;
begin
  if TokenIndex < Tokens.Count then begin
    Result := TToken(Tokens[TokenIndex]).Token;
  end else Result := '';
  Log('NextToken: ' + Result);
end;

function TAnalyzer.NextTokenType: TTokenType;
begin
  if TokenIndex < Tokens.Count then begin
    Result := TToken(Tokens[TokenIndex]).TokenType;
  end else Result := ttEndOfFile;
end;

end.