开源代码:Delphi词法分析全过程

unit DelphiToken;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StringOperations;

const
  WM_TOKENERROR  = WM_USER + 2034;
 
const
  CHR_SYMHEADER  = 1;       //当第1位为1时，可以做为标识符的字符//
  CHR_NUMHEADER  = 2;       //当第2位为1时，可以做为数字的字符//
  CHR_SYMGLOBAL  = 4;       //当第3位为1时，可以做为//
  CHR_NUMGLOBAL  = 8;
  CHR_QUOTE      = 16;       //当第4位为1时，可以做为字符串界符//
  CHR_WHITE      = 32;      //当第5位为1时，可以做为空白符//

const
  bs   = 8; (* BackSpace字符 *)
  tab  = 9; (* TAB字符 *)
  nl   = 10; (* NewLine字符 *)
  cr   = 13; (* Return字符*)
  ff   = 12; (* form feed 字符 *)

const
  LEN_OPRSYMTAB = 13;
  LEN_BNDSYMTAB = 8;

type
  TCharClass=(
    ccUnknown,
    ccSymbolHeader,
    ccSymbolGlobal,
    ccNumberHeader,
    ccNumberGlobal,
    ccQuote,
    ccToDo,
    ccWhite
  );

  TCharClasses=Set of TCharClass;
 
  TDKeywordID=(
    DKW_AND,             //and
    DKW_ARRAY,           //array
    DKW_BEGIN,           //begin
    DKW_BOOL,            //bool
    DKW_BYTE,            //byte
    DKW_CALL,            //call
    DKW_CARDINAL,        //cardinal
    DKW_CASE,            //case
    DKW_CDECL,           //cdecl
    DKW_CHAR,            //char
    DKW_CLASS,           //class
    DKW_CONSTANT,        //constant
    DKW_COMP,            //comp
    DKW_CONST,           //const
    DKW_CURRENCY,        //currency
    DKW_DIV,             //div
    DKW_DO,              //do
    DKW_DOUBLE,          //double
    DKW_ELSE,            //else
    DKW_END,             //end
    DKW_EXCEPT,          //except
    DKW_EXTENTED,        //extented
    DKW_FALSE,           //false
    DKW_FILE,            //file
    DKW_FINALIZATION,    //finalization
    DKW_FINALLY,         //finally
    DKW_FOR,             //for
    DKW_IF,              //if
    DKW_IN,              //in
    DKW_INITIALIZATION,  //initialization
    DKW_INPUT,           //input
    DKW_INTEGER,         //integer
    DKW_INTERFACE,       //interface
    DKW_INT64,           //int64
    DKW_IMPLEMENTATION,  //implementation
    DKW_IMPLEMENTS,      //implements
    DKW_LIBRARY,         //library
    DKW_LONGINT,         //longint
    DKW_LONGWORD,        //longword
    DKW_MOD,             //mod
    DKW_NOT,             //not
    DKW_OF,              //of
    DKW_OR,              //or
    DKW_OUTPUT,          //output
    DKW_PASCAL,          //pascal
    DKW_PRIVATE,         //private
    DKW_PROCEDURE,       //procedure
    DKW_PROGRAM,         //program
    DKW_PROTECTED,       //protected
    DKW_PUBLIC,          //public
    DKW_PUBLISHED,       //published
    DKW_RAISE,           //raise
    DKW_READ,            //read
    DKW_REAL,            //real
    DKW_REAL48,          //real48
    DKW_REGISTER,        //register
    DKW_REPEAT,          //repeat
    DKW_PROPERTY,        //property
    DKW_SAFECALL,        //safecall
    DKW_SINGLE,          //single
    DKW_SET,             //set
    DKW_SMALLINT,        //smallint
    DKW_SHORTINT,        //shortint
    DKW_STDCALL,         //stdcall
    DKW_THEN,            //then
    DKW_TO,              //to
    DKW_TRY,             //try
    DKW_TRUE,            //true
    DKW_TYPE,            //type
    DKW_UNIT,            //unit
    DKW_UNTIL,           //until
    DKW_USES,            //uses
    DKW_VAR,             //var
    DKW_WHILE,           //while
    DKW_WORD,            //word
    DKW_WRITE            //write
  );

  TDKeywordType=(
    kwtUnknown,
    kwtControl,
    kwtOperator,
    kwtInt,
    kwtFloat,
    kwtBool,
    kwtChar
  );

  PKeyword=^TDKeyword;
 
  TDKeyword=record
    id:TDKeywordID;
    str:string;
    type_:TDKeywordType;
  end;

  TDKeywordList = class
  private
    FList:TList;
    function GetItemCount:Integer;
    function GetItem(Index:Integer):PKeyword;
  public
    constructor Create;
    destructor Destroy;override;

    procedure Add(Value:PKeyword);overload;
    function Add:PKeyword;overload;
    function AddAndInit(const id:TDKeywordID; str:string;
      type_:TDKeywordType):PKeyword;overload;
    procedure Insert(const Index:Integer;Value:PKeyword);overload;
    function Insert(const Index:Integer):PKeyword;overload;
    procedure Delete(const Index:Integer);
    procedure Clear;

    function IndexOf(const Keyword:TDKeywordID):Integer;
    function FindKey(const Keyword:TDKeywordID):PKeyword;
    function Lookup(const AStr:string; const bCase:Boolean;
      var KeyInfo:PKeyword):Boolean;

    procedure LoadFromFile(const FileName:string);
    procedure SaveToFile(const FileName:string);
    procedure LoadFromStream(Stream:TStream);
    procedure SaveToStream(Stream:TStream);

    property ItemCount:Integer read GetItemCount;
    property Items[Index:Integer]:PKeyword read GetItem;
  end;

  TCharSet=set of Char;

  TTokenType=(
    //UnknownToken类型//
    ttUnknown,
    //一般Token类型//
    tTDKeyword,
    ttSymbol,
    ttInt,
    ttFloat,
    ttString,
    //操作符Token类型   //
    ttAddr,             // @
    ttPointer,          // ^
    ttAdd,              // +
    ttSub,              // -
    ttMul,              // *
    ttDiv,              // /
    ttMod,              // %
    ttEQ,               // =
    ttLT,               // <
    ttGT,               // >
    ttNE,              // <>
    ttLE,              // <=
    ttGE,              // >=
    ttSV,               // :=
    //界符Token类型//
    ttRET,              // :
    ttDot,              // .
    ttComma,            // ,
    ttSE,               // ;
    ttLParen,           // (
    ttRParen,           // )
    ttLArray,           // [
    ttRArray,           // ]
    //行结束符//
    ttLineEnd,
    //文件结束符//
    ttCodeEnd);

  TSystemToken=record
    id:TTokenType;
    str:string;
  end;
 
  PToken = ^TDToken;

  TDToken = record
    tok_position: PChar;  //词的开始位置//
    tok_length: Integer;  //词的长度//
    tok_string: string;   //词的内容//
    tok_type: TTokenType; //词类型//
    tok_keyword:PKeyword; //如果为关键字，则执行关键字信息//
    tok_line: Integer;
    tok_lineposition: Integer;
  end;

  TDTokenList = class
  private
    FList:TList;
    function GetItemCount:Integer;
    function GetItem(Index:Integer):PToken;
  public
    constructor Create;
    destructor Destroy;override;

    procedure Add(Value:PToken);overload;
    function Add:PToken;overload;
    procedure Insert(const Index:Integer;Value:PToken);overload;
    function Insert(const Index:Integer):PToken;overload;
    procedure Delete(const Index:Integer);
    procedure Clear;
 
    property ItemCount:Integer read GetItemCount;
    property Items[Index:Integer]:PToken read GetItem;
  end;

  TErrorPostType=(epException, epMessage);
 
  TDTokenAnalyzer=class
  private
    FText: string;
    FToken: TDToken;
    FPosition:PChar;                      //当前指针//
    FSourcePtr: PChar;             //指针分析完词后的位置//
    FLineNumber: Integer;         //行号//
    FLine_Position: Integer;      //行内索引号//
    FPrior_Line_Position: Integer;
    FOnBuildToken: TNotifyEvent;
    FMsgHandle: THandle;
    FErrorPost: TErrorPostType;
    FGenNormalString: Boolean;
    {描述：
        返回到上一个字符，必须使用该方法返回到上一个字符。
    参数：
        c: 返回到上一个字符前的当前字符}
    procedure return_cha