{**********************************************************************}

{ }

{ "The contents of this file are subject to the Mozilla Public }

{ License Version 1.1 (the "License"); you may not use this }

{ file except in compliance with the License. You may obtain }

{ a copy of the License at http://www.mozilla.org/MPL/ }

{ }

{ Software distributed under the License is distributed on an }

{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express }

{ or implied. See the License for the specific language }

{ governing rights and limitations under the License. }

{ }

{ The Initial Developer of the Original Code is Matthias }

{ Ackermann. For other initial contributors, see contributors.txt }

{ Subsequent portions Copyright Creative IT. }

{ }

{ Current maintainer: Eric Grange }

{ }

{**********************************************************************}

unit dwsTokenizer;

{$I dws.inc}

interface

uses

SysUtils, Classes, TypInfo,

dwsScriptSource, dwsErrors, dwsStrings, dwsXPlatform, dwsUtils, dwsXXHash

{$ifdef FPC},lazutf8{$endif};

type

TTokenType =

(

ttNone, ttStrVal, ttIntVal, ttFloatVal, ttNAME, ttSWITCH,

ttLAZY, ttVAR, ttCONST, ttRESOURCESTRING,

ttTYPE, ttRECORD, ttARRAY, ttSET, ttDOT, ttDOTDOT, ttOF, ttENUM, ttFLAGS,

ttTRY, ttEXCEPT, ttRAISE, ttFINALLY, ttON, ttREAD, ttWRITE, ttPROPERTY,

ttFUNCTION, ttPROCEDURE, ttCONSTRUCTOR, ttDESTRUCTOR, ttMETHOD, ttLAMBDA, ttOPERATOR,

ttCLASS, ttNIL, ttIS, ttAS, ttIMPLEMENTS, ttINDEX, ttOBJECT,

ttVIRTUAL, ttOVERRIDE, ttREINTRODUCE, ttINHERITED, ttFINAL, ttNEW,

ttABSTRACT, ttSEALED, ttSTATIC, ttPARTIAL, ttDEPRECATED, ttOVERLOAD,

ttEXTERNAL, ttEXPORT, ttFORWARD, ttINLINE, ttEMPTY, ttIN,

ttENSURE, ttREQUIRE, ttINVARIANTS, ttOLD,

ttINTERFACE, ttIMPLEMENTATION, ttINITIALIZATION, ttFINALIZATION,

ttHELPER, ttSTRICT,

ttASM, ttBEGIN, ttEND, ttBREAK, ttCONTINUE, ttEXIT,

ttIF, ttTHEN, ttELSE, ttWITH, ttWHILE, ttREPEAT, ttUNTIL, ttFOR, ttTO, ttDOWNTO, ttDO,

ttCASE,

ttTRUE, ttFALSE,

ttAND, ttOR, ttXOR, ttDIV, ttMOD, ttNOT, ttSHL, ttSHR, ttSAR,

ttPLUS, ttMINUS, ttIMPLIES, ttIMPLICIT,

ttTIMES, ttDIVIDE, ttPERCENT, ttCARET, ttAT, ttTILDE,

ttDOLLAR, ttEXCLAMATION, ttQUESTION, ttQUESTIONQUESTION, ttQUESTIONDOT,

ttEQ, ttNOTEQ, ttGTR, ttGTREQ, ttLESS, ttLESSEQ, ttEQGTR,

ttLESSLESS, ttGTRGTR, ttPIPE, ttPIPEPIPE, ttAMP, ttAMPAMP,

ttSEMI, ttCOMMA, ttCOLON,

ttASSIGN, ttPLUS_ASSIGN, ttMINUS_ASSIGN, ttTIMES_ASSIGN, ttDIVIDE_ASSIGN,

ttPERCENT_ASSIGN, ttCARET_ASSIGN, ttAT_ASSIGN, ttTILDE_ASSIGN,

ttBLEFT, ttBRIGHT, ttALEFT, ttARIGHT, ttCLEFT, ttCRIGHT,

ttDEFAULT, ttUSES, ttUNIT, ttNAMESPACE,

ttPRIVATE, ttPROTECTED, ttPUBLIC, ttPUBLISHED,

ttPROGRAM, ttLIBRARY,

// Tokens for compatibility to Delphi

ttREGISTER, ttPASCAL, ttCDECL, ttSAFECALL, ttSTDCALL, ttFASTCALL, ttREFERENCE

);

TTokenTypes = set of TTokenType;

// TTokenBuffer

//

TTokenBuffer = record

Len : Integer;

Capacity : Integer;

CaseSensitive : Boolean;

Buffer : array of Char;

Unifier : TStringUnifier;

procedure AppendChar(c : Char);

procedure Grow;

function LastChar : Char;

function ToStr : String; overload; inline;

procedure ToStr(var result : String); overload;

procedure AppendMultiToStr(var result : String);

procedure AppendToStr(var result : String);

procedure ToUpperStr(var result : String); overload;

function UpperFirstChar : Char;

function UpperMatchLen(const str : String) : Boolean;

function MatchLen(const str : String) : Boolean;

procedure RaiseInvalidIntegerConstant;

function BinToInt64 : Int64;

function HexToInt64 : Int64;

function ToInt64 : Int64;

function ToFloat : Double;

function ToType : TTokenType;

function ToAlphaType : TTokenType;

function ToAlphaTypeCaseSensitive : TTokenType;

class function StringToTokenType(const str : String) : TTokenType; static;

end;

TToken = ^TTokenRecord;

TTokenRecord = record

private

FString : String;

FNext : TToken;

public

FScriptPos : TScriptPos;

FFloat : Double;

FInteger : Int64;

FTyp : TTokenType;

property AsString : String read FString;

function EmptyString : Boolean; inline;

end;

TCharsType = set of AnsiChar;

TTransition = class;

TState = class (TRefCountedObject)

private

FOwnedTransitions : TTightList;

FTransitions : array [#0..#127] of TTransition;

public

destructor Destroy; override;

function FindTransition(c : Char) : TTransition; inline;

procedure AddTransition(const chrs : TCharsType; o : TTransition);

procedure AddEOFTransition(o : TTransition);

procedure SetTransition(c : AnsiChar; o : TTransition); inline;

procedure SetElse(o : TTransition);

end;

TConvertAction = (caNone, caClear, caName, caNameEscaped,

caBin, caHex, caInteger, caFloat,

caChar, caCharHex, caString, caMultiLineString,

caSwitch, caDotDot, caAmp, caAmpAmp);

TTransitionOptions = set of (toStart, toFinal);

TTransition = class (TRefCountedObject)

private

NextState : TState;

Start : Boolean; // Marks the begin of a Token

Final : Boolean; // Marks the end of a Token

Action : TConvertAction;

IsError : Boolean;

Consume : Boolean;

Seek : Boolean;

public

constructor Create(nstate: TState; opts: TTransitionOptions; actn: TConvertAction);

end;

TElseTransition = class(TTransition)

constructor Create(actn : TConvertAction);

end;

TErrorTransition = class(TTransition)

private

ErrorMessage : String;

public

constructor Create(const msg : String);

end;

TCheckTransition = class(TTransition);

TSeekTransition = class (TCheckTransition) // Transition, next Char

constructor Create(nstate: TState; opts: TTransitionOptions; actn: TConvertAction);

end;

TConsumeTransition = class (TSeekTransition) // Transition, consume Char, next Char

constructor Create(nstate: TState; opts: TTransitionOptions; actn: TConvertAction);

end;

TSwitchHandler = function(const switchName : String) : Boolean of object;

TTokenizer = class;

TTokenizerRules = class

private

FStates : TObjectList<TState>;

FEOFTransition : TErrorTransition;

FReservedNames : TTokenTypes;

FSymbolTokens : TTokenTypes;

FReservedTokens : TTokenTypes;

FCaseSensitive : Boolean;

protected

function CreateState : TState;

function StartState : TState; virtual; abstract;

public

constructor Create; virtual;

destructor Destroy; override;

procedure PrepareStates;

function CreateTokenizer(msgs : TdwsCompileMessageList; unifier : TStringUnifier) : TTokenizer;

property ReservedNames : TTokenTypes read FReservedNames write FReservedNames;

property SymbolTokens : TTokenTypes read FSymbolTokens write FSymbolTokens;

property ReservedTokens : TTokenTypes read FReservedTokens;

property CaseSensitive : Boolean read FCaseSensitive write FCaseSensitive;

end;

TTokenizerSourceInfo = record

FPathName : TFileName;

FText : String;

FDefaultPos : TScriptPos;

FHotPos : TScriptPos;

FCurPos : TScriptPos;

FPosPtr : PChar;

end;

PTokenizerSourceInfo = ^TTokenizerSourceInfo;

TTokenizerConditional = (tcIf, tcElse);

TTokenizerConditionalInfo = record

Conditional : TTokenizerConditional;

ScriptPos : TScriptPos;

end;

TTokenizerEndSourceFileEvent = procedure (sourceFile : TSourceFile) of object;

TTokenizer = class

private

FTokenBuf : TTokenBuffer;

FNextToken : TToken;

FRules : TTokenizerRules;

FStartState : TState;

FToken : TToken;

FSource : TTokenizerSourceInfo;

FSwitchHandler : TSwitchHandler;

FSwitchProcessor : TSwitchHandler;

FMsgs : TdwsCompileMessageList;

FConditionalDefines : IAutoStrings;

FConditionalDepth : TSimpleStack<TTokenizerConditionalInfo>;

FTokenPool : TToken;

FSourceStack : array of TTokenizerSourceInfo;

FOnEndSourceFile : TTokenizerEndSourceFileEvent;

procedure AllocateToken;

procedure ReleaseToken;

procedure HandleChar(var tokenBuf : TTokenBuffer; var result : TToken);

procedure HandleBin(var tokenBuf : TTokenBuffer; var result : TToken);

procedure HandleHexa(var tokenBuf : TTokenBuffer; var result : TToken);

procedure HandleInteger(var tokenBuf : TTokenBuffer; var result : TToken);

procedure HandleFloat(var tokenBuf : TTokenBuffer; var result : TToken);

function HandleSwitch : Boolean;

procedure ConsumeToken;

procedure ReadToken;

procedure AddCompilerStopFmtTokenBuffer(const formatString : String);

public

constructor Create(rules : TTokenizerRules; msgs : TdwsCompileMessageList;

unifier : TStringUnifier = nil);

destructor Destroy; override;

procedure BeginSourceFile(sourceFile : TSourceFile; const pathName : TFileName = '');

procedure EndSourceFile;

function GetToken : TToken; inline;

function HasTokens : Boolean;

procedure KillToken; inline;

function Test(t : TTokenType) : Boolean;

function TestAny(const t : TTokenTypes) : TTokenType;

function TestDelete(t : TTokenType) : Boolean;

function TestDeleteAny(const t : TTokenTypes) : TTokenType;

function TestName : Boolean;

function TestAnyName : Boolean;

function TestDeleteNamePos(var aName : String; var aPos : TScriptPos) : Boolean; inline;

function TestDeleteAnyNamePos(var aName : String; var aPos : TScriptPos) : Boolean; inline;

procedure SkipTo(t : TTokenType);

procedure SimulateToken(t : TTokenType; const scriptPos : TScriptPos);

procedure SimulateStringToken(const scriptPos : TScriptPos; const str : String);

procedure SimulateIntegerToken(const scriptPos : TScriptPos; const i : Int64);

procedure SimulateNameToken(const scriptPos : TScriptPos; const name : String);

property PosPtr : PChar read FSource.FPosPtr;

property Text : String read FSource.FText;

property DefaultPos : TScriptPos read FSource.FDefaultPos;

property HotPos : TScriptPos read FSource.FHotPos;

property CurrentPos : TScriptPos read FSource.FCurPos;

property PathName : TFileName read FSource.FPathName;

function SafePathName : String; inline;

property ConditionalDepth : TSimpleStack<TTokenizerConditionalInfo> read FConditionalDepth;

property Rules : TTokenizerRules read FRules;

property SwitchHandler : TSwitchHandler read FSwitchHandler write FSwitchHandler;

property SwitchProcessor : TSwitchHandler read FSwitchProcessor write FSwitchProcessor;

property ConditionalDefines : IAutoStrings read FConditionalDefines write FConditionalDefines;

property OnEndSourceFile : TTokenizerEndSourceFileEvent read FOnEndSourceFile write FOnEndSourceFile;

end;

const

cTokenStrings : array [TTokenType] of String = (

'', 'UnicodeString Literal', 'Integer Literal', 'Float Literal', 'NAME', 'SWITCH',

'LAZY', 'VAR', 'CONST', 'RESOURCESTRING',

'TYPE', 'RECORD', 'ARRAY', 'SET', '.', '..', 'OF', 'ENUM', 'FLAGS',

'TRY', 'EXCEPT', 'RAISE', 'FINALLY', 'ON', 'READ', 'WRITE', 'PROPERTY',

'FUNCTION', 'PROCEDURE', 'CONSTRUCTOR', 'DESTRUCTOR', 'METHOD', 'LAMBDA', 'OPERATOR',

'CLASS', 'NIL', 'IS', 'AS', 'IMPLEMENTS', 'INDEX', 'OBJECT',

'VIRTUAL', 'OVERRIDE', 'REINTRODUCE', 'INHERITED', 'FINAL', 'NEW',

'ABSTRACT', 'SEALED', 'STATIC', 'PARTIAL', 'DEPRECATED', 'OVERLOAD',

'EXTERNAL', 'EXPORT', 'FORWARD', 'INLINE', 'EMPTY', 'IN',

'ENSURE', 'REQUIRE', 'INVARIANTS', 'OLD',

'INTERFACE', 'IMPLEMENTATION', 'INITIALIZATION', 'FINALIZATION',

'HELPER', 'STRICT',

'ASM', 'BEGIN', 'END', 'BREAK', 'CONTINUE', 'EXIT',

'IF', 'THEN', 'ELSE', 'WITH', 'WHILE', 'REPEAT', 'UNTIL', 'FOR', 'TO', 'DOWNTO', 'DO',

'CASE',

'TRUE', 'FALSE',

'AND', 'OR', 'XOR', 'DIV', 'MOD', 'NOT', 'SHL', 'SHR', 'SAR',

'+', '-', 'IMPLIES', 'IMPLICIT',

'*', '/', '%', '^', '@', '~', '$', '!', '?', '??', '?.',

'=', '<>', '>', '>=', '<', '<=', '=>',

'<<', '>>', '|', '||', '&', '&&',

';', ',', ':',

':=', '+=', '-=', '*=', '/=',

'%=', '^=', '@=', '~=',

'(', ')', '[', ']', '{', '}',

'DEFAULT', 'USES', 'UNIT', 'NAMESPACE',

'PRIVATE', 'PROTECTED', 'PUBLIC', 'PUBLISHED',

'PROGRAM', 'LIBRARY',

'REGISTER', 'PASCAL', 'CDECL', 'SAFECALL', 'STDCALL', 'FASTCALL', 'REFERENCE'

);

function TokenTypesToString(const tt : TTokenTypes) : String;

// ------------------------------------------------------------------

// ------------------------------------------------------------------

// ------------------------------------------------------------------

implementation

// ------------------------------------------------------------------

// ------------------------------------------------------------------

// ------------------------------------------------------------------

const

cFormatSettings : TFormatSettings = ( DecimalSeparator : {%H-}'.' );

// TokenTypesToString

//

function TokenTypesToString(const tt : TTokenTypes) : String;

var

t : TTokenType;

begin

for t in tt do begin

if Result<>'' then

Result:=Result+' or ';

case t of

ttIntVal, ttStrVal, ttFloatVal :

Result:=Result+cTokenStrings[t];

else

Result:=Result+'"'+cTokenStrings[t]+'"';

end;

end;

end;

// EmptyString

//

function TTokenRecord.EmptyString : Boolean;

begin

Result:=(FString='');

end;

// AppendChar

//

procedure TTokenBuffer.AppendChar(c : Char);

begin

if Len>=Capacity then Grow;

Buffer[Len]:=c;

Inc(Len);

end;

// Grow

//

procedure TTokenBuffer.Grow;

begin

if Capacity=0 then

Capacity:=256

else Capacity:=Capacity*2;

SetLength(Buffer, Capacity);

end;

// LastChar

//

function TTokenBuffer.LastChar : Char;

begin

if Len>0 then

Result:=Buffer[Len-1]

else Result:=#0;

end;

// ToStr

//

function TTokenBuffer.ToStr : String;

begin

ToStr(Result);

end;

// ToStr

//

procedure TTokenBuffer.ToStr(var result : String);

begin

case Len of

0 : result := '';

1 : UnifyAssignChar(@Buffer[0], result);

else

if Unifier <> nil then

Unifier.UnifyAssignP(@Buffer[0], Len, result)

else SetString(result, PChar(@Buffer[0]), Len);

end;

end;

// AppendToStr

//

procedure TTokenBuffer.AppendToStr(var result : String);

var

n : Integer;

begin

if Len>0 then begin

n:=Length(result);

SetLength(result, n+Len);

Move(Buffer[0], PChar(Pointer(result))[n], Len*SizeOf(Char));

end;

end;

// AppendMultiToStr

//

procedure TTokenBuffer.AppendMultiToStr(var result : String);

var

i, n, k, minWhite, white : Integer;

leftWhite, firstIsCRLF, firstLine : Boolean;

begin

if Len=0 then Exit;

// count nb lines and minimum whitespace, also detect if first line is whitespace + CRLF

minWhite:=MaxInt;

leftWhite:=True;

white:=0;

firstIsCRLF:=False;

firstLine:=True;

for i:=0 to Len-1 do begin

case Buffer[i] of

' ' : if leftWhite then Inc(white);

#13 : ;

#10 : begin

if firstLine then begin

if leftWhite then

firstIsCRLF:=True;

firstLine:=False;

end;

if not leftWhite then begin

if white<minWhite then

minWhite:=white;

leftWhite:=True;

end;

white:=0;

end;

else

leftWhite:=False;

end;

end;

// ok now collect and remove indents

k:=Length(result);

SetLength(result, k+Len); // allocate for worst case

i:=0;

n:=Len;

// do we have to remove indents?

if firstIsCRLF then begin

// skip first line

while Buffer[i]<>#10 do

Inc(i);

Inc(i);

end;

leftWhite:=(minWhite>0);

white:=0;

while i<n do begin

case Buffer[i] of

' ' : begin

if leftWhite and (white<minWhite) then

Inc(white)

else begin

Inc(k);

result[k]:=' ';

end;

end;

#10 : begin

leftWhite:=(minWhite>0);

white:=0;

Inc(k);

result[k]:=Buffer[i];

end

else

leftWhite:=False;

Inc(k);

result[k]:=Buffer[i];

end;

Inc(i);

end;

SetLength(result, k);

end;

// ToUpperStr

//

procedure TTokenBuffer.ToUpperStr(var result : String);

var

i : Integer;

ch : Char;

pResult : PChar;

begin

if Len=0 then

result:=''

else begin

SetLength(result, Len);

pResult:=PChar(result);

for i:=0 to Len-1 do begin

ch:=Buffer[i];

case ch of

'a'..'z' : pResult[i]:=Char(Word(ch) xor $0020)

else

pResult[i]:=ch;

end;

end;

end;

end;

// UpperFirstChar

//

function TTokenBuffer.UpperFirstChar : Char;

begin

if Len=0 then

Result:=#0

else begin

Result:=Buffer[0];

case Result of

'a'..'z' : Result:=Char(Word(Result) xor $0020)

end;

end;

end;

// RaiseInvalidIntegerConstant

//

procedure TTokenBuffer.RaiseInvalidIntegerConstant;

begin

raise EIntOverflow.CreateFmt(TOK_InvalidIntegerConstant, [ToStr]);

end;

// BinToInt64

//

function TTokenBuffer.BinToInt64 : Int64;

var

i : Integer;

begin

Result:=0;

for i:=2 to Len-1 do begin

// highest bit already set, if we're still here we'll overflow

if Result<0 then

RaiseInvalidIntegerConstant;

case Ord(Buffer[i]) of

Ord('1') : Result:=(Result shl 1) or 1;

Ord('0') : Result:=(Result shl 1);

end;

end;

end;

// BinToInt64

//

function TTokenBuffer.HexToInt64 : Int64;

var

i : Integer;

v : Integer;

begin

if Buffer[0]='$' then

i:=1 // $ form

else i:=2; // 0x form

Result:=0;

while i<Len do begin

// highest nibble already set, if we're still here we'll overflow

if (Result shr 60)>0 then RaiseInvalidIntegerConstant;

v:=Ord(Buffer[i]);

Inc(i);

case v of

Ord('0')..Ord('9') : v:=v-Ord('0');

Ord('a')..Ord('f') : v:=v-(Ord('a')-10);

Ord('A')..Ord('F') : v:=v-(Ord('A')-10);

else

continue;

end;

Result:=(Result shl 4) or v;

end;

end;

// ToInt64

//

function TTokenBuffer.ToInt64 : Int64;

function ComplexToInt64(var buffer : TTokenBuffer) : Int64;

begin

Result := StrToInt64(buffer.ToStr);

end;

var

i, i2 : Integer;

begin

case Len of

1 : begin

i:=Ord(Buffer[0])-Ord('0');

if Cardinal(i)<Cardinal(10) then Exit(i);

end;

2 : begin

i:=Ord(Buffer[0])-Ord('0');

if Cardinal(i)<Cardinal(10) then begin

i2:=Ord(Buffer[1])-Ord('0');

if Cardinal(i2)<Cardinal(10) then

Exit(i*10+i2);

end;

end;

end;

Result:=ComplexToInt64(Self);

end;

// ToFloat

//

function TTokenBuffer.ToFloat : Double;

var

buf : Extended;

begin

AppendChar(#0);

if not TryTextToFloat(PChar(@Buffer[0]), buf, cFormatSettings) then

raise EConvertError.Create('');

Result:=buf;

end;

// ToType

//

function TTokenBuffer.ToType : TTokenType;

begin

Result := ttNAME;

if Len=0 then Exit;

case Buffer[0] of

'/':

if Len=1 then

Result := ttDIVIDE

else if Len=2 then

if Buffer[1]='=' then

Result := ttDIVIDE_ASSIGN; // '/='

'*':

if Len=1 then

Result := ttTIMES

else if Len=2 then

if Buffer[1]='=' then

Result := ttTIMES_ASSIGN; // '*='

'+':

if Len=1 then

Result := ttPLUS

else if Len=2 then

if Buffer[1]='=' then

Result := ttPLUS_ASSIGN; // '+='

'-':

if Len=1 then

Result := ttMINUS

else if Len=2 then

if Buffer[1]='=' then

Result := ttMINUS_ASSIGN; // '-='

'@':

if Len=1 then

Result := ttAT

else if Len=2 then

if Buffer[1]='=' then

Result := ttAT_ASSIGN; // '@='

'%':

if Len=1 then

Result := ttPERCENT

else if Len=2 then

if Buffer[1]='=' then

Result := ttPERCENT_ASSIGN; // '%='

'^':

if Len=1 then

Result := ttCARET

else if Len=2 then

if Buffer[1]='=' then

Result := ttCARET_ASSIGN; // '^='

'~':

if Len=1 then

Result := ttTILDE

else if Len=2 then

if Buffer[1]='=' then

Result := ttTILDE_ASSIGN; // '~='

';': Result := ttSEMI;

'(': Result := ttBLEFT;

')': Result := ttBRIGHT;

'[': Result := ttALEFT;

']': Result := ttARIGHT;

'!': Result := ttEXCLAMATION;

'?':

if Len=1 then

Result := ttQUESTION

else if Len=2 then case Buffer[1] of

'?' : Result:= ttQUESTIONQUESTION; // ??

'.' : Result:= ttQUESTIONDOT; // ?.

end;

'=':

if Len=1 then

Result := ttEQ

else if Len=2 then

if Buffer[1]='>' then

Result := ttEQGTR;

'<':

if Len=1 then // '<'

Result := ttLESS

else if Len=2 then case Buffer[1] of

'=' : Result := ttLESSEQ; // '<='

'>' : Result := ttNOTEQ; // '<>'

'<' : Result := ttLESSLESS; // '<<'

end;

'>':

if Len=1 then // '>'

Result := ttGTR

else if Len=2 then case Buffer[1] of

'=' : Result := ttGTREQ; // '>='

'>' : Result := ttGTRGTR; // '>>'

end;

':':

if Len=1 then // ':'

Result := ttCOLON

else if Len=2 then

if Buffer[1]='=' then

Result := ttASSIGN; // ':='

',': Result := ttCOMMA;

'{': Result := ttCLEFT;

'}': Result := ttCRIGHT;

'.':

if Len=1 then

Result := ttDOT;

'$':

if Len=1 then

Result := ttDOLLAR;

'|':

if Len=1 then

Result := ttPIPE

else if Len=2 then

if Buffer[1]='|' then

Result := ttPIPEPIPE;

else

if CaseSensitive then

Result:=ToAlphaTypeCaseSensitive

else Result:=ToAlphaType;

end;

end;

// ToAlphaType

//

const

cAlphaTypeTokens : TTokenTypes = [

ttAND, ttARRAY, ttABSTRACT, ttAS, ttASM,

ttBEGIN, ttBREAK,

ttCONST, ttCLASS, ttCONSTRUCTOR, ttCASE, ttCDECL, ttCONTINUE,

ttDO, ttDOWNTO, ttDIV, ttDEFAULT, ttDESTRUCTOR, ttDEPRECATED,

ttELSE, ttEMPTY, ttEND, ttENSURE, ttENUM, ttEXCEPT, ttEXIT, ttEXTERNAL, ttEXPORT,

ttFALSE, ttFINAL, ttFINALIZATION, ttFINALLY, ttFLAGS, ttFOR,

ttFORWARD, ttFUNCTION, ttHELPER,

ttIF, ttIMPLIES, ttIMPLEMENTATION, ttIMPLEMENTS, ttIMPLICIT,

ttIN, ttINITIALIZATION, ttINLINE, ttINVARIANTS,

ttINHERITED, ttINDEX, ttINTERFACE, ttIS,

ttLAMBDA, ttLAZY, ttLIBRARY,

ttMETHOD, ttMOD,

ttNAMESPACE, ttNEW, ttNIL, ttNOT,

ttOBJECT, ttOF, ttOLD, ttON, ttOPERATOR, ttOR, ttOVERLOAD, ttOVERRIDE,

ttPARTIAL, ttPROCEDURE, ttPROPERTY, ttPASCAL, ttPROGRAM,

ttPRIVATE, ttPROTECTED, ttPUBLIC, ttPUBLISHED,

ttRECORD, ttREAD, ttRAISE, ttREINTRODUCE, ttREFERENCE, ttREGISTER,

ttREPEAT, ttREQUIRE, ttRESOURCESTRING,

ttSAFECALL, ttSAR, ttSEALED, ttSET, ttSHL, ttSHR, ttSTATIC, ttSTDCALL, ttSTRICT,

ttTHEN, ttTO, ttTRUE, ttTRY, ttTYPE,

ttUNIT, ttUNTIL, ttUSES,

ttVAR, ttVIRTUAL,

ttWHILE, ttWITH, ttWRITE,

ttXOR ];

type

TTokenAlphaLookup = record

Alpha : String;

Token : TTokenType;

end;

TTokenAlphaLookups = array of TTokenAlphaLookup;

PTokenAlphaLookups = ^TTokenAlphaLookups;

var

vAlphaToTokenType : array [2..14] of array ['A'..'X'] of TTokenAlphaLookups;

procedure PrepareAlphaToTokenType;

var

n, len : Integer;

tokenName : String;

tt : TTokenType;

begin

for tt in cAlphaTypeTokens do begin

tokenName := GetEnumName(TypeInfo(TTokenType), Ord(tt));

len:=Length(tokenName)-2;

Assert(len<=14);

n:=Length(vAlphaToTokenType[len][tokenName[3]]);

SetLength(vAlphaToTokenType[len][tokenName[3]], n+1);

with vAlphaToTokenType[len][tokenName[3]][n] do begin

Alpha := StrDeleteLeft(tokenName, 2);

Token := tt;

end;

end;

end;

// ------------------

// ------------------ TTokenBuffer ------------------

// ------------------

// UpperMatchLen

//

function TTokenBuffer.UpperMatchLen(const str : String) : Boolean;

var

i : Integer;

p : PChar;

ch : Char;

begin

p:=PChar(Pointer(str));

for i:=1 to Len-1 do begin

ch:=Buffer[i];

case ch of

'a'..'z' : if Char(Word(ch) xor $0020)<>p[i] then Exit(False);

else

if ch<>p[i] then Exit(False);

end;

end;

Result:=True;

end;

// ToAlphaType

//

function TTokenBuffer.ToAlphaType : TTokenType;

var

ch : Char;

i : Integer;

lookups : PTokenAlphaLookups;

begin

if (Len<2) or (Len>14) then Exit(ttNAME);

ch:=Buffer[0];

case ch of

'a'..'x' : lookups:=@vAlphaToTokenType[Len][Char(Word(ch) xor $0020)];

'A'..'X' : lookups:=@vAlphaToTokenType[Len][ch];

else

Exit(ttNAME);

end;

for i:=0 to High(lookups^) do begin

if UpperMatchLen(lookups^[i].Alpha) then

Exit(lookups^[i].Token);

end;

Result:=ttNAME;

end;

// MatchLen

//

function TTokenBuffer.MatchLen(const str : String) : Boolean;

var

i : Integer;

p : PChar;

ch : Char;

begin

p:=PChar(Pointer(str));

for i:=1 to Len-1 do begin

ch:=Buffer[i];

case ch of

'a'..'z' : if Char(Word(ch) xor $0020)<>p[i] then Exit(False);

else

Exit(False);

end;

end;

Result:=True;

end;

// ToAlphaTypeCaseSensitive

//

function TTokenBuffer.ToAlphaTypeCaseSensitive : TTokenType;

var

ch : Char;

i : Integer;

lookups : PTokenAlphaLookups;

begin

if (Len<2) or (Len>14) then Exit(ttNAME);

ch:=Buffer[0];

case ch of

'a'..'x' : lookups:=@vAlphaToTokenType[Len][Char(Word(ch) xor $0020)];

else

Exit(ttNAME);

end;

for i:=0 to High(lookups^) do begin

if MatchLen(lookups^[i].Alpha) then

Exit(lookups^[i].Token);

end;

Result:=ttNAME;

end;

// StringToTokenType

//

class function TTokenBuffer.StringToTokenType(const str : String) : TTokenType;

var

c : Char;

buffer : TTokenBuffer;

begin

if str='' then Exit(ttNone);

buffer.Capacity:=0;

buffer.Len:=0;

for c in str do

buffer.AppendChar(c);

Result:=buffer.ToType;

end;

// ------------------

// ------------------ TState ------------------

// ------------------

// Destroy

//

destructor TState.Destroy;

begin

FOwnedTransitions.Clean;

inherited Destroy;

end;

// FindTransition

//

function TState.FindTransition(c : Char) : TTransition;

begin

if c>#127 then

c:=#127;

Result:=FTransitions[c];

end;

// AddTransition

//

procedure TState.AddTransition(const chrs : TCharsType; o : TTransition);

var

c : AnsiChar;

begin

for c:=#0 to #127 do

if c in chrs then begin

if FTransitions[c]=nil then

SetTransition(c, o);

end;

FOwnedTransitions.Add(o);

end;

// AddEOFTransition

//

procedure TState.AddEOFTransition(o : TTransition);

begin

SetTransition(#0, o);

FOwnedTransitions.Add(o);

end;

// SetTransition

//

procedure TState.SetTransition(c : AnsiChar; o : TTransition);

begin

FTransitions[c]:=o;

end;

// SetElse

//

procedure TState.SetElse(o : TTransition);

var

c : AnsiChar;

begin

for c:=#1 to #127 do

if FTransitions[c]=nil then

SetTransition(c, o);

FOwnedTransitions.Add(o);

end;

// ------------------

// ------------------ TTransition ------------------

// ------------------

// Create

//

constructor TTransition.Create;