source: branches/xpascal/Tokenizer.pas

unit Tokenizer;

interface

uses
  Classes, SysUtils;

type
  { TTokenizerPos }

  TTokenizerPos = record
    Index: Integer;
    Pos: TPoint;
    procedure Increment;
    procedure IncrementLine;
  end;

  TTokenKind = (tkUnknown, tkIdentifier, tkSpecialSymbol, tkNumber, tkString,
    tkKeyword);

  TToken = record
    Kind: TTokenKind;
    Text: string;
    function Create(Kind: TTokenKind; Text: string): TToken;
  end;

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

  TTokenizerState = (tsNone, tsIdentifier, tsString, tsStringEnd, tsNumber,
    tsSpecialSymbol, tsLineComment);

  { TTokenizer }

  TTokenizer = class
  private
    FOnError: TErrorEvent;
    State: TTokenizerState;
  public
    Pos: TTokenizerPos;
    Source: string;
    function IsAlpha(C: Char): Boolean;
    function IsNumeric(C: Char): Boolean;
    function IsAlphaNumeric(C: Char): Boolean;
    function IsWhiteSpace(C: Char): Boolean;
    function IsSpecialSymbol(C: Char): Boolean;
    function IsSpecialSymbol2(Text: string): Boolean;
    function IsIdentifier(Text: string): Boolean;
    function IsOperator(Text: string): Boolean;
    function IsKeyword(Text: string): Boolean;
    procedure Init;
    function GetNext: TToken;
    function CheckNext(Text: string; Kind: TTokenKind): Boolean;
    function CheckNextAndRead(Text: string; Kind: TTokenKind): Boolean;
    function CheckNextKind(Kind: TTokenKind): Boolean;
    function CheckNextKindAndRead(Kind: TTokenKind): Boolean;
    procedure Expect(Text: string; Kind: TTokenKind);
    procedure Error(Text: string);
    property OnError: TErrorEvent read FOnError write FOnError;
  end;


implementation

resourcestring
  SUnknownToken = 'Unknown token %s';
  SUnsupportedTokenizerState = 'Unsupported tokenizer state.';
  SExpectedButFound = 'Expected %s but %s found.';

{ TToken }

function TToken.Create(Kind: TTokenKind; Text: string): TToken;
begin
  Result.Kind := Kind;
  Result.Text := Text;
end;

{ TTokenizerPos }

procedure TTokenizerPos.Increment;
begin
  Inc(Index);
  Inc(Pos.X);
end;

procedure TTokenizerPos.IncrementLine;
begin
  Inc(Pos.Y);
  Pos.X := 1;
  Inc(Index);
end;

{ TTokenizer }

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

function TTokenizer.IsNumeric(C: Char): Boolean;
begin
  Result := C in ['0'..'9'];
end;

function TTokenizer.IsAlphaNumeric(C: Char): Boolean;
begin
  Result := IsAlpha(C) or IsNumeric(C);
end;

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

function TTokenizer.IsSpecialSymbol(C: Char): Boolean;
begin
  Result := (C = ';') or (C = '.') or (C = '(') or (C = ')') or (C = '=') or
    (C = ':') or (C = '+') or (C = '-') or (C = ',') or (C = '/') or
    (C = '<') or (C = '>') or (C = '*');
end;

function TTokenizer.IsSpecialSymbol2(Text: string): Boolean;
begin
  Result := (Text = ':=') or (Text = '//') or (Text = '<>') or (Text = '<=') or
    (Text = '>=');
end;

function TTokenizer.IsIdentifier(Text: string): Boolean;
var
  I: Integer;
begin
  Result := True;
  for I := 1 to Length(Text) do begin
    if (I = 1) then begin
      if not IsAlpha(Text[I]) then begin
        Result := False;
        Break;
      end;
    end else begin
      if not IsAlphaNumeric(Text[I]) then begin
        Result := False;
        Break;
      end;
    end;
  end;
end;

function TTokenizer.IsOperator(Text: string): Boolean;
begin
  Result := (Text = '+') or (Text = '-') or (Text = '=') or (Text = '<>') or
    (Text = '*') or (Text = '/') or (Text = 'div') or (Text = '<=') or
    (Text = '>=') or (Text = 'mod') or (Text = 'shl') or (Text = 'shr') or
    (Text = 'and') or (Text = 'or') or (Text = 'xor') or (Text = 'not') or
    (Text = '>') or (Text = '<');
end;

function TTokenizer.IsKeyword(Text: string): Boolean;
begin
  Result := (Text = 'begin') or (Text = 'end') or (Text = 'program') or
  (Text = 'var') or (Text = 'const') or (Text = 'if') or (Text = 'then') or
  (Text = 'else') or (Text = 'while') or (Text = 'do') or (Text = 'for') or
  (Text = 'to') or (Text = 'repeat') or (Text = 'until') or (Text = 'break') or
  (Text = 'continue') or (Text = 'function') or (Text = 'procedure');
end;

procedure TTokenizer.Init;
begin
  Pos.Index := 1;
  Pos.Pos := Point(1, 1);
end;

function TTokenizer.GetNext: TToken;
var
  C: Char;
begin
  State := tsNone;
  Result.Text := '';
  Result.Kind := tkUnknown;
  while Pos.Index < Length(Source) do begin
    C := Source[Pos.Index];
    if State = tsNone then begin
      if IsAlpha(C) then begin
        State := tsIdentifier;
        Result.Kind := tkIdentifier;
        Result.Text := C;
        Pos.Increment;
      end else
      if IsWhiteSpace(C) then begin
        Pos.Increment;
      end else
      if C = #10 then begin
        Pos.IncrementLine;
      end else
      if IsSpecialSymbol(C) then begin
        Result.Kind := tkSpecialSymbol;
        Result.Text := C;
        Pos.Increment;
        State := tsSpecialSymbol;
      end else
      if C = '''' then begin
        Pos.Increment;
        Result.Kind := tkString;
        State := tsString;
      end else
      if IsNumeric(C) then begin
        State := tsNumber;
        Result.Kind := tkNumber;
        Result.Text := C;
        Pos.Increment;
      end else begin
        Error(Format(SUnknownToken, [C]));
        Break;
      end;
    end else
    if State = tsIdentifier then begin
      if IsAlphanumeric(C) then begin
        Result.Text := Result.Text + C;
        Pos.Increment;
      end else begin
        if IsKeyword(Result.Text) then
          Result.Kind := tkKeyword;
        Break;
      end;
    end else
    if State = tsNumber then begin
      if IsNumeric(C) then begin
        Result.Text := Result.Text + C;
        Pos.Increment;
      end else begin
        Break;
      end;
    end else
    if State = tsString then begin
      if C = '''' then begin
        State := tsStringEnd;
        Pos.Increment;
      end else begin
        Result.Text := Result.Text + C;
        Pos.Increment;
      end;
    end else
    if State = tsStringEnd then begin
      if C = '''' then begin
        State := tsString;
        Result.Text := Result.Text + C;
        Pos.Increment;
      end else begin
        Break;
      end;
    end else
    if State = tsLineComment then begin
      if C = #10 then begin
        State := tsNone;
      end else Pos.Increment;
    end else
    if State = tsSpecialSymbol then begin
      if IsSpecialSymbol2(Result.Text + C) then begin
        Result.Text := Result.Text + C;
        Pos.Increment;
        if Result.Text = '//' then begin
          Result.Text := '';
          State := tsLineComment;
        end else Break;
      end else begin
        Break;
      end;
    end else
      raise Exception.Create(SUnsupportedTokenizerState);
  end;
end;

function TTokenizer.CheckNext(Text: string; Kind: TTokenKind): Boolean;
var
  LastPos: TTokenizerPos;
  Token: TToken;
begin
  LastPos := Pos;
  Token := GetNext;
  Result := (Token.Text = Text) and (Token.Kind = Kind);
  Pos := LastPos;
end;

function TTokenizer.CheckNextAndRead(Text: string; Kind: TTokenKind): Boolean;
var
  LastPos: TTokenizerPos;
  Token: TToken;
begin
  LastPos := Pos;
  Token := GetNext;
  Result := (Token.Text = Text) and (Token.Kind = Kind);
  if not Result then Pos := LastPos;
end;

function TTokenizer.CheckNextKind(Kind: TTokenKind): Boolean;
var
  LastPos: TTokenizerPos;
  Token: TToken;
begin
  LastPos := Pos;
  Token := GetNext;
  Result := Token.Kind = Kind;
  Pos := LastPos;
end;

function TTokenizer.CheckNextKindAndRead(Kind: TTokenKind): Boolean;
var
  LastPos: TTokenizerPos;
  Token: TToken;
begin
  LastPos := Pos;
  Token := GetNext;
  Result := Token.Kind = Kind;
  if not Result then Pos := LastPos;
end;

procedure TTokenizer.Expect(Text: string; Kind: TTokenKind);
var
  Token: TToken;
begin
  Token := GetNext;
  if (Token.Text <> Text) or (Token.Kind <> Kind) then
    Error(Format(SExpectedButFound, [Text, Token.Text]));
end;

procedure TTokenizer.Error(Text: string);
begin
  if Assigned(OnError) then
    OnError(Pos.Pos, Text);
end;

end.