PasParser/PasLexer

(********************************************************)
(*                                                      *)
(*  Codebot Class Library @ www.codebot.org/delphi      *)
(*                                                      *)
(*  1.00.01 Open Source Released 2006                   *)
(*                                                      *)
(********************************************************)

unit PasParser;

{$I CODEBOT.INC}

interface

uses
  Classes, SysUtils, BaseTypes;

const
  CR              = #13;
  LF              = #10;
  CRLF            = [CR, LF];
  ASCII           = [#0..#255];
  Whitespace      = [#0..#32];
  Alpha           = ['A'..'Z', 'a'..'z', '_'];
  Numeric         = ['0'..'9'];
  AlphaNumeric    = Alpha + Numeric;
  Space           = ASCII - AlphaNumeric;

type
  TTextBufferArray = array of PChar;

  TTextLines = class
  private
    FLines: TTextBufferArray;
    FCount: Integer;
    function GetLine(Index: Integer): string;
    function GetOrigin(Index: Integer): PChar;
  protected
    procedure Add(Buffer: PChar);
    function LineFromOrigin(Buffer: PChar): Integer;
  public
    property Count: Integer read FCount;
    property Line[Index: Integer]: string read GetLine; default;
    property Origin[Index: Integer]: PChar read GetOrigin;
  end;

{ The following parsed token kinds are not reserved words:

  TypeKind                     Example
  -----------------------      -------------------------
  tkIdentifier                 TForm1
  tkNumber                     1234
  tkText                       'Hello World'
  tkComma                      ,
  tkPoint                      .
  tkEqual                      =
  tkLessThan                   <
  tkLessThanOrEqual            <=
  tkGreaterThan                >
  tkGreaterThanOrEqual         >=
  tkGets                       :=
  tkColon                      :
  tkSemiColon                  ;
  tkOperator                   + - / *
  tkAddressOf                  @
  tkPointerTo                  ^
  tkLeftParenthesis            (
  tkRightParenthesis           )
  tkLeftBracket                [ (.
  tkRightBracket               ] .)
  tkRange                      ..
  tkSpecialSymbol              # $
  tkAnsiComment                //
  tkCComment                   (*
  tkPascalComment              {
  tkGarbage                    ~ \ % ! | `
  tkNull                       End of buffer }

  TPascalTokenKind = (tkAnd, tkArray, tkAs, tkAsm, tkBegin, tkCase, tkClass, tkConst,
    tkConstructor, tkDestructor, tkDispinterface, tkDiv, tkDo, tkDownto, tkElse,
    tkEnd, tkExcept, tkExports, tkFile, tkFinalization, tkFinally, tkFor,
    tkFunction, tkGoto, tkIf, tkImplementation, tkIn, tkInherited,
    tkInitialization, tkInline, tkInterface, tkIs, tkLabel, tkLibrary, tkMod,
    tkNil, tkNot, tkObject, tkOf, tkOr, tkOut, tkPacked, tkProcedure, tkProgram,
    tkProperty, tkRaise, tkRecord, tkRepeat, tkResourcestring, tkSet, tkShl,
    tkShr, tkString, tkThen, tkThreadvar, tkTo, tkTry, tkType, tkUnit, tkUntil,
    tkUses, tkVar, tkWhile, tkWith, tkXor, tkIdentifier, tkNumber, tkText,
    tkComma, tkPoint, tkEqual, tkLessThan, tkLessThanOrEqual, tkGreaterThan,
    tkGreaterThanOrEqual, tkGets, tkColon, tkSemiColon, tkOperator, tkAddressOf,
    tkPointerTo, tkLeftParenthesis, tkRightParenthesis, tkLeftBracket,
    tkRightBracket, tkRange, tkSpecialSymbol, tkAnsiComment, tkCComment,
    tkPascalComment, tkDirective, tkGarbage, tkNull);
  TPascalTokenKinds = set of TPascalTokenKind;

  TPascalDirectiveKind = (dkAbsolute, dkAbstract, dkAssembler, dkAutomated,
    dkCdecl, dkContains, dkDefault, dkDispid, dkDynamic, dkExport, dkExternal,
    dkFar, dkForward, dkImplements, dkIndex, dkMessage, dkName, dkNear,
    dkNodefault, dkOverload, dkOverride, dkPackage, dkPascal, dkPrivate,
    dkProtected, dkPublic, dkPublished, dkRead, dkReadonly, dkRegister,
    dkReintroduce, dkRequires, dkResident, dkSafecall, dkStdcall, dkStored,
    dkVirtual, dkWrite,  dkWriteonly, dkNone);
  TPascalDirectiveKinds = set of TPascalDirectiveKind;

{ TBasePascalToken class }

  TPascalParser = class;

  TPascalToken = class
  private
    FOwner: TPascalParser;
    FPosition: Integer;
    FLength: Integer;
    FKind: TPascalTokenKind;
    function GetCol: Integer;
    function GetRow: Integer;
    function GetText: string;
    function GetFirst: Boolean;
    function GetLast: Boolean;
  protected
    property Owner: TPascalParser read FOwner;
  public
    constructor Create(AOwner: TPascalParser);
    procedure Copy(Token: TPascalToken);
    property Position: Integer read FPosition;
    property Length: Integer read FLength write FLength;
    property Text: string read GetText;
    property Col: Integer read GetCol;
    property Row: Integer read GetRow;
    property Kind: TPascalTokenKind read FKind;
    property First: Boolean read GetFirst;
    property Last: Boolean read GetLast;
  end;

{ TPascalTokenList }

  TPascalTokenList = class
  private
    FList: TList;
    function GetCount: Integer;
    function GetToken(Index: Integer): TPascalToken;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(Token: TPascalToken);
    procedure Clear;
    property Count: Integer read GetCount;
    property Token[Index: Integer]: TPascalToken read GetToken; default;
  end;

{ EPascalTokenError exception }

  EPascalTokenError = class(Exception)
  private
    FToken: TPascalToken;
  public
    constructor CreateFromToken(AToken: TPascalToken);
    property Token: TPascalToken read FToken;
  end;

{ TPascalParser class }

  TPascalParser = class
  private
    FBuffer: PChar;
    FEndOfBuffer: PChar;
    FExceptionTokens: TPascalTokenKinds;
    FOrigin: PChar;
    FToken: TPascalToken;
    FScratchToken: TPascalToken;
    FLines: TTextLines;
    FSize: Integer;
    function GetPosition: Integer;
    procedure SetPosition(Value: Integer);
    procedure SetToken(Value: TPascalToken);
  protected
    property InternalBuffer: PChar read FBuffer;
    property InternalSize: Integer read FSize;
  public
    constructor Create(Buffer: PChar = nil; Size: Integer = 0); virtual;
    destructor Destroy; override;
    procedure Initialize(Buffer: PChar; Size: Integer);
    function CopyText(Index: Integer; Count: Integer): string;
    function Next: TPascalTokenKind;
    function Skip(const SkipKinds: TPascalTokenKinds): TPascalTokenKind;
    function Scan(ScanKinds: TPascalTokenKinds): TPascalTokenKind;
    function Peek(const SkipKinds: TPascalTokenKinds = [];
      ScratchToken: TPascalToken = nil): TPascalTokenKind;
    property ExceptionTokens: TPascalTokenKinds read FExceptionTokens write
      FExceptionTokens;
    property Origin: PChar read FOrigin write FOrigin;
    property Position: Integer read GetPosition write SetPosition;
    property Token: TPascalToken read FToken write SetToken;
    property Lines: TTextLines read FLines;
  end;

function SeekToken(P: PChar): PChar;
function SeekWhiteSpace(P: PChar): PChar;

const
  ReservedTokens = [tkAnd, tkArray, tkAs, tkAsm, tkBegin, tkCase, tkClass,
    tkConst, tkConstructor, tkDestructor, tkDispinterface, tkDiv, tkDo,
    tkDownto, tkElse, tkEnd, tkExcept, tkExports, tkFile, tkFinalization,
    tkFinally, tkFor, tkFunction, tkGoto, tkIf, tkImplementation, tkIn,
    tkInherited, tkInitialization, tkInline, tkInterface, tkIs, tkLabel,
    tkLibrary, tkMod, tkNil, tkNot, tkObject, tkOf, tkOr, tkOut, tkPacked,
    tkProcedure, tkProgram, tkProperty, tkRaise, tkRecord, tkRepeat,
    tkResourcestring, tkSet, tkShl, tkShr, tkString, tkThen, tkThreadvar, tkTo,
    tkTry, tkType, tkUnit, tkUntil, tkUses, tkVar, tkWhile, tkWith, tkXor];

  CommentTokens = [tkAnsiComment, tkCComment, tkPascalComment];
  CallingConventions = [dkCdecl, dkPascal, dkRegister, dkSafecall, dkStdcall];

function StrToTokenKind(const Value: string): TPascalTokenKind;
function StrToDirectiveKind(const Value: string): TPascalDirectiveKind;

implementation

uses
  StrConst;

function SeekToken(P: PChar): PChar;
begin
  while CharInSet(P^, [#1..#9, #11, #12, #14..#32]) do
    Inc(P);
  Result := P;
end;

function SeekWhiteSpace(P: PChar): PChar;
begin
  while CharInSet(P^, [#33..#255]) do
    Inc(P);
  Result := P;
end;

function Hash(const Token: string): Integer;
var
  I: Integer;
begin
  Result := 0;
  for I := 1 to Length(Token) do
    Inc(Result, Ord(Token[I]));
end;

function StrToTokenKind(const Value: string): TPascalTokenKind;
var
  Token: string;
  I: Integer;
begin
  Result := tkGarbage;
  Token := UpperCase(Value);
  case Hash(Token) of
    143: if Token = 'IF' then Result := tkIf;
    147: if Token = 'DO' then Result := tkDo;
    148: if Token = 'AS' then Result := tkAs;
    149: if Token = 'OF' then Result := tkOf;
    151: if Token = 'IN' then Result := tkIn;
    156: if Token = 'IS' then Result := tkIs;
    161: if Token = 'OR' then Result := tkOr;
    163: if Token = 'TO' then Result := tkTo;
    211: if Token = 'AND' then Result := tkAnd;
    215: if Token = 'END' then Result := tkEnd;
    224: if Token = 'MOD' then Result := tkMod;
    225: if Token = 'ASM' then Result := tkAsm;
    227: if Token = 'DIV' then Result := tkDiv
      else if Token = 'NIL' then Result := tkNil;
    231: if Token = 'FOR' then Result := tkFor
      else if Token = 'SHL' then Result := tkShl;
    233: if Token = 'VAR' then Result := tkVar;
    236: if Token = 'SET' then Result := tkSet;
    237: if Token = 'SHR' then Result := tkShr;
    241: if Token = 'NOT' then Result := tkNot;
    248: if Token = 'OUT' then Result := tkOut;
    249: if Token = 'XOR' then Result := tkXor;
    255: if Token = 'TRY' then Result := tkTry;
    284: if Token = 'CASE' then Result := tkCase;
    288: if Token = 'FILE' then Result := tkFile;
    297: if Token = 'ELSE' then Result := tkElse;
    303: if Token = 'THEN' then Result := tkThen;
    313: if Token = 'GOTO' then Result := tkGoto;
    316: if Token = 'WITH' then Result := tkWith;
    320: if Token = 'UNIT' then Result := tkUnit
      else if Token = 'USES' then Result := tkUses;
    322: if Token = 'TYPE' then Result := tkType;
    352: if Token = 'LABEL' then Result := tkLabel;
    357: if Token = 'BEGIN' then Result := tkBegin;
    372: if Token = 'RAISE' then Result := tkRaise;
    374: if Token = 'CLASS' then Result := tkClass;
    377: if Token = 'WHILE' then Result := tkWhile;
    383: if Token = 'ARRAY' then Result := tkArray;
    391: if Token = 'CONST' then Result := tkConst;
    396: if Token = 'UNTIL' then Result := tkUntil;
    424: if Token = 'PACKED' then Result := tkPacked;
    439: if Token = 'OBJECT' then Result := tkObject;
    447: if Token = 'INLINE' then Result := tkInline
      else if Token = 'RECORD' then Result := tkRecord;
    449: if Token = 'REPEAT' then Result := tkRepeat;
    457: if Token = 'EXCEPT' then Result := tkExcept;
    471: if Token = 'STRING' then Result := tkString;
    475: if Token = 'DOWNTO' then Result := tkDownto;
    527: if Token = 'FINALLY' then Result := tkFinally;
    533: if Token = 'LIBRARY' then Result := tkLibrary;
    536: if Token = 'PROGRAM' then Result := tkProgram;
    565: if Token = 'EXPORTS' then Result := tkExports;
    614: if Token = 'FUNCTION' then Result := tkFunction;
    645: if Token = 'PROPERTY' then Result := tkProperty;
    657: if Token = 'INTERFACE' then Result := tkInterface;
    668: if Token = 'INHERITED' then Result := tkInherited;
    673: if Token = 'THREADVAR' then Result := tkThreadvar;
    681: if Token = 'PROCEDURE' then Result := tkProcedure;
    783: if Token = 'DESTRUCTOR' then Result := tkDestructor;
    870: if Token = 'CONSTRUCTOR' then Result := tkConstructor;
    904: if Token = 'FINALIZATION' then Result := tkFinalization;
    961: if Token = 'DISPINTERFACE' then Result := tkDispinterface;
    1062: if Token = 'IMPLEMENTATION' then Result := tkImplementation;
    1064: if Token = 'INITIALIZATION' then Result := tkInitialization;
    1087: if Token = 'RESOURCESTRING' then Result := tkResourcestring;
  end;
  if Result = tkGarbage then
    { is valid identifier }
    if CharInSet(Token[1], Alpha) then
    begin
      Result := tkIdentifier;
      for I := 2 to Length(Token) do
      if not CharInSet(Token[I], AlphaNumeric) then
      begin
        Result := tkGarbage;
        Exit;
      end;
    end
    else
    { is valid number }
    for I := 1 to Length(Token) do
    begin
      if not CharInSet(Token[I], Numeric) then
        Exit;
      Result := tkNumber;
    end;
end;

function StrToDirectiveKind(const Value: string): TPascalDirectiveKind;
var
  Token: string;
begin
  Result := dkNone;
  Token := UpperCase(Value);
  case Hash(Token) of
    217: if Token = 'FAR' then Result := dkFar;
    284: if Token = 'READ' then Result := dkRead;
    289: if Token = 'NAME' then Result := dkName;
    294: if Token = 'NEAR' then Result := dkNear;
    347: if Token = 'CDECL' then Result := dkCdecl;
    376: if Token = 'INDEX' then Result := dkIndex;
    395: if Token = 'WRITE' then Result := dkWrite;
    436: if Token = 'PASCAL' then Result := dkPascal;
    445: if Token = 'DISPID' then Result := dkDispid;
    447: if Token = 'PUBLIC' then Result := dkPublic;
    465: if Token = 'STORED' then Result := dkStored;
    482: if Token = 'EXPORT' then Result := dkExport;
    492: if Token = 'PACKAGE' then Result := dkPackage;
    517: if Token = 'DEFAULT' then Result := dkDefault
      else if Token = 'DYNAMIC' then Result := dkDynamic
      else if Token = 'MESSAGE' then Result := dkMessage;
    519: if Token = 'STDCALL' then Result := dkStdcall;
    533: if Token = 'FORWARD' then Result := dkForward;
    539: if Token = 'PRIVATE' then Result := dkPrivate;
    551: if Token = 'VIRTUAL' then Result := dkVirtual;
    571: if Token = 'SAFECALL' then Result := dkSafecall;
    596: if Token = 'ABSTRACT' then Result := dkAbstract;
    604: if Token = 'OVERLOAD' then Result := dkOverload;
    606: if Token = 'READONLY' then Result := dkReadonly
      else if Token = 'RESIDENT' then Result := dkResident;
    607: if Token = 'ABSOLUTE' then Result := dkAbsolute
      else if Token = 'CONTAINS' then Result := dkContains;
    608: if Token = 'OVERRIDE' then Result := dkOverride;
    611: if Token = 'EXTERNAL' then Result := dkExternal;
    613: if Token = 'REGISTER' then Result := dkRegister;
    624: if Token = 'REQUIRES' then Result := dkRequires;
    670: if Token = 'ASSEMBLER' then Result := dkAssembler;
    672: if Token = 'PUBLISHED' then Result := dkPublished;
    674: if Token = 'NODEFAULT' then Result := dkNodefault;
    676: if Token = 'AUTOMATED' then Result := dkAutomated;
    682: if Token = 'PROTECTED' then Result := dkProtected;
    717: if Token = 'WRITEONLY' then Result := dkWriteonly;
    766: if Token = 'IMPLEMENTS' then Result := dkImplements;
    836: if Token = 'REINTRODUCE' then Result := dkReintroduce;
  end;
end;

{ TTextLines }

procedure TTextLines.Add(Buffer: PChar);
const
  Delta = 10;
begin
  if (FCount > 0) and (Buffer <= FLines[FCount - 1]) then
    Exit;
  if FCount mod Delta = 0 then
    SetLength(FLines, FCount + 10);
  FLines[FCount] := Buffer;
  Inc(FCount);
end;

function TTextLines.LineFromOrigin(Buffer: PChar): Integer;
var
  I: Integer;
begin
  Result := -1;
  if FCount = 0 then
    Exit;
  for I := 0 to FCount - 1 do
  begin
    if FLines[I] > Buffer then
      Break;
    Inc(Result);
  end;
end;

function TTextLines.GetLine(Index: Integer): string;
var
  P, Start: PChar;
begin
  Result := '';
  P := GetOrigin(Index);
  if P = nil then
    Exit;
  Start := P;
  while (not CharInSet(P^, CRLF)) and (P^ > #0) do
    Inc(P);
  SetString(Result, Start, P - Start);
end;

function TTextLines.GetOrigin(Index: Integer): PChar;
begin
  Result := nil;
  if (Index < 0) or (Index > FCount - 1) then
    Exit;
  Result := FLines[Index];
end;

{ TPascalToken }

constructor TPascalToken.Create(AOwner: TPascalParser);
begin
  FOwner := AOwner;
end;

procedure TPascalToken.Copy(Token: TPascalToken);
begin
  FOwner := Token.FOwner;
  FPosition := Token.FPosition;
  FLength := Token.FLength;
  FKind := Token.FKind;
end;

function TPascalToken.GetCol: Integer;
var
  P: PChar;
begin
  P := FOwner.FBuffer;
  Inc(P, FPosition);
  Result := FOwner.Lines.LineFromOrigin(P);
  if Result > -1 then
    Result := Integer(P - FOwner.Lines.Origin[Result])
  else
    Result := Integer(P - FOwner.FBuffer);
end;

function TPascalToken.GetRow: Integer;
var
  P: PChar;
begin
  P := FOwner.FBuffer;
  Inc(P, FPosition);
  Result := FOwner.Lines.LineFromOrigin(P);
  if Result = -1 then
    Result := 0;
end;

function TPascalToken.GetText: string;
var
  PrevPosition: Integer;
begin
  PrevPosition := FOwner.Position;
  FOwner.Position := FPosition;
  SetString(Result, FOwner.Origin, Length);
  FOwner.Position := PrevPosition;
end;

function TPascalToken.GetFirst: Boolean;
var
  P: PChar;
begin
  P := FOwner.FBuffer;
  Inc(P, FPosition);
  while P > FOwner.FBuffer do
    if CharInSet(P^, [#10, #13, #33..#255]) then
      Break
    else
      Inc(P);
  Result := (P = FOwner.FBuffer) or CharInSet(P^, CRLF);
end;

function TPascalToken.GetLast: Boolean;
var
  P: PChar;
begin
  P := FOwner.FBuffer;
  Inc(P, FPosition + FLength);
  while P^ > #0 do
    if CharInSet(P^, [#10, #13, #33..#255]) then
      Break
    else
      Inc(P);
  Result := CharInSet(P^, [#0, #10, #13]);
end;

{ TPascalTokenList }

constructor TPascalTokenList.Create;
begin
  inherited Create;
  FList := TList.Create;
end;

destructor TPascalTokenList.Destroy;
begin
  Clear;
  FList.Free;
  inherited Destroy;
end;

procedure TPascalTokenList.Add(Token: TPascalToken);
var
  NewToken: TPascalToken;
begin
  NewToken := TPascalToken.Create(nil);
  NewToken.Copy(Token);
  FList.Add(NewToken);
end;

procedure TPascalTokenList.Clear;
var
  I: Integer;
begin
  for I := FList.Count - 1 downto 0 do
    TObject(FList[I]).Free;
end;

function TPascalTokenList.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TPascalTokenList.GetToken(Index: Integer): TPascalToken;
begin
  Result := TPascalToken(FList[Index]);
end;

{ EPascalTokenError }

constructor EPascalTokenError.CreateFromToken(AToken: TPascalToken);
begin
  FToken := AToken;
  inherited CreateFmt(SUnexpectedToken, [FToken.Position]);
end;

{ TPascalParser }

constructor TPascalParser.Create(Buffer: PChar = nil; Size: Integer = 0);
begin
  inherited Create;
  Initialize(Buffer, Size);
end;

destructor TPascalParser.Destroy;
begin
  FLines.Free;
  FToken.Free;
  FScratchToken.Free;
  inherited Destroy;
end;

procedure TPascalParser.Initialize(Buffer: PChar; Size: Integer);
begin
  FreeAndNil(FLines);
  FreeAndNil(FToken);
  FreeAndNil(FScratchToken);
  FLines := TTextLines.Create;
  FToken := TPascalToken.Create(Self);
  FScratchToken := TPascalToken.Create(Self);
  FBuffer := Buffer;
  FEndOfBuffer := Buffer;
  FOrigin := Buffer;
  FSize := Size;
  Inc(FEndOfBuffer, Size);
end;

function TPascalParser.GetPosition: Integer;
begin
  Result := FOrigin - FBuffer;
end;

procedure TPascalParser.SetToken(Value: TPascalToken);
begin
  if Value.FOwner = Self then
    with FToken do
    begin
      Copy(Value);
      Self.Position := Position + Length;
    end
    else
      raise EPascalTokenError.Create(SInvalidPropertyValue);
end;

procedure TPascalParser.SetPosition(Value: Integer);
begin
  if Value <> Position then
  begin
    FOrigin := FBuffer;
    Inc(FOrigin, Value)
  end;
end;

function TPascalParser.CopyText(Index: Integer; Count: Integer): string;
var
  P: PChar;
begin
  P := FBuffer;
  Inc(P, Index);
  SetString(Result, P, Count);
end;


function TPascalParser.Next: TPascalTokenKind;

  function GetCommentLength: Integer;
  var
    P: PChar;
  begin
    P := FOrigin;
    case FToken.Kind of
      tkAnsiComment:
      repeat
        Inc(P)
      until (P = FEndOfBuffer) or CharInSet(P[0], CRLF);
      tkCComment:
      begin
        Inc(P);
        if @P[1] < FEndOfBuffer then
        begin
          repeat
            Inc(P);
          until (@P[1] = FEndOfBuffer) or ((P[0] = '*') and (P[1] = ')'));
          if @P[1] < FEndOfBuffer then
            Inc(P, 2)
          else
            Inc(P);
        end;
      end;
      tkPascalComment:
      begin
        repeat
          Inc(P);
        until (P = FEndOfBuffer) or (P[0] = '}');
        if P < FEndOfBuffer then
          Inc(P);
      end;
    end;
    Result := P - FOrigin;
  end;

var
  P: PChar;
  S: string;
begin
  if FLines.Count = 0 then
    FLines.Add(FOrigin);
  while (FOrigin < FEndOfBuffer) and CharInSet(FOrigin[0], Whitespace) do
    if (FOrigin[0] = #13) and (FOrigin[1] = #10) then
    begin
      Inc(FOrigin, 2);
      FLines.Add(FOrigin);
    end
    else
      Inc(FOrigin);
  if FOrigin < FEndOfBuffer then
  case FOrigin[0] of
    { tkText }
    '''':
    begin
      P := FOrigin;
      FToken.FKind := tkText;
      repeat
        Inc(P);
        while (P < FEndOfBuffer) and (P[0] = '''') and (P[1] = '''') do
          Inc(P, 2);
      until (P = FEndOfBuffer) or (P[0] = '''') or CharInSet(P[0], CRLF);
      if (P < FEndOfBuffer) and (P[0] = '''') then
        Inc(P)
      else
        FToken.FKind := tkGarbage;
      FToken.FLength := P - FOrigin;
    end;
    { tkComma }
    ',':
    begin
      FToken.FKind := tkComma;
      FToken.FLength := 1;
    end;
    { tkPoint, tkRightBracket, tkRange }
    '.':
    if @FOrigin[1] < FEndOfBuffer then
    case FOrigin[1] of
      ')':
      begin
        FToken.FKind := tkRightBracket;
        FToken.FLength := 2;
      end;
      '.':
      begin
        FToken.FKind := tkRange;
        FToken.FLength := 2;
      end;
      else
      begin
        FToken.FKind := tkPoint;
        FToken.FLength := 1;
      end;
    end
    else
    begin
      FToken.FKind := tkPoint;
      FToken.FLength := 1;
    end;
    { tkEqual }
    '=':
    begin
      FToken.FKind := tkEqual;
      FToken.FLength := 1;
    end;
    { tkLessThan, tkLessThanOrEqual }
    '<':
    if (@FOrigin[1] < FEndOfBuffer) and (Origin[1] = '=') then
    begin
      FToken.FKind := tkLessThanOrEqual;
      FToken.FLength := 2;
    end
    else
    begin
      FToken.FKind := tkLessThan;
      FToken.FLength := 1;
    end;
    { tkGreaterThan, tkGreaterThanOrEqual }
    '>':
    if (@FOrigin[1] < FEndOfBuffer) and (Origin[1] = '=') then
    begin
      FToken.FKind := tkGreaterThanOrEqual;
      FToken.FLength := 2;
    end
    else
    begin
      FToken.FKind := tkGreaterThan;
      FToken.FLength := 1;
    end;
    { tkGets, tkColon }
    ':':
    if (@FOrigin[1] < FEndOfBuffer) and (Origin[1] = '=') then
    begin
      FToken.FKind := tkGets;
      FToken.FLength := 2;
    end
    else
    begin
      FToken.FKind := tkColon;
      FToken.FLength := 1;
    end;
    { tkSemiColon }
    ';':
    begin
      FToken.FKind := tkSemiColon;
      FToken.FLength := 1;
    end;
    { tkAnsiComment, tkOperator }
    '+', '-', '/', '*':
    if (@FOrigin[1] < FEndOfBuffer) and (Origin[0] = '/') and (Origin[1] = '/') then
    begin
      FToken.FKind := tkAnsiComment;
      FToken.FLength := GetCommentLength;
    end
    else
    begin
      FToken.FKind := tkOperator;
      FToken.FLength := 1;
    end;
    { tkAddressOf }
    '@':
    begin
      FToken.FKind := tkAddressOf;
      FToken.FLength := 1;
    end;
    { tkPointerTo }
    '^':
    begin
      FToken.FKind := tkPointerTo;
      FToken.FLength := 1;
    end;
    { tkLeftBracket, tkCComment, tkLeftParenthesis }
    '(':
    if @FOrigin[1] < FEndOfBuffer then
    case FOrigin[1] of
      '.':
      begin
        FToken.FKind := tkLeftBracket;
        FToken.FLength := 2;
      end;
      '*':
      begin
        FToken.FKind := tkCComment;
        if FOrigin[2] = '$' then
        begin
          FToken.FLength := GetCommentLength;
          FToken.FKind := tkDirective;
        end
        else
          FToken.FLength := GetCommentLength;
      end;
      else
      begin
        FToken.FKind := tkLeftParenthesis;
        FToken.FLength := 1;
      end;
    end
    else
    begin
      FToken.FKind := tkLeftParenthesis;
      FToken.FLength := 1;
    end;
    { tkRightParenthesis }
    ')':
    begin
      FToken.FKind := tkRightParenthesis;
      FToken.FLength := 1;
    end;
    { tkLeftBracket }
    '[':
    begin
      FToken.FKind := tkLeftBracket;
      FToken.FLength := 1;
    end;
    { tkRightBracket }
    ']':
    begin
      FToken.FKind := tkRightBracket;
      FToken.FLength := 1;
    end;
    { tkSpecialSymbol }
    '#', '$':
    begin
      FToken.FKind := tkSpecialSymbol;
      FToken.FLength := 1;
    end;
    { tkPascalComment }
    '{':
    begin
      FToken.FKind := tkPascalComment;
      if FOrigin[1] = '$' then
      begin
        FToken.FLength := GetCommentLength;
        FToken.FKind := tkDirective;
      end
      else
        FToken.FLength := GetCommentLength;
    end;
    { token in the range of tkAnd..tkNumber, tkGarbage }
    else
    begin
      P := FOrigin;
      repeat
        Inc(P);
      until (P = FEndOfBuffer) or CharInSet(P[0], Space);
      SetString(S, FOrigin, P - FOrigin);
      FToken.FKind := StrToTokenKind(S);
      FToken.FLength := Length(S);
    end;
  end
  { token is tkNull }
  else
  begin
    FOrigin := FEndOfBuffer;
    FToken.FKind := tkNull;
    FToken.FLength := 0;
  end;
  FToken.FPosition := Position;
  Inc(FOrigin, FToken.FLength);
  Result := FToken.FKind;
end;

function TPascalParser.Skip(const SkipKinds: TPascalTokenKinds):
  TPascalTokenKind;
begin
  repeat
    Result := Next;
    if Result in FExceptionTokens then
      raise EPascalTokenError.CreateFmt(SInvalidToken, [Token.Row, Token.Col]);
  until (not (Result in SkipKinds)) or (Result = tkNull);
end;

function TPascalParser.Scan(ScanKinds: TPascalTokenKinds): TPascalTokenKind;
begin
  repeat
    Result := Next;
    if Result in FExceptionTokens then
      raise EPascalTokenError.CreateFmt(SInvalidToken, [Token.Row, Token.Col]);
  until (Result in ScanKinds) or (Result = tkNull);
end;

function TPascalParser.Peek(const SkipKinds: TPascalTokenKinds = [];
  ScratchToken: TPascalToken = nil): TPascalTokenKind;
var
  P: PChar;
begin
  P := FOrigin;
  FScratchToken.Copy(Token);
  repeat
    Result := Next;
  until (Result = tkNull) or (not (Result in SkipKinds));
  if ScratchToken <> nil then
    ScratchToken.Copy(FToken);
  FToken.Copy(FScratchToken);
  FOrigin := P;
end;

end.



(********************************************************)
(*                                                      *)
(*  Codebot Class Library @ www.codebot.org/delphi      *)
(*                                                      *)
(*  1.00.01 Open Source Released 2006                   *)
(*                                                      *)
(********************************************************)

unit PasLexer;

interface

{$I CODEBOT.INC}

uses
  Classes, SysUtils, PasParser, WinTools, SysTools;

{ The TPascalLexer class is a basic lexical analysis tool. When used in
  conjunction with a source code file, it is assumed that the source is in a
  perfect state. That is to say, the source file MUST conform exactly to Object
  Pascal grammer before being handed off to the TPascalLexer class. The result
  of a less than perfect source file could lead to an endless looping condition. }

type
  TSourceKind = (skArray, skClass, skClassReference, skConstant, skConstructor,
    skDestructor, skEnumeration, skEvent, skField, skFunction, skFunctionEvent,
    skFunctionInterfaceMethod, skFunctionMethod, skFunctionPointer, skInterface,
    skInterfaceMethod, skMember, skMethod, skProcedure, skProcedureEvent,
    skProcedureInterfaceMethod, skProcedureMethod, skProcedurePointer, skProperty,
    skRecord, skResourceString, skSet, skThreadVariable, skType, skVariable, skUses);
  TSourceKinds = set of TSourceKind;

const
  AllSourceKinds: TSourceKinds = [skArray, skClass, skClassReference, skConstant, skConstructor,
    skDestructor, skEnumeration, skEvent, skField, skFunction, skFunctionEvent,
    skFunctionInterfaceMethod, skFunctionMethod, skFunctionPointer, skInterface,
    skInterfaceMethod, skMember, skMethod, skProcedure, skProcedureEvent,
    skProcedureInterfaceMethod, skProcedureMethod, skProcedurePointer, skProperty,
    skRecord, skResourceString, skSet, skThreadVariable, skType, skVariable, skUses];

type
  TRoutineKind = (rkConstructor, rkDestructor, rkFunction, rkProcedure);
  TCallingConvention = (ccDefault, ccCdecl, ccPascal, ccRegister, ccStdcall,
    ccSafecall);

  TMemberVisibility = (mvPrivate, mvProtected, mvPublic, mvPublished);
  TMemberVisibilities = set of TMemberVisibility;

  TPropertyAccess = set of (paRead, paWrite);
  TVirtualKind = (vkStatic, vkDynamic, vkMessage, vkOverride, vkVirtual, vkReintroduce);

  TSourceInfo = packed record
    Line: Integer;
    Column: Integer;
    Name: ShortString;
    Kind: TSourceKind;
    case TSourceKind of
      skClass: (
        ClassParent: ShortString;
        InterfaceCount: Integer);
      skFunction, skProcedure: (
        RoutineKind: TRoutineKind;
        RoutineConvention: TCallingConvention);
      skInterface: (
        InterfaceParent: ShortString);
      skInterfaceMethod: (
        InterfaceName: ShortString;
        InterfaceMethodKind: TRoutineKind;
        InterfaceMethodConvention: TCallingConvention);
      skMember: (
        ClassName: ShortString;
        Visibility: TMemberVisibility;
        case TSourceKind of
          skMethod: (
            ClassMethod: Boolean;
            ClassMethodKind: TRoutineKind;
            VirtualKind: TVirtualKind;
            Abstracted: Boolean;
            Reintroduced: Boolean;
            Overloaded: Boolean;
            ClassMethodConvention: TCallingConvention);
          skProperty: (
            { todo: fix }
                    Promoted: Boolean;
                        Event: Boolean;
            Access: TPropertyAccess;
            Default: Boolean);
          skField: (
            ));
  end;

  TLexicalClassEvent = procedure(Sender: TObject; const Body: string;
    const Info: TSourceInfo; const InheritedName: string;
    InterfaceList: TStrings) of object;
  TLexicalCommentEvent = procedure(Sender: TObject; const Comment: string) of object;
  TLexicalEvent = procedure(Sender: TObject; const Body: string;
    const Info: TSourceInfo) of object;
  TLexicalInterfaceEvent = procedure(Sender: TObject; const Body: string;
    const Info: TSourceInfo; const InheritedName: string) of object;
  TLexicalUsesEvent = procedure(Sender: TObject; UsesList: TStrings) of object;

  TPascalLexer = class(TPascalParser)
  private
    FFileName: string;
    FIdentifier: TPascalToken;
    FInterfaceList: TStrings;
    FMap: TMemoryMappedFile;
    FScratchToken: TPascalToken;
    FSection: TPascalTokenKind;
    FUnitIdent: string;
    FUnitPath: string;
    FOnArray: TLexicalEvent;
    FOnClass: TLexicalClassEvent;
    FOnClassReference: TLexicalEvent;
    FOnMethod: TLexicalEvent;
    FOnComment: TLexicalCommentEvent;
    FOnConstant: TLexicalEvent;
    FOnField: TLexicalEvent;
    FOnFunction: TLexicalEvent;
    FOnEnumeration: TLexicalEvent;
    FOnEvent: TLexicalEvent;
    FOnInterface: TLexicalInterfaceEvent;
    FOnInterfaceMethod: TLexicalEvent;
    FOnProcedure: TLexicalEvent;
    FOnProperty: TLexicalEvent;
    FOnRecord: TLexicalEvent;
    FOnRoutinePointer: TLexicalEvent;
    FOnSet: TLexicalEvent;
    FOnType: TLexicalEvent;
    FOnUses: TLexicalUsesEvent;
    FOnVariable: TLexicalEvent;
    procedure ReadArray;
    function ReadCallingConvention: TCallingConvention;
    procedure ReadClass;
    procedure ReadClassReference;
    procedure ReadComment;
    procedure ReadConstant;
    procedure ReadEnumeration;
    procedure ReadInterface;
    procedure ReadRecord;
    procedure ReadRoutine;
    procedure ReadRoutinePointer(Kind: TRoutineKind);
    procedure ReadSet;
    procedure ReadType;
    procedure ReadUses;
    procedure ReadVariable;
    procedure SetFileName(Value: string);
  protected
    procedure InvokeEvent(var SourceInfo: TSourceInfo; Event: TLexicalEvent);
    procedure StandardEvent(Kind: TSourceKind; Event: TLexicalEvent);
    property Identifier: TPascalToken read FIdentifier;
    property Section: TPascalTokenKind read FSection;
  public
    constructor Create(Buffer: PChar = nil; Size: Integer = 0); override;
    destructor Destroy; override;
    procedure Analyze;
    procedure Reset;
    property FileName: string read FFileName write SetFileName;
    property UnitIdent: string read FUnitIdent;
    property UnitPath: string read FUnitPath;
    property OnArray: TLexicalEvent read FOnArray write FOnArray;
    property OnClass: TLexicalClassEvent read FOnClass write FOnClass;
    property OnClassReference: TLexicalEvent read FOnClassReference write FOnClassReference;
    property OnComment: TLexicalCommentEvent read FOnComment write FOnComment;
    property OnConstant: TLexicalEvent read FOnConstant write FOnConstant;
    property OnField: TLexicalEvent read FOnField write FOnField;
    property OnFunction: TLexicalEvent read FOnFunction write FOnFunction;
    property OnEvent: TLexicalEvent read FOnEvent write FOnEvent;
    property OnEnumeration: TLexicalEvent read FOnEnumeration write FOnEnumeration;
    property OnInterface: TLexicalInterfaceEvent read FOnInterface write FOnInterface;
    property OnInterfaceMethod: TLexicalEvent read FOnInterfaceMethod write FOnInterfaceMethod;
    property OnMethod: TLexicalEvent read FOnMethod write FOnMethod;
    property OnProcedure: TLexicalEvent read FOnProcedure write FOnProcedure;
    property OnProperty: TLexicalEvent read FOnProperty write FOnProperty;
    property OnRecord: TLexicalEvent read FOnRecord write FOnRecord;
    property OnRoutinePointer: TLexicalEvent read FOnRoutinePointer write FOnRoutinePointer;
    property OnSet: TLexicalEvent read FOnSet write FOnSet;
    property OnType: TLexicalEvent read FOnType write FOnType;
    property OnUses: TLexicalUsesEvent read FOnUses write FOnUses;
    property OnVariable: TLexicalEvent read FOnVariable write FOnVariable;
  end;

const
  ClassMembers = [skConstructor, skDestructor, skFunctionMethod,
    skProcedureMethod, skProperty];
  InterfaceMembers = [skFunctionInterfaceMethod, skProcedureInterfaceMethod];

function SourceKindToString(SourceKind: TSourceKind): string;

implementation

uses
  StrConst;

function KindToRoutine(Kind: TPascalTokenKind): TRoutineKind;
begin
  case Kind of
    tkConstructor:
      Result := rkConstructor;
    tkDestructor:
      Result := rkDestructor;
    tkFunction:
      Result := rkFunction;
  else
    Result := rkProcedure;
  end;
end;

const
  SourceKinds: array[TSourceKind] of TIdentMapEntry = (
    (Value: Ord(skArray); Name: 'array'),
    (Value: Ord(skClass); Name: 'class'),
    (Value: Ord(skClassReference); Name: 'class reference'),
    (Value: Ord(skConstant); Name: 'constant'),
    (Value: Ord(skConstructor); Name: 'constructor'),
    (Value: Ord(skDestructor); Name: 'destructor'),
    (Value: Ord(skEnumeration); Name: 'enumeration'),
    (Value: Ord(skEvent); Name: 'event'),
    (Value: Ord(skField); Name: 'field'),
    (Value: Ord(skFunction); Name: 'function'),
    (Value: Ord(skFunctionEvent); Name: 'function event'),
    (Value: Ord(skFunctionInterfaceMethod); Name: 'function interface method'),
    (Value: Ord(skFunctionMethod); Name: 'function method'),
    (Value: Ord(skFunctionPointer); Name: 'function pointer'),
    (Value: Ord(skInterface); Name: 'interface'),
    (Value: Ord(skInterfaceMethod); Name: 'interface method'),
    (Value: Ord(skMember); Name: 'member'),
    (Value: Ord(skMethod); Name: 'method'),
    (Value: Ord(skProcedure); Name: 'procedure'),
    (Value: Ord(skProcedureEvent); Name: 'procedure event'),
    (Value: Ord(skProcedureInterfaceMethod); Name: 'procedure interface method'),
    (Value: Ord(skProcedureMethod); Name: 'procedure method'),
    (Value: Ord(skProcedurePointer); Name: 'procedure pointer'),
    (Value: Ord(skProperty); Name: 'property'),
    (Value: Ord(skRecord); Name: 'record'),
    (Value: Ord(skresourceString); Name: 'resource string'),
    (Value: Ord(skSet); Name: 'set'),
    (Value: Ord(skThreadVariable); Name: 'thread variable'),
    (Value: Ord(skType); Name: 'type'),
    (Value: Ord(skVariable); Name: 'variable'),
    (Value: Ord(skUses); Name: 'uses'));

function SourceKindToString(SourceKind: TSourceKind): string;
begin
  IntToIdent(Ord(SourceKind), Result, SourceKinds);
end;

{ TPascalLexer }

constructor TPascalLexer.Create(Buffer: PChar; Size: Integer);
begin
  inherited Create(Buffer, Size);
  ExceptionTokens := [tkImplementation, tkNull];
  FIdentifier := TPascalToken.Create(Self);
  FInterfaceList := TStringList.Create;
  FScratchToken := TPascalToken.Create(Self);
  FSection := tkNull;
end;

destructor TPascalLexer.Destroy;
begin
  FIdentifier.Free;
  FInterfaceList.Free;
  FScratchToken.Free;
  FileName := '';
  inherited Destroy;
end;

procedure TPascalLexer.Reset;
begin
  Initialize(InternalBuffer, InternalSize);
  FSection := tkNull;
end;

procedure TPascalLexer.Analyze;
var
  InterfaceSection: Boolean;
begin
  if Position <> 0 then
    Reset;
  InterfaceSection := False;
  repeat
    Next;
    case Token.Kind of
      tkConst, tkResourcestring, tkThreadvar, tkType, tkVar: FSection := Token.Kind;
      tkIdentifier:
        Identifier.Copy(Token);
      tkArray: ReadArray;
      tkFunction, tkProcedure:
        if Peek(CommentTokens) = tkIdentifier then
        begin
          FSection := Token.Kind;
          ReadRoutine;
        end
        else
          ReadRoutinePointer(KindToRoutine(Token.Kind));
      tkLeftParenthesis:
        ReadEnumeration;
      tkRecord:
        ReadRecord;
      tkSet:
        ReadSet;
      tkEqual:
        case FSection of
          tkConst, tkResourcestring: ReadConstant;
          tkType:
            if (Peek(CommentTokens + [tkPointerTo]) in [tkIdentifier, tkString, tkType]) then
              ReadType;
        end;
      tkColon:
        if (FSection in [tkConst, tkResourcestring, tkThreadvar,  tkVar]) and
          (Peek(CommentTokens) in [tkIdentifier,  tkString]) then
          case FSection of
            tkConst, tkResourcestring:
              ReadConstant;
            tkThreadvar, tkVar:
              ReadVariable;
          end;
      tkClass:
        case Peek(CommentTokens) of
          tkSemiColon:
            Scan([tkSemiColon]);
          tkOf:
            ReadClassReference;
        else
          ReadClass;
        end;
      tkInterface:
        if InterfaceSection then
          case Peek(CommentTokens) of
            tkSemiColon:
              Scan([tkSemiColon]);
          else
            ReadInterface;
          end
        else
          InterfaceSection := True;
      tkAnsiComment, tkCComment, tkPascalComment:
        ReadComment;
      tkUses:
        ReadUses;
    end;
  until Token.Kind in [tkImplementation, tkNull];
end;

procedure TPascalLexer.InvokeEvent(var SourceInfo: TSourceInfo;
  Event: TLexicalEvent);
var
  Body: string;
begin
  case FSection of
    tkConst:
      begin
        SourceInfo.Kind := skConstant;
        Event := FOnConstant;
      end;
    tkResourceString:
      begin
        SourceInfo.Kind := skResourceString;
        Event := FOnVariable;
      end;
    tkThreadVar:
      begin
        SourceInfo.Kind := skThreadVariable;
        Event := FOnVariable;
      end;
    tkVar:
      begin
        SourceInfo.Kind := skVariable;
        Event := FOnVariable;
      end;
  end;
  if Assigned(Event) then
  begin
    Body := CopyText(Identifier.Position, Token.Position + Token.Length -
      Identifier.Position);
    with SourceInfo do
    begin
      Line := Identifier.Row;
      Column := Identifier.Col;
      Name := Identifier.Text;
    end;
    Event(Self, Body, SourceInfo);
  end;
end;

procedure TPascalLexer.StandardEvent(Kind: TSourceKind; Event: TLexicalEvent);
var
  SourceInfo: TSourceInfo;
  I: Integer;
begin
  I := 0;
  repeat
    case Scan([tkEnd, tkRecord, tkLeftParenthesis, tkRightParenthesis,
      tkSemiColon]) of
      tkLeftParenthesis:
        Inc(I);
      tkRightParenthesis:
        Dec(I);
      tkEnd:
        begin
          Scan([tkSemiColon]);
          Dec(I)
        end;
      tkRecord:
        Inc(I);
    end;
  until (I = 0) and (Token.Kind = tkSemiColon);
  SourceInfo.Kind := Kind;
  InvokeEvent(SourceInfo, Event);
end;

procedure TPascalLexer.ReadArray;
var
  SourceInfo: TSourceInfo;
  I: Integer;
begin
  I := 0;
  repeat
    case Scan([tkLeftParenthesis, tkRightParenthesis, tkSemiColon]) of
      tkLeftParenthesis:
        Inc(I);
      tkRightParenthesis:
        Dec(I);
    end;
  until (I = 0) and (Token.Kind = tkSemiColon);
  SourceInfo.Kind := skArray;
  InvokeEvent(SourceInfo, FOnArray);
end;

function TPascalLexer.ReadCallingConvention: TCallingConvention;
begin
  Result := ccDefault;
  if (Peek(CommentTokens, FScratchToken) = tkIdentifier) then
    case StrToDirectiveKind(FScratchToken.Text) of
      dkCdecl: Result := ccCdecl;
      dkPascal: Result := ccPascal;
      dkRegister: Result := ccRegister;
      dkSafecall: Result := ccSafecall;
      dkStdcall: Result := ccStdcall;
    end;
  if Result <> ccDefault then
    Scan([tkSemiColon]);
end;

procedure TPascalLexer.ReadClass;
var
  Name: string;
  InheritedName: string;
  Visibility: TMemberVisibility;
  ClassMethod: Boolean;

  procedure ReadMethod;
  var
    SourceInfo: TSourceInfo;
    StartToken: TPascalToken;
    Start: Integer;
    Body: string;
  begin
    Start := 0;
    if Assigned(FOnMethod) then
    begin
      SourceInfo.ClassMethod := ClassMethod;
      if ClassMethod then
        StartToken := FScratchToken
      else
        StartToken := Token;
      SourceInfo.Line := StartToken.Row;
      SourceInfo.Column := StartToken.Col;
      Start := StartToken.Position;
      SourceInfo.ClassMethodKind := KindToRoutine(Token.Kind);
      case SourceInfo.ClassMethodKind of
        rkConstructor:
          SourceInfo.Kind := skConstructor;
        rkDestructor:
          SourceInfo.Kind := skDestructor;
        rkFunction:
          SourceInfo.Kind := skFunctionMethod;
        rkProcedure:
          SourceInfo.Kind := skProcedureMethod;
      end;
      Scan([tkIdentifier]);
      SourceInfo.Name := Token.Text;
      SourceInfo.ClassName := Name;
      SourceInfo.Visibility := Visibility;
      SourceInfo.Abstracted := False;
      SourceInfo.Reintroduced := False;
      SourceInfo.Overloaded := False;
    end;
    if Peek(CommentTokens) = tkLeftParenthesis then
      Scan([tkRightParenthesis]);
    Scan([tkSemiColon]);
    SourceInfo.VirtualKind := vkStatic;
    while Peek(CommentTokens, FScratchToken) = tkIdentifier do
      case StrToDirectiveKind(FScratchToken.Text) of
        dkAbstract:
          begin
            SourceInfo.Abstracted := True;
            Scan([tkSemiColon]);
          end;
        dkDynamic:
          begin
            SourceInfo.VirtualKind := vkDynamic;
            Scan([tkSemiColon]);
          end;
        dkMessage:
          begin
            SourceInfo.VirtualKind := vkMessage;
            Scan([tkSemiColon]);
          end;
        dkOverride:
          begin
            SourceInfo.VirtualKind := vkOverride;
            Scan([tkSemiColon]);
          end;
        dkVirtual:
          begin
            SourceInfo.VirtualKind := vkVirtual;
            Scan([tkSemiColon]);
          end;
        dkReintroduce:
          begin
            SourceInfo.Reintroduced := True;
            Scan([tkSemiColon]);
          end;
        dkOverload:
          begin
            SourceInfo.Overloaded := True;
            Scan([tkSemiColon]);
          end;
      else
        Break;
      end;
    if Token.Kind <> tkSemiColon then
      Scan([tkSemiColon]);
    SourceInfo.ClassMethodConvention := ReadCallingConvention;
    if Assigned(FOnMethod) then
    begin
      Body := CopyText(Start, Token.Position + Token.Length - Start);
      FOnMethod(Self, Body, SourceInfo);
    end;
  end;

  procedure ReadProperty;
  var
    Start: Integer;
    SourceInfo: TSourceInfo;
    ColonFound: Boolean;
    Body: string;
    I: Integer;
  begin
    Start := 0;
    if Assigned(FOnProperty) then
    begin
      Start := Token.Position;
      SourceInfo.Line :=  Token.Row;
      SourceInfo.Column := Token.Col;
      Scan([tkIdentifier]);
      SourceInfo.Name := Token.Text;
      SourceInfo.Kind := skProperty;
      SourceInfo.ClassName := Name;
      SourceInfo.Visibility := Visibility;
      SourceInfo.Access := [];
    end;
    ColonFound := False;
    I := 0;
    repeat
      case Scan([tkLeftBracket, tkRightBracket, tkIdentifier, tkColon,
        tkSemicolon]) of
        tkLeftBracket:
          Inc(I);
        tkRightBracket:
          Dec(I);
        tkIdentifier:
          if ColonFound and Assigned(FOnProperty) then
            case StrToDirectiveKind(Token.Text) of
              dkRead:
                Include(SourceInfo.Access, paRead);
              dkWrite:
                Include(SourceInfo.Access, paWrite);
            end;
        tkColon:
          if I = 0 then
           ColonFound := True;
      end;
    until (I = 0) and (Token.Kind = tkSemicolon);
    if ColonFound then
    begin
      SourceInfo.Default := False;
      if Peek(CommentTokens, FScratchToken) = tkIdentifier then
        SourceInfo.Default := StrToDirectiveKind(FScratchToken.Text) = dkDefault;
      if SourceInfo.Default then
        Scan([tkSemiColon]);
    end;
    if Assigned(FOnProperty) then
    begin
      SourceInfo.Promoted := not ColonFound;
      Body := CopyText(Start, Token.Position + Token.Length - Start);
      FOnProperty(Self, Body, SourceInfo);
    end;
  end;

  procedure ReadIdentifier;
  var
    Start: Integer;
    SourceInfo: TSourceInfo;
    Body: string;
  begin
    Start := 0;
    if Assigned(FOnField) then
    begin
      Start := Token.Position;
      SourceInfo.Line :=  Token.Row;
      SourceInfo.Column := Token.Col;
      SourceInfo.Name := Token.Text;
      SourceInfo.Kind := skField;
      SourceInfo.ClassName := Name;
      SourceInfo.Visibility := Visibility;
    end;
    Scan([tkSemiColon]);
    if Assigned(FOnField) then
    begin
      Body := CopyText(Start, Token.Position + Token.Length - Start);
      FOnField(Self, Body, SourceInfo);
    end;
  end;

var
  SourceInfo: TSourceInfo;
  Body: string;
  I: Integer;
const
  ClassTokens = [tkIdentifier, tkProperty, tkClass, tkConstructor, tkDestructor,
    tkFunction, tkProcedure, tkRecord, tkEnd];
begin
  Name := Identifier.Text;
  InheritedName := 'TObject';
  FInterfaceList.Clear;
  if Peek(CommentTokens) = tkLeftParenthesis then
  begin
    Scan([tkIdentifier]);
    InheritedName := Token.Text;
    while Scan([tkIdentifier, tkRightParenthesis]) = tkIdentifier do
      FInterfaceList.Add(Token.Text);
  end;
  ClassMethod := False;
  Visibility := mvPublished;
  I := 1;
  if Peek(CommentTokens) = tkSemiColon then
  begin
    Scan([tkSemiColon]);
    Dec(I);
  end;
  while I > 0 do
  begin
    case Scan(ClassTokens) of
      tkIdentifier:
        case StrToDirectiveKind(Token.Text) of
          dkPrivate:
            Visibility := mvPrivate;
          dkProtected:
            Visibility := mvProtected;
          dkPublic:
            Visibility := mvPublic;
          dkPublished:
            Visibility := mvPublished;
        else
          ReadIdentifier;
        end;
      tkClass:
        begin
          ClassMethod := True;
          FScratchToken.Copy(Token);
          Continue;
        end;
      tkConstructor, tkDestructor, tkFunction, tkProcedure: ReadMethod;
      tkProperty: ReadProperty;
      tkRecord:
        Inc(I);
      tkEnd:
        begin
          Scan([tkSemiColon]);
          Dec(I);
        end;
    end;
    ClassMethod := False;
  end;
  if Assigned(FOnClass) then
  begin
    Body := CopyText(Identifier.Position, Token.Position + Token.Length -
      Identifier.Position);
    with SourceInfo do
    begin
      Line := Identifier.Row;
      Column := Identifier.Col;
      Name := Identifier.Text;
      Kind := skClass;
      ClassParent := InheritedName;
      InterfaceCount := FInterfaceList.Count;
    end;
    FOnClass(Self, Body, SourceInfo, InheritedName, FInterfaceList);
  end;
end;

procedure TPascalLexer.ReadComment;
begin
  if Assigned(FOnComment) then
    FOnComment(Self, Token.Text);
end;

procedure TPascalLexer.ReadConstant;
var
  SourceInfo: TSourceInfo;
  I: Integer;
begin
  I := 0;
  repeat
    case Scan([tkLeftParenthesis, tkRightParenthesis, tkSemiColon]) of
      tkLeftParenthesis:
        Inc(I);
      tkRightParenthesis:
        Dec(I);
    end;
  until (I = 0) and (Token.Kind = tkSemiColon);
  SourceInfo.Kind := skConstant;
  InvokeEvent(SourceInfo, FOnConstant);
end;

procedure TPascalLexer.ReadInterface;
var
  Name: string;
  InheritedName: string;

  procedure ReadInterfaceMethod;
  var
    SourceInfo: TSourceInfo;
    Start: Integer;
    Body: string;
  begin
    Start := 0;
    if Assigned(FOnInterfaceMethod) then
    begin
      SourceInfo.Line := Token.Row;
      SourceInfo.Column := Token.Col;
      Start := Token.Position;
      SourceInfo.InterfaceName := Name;
      SourceInfo.InterfaceMethodKind := KindToRoutine(Token.Kind);
      case SourceInfo.InterfaceMethodKind of
        rkFunction:
          SourceInfo.Kind := skFunctionInterfaceMethod;
        rkProcedure:
          SourceInfo.Kind := skProcedureInterfaceMethod;
      end;
      Scan([tkIdentifier]);
      SourceInfo.Name := Token.Text;
    end;
    if Peek(CommentTokens) = tkLeftParenthesis then
      Scan([tkRightParenthesis]);
    Scan([tkSemiColon]);
    SourceInfo.InterfaceMethodConvention := ReadCallingConvention;
    if Assigned(FOnInterfaceMethod) then
    begin
      Body := CopyText(Start, Token.Position + Token.Length - Start);
      FOnInterfaceMethod(Self, Body, SourceInfo);
    end;
  end;

var
  SourceInfo: TSourceInfo;
  Body: string;
  I: Integer;
const
  ClassTokens = [tkIdentifier, tkProperty, tkClass, tkFunction, tkProcedure,
    tkRecord, tkEnd];
begin
  Name := Identifier.Text;
  InheritedName := 'IUnknown';
  if Peek(CommentTokens) = tkLeftParenthesis then
  begin
    Scan([tkIdentifier]);
    InheritedName := Token.Text;
    Scan([tkRightParenthesis]);
  end;
  I := 1;
  if Peek(CommentTokens) = tkSemiColon then
  begin
    Scan([tkSemiColon]);
    Dec(I);
  end;
  while I > 0 do
    case Scan(ClassTokens) of
      tkFunction, tkProcedure: ReadInterfaceMethod;
      tkEnd:
        begin
          Scan([tkSemiColon]);
          Dec(I);
        end;
    end;
  if Assigned(FOnInterface) then
  begin
    Body := CopyText(Identifier.Position, Token.Position + Token.Length -
      Identifier.Position);
    with SourceInfo do
    begin
      Line := Identifier.Row;
      Column := Identifier.Col;
      Name := Identifier.Text;
      Kind := skInterface;
      InterfaceParent := InheritedName;
    end;
    FOnInterface(Self, Body, SourceInfo, InheritedName);
  end;
end;

procedure TPascalLexer.ReadClassReference;
var
  SourceInfo: TSourceInfo;
begin
  Scan([tkSemiColon]);
  SourceInfo.Kind := skClassReference;
  InvokeEvent(SourceInfo, FOnClassReference);
end;

procedure TPascalLexer.ReadEnumeration;
var
  SourceInfo: TSourceInfo;
begin
  Scan([tkSemiColon]);
  SourceInfo.Kind := skEnumeration;
  InvokeEvent(SourceInfo, FOnEnumeration);
end;

procedure TPascalLexer.ReadRecord;
var
  SourceInfo: TSourceInfo;
  I: Integer;
begin
  I := 1;
  while I > 0 do
    case Scan([tkEnd, tkRecord]) of
      tkEnd:
        begin
          Scan([tkSemiColon]);
          Dec(I)
        end;
      tkRecord:
        Inc(I);
    end;
  SourceInfo.Kind := skRecord;
  InvokeEvent(SourceInfo, FOnRecord);
end;

procedure TPascalLexer.ReadRoutine;
var
  SourceInfo: TSourceInfo;
  Event: TLexicalEvent;
  Start: Integer;
begin
  SourceInfo.RoutineKind := KindToRoutine(Section);
  Event := nil;
  case SourceInfo.RoutineKind of
    rkFunction:
      begin
        SourceInfo.Kind := skFunction;
        Event := FOnFunction;
      end;
    rkProcedure:
      begin
        SourceInfo.Kind := skProcedure;
        Event := FOnProcedure;
      end;
  end;
  if Assigned(Event) then
  begin
    Start := Token.Position;
    SourceInfo.Line := Token.Row;
    SourceInfo.Column := Token.Col;
  end
  else
    Start := 0;
  Scan([tkIdentifier]);
  if Assigned(Event) then
    SourceInfo.Name := Token.Text;
  if Peek(CommentTokens) = tkLeftParenthesis then
    Scan([tkRightParenthesis]);
  Scan([tkSemiColon]);
  SourceInfo.RoutineConvention := ReadCallingConvention;
  if Assigned(Event) then
    Event(Self, CopyText(Start, Token.Position + Token.Length - Start),
      SourceInfo);
end;

procedure TPascalLexer.ReadRoutinePointer(Kind: TRoutineKind);
var
  SourceInfo: TSourceInfo;
  MethodPointer: Boolean;
begin
  if Peek(CommentTokens) = tkLeftParenthesis then
    Scan([tkRightParenthesis]);
  MethodPointer := Scan([tkOf, tkSemiColon]) = tkOf;
  SourceInfo.RoutineKind := Kind;
  if MethodPointer then
  begin
    Scan([tkSemiColon]);
    case Kind of
      rkFunction: SourceInfo.Kind := skFunctionEvent;
      rkProcedure: SourceInfo.Kind := skProcedureEvent;
    end;
    SourceInfo.RoutineConvention := ReadCallingConvention;
    InvokeEvent(SourceInfo, FOnEvent);
  end
  else
  begin
    case Kind of
      rkFunction: SourceInfo.Kind := skFunctionPointer;
      rkProcedure: SourceInfo.Kind := skProcedurePointer;
    end;
    SourceInfo.RoutineConvention := ReadCallingConvention;
    InvokeEvent(SourceInfo, FOnRoutinePointer);
  end;
end;

procedure TPascalLexer.ReadSet;
var
  SourceInfo: TSourceInfo;
begin
  Scan([tkImplementation, tkNull, tkSemiColon]);
  SourceInfo.Kind := skSet;
  InvokeEvent(SourceInfo, FOnSet);
end;

procedure TPascalLexer.ReadType;
begin
  StandardEvent(skType, FOnType);
end;

procedure TPascalLexer.ReadUses;
var
  UsesList: TStrings;
begin
  if Assigned(FOnUses) then
  begin
    UsesList := TStringList.Create;
    try
      while Scan([tkIdentifier, tkSemiColon]) = tkIdentifier do
        UsesList.Add(Token.Text);
      FOnUses(Self, UsesList);
    finally
      UsesList.Free;
    end;
  end;
end;

procedure TPascalLexer.ReadVariable;
begin
  StandardEvent(skVariable, FOnVariable);
end;

procedure TPascalLexer.SetFileName(Value: string);
begin
  FMap.Free;
  if Value = '' then
    FMap := nil
  else
  begin
    FMap := TMemoryMappedFile.Create(Value);
    Initialize(PChar(FMap.ViewStart), Integer(FMap.ViewEnd - FMap.ViewStart));
    Scan([tkUnit]);
    Scan([tkIdentifier]);
    FUnitPath := Value;
    FUnitIdent := Token.Text;
  end;
end;

{ root
   + units
   |  + name1
   |  |  + path
   |  |  + uses
   |  |     + unit1
   |  |     + unit2 ...
   |  |  + classes
   |  |     + class1
   |  |     + class2 ...
   |  + name2 ...
   + unknown ...
   }

end.