From 6cf764e3f4e2ebfac1beb93aa4b4f92653857ece Mon Sep 17 00:00:00 2001 From: Niels Date: Fri, 26 Mar 2010 23:09:12 +0100 Subject: [PATCH] Oh right, forgot the other files :) --- Projects/SAMufasaGUI/CastaliaPasLex.pas | 2882 ++++++++ Projects/SAMufasaGUI/CastaliaPasLexTypes.pas | 322 + Projects/SAMufasaGUI/CastaliaSimplePasPar.pas | 5955 +++++++++++++++++ .../SAMufasaGUI/CastaliaSimplePasParTypes.pas | 330 + Projects/SAMufasaGUI/PSDump.pas | 343 + Projects/SAMufasaGUI/ValistusDefines.inc | 11 + Projects/SAMufasaGUI/v_Constants.pas | 18 + Projects/SAMufasaGUI/v_MiscFunctions.pas | 145 + Projects/SAMufasaGUI/v_autocompleteform.pas | 585 ++ Projects/SAMufasaGUI/v_ideCodeInsight.pas | 1259 ++++ Projects/SAMufasaGUI/v_ideCodeParser.pas | 1675 +++++ 11 files changed, 13525 insertions(+) create mode 100644 Projects/SAMufasaGUI/CastaliaPasLex.pas create mode 100644 Projects/SAMufasaGUI/CastaliaPasLexTypes.pas create mode 100644 Projects/SAMufasaGUI/CastaliaSimplePasPar.pas create mode 100644 Projects/SAMufasaGUI/CastaliaSimplePasParTypes.pas create mode 100644 Projects/SAMufasaGUI/PSDump.pas create mode 100644 Projects/SAMufasaGUI/ValistusDefines.inc create mode 100644 Projects/SAMufasaGUI/v_Constants.pas create mode 100644 Projects/SAMufasaGUI/v_MiscFunctions.pas create mode 100644 Projects/SAMufasaGUI/v_autocompleteform.pas create mode 100644 Projects/SAMufasaGUI/v_ideCodeInsight.pas create mode 100644 Projects/SAMufasaGUI/v_ideCodeParser.pas diff --git a/Projects/SAMufasaGUI/CastaliaPasLex.pas b/Projects/SAMufasaGUI/CastaliaPasLex.pas new file mode 100644 index 0000000..789f274 --- /dev/null +++ b/Projects/SAMufasaGUI/CastaliaPasLex.pas @@ -0,0 +1,2882 @@ +{----------------------------------------------------------------------------- +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/NPL/NPL-1_1Final.html + +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 Original Code is: mwPasLex.PAS, released August 17, 1999. + +The Initial Developer of the Original Code is Martin Waldenburg +(Martin.Waldenburg@T-Online.de). +Portions created by Martin Waldenburg are Copyright (C) 1998, 1999 Martin +Waldenburg. +All Rights Reserved. + +Contributor(s): James Jacobson _____________________________________. + +Last Modified: mm/dd/yyyy +Current Version: 2.2 + +Notes: This program is a very fast Pascal tokenizer. I'd like to invite the +Delphi community to develop it further and to create a fully featured Object +Pascal parser. + +Modification history: + +Daniel Rolf between 20010723 and 20020116 + +Made ready for Delphi 6 + +platform +deprecated +varargs +local + +Known Issues: +-----------------------------------------------------------------------------} + +unit CastaliaPasLex; + +{$include ValistusDefines.inc} +{$IFDEF FPC} + {$mode delphi} +{$ENDIF} + +interface + +uses + //!! pruned uses + SysUtils, Classes, Controls, CastaliaPasLexTypes; + +var + Identifiers: array[#0..#255] of ByteBool; + mHashTable: array[#0..#255] of Integer; + +type + TmwBasePasLex = class; + TDirectiveEvent = procedure(Sender: TmwBasePasLex) of object; + + PDefineRec = ^TDefineRec; + TDefineRec = record + Defined: Boolean; + StartCount: Integer; + Next: PDefineRec; + end; + TDefineRecArray = array of TDefineRec; + + TSaveDefinesRec = record + RecArray: TDefineRecArray; + Stack: Integer; + Defines: string; + end; + + TmwBasePasLex = class(TObject) + private + fCommentState: TCommentState; + fOrigin: PAnsiChar; + fProcTable: array[#0..#255] of procedure of object; + Run: Integer; + RunAhead: Integer; + TempRun: Integer; + fIdentFuncTable: array[0..191] of function: TptTokenKind of object; + fTokenPos: Integer; + fLineNumber: Integer; + FTokenID: TptTokenKind; + fLinePos: Integer; + fExID: TptTokenKind; + FOnMessage: TMessageEvent; + fOnCompDirect: TDirectiveEvent; + fOnElseDirect: TDirectiveEvent; + fOnEndIfDirect: TDirectiveEvent; + fOnIfDefDirect: TDirectiveEvent; + fOnIfNDefDirect: TDirectiveEvent; + fOnResourceDirect: TDirectiveEvent; + fOnIncludeDirect: TDirectiveEvent; + fOnDefineDirect: TDirectiveEvent; + fOnIfOptDirect: TDirectiveEvent; + fOnIfDirect: TDirectiveEvent; + fOnIfEndDirect: TDirectiveEvent; + fOnElseIfDirect: TDirectiveEvent; + fOnUnDefDirect: TDirectiveEvent; + FDirectiveParamOrigin: PAnsiChar; + + fAsmCode : Boolean; // DR 2002-01-14 + + FDefines: TStrings; + FDefineStack: Integer; + FTopDefineRec: PDefineRec; + FUseDefines: Boolean; + + function KeyHash: Integer; + function KeyComp(const aKey: string): Boolean; + function Func9: tptTokenKind; + function Func15: TptTokenKind; + function Func19: TptTokenKind; + function Func20: TptTokenKind; + function Func21: TptTokenKind; + function Func23: TptTokenKind; + function Func25: TptTokenKind; + function Func27: TptTokenKind; + function Func28: TptTokenKind; + function Func29: TptTokenKind; + function Func30: TptTokenKind; + function Func32: TptTokenKind; + function Func33: TptTokenKind; + function Func35: TptTokenKind; + function Func36: TptTokenKind; + function Func37: TptTokenKind; + function Func38: TptTokenKind; + function Func39: TptTokenKind; + function Func40: TptTokenKind; + function Func41: TptTokenKind; + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + function Func42: TptTokenKind; + {$ENDIF} + function Func43: TptTokenKind; + function Func44: TptTokenKind; + function Func45: TptTokenKind; + function Func46: TptTokenKind; + function Func47: TptTokenKind; + function Func49: TptTokenKind; + function Func52: TptTokenKind; + function Func54: TptTokenKind; + function Func55: TptTokenKind; + function Func56: TptTokenKind; + function Func57: TptTokenKind; + function Func58: TptTokenKind; + function Func59: TptTokenKind; + function Func60: TptTokenKind; + function Func61: TptTokenKind; + function Func62: TptTokenKind; + function Func63: TptTokenKind; + function Func64: TptTokenKind; + function Func65: TptTokenKind; + function Func66: TptTokenKind; + function Func69: TptTokenKind; + function Func71: TptTokenKind; + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + function Func72: TptTokenKind; + {$ENDIF} + function Func73: TptTokenKind; + function Func75: TptTokenKind; + function Func76: TptTokenKind; + function Func78: TptTokenKind; + function Func79: TptTokenKind; + function Func81: TptTokenKind; + function Func84: TptTokenKind; + function Func85: TptTokenKind; + function Func86: TptTokenKind; + function Func87: TptTokenKind; + function Func88: TptTokenKind; + {$IFDEF D8_NEWER} + function Func89: TptTokenKind; //JThurman 2004-03-03 + {$ENDIF} + function Func91: TptTokenKind; + function Func92: TptTokenKind; + function Func94: TptTokenKind; + function Func95: TptTokenKind; + function Func96: TptTokenKind; + function Func97: TptTokenKind; + function Func98: TptTokenKind; + function Func99: TptTokenKind; + function Func100: TptTokenKind; + function Func101: TptTokenKind; + function Func102: TptTokenKind; + function Func103: TptTokenKind; + function Func104: TptTokenKind; + function Func105: TptTokenKind; + function Func106: TptTokenKind; + function Func107: TptTokenKind; + function Func108: TptTokenKind; + function Func112: TptTokenKind; + function Func117: TptTokenKind; + function Func123: TptTokenKind; + function Func126: TptTokenKind; + function Func127: TptTokenKind; + function Func128: TptTokenKind; + function Func129: TptTokenKind; + function Func130: TptTokenKind; + function Func132: TptTokenKind; + function Func133: TptTokenKind; + function Func136: TptTokenKind; + function Func141: TptTokenKind; + function Func143: TptTokenKind; + function Func166: TptTokenKind; + function Func167: TptTokenKind; + function Func168: TptTokenKind; + function Func191: TptTokenKind; + function AltFunc: TptTokenKind; + procedure InitIdent; + function GetPosXY: TTokenPoint; // !! changed to TokenPoint //jdj 7/18/1999 + function IdentKind: TptTokenKind; + procedure SetRunPos(Value: Integer); + procedure MakeMethodTables; + procedure AddressOpProc; + {$IFDEF D8_NEWER} //JThurman 2004-04-06 + procedure AmpersandOpProc; + {$ENDIF} + procedure AsciiCharProc; + procedure AnsiProc; + procedure BorProc; + procedure BraceCloseProc; + procedure BraceOpenProc; + procedure ColonProc; + procedure CommaProc; + procedure CRProc; + procedure EqualProc; + procedure GreaterProc; + procedure IdentProc; + procedure IntegerProc; + procedure LFProc; + procedure LowerProc; + procedure MinusProc; + procedure NullProc; + procedure NumberProc; + procedure PlusProc; + procedure PointerSymbolProc; + procedure PointProc; + procedure RoundCloseProc; + procedure RoundOpenProc; + procedure SemiColonProc; + procedure SlashProc; + procedure SpaceProc; + procedure SquareCloseProc; + procedure SquareOpenProc; + procedure StarProc; + procedure StringProc; + procedure StringDQProc; + procedure SymbolProc; + procedure UnknownProc; + function GetToken: string; + function GetTokenLen: Integer; + function GetCommentState: Pointer; + function GetCompilerDirective: string; + procedure SetCommentState(const Value: Pointer); + procedure InitLine; + function GetDirectiveKind: TptTokenKind; + function GetDirectiveParam: string; + function GetStringContent: string; + function GetIsJunk: Boolean; + function GetIsSpace: Boolean; + function GetIsOrdIdent: Boolean; + function GetIsRealType: Boolean; + function GetIsStringType: Boolean; + function GetIsVarantType: Boolean; + function GetIsAddOperator: Boolean; + function GetIsMulOperator: Boolean; + function GetIsRelativeOperator: Boolean; + function GetIsCompilerDirective: Boolean; + function GetIsOrdinalType: Boolean; + function GetGenID: TptTokenKind;procedure SetOnElseIfDirect(const Value: TDirectiveEvent); + + function IsDefined(const ADefine: string): Boolean; + procedure EnterDefineBlock(ADefined: Boolean); + procedure ExitDefineBlock; + + procedure DoProcTable(AChar: AnsiChar); + function IsIdentifiers(AChar: AnsiChar): Boolean; + function HashValue(AChar: AnsiChar): Integer; + protected + procedure SetLine(const Value: AnsiString); virtual; + procedure SetOrigin(NewValue: PAnsiChar); virtual; + procedure SetOnCompDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnDefineDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnElseDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnEndIfDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnIfDefDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnIfNDefDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnIfOptDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnIncludeDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnResourceDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnUnDefDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnIfDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnIfEndDirect(const Value: TDirectiveEvent); virtual; + + public + MaxPos: Integer; + + constructor Create; + destructor Destroy; override; + function CharAhead: AnsiChar; + procedure Next; + procedure NextID(ID: TptTokenKind); + procedure NextNoJunk; + procedure NextNoSpace; + procedure Init; + procedure InitFrom(ALexer: TmwBasePasLex); + function FirstInLine: Boolean; + + procedure AddDefine(const ADefine: string); + procedure RemoveDefine(const ADefine: string); + procedure ClearDefines; + procedure InitDefines; + procedure CloneDefinesFrom(ALexer: TmwBasePasLex); + function SaveDefines: TSaveDefinesRec; + procedure LoadDefines(From: TSaveDefinesRec); + + property CommentState: Pointer read GetCommentState write SetCommentState; + property CompilerDirective: string read GetCompilerDirective; + property DirectiveParam: string read GetDirectiveParam; + property IsJunk: Boolean read GetIsJunk; + property IsSpace: Boolean read GetIsSpace; + property Line: AnsiString write SetLine; + //Note: setting the following two properties does not GO to that line, it just sets the internal counters + property LineNumber: Integer read fLineNumber write fLineNumber; + property LinePos: Integer read fLinePos write fLinePos; + property Origin: PAnsiChar read fOrigin write SetOrigin; + property PosXY: TTokenPoint read GetPosXY; // !! changed to TokenPoint //jdj 7/18/1999 + property RunPos: Integer read Run write SetRunPos; + property Token: string read GetToken; + property TokenLen: Integer read GetTokenLen; + property TokenPos: Integer read fTokenPos; + property TokenID: TptTokenKind read FTokenID; + property ExID: TptTokenKind read fExID; + property GenID: TptTokenKind read GetGenID; + property StringContent: string read GetStringContent; + property IsOrdIdent: Boolean read GetIsOrdIdent; + property IsOrdinalType: Boolean read GetIsOrdinalType; + property IsRealType: Boolean read GetIsRealType; + property IsStringType: Boolean read GetIsStringType; + property IsVariantType: Boolean read GetIsVarantType; + property IsRelativeOperator: Boolean read GetIsRelativeOperator; + property IsAddOperator: Boolean read GetIsAddOperator; + property IsMulOperator: Boolean read GetIsMulOperator; + property IsCompilerDirective: Boolean read GetIsCompilerDirective; + property OnMessage: TMessageEvent read FOnMessage write FOnMessage; + property OnCompDirect: TDirectiveEvent read fOnCompDirect write SetOnCompDirect; + property OnDefineDirect: TDirectiveEvent read fOnDefineDirect write SetOnDefineDirect; + property OnElseDirect: TDirectiveEvent read fOnElseDirect write SetOnElseDirect; + property OnEndIfDirect: TDirectiveEvent read fOnEndIfDirect write SetOnEndIfDirect; + property OnIfDefDirect: TDirectiveEvent read fOnIfDefDirect write SetOnIfDefDirect; + property OnIfNDefDirect: TDirectiveEvent read fOnIfNDefDirect write SetOnIfNDefDirect; + property OnIfOptDirect: TDirectiveEvent read fOnIfOptDirect write SetOnIfOptDirect; + property OnIncludeDirect: TDirectiveEvent read fOnIncludeDirect write SetOnIncludeDirect; + property OnIfDirect: TDirectiveEvent read fOnIfDirect write SetOnIfDirect; + property OnIfEndDirect: TDirectiveEvent read fOnIfEndDirect write + SetOnIfEndDirect; + property OnElseIfDirect: TDirectiveEvent read fOnElseIfDirect write + SetOnElseIfDirect; + property OnResourceDirect: TDirectiveEvent read fOnResourceDirect write SetOnResourceDirect; + property OnUnDefDirect: TDirectiveEvent read fOnUnDefDirect write SetOnUnDefDirect; + + property AsmCode : Boolean read fAsmCode write fAsmCode; // DR 2002-01-14 + property DirectiveParamOrigin: PAnsiChar read FDirectiveParamOrigin; + + property UseDefines: Boolean read FUseDefines write FUseDefines; + + property Defines: TStrings read FDefines; + end; + + TmwPasLex = class(TmwBasePasLex) + private + fAheadLex: TmwBasePasLex; + function GetAheadExID: TptTokenKind; + function GetAheadGenID: TptTokenKind; + function GetAheadToken: string; + function GetAheadTokenID: TptTokenKind; + function GetStatus: TmwPasLexStatus; + procedure SetStatus(const Value: TmwPasLexStatus); + protected + procedure SetLine(const Value: AnsiString); override; + procedure SetOrigin(NewValue: PAnsiChar); override; + procedure SetOnCompDirect(const Value: TDirectiveEvent); override; + procedure SetOnDefineDirect(const Value: TDirectiveEvent); override; + procedure SetOnElseDirect(const Value: TDirectiveEvent); override; + procedure SetOnEndIfDirect(const Value: TDirectiveEvent); override; + procedure SetOnIfDefDirect(const Value: TDirectiveEvent); override; + procedure SetOnIfNDefDirect(const Value: TDirectiveEvent); override; + procedure SetOnIfOptDirect(const Value: TDirectiveEvent); override; + procedure SetOnIncludeDirect(const Value: TDirectiveEvent); override; + procedure SetOnResourceDirect(const Value: TDirectiveEvent); override; + procedure SetOnUnDefDirect(const Value: TDirectiveEvent); override; + public + constructor Create; + destructor Destroy; override; + procedure InitAhead; + procedure AheadNext; + property AheadLex: TmwBasePasLex read fAheadLex; + property AheadToken: string read GetAheadToken; + property AheadTokenID: TptTokenKind read GetAheadTokenID; + property AheadExID: TptTokenKind read GetAheadExID; + property AheadGenID: TptTokenKind read GetAheadGenID; + property Status: TmwPasLexStatus read GetStatus write SetStatus; + end; + +implementation + +{$IFNDEF LCL} +uses Windows; +{$ENDIF} + +procedure MakeIdentTable; +var + I, J: AnsiChar; +begin + for I := #0 to #255 do + begin + case I of + '_', '0'..'9', 'a'..'z', 'A'..'Z': Identifiers[I] := True; + else Identifiers[I] := False; + end; + J := AnsiString(UpCase(I))[1]; + case I of + 'a'..'z', 'A'..'Z', '_': mHashTable[I] := Ord(J) - 64; + '0'..'9': mHashTable[I] := Ord(J) - 47; + else mHashTable[Char(I)] := 0; + end; + end; +end; + +function TmwBasePasLex.CharAhead: AnsiChar; +begin + RunAhead := Run; +// while fOrigin[RunAhead] in [#1..#32] do + while (fOrigin[RunAhead] > #0) and (fOrigin[RunAhead] < #33) do + + inc(RunAhead); + Result := fOrigin[RunAhead]; +end; + +procedure TmwBasePasLex.ClearDefines; +var + Frame: PDefineRec; +begin + while FTopDefineRec <> nil do + begin + Frame := FTopDefineRec; + FTopDefineRec := Frame^.Next; + Dispose(Frame); + end; + FDefines.Clear; + FDefineStack := 0; + FTopDefineRec := nil; +end; + +procedure TmwBasePasLex.CloneDefinesFrom(ALexer: TmwBasePasLex); +var + Frame, LastFrame, SourceFrame: PDefineRec; +begin + ClearDefines; + FDefines.Assign(ALexer.FDefines); + FDefineStack := ALexer.FDefineStack; + + Frame := nil; + LastFrame := nil; + SourceFrame := ALexer.FTopDefineRec; + while SourceFrame <> nil do + begin + New(Frame); + if FTopDefineRec = nil then + FTopDefineRec := Frame + else + LastFrame^.Next := Frame; + Frame^.Defined := SourceFrame^.Defined; + Frame^.StartCount := SourceFrame^.StartCount; + LastFrame := Frame; + + SourceFrame := SourceFrame^.Next; + end; + if Frame <> nil then + Frame^.Next := nil; +end; + +function TmwBasePasLex.SaveDefines: TSaveDefinesRec; +var + Frame: PDefineRec; +begin + Result.Defines := FDefines.CommaText; + Result.Stack := FDefineStack; + + Frame := FTopDefineRec; + while (Frame <> nil) do + begin + SetLength(Result.RecArray, Length(Result.RecArray) + 1); + Result.RecArray[High(Result.RecArray)] := Frame^; + Result.RecArray[High(Result.RecArray)].Next := nil; + Frame := Frame^.Next; + end; +end; + +procedure TmwBasePasLex.LoadDefines(From: TSaveDefinesRec); +var + Frame, LastFrame: PDefineRec; + i: Integer; +begin + ClearDefines; + FDefines.CommaText := From.Defines; + FDefineStack := From.Stack; + + Frame := nil; + LastFrame := nil; + for i := 0 to High(From.RecArray) do + begin + New(Frame); + if (i = 0) then + FTopDefineRec := Frame + else + LastFrame^.Next := Frame; + + Frame^ := From.RecArray[i]; + LastFrame := Frame; + end; + + if (Frame <> nil) then + Frame^.Next := nil; +end; + +function TmwBasePasLex.GetPosXY: TTokenPoint; +begin //jdj 7/18/1999 + // !! changed setting code + Result.X:= FTokenPos - FLinePos; + Result.Y:= FLineNumber; +end; + +procedure TmwBasePasLex.InitIdent; +var + I: Integer; +begin + for I := 0 to 191 do + case I of + {$IFDEF D8_NEWER} + 9: fIdentFuncTable[I] := Func9; + {$ENDIF} + 15: fIdentFuncTable[I] := Func15; + 19: fIdentFuncTable[I] := Func19; + 20: fIdentFuncTable[I] := Func20; + 21: fIdentFuncTable[I] := Func21; + 23: fIdentFuncTable[I] := Func23; + 25: fIdentFuncTable[I] := Func25; + 27: fIdentFuncTable[I] := Func27; + 28: fIdentFuncTable[I] := Func28; + 29: fIdentFuncTable[I] := Func29; + 30: fIdentFuncTable[I] := Func30; + 32: fIdentFuncTable[I] := Func32; + 33: fIdentFuncTable[I] := Func33; + 35: fIdentFuncTable[I] := Func35; + 36: fIdentFuncTable[I] := Func36; + 37: fIdentFuncTable[I] := Func37; + 38: fIdentFuncTable[I] := Func38; + 39: fIdentFuncTable[I] := Func39; + 40: fIdentFuncTable[I] := Func40; + 41: fIdentFuncTable[I] := Func41; + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + 42: fIdentFuncTable[I] := Func42; + {$ENDIF} + 43: fIdentFuncTable[I] := Func43; + 44: fIdentFuncTable[I] := Func44; + 45: fIdentFuncTable[I] := Func45; + 46: fIdentFuncTable[I] := Func46; + 47: fIdentFuncTable[I] := Func47; + 49: fIdentFuncTable[I] := Func49; + 52: fIdentFuncTable[I] := Func52; + 54: fIdentFuncTable[I] := Func54; + 55: fIdentFuncTable[I] := Func55; + 56: fIdentFuncTable[I] := Func56; + 57: fIdentFuncTable[I] := Func57; + 58: fIdentFuncTable[I] := Func58; + 59: fIdentFuncTable[I] := Func59; + 60: fIdentFuncTable[I] := Func60; + 61: fIdentFuncTable[I] := Func61; + 62: fIdentFuncTable[I] := Func62; + 63: fIdentFuncTable[I] := Func63; + 64: fIdentFuncTable[I] := Func64; + 65: fIdentFuncTable[I] := Func65; + 66: fIdentFuncTable[I] := Func66; + 69: fIdentFuncTable[I] := Func69; + 71: fIdentFuncTable[I] := Func71; + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + 72: fIdentFuncTable[I] := Func72; + {$ENDIF} + 73: fIdentFuncTable[I] := Func73; + 75: fIdentFuncTable[I] := Func75; + 76: fIdentFuncTable[I] := Func76; + 78: fIdentFuncTable[I] := Func78; + 79: fIdentFuncTable[I] := Func79; + 81: fIdentFuncTable[I] := Func81; + 84: fIdentFuncTable[I] := Func84; + 85: fIdentFuncTable[I] := Func85; + 86: fIdentFuncTable[I] := Func86; + 87: fIdentFuncTable[I] := Func87; + 88: fIdentFuncTable[I] := Func88; + {$IFDEF D8_NEWER} //JThurman 2004-03-03 + 89: fIdentFuncTable[I] := Func89; + {$ENDIF} + 91: fIdentFuncTable[I] := Func91; + 92: fIdentFuncTable[I] := Func92; + 94: fIdentFuncTable[I] := Func94; + 95: fIdentFuncTable[I] := Func95; + 96: fIdentFuncTable[I] := Func96; + 97: fIdentFuncTable[I] := Func97; + 98: fIdentFuncTable[I] := Func98; + 99: fIdentFuncTable[I] := Func99; + 100: fIdentFuncTable[I] := Func100; + 101: fIdentFuncTable[I] := Func101; + 102: fIdentFuncTable[I] := Func102; + 103: fIdentFuncTable[I] := Func103; + 104: fIdentFuncTable[I] := Func104; + 105: fIdentFuncTable[I] := Func105; + 106: fIdentFuncTable[I] := Func106; + 107: fIdentFuncTable[I] := Func107; + 108: fIdentFuncTable[I] := Func108; + 112: fIdentFuncTable[I] := Func112; + 117: fIdentFuncTable[I] := Func117; + 123: fIdentFuncTable[I] := Func123; + 126: fIdentFuncTable[I] := Func126; + 127: fIdentFuncTable[I] := Func127; + 128: fIdentFuncTable[I] := Func128; + 129: fIdentFuncTable[I] := Func129; + 130: fIdentFuncTable[I] := Func130; + 132: fIdentFuncTable[I] := Func132; + 133: fIdentFuncTable[I] := Func133; + 136: fIdentFuncTable[I] := Func136; + 141: fIdentFuncTable[I] := Func141; + 143: fIdentFuncTable[I] := Func143; + 166: fIdentFuncTable[I] := Func166; + 167: fIdentFuncTable[I] := Func167; + 168: fIdentFuncTable[I] := Func168; + 191: fIdentFuncTable[I] := Func191; + else fIdentFuncTable[I] := AltFunc; + end; +end; + +function TmwBasePasLex.KeyHash: Integer; +begin + Result := 0; + while IsIdentifiers(fOrigin[Run]) do + begin + Inc(Result, HashValue(fOrigin[Run])); + //inc(Result, mHashTable[fOrigin[Run]]); + inc(Run); + end; +end; { KeyHash } + +function TmwBasePasLex.KeyComp(const aKey: string): Boolean; +var + I: Integer; + Temp: PAnsiChar; +begin + if Length(aKey) = TokenLen then + begin + Temp := fOrigin + fTokenPos; + Result := True; + for i := 1 to TokenLen do + begin + if mHashTable[Temp^] <> mHashTable[aKey[i]] then + begin + Result := False; + break; + end; + inc(Temp); + end; + end + else Result := False; +end; { KeyComp } + +function TmwBasePasLex.Func9: tptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Add') then + FExID := tokAdd; +end; + +function TmwBasePasLex.Func15: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('If') then Result := tokIf; +end; + +function TmwBasePasLex.Func19: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Do') then Result := tokDo else + if KeyComp('And') then Result := tokAnd; +end; + +function TmwBasePasLex.Func20: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('As') then Result := tokAs; +end; + +function TmwBasePasLex.Func21: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Of') then Result := tokOf else + if KeyComp('At') then fExID := tokAt; +end; + +function TmwBasePasLex.Func23: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('End') then Result := tokEnd else + if KeyComp('In') then Result := tokIn; +end; + +function TmwBasePasLex.Func25: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Far') then fExID := tokFar; +end; + +function TmwBasePasLex.Func27: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Cdecl') then fExID := tokCdecl; +end; + +function TmwBasePasLex.Func28: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Read') then fExID := tokRead else + if KeyComp('Case') then Result := tokCase else + if KeyComp('Is') then Result := tokIs; +end; + +function TmwBasePasLex.Func29: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('On') then fExID := tokOn; +end; + +function TmwBasePasLex.Func30: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Char') then fExID := tokChar; +end; + +function TmwBasePasLex.Func32: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('File') then Result := tokFile else + if KeyComp('Label') then Result := tokLabel else + if KeyComp('Mod') then Result := tokMod; +end; + +function TmwBasePasLex.Func33: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Or') then Result := tokOr else + if KeyComp('Name') then fExID := tokName else + if KeyComp('Asm') then Result := tokAsm; +end; + +function TmwBasePasLex.Func35: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Nil') then Result := tokNil else + if KeyComp('To') then Result := tokTo else + if KeyComp('Div') then Result := tokDiv; +end; + +function TmwBasePasLex.Func36: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Real') then fExID := tokReal else + if KeyComp('Real48') then fExID := tokReal48; +end; + +function TmwBasePasLex.Func37: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Begin') then Result := tokBegin else + if KeyComp('Break') then fExID := tokBreak; +end; + +function TmwBasePasLex.Func38: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Near') then fExID := tokNear; +end; + +function TmwBasePasLex.Func39: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('For') then Result := tokFor else + if KeyComp('Shl') then Result := tokShl; +end; + +function TmwBasePasLex.Func40: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Packed') then Result := tokPacked; +end; + +function TmwBasePasLex.Func41: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Var') then Result := tokVar else + if KeyComp('Else') then Result := tokElse else + if KeyComp('Halt') then fExID := tokHalt; +end; + +{$IFDEF D8_NEWER} //JThurman 2004-03-2003 +function TmwBasePasLex.Func42: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Final') then + fExID := tokFinal; //TODO: Is this supposed to be an ExID? +end; +{$ENDIF} + +function TmwBasePasLex.Func43: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Int64') then fExID := tokInt64 + else if KeyComp('local') then fExID := tokLocal; +end; + +function TmwBasePasLex.Func44: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Set') then Result := tokSet else + if KeyComp('Package') then fExID := tokPackage; +end; + +function TmwBasePasLex.Func45: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Shr') then Result := tokShr; +end; + +function TmwBasePasLex.Func46: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('PChar') then fExId := tokPChar + {$IFDEF D8_NEWER} //JThurman 2004-03-19 + else + if KeyComp('Sealed') then Result := tokSealed; + {$ELSE} + ; + {$ENDIF} +end; + +function TmwBasePasLex.Func47: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Then') then Result := tokThen else + if KeyComp('Comp') then fExID := tokComp; +end; + +function TmwBasePasLex.Func49: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Not') then Result := tokNot; +end; + +function TmwBasePasLex.Func52: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Byte') then fExID := tokByte else + if KeyComp('Raise') then Result := tokRaise else + if KeyComp('Pascal') then fExID := tokPascal; +end; + +function TmwBasePasLex.Func54: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Class') then Result := tokClass; +end; + +function TmwBasePasLex.Func55: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Object') then Result := tokObject; +end; + +function TmwBasePasLex.Func56: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Index') then fExID := tokIndex else + if KeyComp('Out') then fExID := tokOut else // bug in Delphi's documentation: OUT is a directive + if KeyComp('Abort') then fExID := tokAbort; +end; + +function TmwBasePasLex.Func57: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('While') then Result := tokWhile else + if KeyComp('Xor') then Result := tokXor else + if KeyComp('Goto') then Result := tokGoto; +end; + +function TmwBasePasLex.Func58: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Exit') then fExID := tokExit; +end; + +function TmwBasePasLex.Func59: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Safecall') then fExID := tokSafecall else + if KeyComp('Double') then fExID := tokDouble; +end; + +function TmwBasePasLex.Func60: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('With') then Result := tokWith else + if KeyComp('Word') then fExID := tokWord; +end; + +function TmwBasePasLex.Func61: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Dispid') then fExID := tokDispid; +end; + +function TmwBasePasLex.Func62: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Cardinal') then fExID := tokCardinal; +end; + +function TmwBasePasLex.Func63: TptTokenKind; +begin + Result := tokIdentifier; + case fOrigin[fTokenPos] of + 'P', 'p': if KeyComp('Public') then fExID := tokPublic; + 'A', 'a': if KeyComp('Array') then Result := tokArray; + 'T', 't': if KeyComp('Try') then Result := tokTry; + 'R', 'r': if KeyComp('Record') then Result := tokRecord; + 'I', 'i': if KeyComp('Inline') then + begin + Result := tokInline; + fExID := tokInline; + end; + end; +end; + +function TmwBasePasLex.Func64: TptTokenKind; +begin + Result := tokIdentifier; + case fOrigin[fTokenPos] of + 'B', 'b': if KeyComp('Boolean') then fExID := tokBoolean; + 'D', 'd': if KeyComp('DWORD') then fExID := tokDWORD; + 'U', 'u': if KeyComp('Uses') then Result := tokUses + else + if KeyComp('Unit') then Result := tokUnit; + {$IFDEF D8_NEWER} + 'H', 'h': if KeyComp('Helper') then fExID := tokHelper; + {$ENDIF} + end; +end; + +function TmwBasePasLex.Func65: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Repeat') then Result := tokRepeat; +end; + +function TmwBasePasLex.Func66: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Single') then fExID := tokSingle else + if KeyComp('Type') then Result := tokType + {$IFDEF D8_NEWER}//JThurman 2004-03-23 + else + if KeyComp('Unsafe') then Result := tokUnsafe + {$ENDIF} + ; +end; + +function TmwBasePasLex.Func69: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Default') then fExID := tokDefault else + if KeyComp('Dynamic') then fExID := tokDynamic else + if KeyComp('Message') then fExID := tokMessage; +end; + +function TmwBasePasLex.Func71: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('WideChar') then fExID := tokWideChar else + if KeyComp('Stdcall') then fExID := tokStdcall else + if KeyComp('Const') then Result := tokConst; +end; + +{$IFDEF D8_NEWER} //JThurman 2004-03-2003 +function TmwBasePasLex.Func72: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Static') then + fExID := tokStatic; +end; +{$ENDIF} + +function TmwBasePasLex.Func73: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Except') then Result := tokExcept; +end; + +function TmwBasePasLex.Func75: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Write') then fExID := tokWrite; +end; + +function TmwBasePasLex.Func76: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Until') then Result := tokUntil; +end; + +function TmwBasePasLex.Func78: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Integer') then fExID := tokInteger + {$IFDEF D8_NEWER} + else if KeyComp('Remove') then + FExID := tokRemove + {$ENDIF} + ; +end; + +function TmwBasePasLex.Func79: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Finally') then Result := tokFinally + {$IFDEF D12_NEWER} + else if KeyComp('Reference') then fExID := tokReference; + {$ENDIF} + +end; + +function TmwBasePasLex.Func81: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Extended') then fExID := tokExtended else + if KeyComp('Stored') then fExID := tokStored else + if KeyComp('Interface') then Result := tokInterface + else if KeyComp('Deprecated') then fExID := tokDeprecated; // DR 2001-10-20 +end; + +function TmwBasePasLex.Func84: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Abstract') then fExID := tokAbstract; +end; + +function TmwBasePasLex.Func85: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Library') then Result := tokLibrary else + if KeyComp('Forward') then fExID := tokForward else + if KeyComp('Variant') then fExID := tokVariant; +end; + +function TmwBasePasLex.Func87: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('String') then Result := tokString; +end; + +function TmwBasePasLex.Func88: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Program') then Result := tokProgram; +end; + +{$IFDEF D8_NEWER} //JThurman 2004-03-03 +function TmwBasePasLex.Func89: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Strict') then Result := tokStrict; +end; +{$ENDIF} + +function TmwBasePasLex.Func91: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Downto') then Result := tokDownto else + if KeyComp('Private') then fExID := tokPrivate else + if KeyComp('Longint') then fExID := tokLongint; +end; + +function TmwBasePasLex.Func92: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Inherited') then Result := tokInherited else + if KeyComp('LongBool') then fExID := tokLongBool else + if KeyComp('Overload') then fExID := tokOverload; +end; + +function TmwBasePasLex.Func94: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Resident') then fExID := tokResident else + if KeyComp('Readonly') then fExID := tokReadonly else + if KeyComp('Assembler') then fExID := tokAssembler; +end; + +function TmwBasePasLex.Func95: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Contains') then fExID := tokContains else + if KeyComp('Absolute') then fExID := tokAbsolute; +end; + +function TmwBasePasLex.Func96: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('ByteBool') then fExID := tokByteBool else + if KeyComp('Override') then fExID := tokOverride else + if KeyComp('Published') then fExID := tokPublished; +end; + +function TmwBasePasLex.Func97: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Threadvar') then Result := tokThreadvar; +end; + +function TmwBasePasLex.Func98: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Export') then fExID := tokExport else + if KeyComp('Nodefault') then fExID := tokNodefault; +end; + +function TmwBasePasLex.Func99: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('External') then fExID := tokExternal; +end; + +function TmwBasePasLex.Func100: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Automated') then fExID := tokAutomated else + if KeyComp('Smallint') then fExID := tokSmallint; +end; + +function TmwBasePasLex.Func101: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Register') then fExID := tokRegister + else if KeyComp('Platform') then fExID := tokPlatform // DR 2001-10-20 + else if KeyComp('Continue') then fExID := tokContinue; +end; + +function TmwBasePasLex.Func102: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Function') then Result := tokFunction; +end; + +function TmwBasePasLex.Func103: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Virtual') then fExID := tokVirtual; +end; + +function TmwBasePasLex.Func104: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('WordBool') then fExID := tokWordBool; +end; + +function TmwBasePasLex.Func105: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Procedure') then Result := tokProcedure; +end; + +function TmwBasePasLex.Func106: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Protected') then fExID := tokProtected; +end; + +function TmwBasePasLex.Func107: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Currency') then fExID := tokCurrency; +end; + +function TmwBasePasLex.Func108: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Longword') then fExID := tokLongword; + {$IFDEF D8_NEWER} //JThurman 2004-03-20 + if KeyComp('Operator') then fExID := tokOperator; + {$ENDIF} +end; + +function TmwBasePasLex.Func112: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Requires') then fExID := tokRequires; +end; + +function TmwBasePasLex.Func117: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Exports') then Result := tokExports else + if KeyComp('OleVariant') then fExID := tokOleVariant; +end; + +function TmwBasePasLex.Func123: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Shortint') then fExID := tokShortint; +end; + +function TmwBasePasLex.Func126: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Implements') then fExID := tokImplements; +end; + +function TmwBasePasLex.Func127: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Runerror') then fExID := tokRunError; +end; + +function TmwBasePasLex.Func128: TptTokenKind; +begin + if KeyComp('WideString') then fExID := tokWideString; + Result := tokIdentifier; +end; + +function TmwBasePasLex.Func129: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Dispinterface') then Result := tokDispinterface +end; + +function TmwBasePasLex.Func130: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('AnsiString') then fExID := tokAnsiString; +end; + +function TmwBasePasLex.Func132: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Reintroduce') then fExID := tokReintroduce; +end; + +function TmwBasePasLex.Func133: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Property') then Result := tokProperty; +end; + +function TmwBasePasLex.Func136: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Finalization') then Result := tokFinalization; +end; + +function TmwBasePasLex.Func141: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Writeonly') then fExID := tokWriteonly; +end; + +function TmwBasePasLex.Func143: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Destructor') then Result := tokDestructor; +end; + +function TmwBasePasLex.Func166: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Constructor') then Result := tokConstructor else + if KeyComp('Implementation') then Result := tokImplementation; +end; + +function TmwBasePasLex.Func167: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('ShortString') then fExID := tokShortString; +end; + +function TmwBasePasLex.Func168: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Initialization') then Result := tokInitialization; +end; + +function TmwBasePasLex.Func191: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Resourcestring') then Result := tokResourcestring else + if KeyComp('Stringresource') then fExID := tokStringresource; +end; + +function TmwBasePasLex.AltFunc: TptTokenKind; +begin + Result := tokIdentifier; +end; + +function TmwBasePasLex.IdentKind: TptTokenKind; +var + HashKey: Integer; +begin + HashKey := KeyHash; + if HashKey < 192 then + Result := fIdentFuncTable[HashKey] + else Result := tokIdentifier; +end; + +procedure TmwBasePasLex.MakeMethodTables; +var + I: Char; +begin + for I := #0 to #255 do + case I of + #0: fProcTable[I] := NullProc; + #10: fProcTable[I] := LFProc; + #13: fProcTable[I] := CRProc; + #1..#9, #11, #12, #14..#32: + fProcTable[I] := SpaceProc; + '#': fProcTable[I] := AsciiCharProc; + '$': fProcTable[I] := IntegerProc; + #39: fProcTable[I] := StringProc; + '0'..'9': fProcTable[I] := NumberProc; + 'A'..'Z', 'a'..'z', '_': + fProcTable[I] := IdentProc; + '{': fProcTable[I] := BraceOpenProc; + '}': fProcTable[I] := BraceCloseProc; + '!', '"', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~': + begin + case I of + '(': fProcTable[I] := RoundOpenProc; + ')': fProcTable[I] := RoundCloseProc; + '*': fProcTable[I] := StarProc; + '+': fProcTable[I] := PlusProc; + ',': fProcTable[I] := CommaProc; + '-': fProcTable[I] := MinusProc; + '.': fProcTable[I] := PointProc; + '/': fProcTable[I] := SlashProc; + ':': fProcTable[I] := ColonProc; + ';': fProcTable[I] := SemiColonProc; + '<': fProcTable[I] := LowerProc; + '=': fProcTable[I] := EqualProc; + '>': fProcTable[I] := GreaterProc; + '@': fProcTable[I] := AddressOpProc; + '[': fProcTable[I] := SquareOpenProc; + ']': fProcTable[I] := SquareCloseProc; + '^': fProcTable[I] := PointerSymbolProc; + '"': fProcTable[I] := StringDQProc; // DR 2002-01-14 + {$IFDEF D8_NEWER} //JThurman 2004-04-06 + '&': fProcTable[I] := AmpersandOpProc; + {$ENDIF} + else fProcTable[I] := SymbolProc; + end; + end; + else fProcTable[I] := UnknownProc; + end; +end; + +constructor TmwBasePasLex.Create; +begin + inherited Create; + fOrigin := nil; + InitIdent; + MakeMethodTables; + fExID := tokUnKnown; + + FUseDefines := True; + FDefines := TStringList.Create; + FTopDefineRec := nil; + InitDefines; + + MaxPos := -1; +end; { Create } + +destructor TmwBasePasLex.Destroy; +begin + ClearDefines; //If we don't do this, we get a memory leak + FDefines.Free; + fOrigin := nil; + inherited Destroy; +end; + +procedure TmwBasePasLex.DoProcTable(AChar: AnsiChar); +begin + if AChar <= #255 then + fProcTable[AChar] + else + begin + IdentProc; + end; +end; + +{ Destroy } + +procedure TmwBasePasLex.SetOrigin(NewValue: PAnsiChar); +begin + fOrigin := NewValue; + Init; + Next; +end; { SetOrigin } + +procedure TmwBasePasLex.SetRunPos(Value: Integer); +begin + Run := Value; + Next; +end; + +procedure TmwBasePasLex.AddDefine(const ADefine: string); +begin + if (FDefines.IndexOf(ADefine) < 0) then + FDefines.Add(ADefine); +end; + +procedure TmwBasePasLex.AddressOpProc; +begin + case FOrigin[Run + 1] of + '@': + begin + fTokenID := tokDoubleAddressOp; + inc(Run, 2); + end; + else + begin + fTokenID := tokAddressOp; + inc(Run); + end; + end; +end; + +procedure TmwBasePasLex.AsciiCharProc; +begin + fTokenID := tokAsciiChar; + inc(Run); + if FOrigin[Run] = '$' then + begin + inc(Run); + while FOrigin[Run] in ['0'..'9', 'A'..'F', 'a'..'f'] do inc(Run); + end else + begin + while FOrigin[Run] in ['0'..'9'] do + inc(Run); + end; +end; + +procedure TmwBasePasLex.BraceCloseProc; +begin + inc(Run); + fTokenId := tokError; + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Illegal character', PosXY.X, PosXY.Y); +end; + +procedure TmwBasePasLex.BorProc; +begin + fTokenID := tokBorComment; + case FOrigin[Run] of + #0: + begin + NullProc; + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unexpected file end', PosXY.X, PosXY.Y); + exit; + end; +{ DR 2001-08-02 + + #10: + begin + LFProc; + exit; + end; + + #13: + begin + CRProc; + exit; + end; +} + end; + + while FOrigin[Run] <> #0 do + case FOrigin[Run] of + '}': + begin + fCommentState := csNo; + inc(Run); + break; + end; +{ DR 2001-08-02 + #10: break; + + #13: break; +} + #10: + begin + inc(Run); + inc(fLineNumber); + fLinePos := Run; + end; + #13: + begin + inc(Run); + if FOrigin[Run] = #10 then inc( Run ); + inc(fLineNumber); + fLinePos := Run; + end; + else inc(Run); + end; +end; + +procedure TmwBasePasLex.BraceOpenProc; +var + Param, Def: string; + tmpRun: Integer; +begin + case FOrigin[Run + 1] of + '$': fTokenID := GetDirectiveKind; + '.': + begin + tmpRun := fTokenPos; + Run := fTokenPos + 2; + FDirectiveParamOrigin := FOrigin + FTokenPos; + FTokenPos := Run; + case KeyHash of + 68: if KeyComp('INCLUDE') then + fTokenID := tokIncludeDirect + else + fTokenID := tokBorComment; + 136: if KeyComp('INCLUDE_ONCE') then + fTokenID := tokIncludeDirect + else + fTokenID := tokBorComment; + else + fTokenId := tokBorComment; + end; + FTokenPos := tmpRun; + Dec(Run); + end + else + fTokenID := tokBorComment; + end; + if (fTokenID = tokBorComment) then + fCommentState := csBor; + inc(Run); + while FOrigin[Run] <> #0 do + case FOrigin[Run] of + '}': + begin + fCommentState := csNo; + inc(Run); + break; + end; + #10: + begin + inc(Run); + inc(fLineNumber); + fLinePos := Run; + end; + #13: + begin + inc(Run); + if FOrigin[Run] = #10 then inc( Run ); + inc(fLineNumber); + fLinePos := Run; + end; +{ #10: break; DR 2001-10-12 + + #13: break;} + else inc(Run); + end; + case fTokenID of + tokCompDirect: + begin + if Assigned(fOnCompDirect) and (FDefineStack = 0) then + fOnCompDirect(Self); + end; + tokDefineDirect: + begin + if FUseDefines and (FDefineStack = 0) then + AddDefine(DirectiveParam); + if Assigned(fOnDefineDirect) then + fOnDefineDirect(Self); + end; + tokElseDirect: + begin + if FUseDefines then + begin + if FTopDefineRec <> nil then + begin + if FTopDefineRec^.Defined then + Inc(FDefineStack) + else + if FDefineStack > 0 then + Dec(FDefineStack); + end; + end; + if Assigned(fOnElseDirect) then + fOnElseDirect(Self); + end; + tokEndIfDirect: + begin + if FUseDefines then + ExitDefineBlock; + if Assigned(fOnEndIfDirect) then + fOnEndIfDirect(Self); + end; + tokIfDefDirect: + begin + if FUseDefines then + EnterDefineBlock(IsDefined(DirectiveParam)); + if Assigned(fOnIfDefDirect) then + fOnIfDefDirect(Self); + end; + tokIfNDefDirect: + begin + if FUseDefines then + EnterDefineBlock(not IsDefined(DirectiveParam)); + if Assigned(fOnIfNDefDirect) then + fOnIfNDefDirect(Self); + end; + tokIfOptDirect: + begin + if Assigned(fOnIfOptDirect) then + fOnIfOptDirect(Self); + end; + tokIfDirect: + begin + if FUseDefines then + begin + Param := DirectiveParam; + if Pos('DEFINED', Param) = 1 then + begin + Def := Copy(Param, 9, Length(Param) - 9); + EnterDefineBlock(IsDefined(Def)); + end; + end; + if Assigned(fOnIfDirect) then + fOnIfDirect(Self); + end; + tokIfEndDirect: + begin + if FUseDefines then + ExitDefineBlock; + if Assigned(fOnIfEndDirect) then + fOnIfEndDirect(Self); + end; + tokElseIfDirect: + begin + if FUseDefines then + begin + if FTopDefineRec <> nil then + begin + if FTopDefineRec^.Defined then + Inc(FDefineStack) + else + begin + if FDefineStack > 0 then + Dec(FDefineStack); + Param := DirectiveParam; + if Pos('DEFINED', Param) = 1 then + begin + Def := Copy(Param, 9, Length(Param) - 9); + EnterDefineBlock(IsDefined(Def)); + end; + end; + end; + end; + if Assigned(fOnElseIfDirect) then + fOnElseIfDirect(Self); + end; + tokIncludeDirect: + begin + if Assigned(fOnIncludeDirect) and (FDefineStack = 0) then + fOnIncludeDirect(Self); + end; + tokResourceDirect: + begin + if Assigned(fOnResourceDirect) and (FDefineStack = 0) then + fOnResourceDirect(Self); + end; + tokUndefDirect: + begin + if FUseDefines and (FDefineStack = 0) then + RemoveDefine(DirectiveParam); + if Assigned(fOnUndefDirect) then + fOnUndefDirect(Self); + end; + end; +end; + +procedure TmwBasePasLex.ColonProc; +begin + case FOrigin[Run + 1] of + '=': + begin + inc(Run, 2); + fTokenID := tokAssign; + end; + else + begin + inc(Run); + fTokenID := tokColon; + end; + end; +end; + +procedure TmwBasePasLex.CommaProc; +begin + inc(Run); + fTokenID := tokComma; +end; + +procedure TmwBasePasLex.CRProc; +begin + case fCommentState of + csBor: fTokenID := tokCRLFCo; + csAnsi: fTokenID := tokCRLFCo; + else fTokenID := tokCRLF; + end; + + case FOrigin[Run + 1] of + #10: inc(Run, 2); + else inc(Run); + end; + inc(fLineNumber); + fLinePos := Run; +end; + +procedure TmwBasePasLex.EnterDefineBlock(ADefined: Boolean); +var + StackFrame: PDefineRec; +begin + New(StackFrame); + StackFrame^.Next := FTopDefineRec; + StackFrame^.Defined := ADefined; + StackFrame^.StartCount := FDefineStack; + FTopDefineRec := StackFrame; + if not ADefined then + Inc(FDefineStack); +end; + +procedure TmwBasePasLex.EqualProc; +begin + inc(Run); + fTokenID := tokEqual; +end; + +procedure TmwBasePasLex.ExitDefineBlock; +var + StackFrame: PDefineRec; +begin + StackFrame := FTopDefineRec; + if StackFrame <> nil then + begin + FDefineStack := StackFrame^.StartCount; + FTopDefineRec := StackFrame^.Next; + Dispose(StackFrame); + end; +end; +procedure TmwBasePasLex.GreaterProc; +begin + case FOrigin[Run + 1] of + '=': + begin + inc(Run, 2); + fTokenID := tokGreaterEqual; + end; + else + begin + inc(Run); + fTokenID := tokGreater; + end; + end; +end; + +function TmwBasePasLex.HashValue(AChar: AnsiChar): Integer; +begin + if AChar <= #255 then + Result := mHashTable[fOrigin[Run]] + else + Result := Ord(AChar); +end; + +procedure TmwBasePasLex.IdentProc; +begin + fTokenID := IdentKind; +end; + +procedure TmwBasePasLex.IntegerProc; +begin + inc(Run); + fTokenID := tokIntegerConst; + while FOrigin[Run] in ['0'..'9', 'A'..'F', 'a'..'f'] do + inc(Run); +end; + +function TmwBasePasLex.IsDefined(const ADefine: string): Boolean; +begin + Result := FDefines.IndexOf(ADefine) > -1; +end; + +function TmwBasePasLex.IsIdentifiers(AChar: AnsiChar): Boolean; +begin + if AChar <= #255 then + Result := Identifiers[AChar] + else + Result := True; +end; + +procedure TmwBasePasLex.LFProc; +begin + case fCommentState of + csBor: fTokenID := tokCRLFCo; + csAnsi: fTokenID := tokCRLFCo; + else fTokenID := tokCRLF; + end; + inc(Run); + inc(fLineNumber); + fLinePos := Run; +end; + +procedure TmwBasePasLex.LowerProc; +begin + case FOrigin[Run + 1] of + '=': + begin + inc(Run, 2); + fTokenID := tokLowerEqual; + end; + '>': + begin + inc(Run, 2); + fTokenID := tokNotEqual; + end + else + begin + inc(Run); + fTokenID := tokLower; + end; + end; +end; + +procedure TmwBasePasLex.MinusProc; +begin + inc(Run); + fTokenID := tokMinus; +end; + +procedure TmwBasePasLex.NullProc; +begin + fTokenID := tokNull; +end; + +procedure TmwBasePasLex.NumberProc; +begin + inc(Run); + fTokenID := tokIntegerConst; + while FOrigin[Run] in ['0'..'9', '.', 'e', 'E'] do + begin + case FOrigin[Run] of + '.': + if FOrigin[Run + 1] = '.' then + break + else fTokenID := tokFloat + end; + inc(Run); + end; +end; + +procedure TmwBasePasLex.PlusProc; +begin + inc(Run); + fTokenID := tokPlus; +end; + +procedure TmwBasePasLex.PointerSymbolProc; +begin + inc(Run); + fTokenID := tokPointerSymbol; + + //This is a wierd Pascal construct that rarely appears, but needs to be + //supported. ^M is a valid char reference (#13, in this case) + if FOrigin[Run] in ['a'..'z','A'..'Z'] then + begin + inc(Run); + fTokenID := tokAsciiChar; + end; +end; + +procedure TmwBasePasLex.PointProc; +begin + case FOrigin[Run + 1] of + '.': + begin + inc(Run, 2); + fTokenID := tokDotDot; + end; + ')': + begin + inc(Run, 2); + fTokenID := tokSquareClose; + end; + else + begin + inc(Run); + fTokenID := tokPoint; + end; + end; +end; + +procedure TmwBasePasLex.RemoveDefine(const ADefine: string); +var + I: Integer; +begin + I := FDefines.IndexOf(ADefine); + if I > -1 then + FDefines.Delete(I); +end; + +procedure TmwBasePasLex.RoundCloseProc; +begin + inc(Run); + fTokenID := tokRoundClose; +end; + +procedure TmwBasePasLex.AnsiProc; +begin + fTokenID := tokAnsiComment; + case FOrigin[Run] of + #0: + begin + NullProc; + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unexpected file end', PosXY.X, PosXY.Y); + exit; + end; + +{ DR 2001-08-02 + #10: + begin + LFProc; + exit; + end; + + #13: + begin + CRProc; + exit; + end; +} + end; + + while fOrigin[Run] <> #0 do + case fOrigin[Run] of + '*': + if fOrigin[Run + 1] = ')' then + begin + fCommentState := csNo; + inc(Run, 2); + break; + end + else inc(Run); +{ DR 2001-08-02 + #10: break; + + #13: break; +} + #10: + begin + inc(Run); + inc(fLineNumber); + fLinePos := Run; + end; + #13: + begin + inc(Run); + if FOrigin[Run] = #10 then inc( Run ); + inc(fLineNumber); + fLinePos := Run; + end; + else inc(Run); + end; +end; + +procedure TmwBasePasLex.RoundOpenProc; +begin + inc(Run); + case fOrigin[Run] of + '*': + begin + fTokenID := tokAnsiComment; + if FOrigin[Run + 1] = '$' then + fTokenID := GetDirectiveKind + else fCommentState := csAnsi; + inc(Run); + while fOrigin[Run] <> #0 do + case fOrigin[Run] of + '*': + if fOrigin[Run + 1] = ')' then + begin + fCommentState := csNo; + inc(Run, 2); + break; + end + else inc(Run); +{ DR 2001-08-02 + #10: break; + #13: break; +} + #10: + begin + inc(Run); + inc(fLineNumber); + fLinePos := Run; + end; + #13: + begin + inc(Run); + if FOrigin[Run] = #10 then inc( Run ); + inc(fLineNumber); + fLinePos := Run; + end; + else inc(Run); + end; + end; + '.': + begin + inc(Run); + fTokenID := tokSquareOpen; + end; + else fTokenID := tokRoundOpen; + end; + case fTokenID of + tokCompDirect: + begin + if Assigned(fOnCompDirect) then + fOnCompDirect(Self); + end; + tokDefineDirect: + begin + if Assigned(fOnDefineDirect) then + fOnDefineDirect(Self); + end; + tokElseDirect: + begin + if Assigned(fOnElseDirect) then + fOnElseDirect(Self); + end; + tokEndIfDirect: + begin + if Assigned(fOnEndIfDirect) then + fOnEndIfDirect(Self); + end; + tokIfDefDirect: + begin + if Assigned(fOnIfDefDirect) then + fOnIfDefDirect(Self); + end; + tokIfNDefDirect: + begin + if Assigned(fOnIfNDefDirect) then + fOnIfNDefDirect(Self); + end; + tokIfOptDirect: + begin + if Assigned(fOnIfOptDirect) then + fOnIfOptDirect(Self); + end; + tokIncludeDirect: + begin + if Assigned(fOnIncludeDirect) then + fOnIncludeDirect(Self); + end; + tokResourceDirect: + begin + if Assigned(fOnResourceDirect) then + fOnResourceDirect(Self); + end; + tokUndefDirect: + begin + if Assigned(fOnUndefDirect) then + fOnUndefDirect(Self); + end; + end; +end; + +procedure TmwBasePasLex.SemiColonProc; +begin + inc(Run); + fTokenID := tokSemiColon; +end; + +procedure TmwBasePasLex.SlashProc; +begin + case FOrigin[Run + 1] of + '/': + begin + inc(Run, 2); + fTokenID := tokSlashesComment; + while FOrigin[Run] <> #0 do + begin + case FOrigin[Run] of + #10, #13: break; + end; + inc(Run); + end; + end; + else + begin + inc(Run); + fTokenID := tokSlash; + end; + end; +end; + +procedure TmwBasePasLex.SpaceProc; +begin + inc(Run); + fTokenID := tokSpace; + while FOrigin[Run] in [#1..#9, #11, #12, #14..#32] do + inc(Run); +end; + +procedure TmwBasePasLex.SquareCloseProc; +begin + inc(Run); + fTokenID := tokSquareClose; +end; + +procedure TmwBasePasLex.SquareOpenProc; +begin + inc(Run); + fTokenID := tokSquareOpen; +end; + +procedure TmwBasePasLex.StarProc; +begin + inc(Run); + fTokenID := tokStar; +end; + +procedure TmwBasePasLex.StringProc; +begin + fTokenID := tokStringConst; + repeat + inc(Run); + case FOrigin[Run] of + #0, #10, #13: + begin + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unterminated string', PosXY.X, PosXY.Y); + break; + end; + #39: + begin + while (FOrigin[Run] = #39) and (FOrigin[Run + 1] = #39) do + begin + inc(Run, 2); + end; + end; + end; + until FOrigin[Run] = #39; + if FOrigin[Run] = #39 then + begin + inc(Run); + if TokenLen = 3 then + begin + fTokenID := tokAsciiChar; + end; + end; +end; + +procedure TmwBasePasLex.SymbolProc; +begin + inc(Run); + fTokenID := tokSymbol; +end; + +procedure TmwBasePasLex.UnknownProc; +begin + inc(Run); + fTokenID := tokUnknown; + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unknown Character', PosXY.X, PosXY.Y); +end; + +procedure TmwBasePasLex.Next; +begin + fExID := tokUnKnown; + fTokenPos := Run; + + if (MaxPos > -1) and (fTokenPos > MaxPos) then + fTokenID := tok_DONE + else + case fCommentState of + csNo: + begin + DoProcTable(fOrigin[Run]); + (*{$IFDEF D10_NEWER} + if fOrigin[Run] < #256 then + fProcTable[fOrigin[Run]] + else //non-ASCII unicode char + IdentProc; + {$ELSE} + fProcTable[fOrigin[Run]]; + {$ENDIF}*) + end; + else + case fCommentState of + csBor: BorProc; + csAnsi: AnsiProc; + end; + end; +end; + + +function TmwBasePasLex.GetIsJunk: Boolean; +begin + result := IsTokenIDJunk(FTokenID) or (FUseDefines and (FDefineStack > 0) and (TokenID <> tokNull) and (TokenID <> tok_DONE)); +// Result := fTokenID in [tokAnsiComment, tokBorComment, tokCRLF, tokCRLFCo, tokSlashesComment, tokSpace]; //XM 20001210 +end; + +function TmwBasePasLex.GetIsSpace: Boolean; +begin + Result := fTokenID in [tokCRLF, tokSpace]; +end; + +function TmwBasePasLex.GetToken: string; +begin + SetString(Result, (FOrigin + fTokenPos), GetTokenLen); +end; + +function TmwBasePasLex.GetTokenLen: Integer; +begin + Result := Run - fTokenPos; +end; + +procedure TmwBasePasLex.NextID(ID: TptTokenKind); +begin + repeat + case fTokenID of + tokNull, tok_DONE: break; + else Next; + end; + until fTokenID = ID; +end; + +procedure TmwBasePasLex.NextNoJunk; +begin + repeat + Next; + until not IsJunk; +end; + +procedure TmwBasePasLex.NextNoSpace; +begin + repeat + Next; + until not IsSpace; +end; + +function TmwBasePasLex.FirstInLine: Boolean; +var + RunBack: Integer; +begin + Result := True; + if fTokenPos = 0 then exit; + RunBack := fTokenPos; + dec(RunBack); + while fOrigin[RunBack] in [#1..#9, #11, #12, #14..#32] do + dec(RunBack); + if RunBack = 0 then exit; + case fOrigin[RunBack] of + #10, #13: exit; + else + begin + Result := False; + exit; + end; + end; +end; + +function TmwBasePasLex.GetCommentState: Pointer; +begin + Result := Pointer(fCommentState); +end; + +function TmwBasePasLex.GetCompilerDirective: string; +var + DirectLen: Integer; +begin + if TokenID <> tokCompDirect then + Result := '' + else + case fOrigin[fTokenPos] of + '(': + begin + DirectLen := Run - fTokenPos - 4; + SetString(Result, (FOrigin + fTokenPos + 2), DirectLen); + Result := UpperCase(Result); + end; + '{': + begin + DirectLen := Run - fTokenPos - 2; + SetString(Result, (FOrigin + fTokenPos + 1), DirectLen); + Result := UpperCase(Result); + end; + end; +end; + +function TmwBasePasLex.GetDirectiveKind: TptTokenKind; +var + TempPos: Integer; +begin + case fOrigin[fTokenPos] of + '(': Run := FTokenPos + 3; + '{': Run := FTokenPos + 2; + end; + FDirectiveParamOrigin := FOrigin + FTokenPos; + TempPos := fTokenPos; + fTokenPos := Run; + case KeyHash of + 9: + if KeyComp('I') then + Result := tokIncludeDirect else + Result := tokCompDirect; + 15: + if KeyComp('IF') then + Result := tokIfDirect else + Result := tokCompDirect; + 18: + if KeyComp('R') then + begin + if not (fOrigin[Run] in ['+', '-']) then + Result := tokResourceDirect else Result := tokCompDirect; + end else Result := tokCompDirect; + 30: + if KeyComp('IFDEF') then + Result := tokIfDefDirect else + Result := tokCompDirect; + 38: + if KeyComp('ENDIF') then + Result := tokEndIfDirect else + if KeyComp('IFEND') then + Result := tokIfEndDirect else + Result := tokCompDirect; + 41: + if KeyComp('ELSE') then + Result := tokElseDirect else + Result := tokCompDirect; + 43: + if KeyComp('DEFINE') then + Result := tokDefineDirect else + Result := tokCompDirect; + 44: + if KeyComp('IFNDEF') then + Result := tokIfNDefDirect else + Result := tokCompDirect; + 50: + if KeyComp('UNDEF') then + Result := tokUndefDirect else + Result := tokCompDirect; + 56: + if KeyComp('ELSEIF') then + Result := tokElseIfDirect else + Result := tokCompDirect; + 66: + if KeyComp('IFOPT') then + Result := tokIfOptDirect else + Result := tokCompDirect; + 68: + if KeyComp('INCLUDE') then + Result := tokIncludeDirect else + Result := tokCompDirect; + 104: + if KeyComp('Resource') then + Result := tokResourceDirect else + Result := tokCompDirect; + else Result := tokCompDirect; + end; + fTokenPos := TempPos; + dec(Run); +end; + +function TmwBasePasLex.GetDirectiveParam: string; +var + EndPos: Integer; + ParamLen: Integer; +begin + // !! without this set... there is a warning? + EndPos:= 0; + case fOrigin[fTokenPos] of + '(': + begin + TempRun := FTokenPos + 3; + EndPos := Run - 2; + end; + '{': + begin + TempRun := FTokenPos + 2; + EndPos := Run - 1; + end; + end; + while IsIdentifiers(fOrigin[TempRun]) do + inc(TempRun); + while fOrigin[TempRun] in ['+', ',', '-'] do + begin + inc(TempRun); + while IsIdentifiers(fOrigin[TempRun]) do + inc(TempRun); + if (fOrigin[TempRun - 1] in ['+', ',', '-']) and (fOrigin[TempRun] = ' ') + then inc(TempRun); + end; + if fOrigin[TempRun] = ' ' then inc(TempRun); + ParamLen := EndPos - TempRun; + SetString(Result, (FOrigin + TempRun), ParamLen); + Result := UpperCase(Result); +end; + +procedure TmwBasePasLex.Init; +begin + fCommentState := csNo; + fLineNumber := 0; + fLinePos := 0; + Run := 0; + //InitDefines; +end; + +procedure TmwBasePasLex.InitFrom(ALexer: TmwBasePasLex); +begin + Origin := ALexer.Origin; + fCommentState := ALexer.fCommentState; + fLineNumber := ALexer.fLineNumber; + fLinePos := ALexer.fLinePos; + Run := ALexer.Run; + CloneDefinesFrom(ALexer); +end; + +procedure TmwBasePasLex.InitDefines; +begin + ClearDefines; + //Set up the defines that are defined by the compiler + (* + {$IFDEF VER130} + AddDefine('VER130'); + {$ENDIF} + {$IFDEF VER140} + AddDefine('VER140'); + {$ENDIF} + {$IFDEF VER150} + AddDefine('VER150'); + {$ENDIF} + {$IFDEF VER160} + AddDefine('VER160'); + {$ENDIF} + {$IFDEF VER170} + AddDefine('VER170'); + {$ENDIF} + {$IFDEF VER180} + AddDefine('VER180'); + {$ENDIF} + {$IFDEF VER185} + AddDefine('VER185'); + {$ENDIF} + {$IFDEF VER190} + AddDefine('VER190'); + {$ENDIF} + {$IFDEF VER200} + AddDefine('VER200'); + {$ENDIF} + {$IFDEF WIN32} + AddDefine('WIN32'); + {$ENDIF} + {$IFDEF LINUX} + AddDefine('LINUX'); + {$ENDIF} + {$IFDEF CPU386} + AddDefine('CPU386'); + {$ENDIF} + {$IFDEF MSWINDOWS} + AddDefine('MSWINDOWS'); + {$ENDIF} + {$IFDEF CONDITIONALEXPRESSIONS} + AddDefine('CONDITIONALEXPRESSIONS'); + {$ENDIF} + {$IFDEF UNICODE} + AddDefine('UNICODE'); + {$ENDIF} + *) +end; + +procedure TmwBasePasLex.InitLine; +begin + fLineNumber := 0; + fLinePos := 0; + Run := 0; +end; + +procedure TmwBasePasLex.SetCommentState(const Value: Pointer); +begin + fCommentState := TCommentState(Value); +end; + +procedure TmwBasePasLex.SetLine(const Value: AnsiString); +begin + fOrigin := PAnsiChar(Value); + InitLine; + Next; +end; + +function TmwBasePasLex.GetStringContent: string; +var + TempString: string; + sEnd: Integer; +begin + if TokenID <> tokStringConst then + Result := '' + else + begin + TempString := Token; + sEnd := Length(TempString); + if TempString[sEnd] <> #39 then inc(sEnd); + Result := Copy(TempString, 2, sEnd - 2); + TempString := ''; + end; +end; + +function TmwBasePasLex.GetIsOrdIdent: Boolean; +begin + Result := False; + if fTokenID = tokIdentifier then + Result := fExID in [tokBoolean, tokByte, tokChar, tokDWord, tokInt64, tokInteger, + tokLongInt, tokLongWord, tokPChar, tokShortInt, tokSmallInt, tokWideChar, tokWord] +end; + +function TmwBasePasLex.GetIsOrdinalType: Boolean; +begin + Result := GetIsOrdIdent or (fTokenID in [tokAsciiChar, tokIntegerConst]); +end; + +function TmwBasePasLex.GetIsRealType: Boolean; +begin + Result := False; + if fTokenID = tokIdentifier then + Result := fExID in [tokComp, tokCurrency, tokDouble, tokExtended, tokReal, tokReal48, tokSingle] +end; + +function TmwBasePasLex.GetIsStringType: Boolean; +begin + Result := False; + if fTokenID = tokIdentifier then + Result := fExID in [tokAnsiString, tokWideString] + else + if fTokenID = tokString then + Result := True + else + if fTokenID = tokStringConst then Result := True; +end; + +function TmwBasePasLex.GetIsVarantType: Boolean; +begin + Result := False; + if fTokenID = tokIdentifier then + Result := fExID in [tokOleVariant, tokVariant] +end; + +function TmwBasePasLex.GetIsAddOperator: Boolean; +begin + Result := fTokenID in [tokMinus, tokOr, tokPlus, tokXor]; +end; + +function TmwBasePasLex.GetIsMulOperator: Boolean; +begin + Result := fTokenID in [tokAnd, tokAs, tokDiv, tokMod, tokShl, tokShr, tokSlash, tokStar]; +end; + +function TmwBasePasLex.GetIsRelativeOperator: Boolean; +begin + Result := fTokenID in [tokAs, tokEqual, tokGreater, tokGreaterEqual, tokLower, tokLowerEqual, + tokIn, tokIs, tokNotEqual]; +end; + +function TmwBasePasLex.GetIsCompilerDirective: Boolean; +begin + Result := fTokenID in [tokCompDirect, tokDefineDirect, tokElseDirect, + tokEndIfDirect, tokIfDefDirect, tokIfNDefDirect, tokIfOptDirect, + tokIncludeDirect, tokResourceDirect, tokUndefDirect]; +end; + +function TmwBasePasLex.GetGenID: TptTokenKind; +begin + Result := fTokenID; + if fTokenID = tokIdentifier then + if fExID <> tokUnknown then Result := fExID; +end; + +{ TmwPasLex } + +constructor TmwPasLex.Create; +begin + inherited Create; + fAheadLex := TmwBasePasLex.Create; +end; + +destructor TmwPasLex.Destroy; +begin + fAheadLex.Free; + inherited Destroy; +end; + +procedure TmwPasLex.SetOrigin(NewValue: PAnsiChar); +begin + inherited SetOrigin(NewValue); + fAheadLex.SetOrigin(NewValue); +end; + +procedure TmwPasLex.SetLine(const Value: AnsiString); +begin + inherited SetLine(Value); + fAheadLex.SetLine(Value); +end; + +procedure TmwPasLex.AheadNext; +begin + fAheadLex.NextNoJunk; +end; + +function TmwPasLex.GetAheadExID: TptTokenKind; +begin + Result := fAheadLex.ExID; +end; + +function TmwPasLex.GetAheadGenID: TptTokenKind; +begin + Result := fAheadLex.GenID; +end; + +function TmwPasLex.GetAheadToken: string; +begin + Result := fAheadLex.Token; +end; + +function TmwPasLex.GetAheadTokenID: TptTokenKind; +begin + Result := fAheadLex.TokenID; +end; + +procedure TmwPasLex.InitAhead; +begin + fAheadLex.CommentState := CommentState; + fAheadLex.RunPos := RunPos; + FAheadLex.fLineNumber := FLineNumber; + FAheadLex.FLinePos := FLinePos; + + FAheadLex.CloneDefinesFrom(Self); + + //FAheadLex.FTokenPos := FTokenPos; + while fAheadLex.IsJunk do + fAheadLex.Next; +end; + +function TmwPasLex.GetStatus: TmwPasLexStatus; +begin + Result.CommentState := fCommentState; + Result.ExID := fExID; + Result.LineNumber := fLineNumber; + Result.LinePos := fLinePos; + Result.Origin := fOrigin; + Result.RunPos := Run; + Result.TokenPos := fTokenPos; + Result.TokenID := fTokenID; +end; + +procedure TmwPasLex.SetStatus(const Value: TmwPasLexStatus); +begin + fCommentState := Value.CommentState; + fExID := Value.ExID; + fLineNumber := Value.LineNumber; + fLinePos := Value.LinePos; + fOrigin := Value.Origin; + Run := Value.RunPos; + fTokenPos := Value.TokenPos; + fTokenID := Value.TokenID; + fAheadLex.Origin := Value.Origin; +end; + +procedure TmwBasePasLex.SetOnCompDirect(const Value: TDirectiveEvent); +begin + fOnCompDirect := Value; +end; + +procedure TmwBasePasLex.SetOnDefineDirect(const Value: TDirectiveEvent); +begin + fOnDefineDirect := Value; +end; + +procedure TmwBasePasLex.SetOnElseDirect(const Value: TDirectiveEvent); +begin + fOnElseDirect := Value; +end; + +procedure TmwBasePasLex.SetOnElseIfDirect(const Value: TDirectiveEvent); +begin + fOnElseIfDirect := Value; +end; + +procedure TmwBasePasLex.SetOnEndIfDirect(const Value: TDirectiveEvent); +begin + fOnEndIfDirect := Value; +end; + +procedure TmwBasePasLex.SetOnIfDefDirect(const Value: TDirectiveEvent); +begin + fOnIfDefDirect := Value; +end; + +procedure TmwBasePasLex.SetOnIfDirect(const Value: TDirectiveEvent); +begin + FOnIfDirect := Value; +end; + +procedure TmwBasePasLex.SetOnIfEndDirect(const Value: TDirectiveEvent); +begin + FOnIfEndDirect := Value; +end; + +procedure TmwBasePasLex.SetOnIfNDefDirect(const Value: TDirectiveEvent); +begin + fOnIfNDefDirect := Value; +end; + +procedure TmwBasePasLex.SetOnIfOptDirect(const Value: TDirectiveEvent); +begin + fOnIfOptDirect := Value; +end; + +procedure TmwBasePasLex.SetOnIncludeDirect(const Value: TDirectiveEvent); +begin + fOnIncludeDirect := Value; +end; + +procedure TmwBasePasLex.SetOnResourceDirect(const Value: TDirectiveEvent); +begin + fOnResourceDirect := Value; +end; + +procedure TmwBasePasLex.SetOnUnDefDirect(const Value: TDirectiveEvent); +begin + fOnUnDefDirect := Value; +end; + +procedure TmwPasLex.SetOnCompDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnCompDirect := Value; +end; + +procedure TmwPasLex.SetOnDefineDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnDefineDirect := Value; +end; + +procedure TmwPasLex.SetOnElseDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnElseDirect := Value; +end; + +procedure TmwPasLex.SetOnEndIfDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnEndIfDirect := Value; +end; + +procedure TmwPasLex.SetOnIfDefDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnIfDefDirect := Value; +end; + +procedure TmwPasLex.SetOnIfNDefDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnIfNDefDirect := Value; +end; + +procedure TmwPasLex.SetOnIfOptDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnIfOptDirect := Value; +end; + +procedure TmwPasLex.SetOnIncludeDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnIncludeDirect := Value; +end; + +procedure TmwPasLex.SetOnResourceDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnResourceDirect := Value; +end; + +procedure TmwPasLex.SetOnUnDefDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnUnDefDirect := Value; +end; + +function TmwBasePasLex.Func86: TptTokenKind; +begin + Result := tokIdentifier; + if KeyComp('Varargs') then fExID := tokVarargs; +end; + +procedure TmwBasePasLex.StringDQProc; +begin + if not fAsmCode then + begin + SymbolProc; + Exit; + end; + fTokenID := tokStringDQConst; + repeat + inc(Run); + case FOrigin[Run] of + #0, #10, #13: + begin + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unterminated string', PosXY.X, PosXY.Y); + break; + end; + '\': + begin + Inc( Run ); + if FOrigin[Run] in [#32..#255] then Inc( Run ); + end; + end; + until FOrigin[Run] = '"'; + if FOrigin[Run] = '"' then + inc(Run); +end; + +{$IFDEF D8_NEWER} //JThurman 2004-04-06 +procedure TmwBasePasLex.AmpersandOpProc; +begin + FTokenID := tokAmpersand; + inc(Run); + while FOrigin[Run] in ['a'..'z', 'A'..'Z','0'..'9'] do + inc(Run); + FTokenID := tokIdentifier; +end; +{$ENDIF} + +initialization + MakeIdentTable; +end. + diff --git a/Projects/SAMufasaGUI/CastaliaPasLexTypes.pas b/Projects/SAMufasaGUI/CastaliaPasLexTypes.pas new file mode 100644 index 0000000..ce65d81 --- /dev/null +++ b/Projects/SAMufasaGUI/CastaliaPasLexTypes.pas @@ -0,0 +1,322 @@ +{--------------------------------------------------------------------------- +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/NPL/NPL-1_1Final.html + +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 Original Code is: mwPasLexTypes, released November 14, 1999. + +The Initial Developer of the Original Code is Martin Waldenburg +unit CastaliaPasLexTypes; + +----------------------------------------------------------------------------} + +unit CastaliaPasLexTypes; + +{$include ValistusDefines.inc} + +interface + +uses SysUtils, TypInfo; + +var + CompTable: array[#0..#255] of byte; + +type + + TMessageEventType = ( meError, meNotSupported ); + + TMessageEvent = procedure(Sender: TObject; const Typ : TMessageEventType; const Msg: string; X, Y: Integer ) of object; //jdj 7/16/1999; DR 2001-11-06 + + TCommentState = (csAnsi, csBor, csNo); + + TTokenPoint = packed record + X : Integer; + Y : Integer; + end; + + TptTokenKind = ( + tokAbort, //JThurman 2004-11-8 (flow control routines) + tokAbsolute, + tokAbstract, + tokAdd, + tokAddressOp, + tokAmpersand, + tokAnd, + tokAnsiComment, + tokAnsiString, + tokArray, + tokAs, + tokAsciiChar, + tokAsm, + tokAssembler, + tokAssign, + tokAt, + tokAutomated, + tokBegin, + tokBoolean, + tokBorComment, + tokBraceClose, + tokBraceOpen, + tokBreak, //JThurman 2004-11-8 (flow control routines) + tokByte, + tokByteBool, + tokCardinal, + tokCase, + tokCdecl, + tokChar, + tokClass, + tokClassForward, + tokClassFunction, + tokClassProcedure, + tokColon, + tokComma, + tokComp, + tokCompDirect, + tokConst, + tokConstructor, + tokContains, + tokContinue, //JThurman 2004-11-8 (flow control routines) + tokCRLF, + tokCRLFCo, + tokCurrency, + tokDefault, + tokDefineDirect, + tokDeprecated, // DR 2001-10-20 + tokDestructor, + tokDispid, + tokDispinterface, + tokDiv, + tokDo, + tokDotDot, + tokDouble, + tokDoubleAddressOp, + tokDownto, + tokDWORD, + tokDynamic, + tokElse, + tokElseDirect, + tokEnd, + tokEndIfDirect, + tokEqual, + tokError, + tokExcept, + tokExit, //JThurman 2004-11-8 (flow control routine) + tokExport, + tokExports, + tokExtended, + tokExternal, + tokFar, + tokFile, + {$IFDEF D8_NEWER} //JThurman 2004-03-20 + tokFinal, + {$ENDIF} + tokFinalization, + tokFinally, + tokFloat, + tokFor, + tokForward, + tokFunction, + tokGoto, + tokGreater, + tokGreaterEqual, + tokHalt, //JThurman 2004-11-8 (flow control routines) + {$IFDEF D8_NEWER} //JThurman 2004-04-06 + tokHelper, + {$ENDIF} + tokIdentifier, + tokIf, + tokIfDirect, + tokIfEndDirect, + tokElseIfDirect, + tokIfDefDirect, + tokIfNDefDirect, + tokIfOptDirect, + tokImplementation, + tokImplements, + tokIn, + tokIncludeDirect, + tokIndex, + tokInherited, + tokInitialization, + tokInline, + tokInt64, + tokInteger, + tokIntegerConst, + tokInterface, + tokIs, + tokLabel, + tokLibrary, + tokLocal, // DR 2001-11-14 + tokLongBool, + tokLongint, + tokLongword, + tokLower, + tokLowerEqual, + tokMessage, + tokMinus, + tokMod, + tokName, + tokNear, + tokNil, + tokNodefault, + tokNone, + tokNot, + tokNotEqual, + tokNull, + tokObject, + tokOf, + tokOleVariant, + tokOn, + {$IFDEF D8_NEWER} //JThurman 2004-03-20 + tokOperator, + {$ENDIF} + tokOr, + tokOut, + tokOverload, + tokOverride, + tokPackage, + tokPacked, + tokPascal, + tokPChar, + tokPlatform, // DR 2001-10-20 + tokPlus, + tokPoint, + tokPointerSymbol, + tokPrivate, + tokProcedure, + tokProgram, + tokProperty, + tokProtected, + tokPublic, + tokPublished, + tokRaise, + tokRead, + tokReadonly, + tokReal, + tokReal48, + tokRecord, + {$IFDEF D12_NEWER} + tokReference, //JThurman 2008-25-07 (anonymous methods) + {$ENDIF} + tokRegister, + tokReintroduce, + tokRemove, + tokRepeat, + tokRequires, + tokResident, + tokResourceDirect, + tokResourcestring, + tokRoundClose, + tokRoundOpen, + tokRunError, //JThurman 2004-11-8 (flow control routines) + tokSafeCall, + {$IFDEF D8_NEWER} //JThurman 2004-03-19 + tokSealed, + {$ENDIF} + tokSemiColon, + tokSet, + tokShl, + tokShortint, + tokShortString, + tokShr, + tokSingle, + tokSlash, + tokSlashesComment, + tokSmallint, + tokSpace, + tokSquareClose, + tokSquareOpen, + tokStar, + {$IFDEF D8_NEWER} //JThurman 2004-03-20 + tokStatic, + {$ENDIF} + tokStdcall, + tokStored, + {$IFDEF D8_NEWER} + tokStrict, //JThurman 2004-03-03 + {$ENDIF} + tokString, + tokStringConst, + tokStringDQConst, // 2002-01-14 + tokStringresource, + tokSymbol, + tokThen, + tokThreadvar, + tokTo, + tokTry, + tokType, + tokUndefDirect, + tokUnit, + tokUnknown, + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + tokUnsafe, + {$ENDIF} + tokUntil, + tokUses, + tokVar, + tokVarargs, // DR 2001-11-14 + tokVariant, + tokVirtual, + tokWhile, + tokWideChar, + tokWideString, + tokWith, + tokWord, + tokWordBool, + tokWrite, + tokWriteonly, + tokXor, + + tok_DONE); + +TmwPasLexStatus = record + CommentState: TCommentState; + ExID: TptTokenKind; + LineNumber: Integer; + LinePos: Integer; + Origin: PAnsiChar; + RunPos: Integer; + TokenPos: Integer; + TokenID: TptTokenKind; +end; + +const ExTypes = [tokDWORD, tokUnknown]; + +function TokenName(Value: TptTokenKind): string; +function tokTokenName(Value: TptTokenKind): string; +function IsTokenIDJunk(const aTokenID : TptTokenKind ) :Boolean; //XM 20001210 + +implementation + +function TokenName(Value: TptTokenKind): string; +begin //jdj 7/18/1999 + Result := Copy(tokTokenName(Value), 4, MaxInt); +end; + +function tokTokenName(Value: TptTokenKind): string; +begin + result := GetEnumName(TypeInfo(TptTokenKind), Integer(Value)); +end; + +function IsTokenIDJunk(const aTokenID : TptTokenKind ) :boolean; //XM 20001210 +begin + Result := aTokenID in [tokAnsiComment, tokBorComment, tokCRLF, tokCRLFCo, tokSlashesComment, tokSpace, + tokIfDirect, + tokIfEndDirect, + tokElseIfDirect, + tokIfDefDirect, + tokIfNDefDirect, + tokEndIfDirect, + tokIfOptDirect, + tokDefineDirect, + tokUndefDirect]; +end; + + +end. + diff --git a/Projects/SAMufasaGUI/CastaliaSimplePasPar.pas b/Projects/SAMufasaGUI/CastaliaSimplePasPar.pas new file mode 100644 index 0000000..ee23d07 --- /dev/null +++ b/Projects/SAMufasaGUI/CastaliaSimplePasPar.pas @@ -0,0 +1,5955 @@ +{--------------------------------------------------------------------------- +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/NPL/NPL-1_1Final.html + +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 Original Code is: mwSimplePasPar.pas, released November 14, 1999. + +The Initial Developer of the Original Code is Martin Waldenburg +(Martin.Waldenburg@T-Online.de). +Portions created by Martin Waldenburg are Copyright (C) 1998, 1999 Martin +Waldenburg. +All Rights Reserved. +Portions CopyRight by Robert Zierer. + +Contributor(s): James Jacobson, Dean Hill, Vladimir Churbanov___________________. + +Last Modified: 2002/01/16 +Current Version: 1.02 + +Notes: This program is an early beginning of a Pascal parser. +I'd like to invite the Delphi community to develop it further and to create +a fully featured Object Pascal parser. + +Modification history: + +Jacob Thurman between 20040301 and 20020401 + +Made ready for Delphi 8: + +Added new directives and keywords: static, sealed, final, operator, unsafe. + +Added parsing for custom attributes (based on ECMA C# specification). + +Added support for nested types in class declarations. + +Jeff Rafter between 20020116 and 20020302 + +Added AncestorId and AncestorIdList back in, but now treat them as Qualified +Identifiers per Daniel Rolf's fix. The separation from QualifiedIdentifierList +is need for descendent classes. + +Added VarName and VarNameList back in for descendent classes, fixed to correctly +use Identifiers as in Daniel's verison + +Removed fInJunk flags (they were never used, only set) + +Pruned uses clause to remove windows dependency. This required changing +"TPoint" to "TTokenPoint". TTokenPoint was declared in mwPasLexTypes + +Daniel Rolf between 20010723 and 20020116 + +Made ready for Delphi 6 + +ciClassClass for "class function" etc. +ciClassTypeEnd marks end of a class declaration (I needed that for the delphi-objectif-connector) +ciEnumeratedTypeItem for items of enumerations +ciDirectiveXXX for the platform, deprecated, varargs, local +ciForwardDeclaration for "forward" (until now it has been read but no event) +ciIndexSpecifier for properties +ciObjectTypeEnd marks end of an object declaration +ciObjectProperty property for objects +ciObjectPropertySpecifiers property for objects +ciPropertyDefault marking default of property +ciDispIDSpecifier for dispid + +patched some functions for implementing the above things and patching the following bugs/improv.: + +ObjectProperty handling overriden properties +ProgramFile, UnitFile getting Identifier instead of dropping it +InterfaceHeritage: Qualified identifiers +bugs in variant records +typedconstant failed with complex set constants. simple patch using ConstantExpression + +German localization for the two string constants. Define GERMAN for german string constants. + +Greg Chapman on 20010522 +Better handling of defaut array property +Separate handling of X and Y in property Pixels[X, Y: Integer through identifier "event" +corrected spelling of "ForwardDeclaration" + +James Jacobson on 20010223 +semi colon before finalization fix + +James Jacobson on 20010223 +RecordConstant Fix + +Martin waldenburg on 2000107 +Even Faster lexer implementation !!!! + +James Jacobson on 20010107 + Improper handling of the construct + property TheName: Integer read FTheRecord.One.Two; (stop at second point) + where one and two are "qualifiable" structures. + +James Jacobson on 20001221 + Stops at the second const. + property Anchor[const Section: string; const Ident:string]: string read + changed TmwSimplePasPar.PropertyParameterList + +On behalf of Martin Waldenburg and James Jacobson + Correction in array property Handling (Matin and James) 07/12/2000 + Use of ExId instead of TokenId in ExportsElements (James) 07/12/2000 + Reverting to old behavior in Statementlist [tokintegerConst put back in] (James) 07/12/2000 + +Xavier Masson InnerCircleProject : XM : 08/11/2000 + Integration of the new version delivered by Martin Waldenburg with the modification I made described just below + +Xavier Masson InnerCircleProject : XM : 07/15/2000 + Added "states/events " for spaces( SkipSpace;) CRLFco (SkipCRLFco) and + CRLF (SkipCRLF) this way the parser can give a complete view on code allowing + "perfect" code reconstruction. + (I fully now that this is not what a standard parser will do but I think it is more usefull this way ;) ) + go to www.innercircleproject.com for more explanations or express your critisism ;) + +previous modifications not logged sorry ;) + +Known Issues: +-----------------------------------------------------------------------------} +{---------------------------------------------------------------------------- + Last Modified: 05/22/2001 + Current Version: 1.1 + official version + Maintained by InnerCircle + + http://www.innercircleproject.org + + 02/07/2001 + added property handling in Object types + changed handling of forward declarations in ExportedHeading method +-----------------------------------------------------------------------------} +unit CastaliaSimplePasPar; + +{$include ValistusDefines.inc} + +interface + +uses + //!! pruned uses + SysUtils, + Classes, + CastaliaPasLexTypes, + CastaliaPasLex, + CastaliaSimplePasParTypes; + +resourcestring + rsExpected = '''%s'' expected found ''%s'''; + rsEndOfFile = 'end of file'; + +const + + ClassMethodDirectiveEnum = [tokAbstract, tokCdecl, tokDynamic, tokMessage, tokOverride, + tokOverload, tokPascal, tokRegister, tokReintroduce, tokSafeCall, tokStdCall, + tokVirtual, + tokDeprecated, tokLibrary, tokPlatform // DR 2001-10-20 + {$IFDEF D8_NEWER} + , tokStatic //JThurman 2004-11-10 + {$ENDIF} + {$IFDEF D9_NEWER} + , tokInline + {$ENDIF} + ]; //XM 2002-01-29 + +type + ESyntaxError = class(Exception) + private //jdj 7/18/1999 + FPosXY: TTokenPoint; + protected + + public + constructor Create(const Msg: string); + constructor CreateFmt(const Msg: string; const Args: array of const); + constructor CreatePos(const Msg: string; aPosXY: TTokenPoint); + property PosXY: TTokenPoint read FPosXY write FPosXY; + end; + +type + TmwSimplePasPar = class(TObject) + private + fOnMessage: TMessageEvent; + fLexer: TmwPasLex; + fInterfaceOnly: Boolean; + fLastNoJunkPos: Integer; + fLastNoJunkLen: Integer; + + AheadParse: TmwSimplePasPar; + procedure InitAhead; + protected + fInRound: Boolean; + + procedure Expected(Sym: TptTokenKind); virtual; + procedure ExpectedEx(Sym: TptTokenKind); virtual; + procedure ExpectedFatal(Sym: TptTokenKind); virtual; + procedure HandlePtCompDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtDefineDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtElseDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtEndIfDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfDefDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfNDefDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfOptDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIncludeDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtResourceDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtUndefDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfEndDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtElseIfDirect(Sender: TmwBasePasLex); virtual; + procedure NextToken; virtual; + procedure SkipJunk; virtual; + procedure TerminateStream(Stream: TCustomMemoryStream); virtual; + procedure SEMICOLON; virtual; + function GetExID: TptTokenKind; virtual; + function GetTokenID: TptTokenKind; virtual; + function GetGenID: TptTokenKind; virtual; + procedure AccessSpecifier; virtual; + procedure AdditiveOperator; virtual; + procedure AncestorIdList; virtual; // !! Added ancestorIdList back in... + procedure AncestorId; virtual; // !! Added ancestorId back in... + procedure AnonymousMethod; virtual; + procedure AnonymousMethodType; virtual; + procedure ArrayConstant; virtual; + procedure ArrayType; virtual; + procedure AsmStatement; virtual; + procedure Block; virtual; + procedure CaseLabel; virtual; + procedure CaseSelector; virtual; + procedure CaseStatement; virtual; + procedure CharString; virtual; + procedure ClassField; virtual; + procedure ClassForward; virtual; + procedure ClassFunctionHeading; virtual; + procedure ClassHeritage; virtual; + procedure ClassMemberList; virtual; + procedure ClassMethodDirective; virtual; + procedure ClassMethodHeading; virtual; + procedure ClassMethodOrProperty; virtual; + procedure ClassMethodResolution; virtual; + procedure ClassProcedureHeading; virtual; + procedure ClassClass; virtual; + procedure ClassProperty; virtual; + procedure ClassReferenceType; virtual; + procedure ClassType; virtual; + procedure ClassTypeEnd; virtual; // DR 2001-07-31 + procedure ClassVisibility; virtual; + procedure CompoundStatement; virtual; + procedure ConstantColon; virtual; + procedure ConstantDeclaration; virtual; + procedure ConstantEqual; virtual; + procedure ConstantExpression; virtual; + procedure ConstantName; virtual; +//JR added constant type + procedure ConstantType; virtual; + procedure ConstantValue; virtual; + procedure ConstantValueTyped; virtual; + procedure ConstParameter; virtual; + procedure ConstructorHeading; virtual; + procedure ConstructorName; virtual; + procedure ConstSection; virtual; + procedure ContainsClause; virtual; + procedure ContainsExpression; virtual; + procedure ContainsIdentifier; virtual; + procedure ContainsStatement; virtual; + {$IFDEF D8_NEWER} + procedure CustomAttribute; virtual; //JThurman 2004-03-03 + {$ENDIF} + procedure DeclarationSection; virtual; + procedure Designator; virtual; + procedure DestructorHeading; virtual; + procedure DestructorName; virtual; + procedure Directive16Bit; virtual; + procedure DirectiveBinding; virtual; + procedure DirectiveCalling; virtual; + procedure DirectiveDeprecated; virtual; // DR 2001-10-20 + procedure DirectiveLibrary; virtual; // DR 2001-10-20 + procedure DirectiveLocal; virtual; // DR 2001-11-14 + procedure DirectivePlatform; virtual; // DR 2001-10-20 + procedure DirectiveVarargs; virtual; // DR 2001-11-14 + procedure DispInterfaceForward; virtual; + procedure DispIDSpecifier; virtual; // DR 2001-07-26 + procedure EmptyStatement; virtual; + procedure EnumeratedType; virtual; + procedure EnumeratedTypeItem; virtual; // DR 2001-10-29 + procedure ExceptBlock; virtual; + procedure ExceptionBlockElseBranch; virtual; + procedure ExceptionClassTypeIdentifier; virtual; + procedure ExceptionHandler; virtual; + procedure ExceptionHandlerList; virtual; + procedure ExceptionIdentifier; virtual; + procedure ExceptionVariable; virtual; + procedure ExplicitType; virtual; // !! changed spelling to "Explicit" + procedure ExportedHeading; virtual; + procedure ExportsClause; virtual; + procedure ExportsElement; virtual; + procedure Expression; virtual; + procedure ExpressionList; virtual; + procedure ExternalDirective; virtual; + procedure ExternalDirectiveThree; virtual; + procedure ExternalDirectiveTwo; virtual; + procedure Factor; virtual; + procedure FieldDeclaration; virtual; + procedure FieldList; virtual; + procedure FieldNameList; virtual; + procedure FieldName; virtual; + procedure FileType; virtual; + procedure FormalParameterList; virtual; + procedure FormalParameterSection; virtual; + procedure ForStatement; virtual; + procedure ForwardDeclaration; virtual; {GLC: corrected spelling} + procedure FunctionHeading; virtual; + procedure FunctionMethodDeclaration; virtual; + procedure FunctionMethodName; virtual; + procedure FunctionProcedureBlock; virtual; + procedure FunctionProcedureName; virtual; + procedure Identifier; virtual; + procedure IdentifierList; virtual; + procedure IfStatement; virtual; + procedure ImplementationSection; virtual; + procedure IncludeFile; virtual; + procedure IndexSpecifier; virtual; // DR 2001-07-26 + procedure InheritedStatement; virtual; + procedure InitializationSection; virtual; + procedure InlineStatement; virtual; + procedure InParameter; virtual; + procedure InterfaceDeclaration; virtual; + procedure InterfaceForward; virtual; + procedure InterfaceGUID; virtual; + procedure InterfaceHeritage; virtual; + procedure InterfaceMemberList; virtual; + procedure InterfaceSection; virtual; + procedure InterfaceType; virtual; + procedure LabelDeclarationSection; virtual; + procedure LabeledStatement; virtual; + procedure LabelId; virtual; + procedure LibraryFile; virtual; + procedure MainUsedUnitExpression; virtual; + procedure MainUsedUnitName; virtual; + procedure MainUsedUnitStatement; virtual; + procedure MainUsesClause; virtual; + procedure MultiplicativeOperator; virtual; + procedure NewFormalParameterType; virtual; + procedure Number; virtual; + procedure ObjectConstructorHeading; virtual; + procedure ObjectDestructorHeading; virtual; + procedure ObjectField; virtual; + procedure ObjectForward; virtual; + procedure ObjectFunctionHeading; virtual; + procedure ObjectHeritage; virtual; + procedure ObjectMemberList; virtual; + procedure ObjectMethodDirective; virtual; + procedure ObjectMethodHeading; virtual; + procedure ObjectNameOfMethod; virtual; + procedure ObjectProperty; virtual; + procedure ObjectPropertySpecifiers; virtual; + procedure ObjectProcedureHeading; virtual; + procedure ObjectType; virtual; + procedure ObjectTypeEnd; virtual; // DR 2001-08-07 + procedure ObjectVisibility; virtual; + procedure OldFormalParameterType; virtual; + procedure OrdinalIdentifier; virtual; + procedure OrdinalType; virtual; + procedure OutParameter; virtual; + procedure PackageFile; virtual; + procedure ParameterFormal; virtual; + procedure ParameterName; virtual; + procedure ParameterNameList; virtual; + procedure ParseFile; virtual; + procedure PointerType; virtual; + procedure ProceduralDirective; virtual; + procedure ProceduralType; virtual; + procedure ProcedureDeclarationSection; virtual; + procedure ProcedureHeading; virtual; + procedure ProcedureMethodDeclaration; virtual; + procedure ProcedureMethodName; virtual; + procedure ProgramBlock; virtual; + procedure ProgramFile; virtual; + procedure PropertyDefault; virtual; + procedure PropertyInterface; virtual; + procedure PropertyName; virtual; + procedure PropertyParameterConst; virtual; + procedure PropertyParameterList; virtual; + procedure PropertySpecifiers; virtual; + procedure QualifiedIdentifier; virtual; + procedure QualifiedIdentifierList; virtual; + procedure RaiseStatement; virtual; + procedure ReadAccessIdentifier; virtual; + procedure RealIdentifier; virtual; + procedure RealType; virtual; + procedure RecordConstant; virtual; + procedure RecordFieldConstant; virtual; + procedure RecordType; virtual; + procedure RecordVariant; virtual; + procedure RelativeOperator; virtual; + procedure RepeatStatement; virtual; + procedure RequiresClause; virtual; + procedure RequiresIdentifier; virtual; + procedure ResolutionInterfaceName; virtual; + procedure ResourceDeclaration; virtual; + procedure ReturnType; virtual; + procedure SetConstructor; virtual; + procedure SetElement; virtual; + procedure SetType; virtual; + procedure SimpleExpression; virtual; + procedure SimpleStatement; virtual; + procedure SimpleType; virtual; + procedure SkipAnsiComment; virtual; + procedure SkipBorComment; virtual; + procedure SkipSlashesComment; virtual; + procedure SkipSpace; virtual; //XM Jul-2000 + procedure SkipCRLFco; virtual; //XM Jul-2000 + procedure SkipCRLF; virtual; //XM Jul-2000 + procedure Statement; virtual; + procedure StatementList; virtual; + procedure StorageExpression; virtual; + procedure StorageIdentifier; virtual; + procedure StorageDefault; virtual; + procedure StorageNoDefault; virtual; + procedure StorageSpecifier; virtual; + procedure StorageStored; virtual; + procedure StringIdentifier; virtual; + procedure StringStatement; virtual; + procedure StringType; virtual; + procedure StructuredType; virtual; + procedure SubrangeType; virtual; + procedure TagField; virtual; + procedure TagFieldName; virtual; + procedure TagFieldTypeName; virtual; + procedure Term; virtual; + procedure TryStatement; virtual; + procedure TypedConstant; virtual; + procedure TypeDeclaration; virtual; + procedure TypeId; virtual; + procedure TypeKind; virtual; + procedure TypeName; virtual; + //generics + procedure TypeArgs; virtual; + procedure TypeParams; virtual; + procedure TypeParamDecl; virtual; + procedure TypeParamDeclList; virtual; + procedure TypeParamList; virtual; + procedure ConstraintList; virtual; + procedure Constraint; virtual; + //end generics + procedure TypeSection; virtual; + procedure UnitFile; virtual; + procedure UnitId; virtual; + procedure UnitName; virtual; + procedure UsedUnitName; virtual; + procedure UsedUnitsList; virtual; + procedure UsesClause; virtual; + procedure VarAbsolute; virtual; + procedure VarEqual; virtual; + procedure VarDeclaration; virtual; + procedure Variable; virtual; + procedure VariableList; virtual; + procedure VariableReference; virtual; + procedure VariableTwo; virtual; + procedure VariantIdentifier; virtual; + procedure VariantSection; virtual; + procedure VarParameter; virtual; + procedure VarName; virtual; //!! Added VarName and VarNameList back in... + procedure VarNameList; virtual; + procedure VarSection; virtual; + procedure VisibilityAutomated; virtual; + procedure VisibilityPrivate; virtual; + procedure VisibilityProtected; virtual; + procedure VisibilityPublic; virtual; + procedure VisibilityPublished; virtual; + procedure VisibilityUnknown; virtual; + procedure WhileStatement; virtual; + procedure WithStatement; virtual; + procedure WriteAccessIdentifier; virtual; + {$IFDEF D8_NEWER}//JThurman 2004-03-21 + {This is the syntax for custom attributes, based quite strictly on the + ECMA syntax specifications for C#, but with a Delphi expression being + used at the bottom as opposed to a C# expression} + procedure GlobalAttributes; + procedure GlobalAttributeSections; + procedure GlobalAttributeSection; + procedure GlobalAttributeTargetSpecifier; + procedure GlobalAttributeTarget; + procedure Attributes; + procedure AttributeSections; + procedure AttributeSection; + procedure AttributeTargetSpecifier; + procedure AttributeTarget; + procedure AttributeList; + procedure Attribute; + procedure AttributeName; + procedure AttributeArguments; + procedure PositionalArgumentList; + procedure PositionalArgument; + procedure NamedArgumentList; + procedure NamedArgument; + procedure AttributeArgumentExpression; + {$ENDIF} + property ExID: TptTokenKind read GetExID; + property GenID: TptTokenKind read GetGenID; + property TokenID: TptTokenKind read GetTokenID; + public + constructor Create; + destructor Destroy; override; + procedure Assign(From: TObject); virtual; + procedure SynError(Error: TmwParseError); virtual; + procedure Run(SourceStream: TCustomMemoryStream; MaxPos: Integer = -1); virtual; + + property InterfaceOnly: Boolean read fInterfaceOnly write fInterfaceOnly; + property Lexer: TmwPasLex read fLexer; + property OnMessage: TMessageEvent read FOnMessage write FOnMessage; + property LastNoJunkPos: Integer read fLastNoJunkPos; + property LastNoJunkLen: Integer read fLastNoJunkLen; + published + end; + +implementation + +{ ESyntaxError } + +constructor ESyntaxError.Create(const Msg: string); +begin + // !! changed initialization for TTokenPoint + FPosXY.X:= -1; + FPosXY.Y:= -1; + inherited Create(Msg); +end; + +constructor ESyntaxError.CreateFmt(const Msg: string; const Args: array of const); +begin + // !! changed initialization for TTokenPoint + FPosXY.X:= -1; + FPosXY.Y:= -1; + inherited CreateFmt(Msg, Args); +end; + +constructor ESyntaxError.CreatePos(const Msg: string; aPosXY: TTokenPoint); +begin + Message := Msg; + FPosXY := aPosXY; +end; + +{ TmwSimplePasPar } +(* DR 2002-01-16 +const + cnExpected = 'Expected ''%s'' found ''%s'''; +// cnOrExpected = 'Expected ''%s'' or ''%s'' found ''%s'''; + cnEndOfFile = 'end of file'; {jdj 7/22/1999} +// cnIntegerOverflow = 'Integer constant too large'; {jdj 7/22/1999} +*) + + {range checks a tokIntegerConst-slightly faster than StrToInt} +{function IsValidInteger(const S: string): Boolean; jdj 7/22/1999 +var jdj removed 02/07/2001 + C: Integer; + N: Integer; +begin + Val(S, N, C); + Result := (C = 0); +end;} + +procedure TmwSimplePasPar.ForwardDeclaration; +begin {jdj added method 02/07/2001} + NextToken; + SEMICOLON; +end; + +procedure TmwSimplePasPar.ObjectProperty; +begin {jdj added method 02/07/2001} + // DR 2001-08-07 -> changed. for array-property override failure + Expected(tokProperty); + PropertyName; + case TokenID of + tokColon, tokSquareOpen: + begin + PropertyInterface; + end; + end; + ObjectPropertySpecifiers; + case ExID of + tokDefault: + begin + PropertyDefault; //DR 2001-07-16 + SEMICOLON; + end; + end; +end; + +procedure TmwSimplePasPar.ObjectPropertySpecifiers; +begin {jdj added method 02/07/2001} + if ExID = tokIndex then + begin + IndexSpecifier; // DR 2001-08-07 + end; + while ExID in [tokRead, tokReadOnly, tokWrite, tokWriteOnly] do + begin + AccessSpecifier; + end; + while ExID in [tokDefault, tokNoDefault, tokStored] do + begin + StorageSpecifier; + end; + SEMICOLON; +end; + +procedure TmwSimplePasPar.Run(SourceStream: TCustomMemoryStream; MaxPos: Integer = -1); +begin + TerminateStream(SourceStream); + fLexer.Origin := SourceStream.Memory; + fLexer.MaxPos := MaxPos; + + ParseFile; +end; + +constructor TmwSimplePasPar.Create; +begin + inherited Create; + fLexer := TmwPasLex.Create; + fLexer.OnCompDirect := {$IFDEF FPC}@{$ENDIF}HandlePtCompDirect; + fLexer.OnDefineDirect := {$IFDEF FPC}@{$ENDIF}HandlePtDefineDirect; + fLexer.OnElseDirect := {$IFDEF FPC}@{$ENDIF}HandlePtElseDirect; + fLexer.OnEndIfDirect := {$IFDEF FPC}@{$ENDIF}HandlePtEndIfDirect; + fLexer.OnIfDefDirect := {$IFDEF FPC}@{$ENDIF}HandlePtIfDefDirect; + fLexer.OnIfNDefDirect := {$IFDEF FPC}@{$ENDIF}HandlePtIfNDefDirect; + fLexer.OnIfOptDirect := {$IFDEF FPC}@{$ENDIF}HandlePtIfOptDirect; + fLexer.OnIncludeDirect := {$IFDEF FPC}@{$ENDIF}HandlePtIncludeDirect; + fLexer.OnResourceDirect := {$IFDEF FPC}@{$ENDIF}HandlePtResourceDirect; + fLexer.OnUnDefDirect := {$IFDEF FPC}@{$ENDIF}HandlePtUndefDirect; + fLexer.OnIfDirect := {$IFDEF FPC}@{$ENDIF}HandlePtIfDirect; + fLexer.OnIfEndDirect := {$IFDEF FPC}@{$ENDIF}HandlePtIfEndDirect; + fLexer.OnElseIfDirect := {$IFDEF FPC}@{$ENDIF}HandlePtElseIfDirect; +end; + +destructor TmwSimplePasPar.Destroy; +begin + FreeAndNil(AheadParse); + FreeAndNil(fLexer); + + inherited; +end; + +procedure TmwSimplePasPar.Assign(From: TObject); +begin + if (From is TmwSimplePasPar) then + with From as TmwSimplePasPar do + begin + Self.Lexer.CloneDefinesFrom(Lexer); + Self.OnMessage := OnMessage; + end; +end; + +{next two check for tokNull and ExpectedFatal for an EOF Error} + +procedure TmwSimplePasPar.Expected(Sym: TptTokenKind); +begin + if Sym <> Lexer.TokenID then + begin + if TokenID = tokNull then + ExpectedFatal(Sym) {jdj 7/22/1999} + else + begin + if Assigned(FOnMessage) then + FOnMessage(Self, meError, Format(rsExpected, [TokenName(Sym), fLexer.Token]), + fLexer.PosXY.X, fLexer.PosXY.Y); + end; + end + else + NextToken; +end; + +procedure TmwSimplePasPar.ExpectedEx(Sym: TptTokenKind); +begin + if Sym <> Lexer.ExID then + begin + if Lexer.TokenID = tokNull then + ExpectedFatal(Sym) {jdj 7/22/1999} + else if Assigned(FOnMessage) then + FOnMessage(Self, meError, Format(rsExpected, ['EX:' + TokenName(Sym), fLexer.Token]), + fLexer.PosXY.X, fLexer.PosXY.Y); + end + else + NextToken; +end; + +{Replace Token with cnEndOfFile if TokenId = toknull} + +procedure TmwSimplePasPar.ExpectedFatal(Sym: TptTokenKind); +var + tS: string; +begin + if Sym <> Lexer.TokenID then + begin + {--jdj 7/22/1999--} + if Lexer.TokenId = tokNull then + tS := rsEndOfFile + else + tS := fLexer.Token; + {--jdj 7/22/1999--} + raise ESyntaxError.CreatePos(Format(rsExpected, [TokenName(Sym), tS]), fLexer.PosXY); + end + else + NextToken; +end; + +procedure TmwSimplePasPar.HandlePtCompDirect(Sender: TmwBasePasLex); +begin + if Assigned(FOnMessage) then + FOnMessage(Self, meNotSupported, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y); + + Sender.Next; //XM Jul-2000 + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtDefineDirect(Sender: TmwBasePasLex); +begin + Sender.Next; //XM Jul-2000 +end; + +procedure TmwSimplePasPar.HandlePtElseDirect(Sender: TmwBasePasLex); +begin + if Sender = Lexer then + NextToken + else + Sender.Next; //XM Jul-2000 + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtElseIfDirect(Sender: TmwBasePasLex); +begin + if Sender = Lexer then + NextToken + else + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtEndIfDirect(Sender: TmwBasePasLex); +begin + if Sender = Lexer then + NextToken + else + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtIfDefDirect(Sender: TmwBasePasLex); +begin + if Sender = Lexer then + NextToken + else + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtIfDirect(Sender: TmwBasePasLex); +begin + if Sender = Lexer then + NextToken + else + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtIfEndDirect(Sender: TmwBasePasLex); +begin + if Sender = Lexer then + NextToken + else + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtIfNDefDirect(Sender: TmwBasePasLex); +begin + if Sender = Lexer then + NextToken + else + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtIfOptDirect(Sender: TmwBasePasLex); +begin + if Assigned(FOnMessage) then + FOnMessage(Self, meNotSupported, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y); + + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtIncludeDirect(Sender: TmwBasePasLex); +begin + if Assigned(FOnMessage) then + FOnMessage(Self, meNotSupported, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y); + + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtResourceDirect(Sender: TmwBasePasLex); +begin + if Assigned(FOnMessage) then + FOnMessage(Self, meNotSupported, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y); + + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtUndefDirect(Sender: TmwBasePasLex); +begin + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.NextToken; +begin + FLexer.NextNoJunk; +end; + +procedure TmwSimplePasPar.SkipJunk; +begin + if Lexer.IsJunk then + begin + case TokenID of + tokAnsiComment: + begin + SkipAnsiComment; + end; + tokBorComment: + begin + SkipBorComment; + end; + tokSlashesComment: + begin + SkipSlashesComment; + end; + tokSpace: + begin + SkipSpace; //XM Jul-2000 + end; + tokCRLFCo: + begin + SkipCRLFco; + end; + tokCRLF: + begin + SkipCRLF; + end; + {$IFDEF D8_NEWER} //JThurman 2004-3-19 + tokSquareOpen: + begin + CustomAttribute; + end; + {$ENDIF} + else + begin + Lexer.Next; + end; + end; + end; + fLastNoJunkPos := Lexer.TokenPos; + fLastNoJunkLen := Lexer.TokenLen; +end; + +procedure TmwSimplePasPar.SkipAnsiComment; +begin + Expected(tokAnsiComment); + while TokenID in [tokAnsiComment] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.SkipBorComment; +begin + Expected(tokBorComment); + while TokenID in [tokBorComment] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.SkipSlashesComment; +begin + Expected(tokSlashesComment); +end; + +procedure TmwSimplePasPar.TerminateStream(Stream: TCustomMemoryStream); +var + aChar: Char; +begin + Stream.Position := Stream.Size; + aChar := #0; + Stream.Write(aChar, SizeOf(char)); +end; + +procedure TmwSimplePasPar.SEMICOLON; +begin + case Lexer.TokenID of + tokElse, tokEnd, tokExcept, tokfinally, tokFinalization, tokRoundClose, tokUntil: // jdj 2.23.20001 added tokFinalization + ; + else + Expected(tokSemiColon); + //Check for semicolon before else - common syntax error - JT 11.10.2007 + //Doesn't work here - it fails a CASE statement +// if Lexer.TokenID = tokElse then +// begin +// if Assigned(FOnMessage) then +// begin +// FOnMessage(Self, meError, ''';'' not allowed before ''ELSE''', +// FLexer.PosXY.X, FLexer.PosXY.Y); +// end; +// end; + end; +end; + +function TmwSimplePasPar.GetExID: TptTokenKind; +begin + Result := fLexer.ExID; +end; + +function TmwSimplePasPar.GetTokenID: TptTokenKind; +begin + Result := fLexer.TokenID; +end; + +function TmwSimplePasPar.GetGenID: TptTokenKind; +begin + Result := fLexer.GenID; +end; + +procedure TmwSimplePasPar.SynError(Error: TmwParseError); +begin + if Assigned(FOnMessage) then + FOnMessage(Self, meError, ParserErrorName(Error) + ' found ' + fLexer.Token, fLexer.PosXY.X, + fLexer.PosXY.Y); + +end; + +(****************************************************************************** + This part is oriented at the official grammar of Delphi 4 + and parialy based on Robert Zierers Delphi grammar. + For more information about Delphi grammars take a look at: + http://www.stud.mw.tu-muenchen.de/~rz1/Grammar.html +******************************************************************************) + +procedure TmwSimplePasPar.ParseFile; +//var +// I: Integer; +begin +// OutputDebugString('ParseFile'); + + SkipJunk; + case GenID of + tokLibrary: + begin + LibraryFile; + end; + tokPackage: + begin + PackageFile; + end; + tokProgram: + begin + ProgramFile; + end; + tokUnit: + begin + UnitFile; + end; + else + begin + IncludeFile; + end; + end; +end; + +procedure TmwSimplePasPar.LibraryFile; +begin + Expected(tokLibrary); + Expected(tokIdentifier); + SEMICOLON; + ProgramBlock; + Expected(tokPoint); +end; + +procedure TmwSimplePasPar.PackageFile; +begin + ExpectedEx(tokPackage); + Expected(tokIdentifier); + + {$IFDEF D8_NEWER} + while Lexer.TokenID = tokPoint do + begin + NextToken; + Expected(tokIdentifier); + end; + {$ENDIF} + + SEMICOLON; + case ExID of + tokRequires: + begin + RequiresClause; + end; + end; + case ExID of + tokContains: + begin + ContainsClause; + end; + end; + + {$IFDEF D8_NEWER} + while Lexer.TokenID = tokSquareOpen do + begin + CustomAttribute; + end; + {$ENDIF} + + Expected(tokEnd); + Expected(tokPoint); +end; + +procedure TmwSimplePasPar.ProgramFile; +begin + // DR 2002-01-11 + Expected(tokProgram); + QualifiedIdentifier; + if TokenID = tokRoundOpen then + begin + NextToken; + IdentifierList; + Expected(tokRoundClose); + end; + if not InterfaceOnly then + begin + SEMICOLON; + ProgramBlock; + Expected(tokPoint); + end; +end; + +procedure TmwSimplePasPar.UnitFile; +begin + // DR 2002-01-11 + +//?? + Expected(tokUnit); + UnitName; + + while ExID in [tokDeprecated, tokLibrary, tokPlatform] do + case ExID of + tokDeprecated: DirectiveDeprecated; + tokLibrary: DirectiveLibrary; + tokPlatform: DirectivePlatform; + end; + + SEMICOLON; + InterfaceSection; + if not InterfaceOnly then + begin + ImplementationSection; + InitializationSection; + Expected(tokPoint); + end; +end; + +procedure TmwSimplePasPar.ProgramBlock; +begin + if TokenID = tokUses then + begin + MainUsesClause; + end; + Block; +end; + +procedure TmwSimplePasPar.MainUsesClause; +begin + Expected(tokUses); + MainUsedUnitStatement; + while TokenID = tokComma do + begin + NextToken; + MainUsedUnitStatement; + end; + SEMICOLON; +end; + +procedure TmwSimplePasPar.MainUsedUnitStatement; +begin + MainUsedUnitName; + if Lexer.TokenID = tokIn then + begin + NextToken; + MainUsedUnitExpression; + end; +end; + +procedure TmwSimplePasPar.MainUsedUnitName; +begin +// Expected(tokIdentifier); + UsedUnitName; //JThurman 2004-11-10 +end; + +procedure TmwSimplePasPar.MainUsedUnitExpression; +begin + ConstantExpression; +end; + +procedure TmwSimplePasPar.UsesClause; +begin + Expected(tokUses); + UsedUnitsList; + SEMICOLON; +end; + +procedure TmwSimplePasPar.UsedUnitsList; +begin + UsedUnitName; + while TokenID = tokComma do + begin + NextToken; + UsedUnitName; + end; +end; + +procedure TmwSimplePasPar.UsedUnitName; +begin + {$IFDEF D8_NEWER} //JThurman 2004-03-03 + Expected(tokIdentifier); + while TokenID = tokPoint do + begin + NextToken; + Expected(tokIdentifier); + end; + {$ELSE} + Expected(tokIdentifier); + {$ENDIF} +end; + +procedure TmwSimplePasPar.Block; +begin + while TokenID in [tokClass, tokConst, tokConstructor, tokDestructor, tokExports, + tokFunction, tokLabel, tokProcedure, tokResourceString, tokThreadVar, tokType, + tokVar{$IFDEF D8_NEWER}, tokSquareOpen{$ENDIF}] do + begin + DeclarationSection; + end; + case TokenID of + tokAsm: + begin + AsmStatement; + end; + else + begin + CompoundStatement; + end; + end; +end; + +procedure TmwSimplePasPar.DeclarationSection; +begin + case TokenID of + tokClass: + begin + ProcedureDeclarationSection; + end; + tokConst: + begin + ConstSection; + end; + tokConstructor: + begin + ProcedureDeclarationSection; + end; + tokDestructor: + begin + ProcedureDeclarationSection; + end; + tokExports: + begin + ExportsClause; + end; + tokFunction: + begin + ProcedureDeclarationSection; + end; + tokLabel: + begin + LabelDeclarationSection; + end; + tokProcedure: + begin + ProcedureDeclarationSection; + end; + tokResourceString: + begin + ConstSection; + end; + tokType: + begin + TypeSection; + end; + tokThreadVar: + begin + VarSection; + end; + tokVar: + begin + VarSection; + end; + {$IFDEF D8_NEWER} //JThurman + tokSquareOpen: + begin + CustomAttribute; + end; + {$ENDIF} + else + begin + SynError(InvalidDeclarationSection); + end; + end; +end; + +procedure TmwSimplePasPar.UnitId; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.UnitName; +begin + Expected(tokIdentifier); + while Lexer.TokenID = tokPoint do + begin + NextToken; + Expected(tokIdentifier); + end; +end; + +procedure TmwSimplePasPar.InterfaceHeritage; +begin + Expected(tokRoundOpen); + AncestorIdList; // JR moved qualified check into ancestorIdList // DR 2001-11-01 can also be qualified! + Expected(tokRoundClose); +end; + +procedure TmwSimplePasPar.InterfaceGUID; +begin + Expected(tokSquareOpen); + CharString; + Expected(tokSquareClose); +end; + +procedure TmwSimplePasPar.AccessSpecifier; +begin + case ExID of + tokRead: + begin + NextToken; + ReadAccessIdentifier; + end; + tokWrite: + begin + NextToken; + WriteAccessIdentifier; + end; + tokReadOnly: + begin + NextToken; + end; + tokWriteOnly: + begin + NextToken; + end; + {$IFDEF D8_NEWER} + tokAdd: + begin + NextToken; + QualifiedIdentifier; //TODO: AddAccessIdentifier + end; + tokRemove: + begin + NextToken; + QualifiedIdentifier; //TODO: RemoveAccessIdentifier + end; + {$ENDIF} + else + begin + SynError(InvalidAccessSpecifier); + end; + end; +end; + +procedure TmwSimplePasPar.ReadAccessIdentifier; +begin + QualifiedIdentifier; + (* XM removed at Martin suggestion. Martin send a more general fix in QualifiedIdentifier + //jdj 12/05/2000 + if (TokenID = tokSquareOpen) then + begin + ConstantExpression; + end; + //jdj 12/05/2000*) +end; + +procedure TmwSimplePasPar.WriteAccessIdentifier; +begin + QualifiedIdentifier; + (* XM removed at Martin suggestion. Martin send a more general fix in QualifiedIdentifier + //jdj 12/05/2000 + if (TokenID = tokSquareOpen) then + begin + ConstantExpression; + end; + //jdj 12/05/2000*) +end; + +procedure TmwSimplePasPar.StorageSpecifier; +begin + case ExID of + tokStored: + begin + StorageStored; + end; + tokDefault: + begin + StorageDefault; + end; + tokNoDefault: + begin + StorageNoDefault; + end + else + begin + SynError(InvalidStorageSpecifier); + end; + end; +end; + +procedure TmwSimplePasPar.StorageDefault; +begin + ExpectedEx(tokDefault); + StorageExpression; +end; + +procedure TmwSimplePasPar.StorageNoDefault; +begin + ExpectedEx(tokNoDefault); +end; + +procedure TmwSimplePasPar.StorageStored; +begin + ExpectedEx(tokStored); + case TokenID of + tokIdentifier: + begin + StorageIdentifier; + end; + else + if TokenID <> tokSemiColon then + begin + StorageExpression; + end; + end; +end; + +procedure TmwSimplePasPar.StorageExpression; +begin + ConstantExpression; +end; + +procedure TmwSimplePasPar.StorageIdentifier; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.PropertyParameterList; +//changed James Jacobson on 20001221 +begin + Expected(tokSquareOpen); + if TokenID = tokConst then + begin + PropertyParameterConst; + end; + IdentifierList; + Expected(tokColon); + TypeId; + while TokenID = tokSemiColon do + begin + SEMICOLON; + if TokenID = tokConst then + begin //jdj 12-21-2000 + PropertyParameterConst; + end; + IdentifierList; + Expected(tokColon); + TypeId; + end; + Expected(tokSquareClose); +end; + +(*begin + Expected(tokSquareOpen); + if TokenID = tokConst then + begin + PropertyParameterConst; + end; + IdentifierList; + Expected(tokColon); + TypeId; + while TokenID = tokSemiColon do + begin + SEMICOLON; + IdentifierList; + Expected(tokColon); + TypeId; + end; + Expected(tokSquareClose); +end;*) + +procedure TmwSimplePasPar.PropertyParameterConst; +begin + Expected(tokConst); +end; + +procedure TmwSimplePasPar.PropertySpecifiers; +begin + if ExID = tokIndex then + begin + IndexSpecifier; // DR 2001-07-26 + end; + while ExID in [tokRead, tokReadOnly, tokWrite, tokWriteOnly + {$IFDEF D8_NEWER}, tokAdd, tokRemove{$ENDIF}] do + begin + AccessSpecifier; + end; + if ExID = tokDispId then + begin + DispIDSpecifier; // DR 2001-07-26 + end; + while ExID in [tokDefault, tokNoDefault, tokStored] do + begin + StorageSpecifier; + end; + if ExID = tokImplements then + begin + NextToken; + QualifiedIdentifierList; + end; + SEMICOLON; +end; + +procedure TmwSimplePasPar.PropertyInterface; +begin + if TokenID = tokSquareOpen then + begin + PropertyParameterList; + end; + Expected(tokColon); + TypeID; +end; + +procedure TmwSimplePasPar.ClassMethodHeading; +begin + case TokenID of + tokConstructor: + begin + ConstructorHeading; + end; + tokDestructor: + begin + DestructorHeading; + end; + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + tokFunction, tokIdentifier: + begin + if (TokenID = tokIdentifier) and (Lexer.ExID <> tokOperator) then + Expected(tokOperator); + {$ELSE} + tokFunction: + begin + {$ENDIF} + Lexer.InitAhead; + Lexer.AheadNext; + case Lexer.AheadTokenID of + tokPoint: + begin + ClassMethodResolution; + end; + else + begin + ClassFunctionHeading; + end; + end; + end; + tokProcedure: + begin + Lexer.InitAhead; + Lexer.AheadNext; + case Lexer.AheadTokenID of + tokPoint: + begin + ClassMethodResolution; + end; + else + begin + ClassProcedureHeading; + end; + end; + end; + else + SynError(InvalidClassMethodHeading); + end; +end; + +procedure TmwSimplePasPar.ClassFunctionHeading; +begin + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + if (TokenID = tokIdentifier) and (Lexer.ExID = tokOperator) then + Expected(tokIdentifier) else + {$ENDIF} + Expected(tokFunction); + FunctionMethodName; + if TokenID = tokRoundOpen then + begin + FormalParameterList; + end; + Expected(tokColon); + ReturnType; + if TokenId = tokSemicolon then // DR 2002-01-14 + SEMICOLON; + if ExID = tokDispId then + begin + DispIDSpecifier; // DR 2001-07-26 + if TokenId = tokSemicolon then // DR 2002-01-14 + SEMICOLON; + end; + if ExID in ClassMethodDirectiveEnum //XM 2002-01-29 + then ClassMethodDirective; //XM 2002-01-26 +end; + +procedure TmwSimplePasPar.FunctionMethodName; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.ClassProcedureHeading; +begin + Expected(tokProcedure); + ProcedureMethodName; + if TokenID = tokRoundOpen then + begin + FormalParameterList; + end; + + if TokenId = tokSemicolon then // DR 2002-01-14 + SEMICOLON; + + if ExID = tokDispId then + begin + DispIDSpecifier; // DR 2001-07-26 + if TokenId = tokSemicolon then // DR 2002-01-14 + SEMICOLON; + end; + if exID in ClassMethodDirectiveEnum then // XM 2002-01-29 + ClassMethodDirective; +end; + +procedure TmwSimplePasPar.ProcedureMethodName; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.ClassMethodResolution; +begin + case TokenID of + tokFunction: + begin + NextToken; + end; + tokProcedure: + begin + NextToken; + end; + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + tokIdentifier: + begin + if Lexer.ExID = tokOperator then + NextToken; + end; + {$ENDIF} + end; + ResolutionInterfaceName; + Expected(tokPoint); + Expected(tokIdentifier); + Expected(tokEqual); + Expected(tokIdentifier); + SEMICOLON; +end; + +procedure TmwSimplePasPar.ResolutionInterfaceName; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.Constraint; +begin + while TokenId in [tokConstructor, tokRecord, tokClass, tokIdentifier] do + begin + case TokenId of + tokConstructor, tokRecord, tokClass: NextToken; + tokIdentifier: TypeId; + end; + if TokenId = tokComma then + NextToken; + end; +end; + +procedure TmwSimplePasPar.ConstraintList; +begin + Constraint; + while TokenId = tokComma do + begin + Constraint; + end; +end; + +procedure TmwSimplePasPar.ConstructorHeading; +begin + Expected(tokConstructor); + ConstructorName; + if TokenID = tokRoundOpen then + begin + FormalParameterList; + end; + SEMICOLON; + ClassMethodDirective; +end; + +procedure TmwSimplePasPar.ConstructorName; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.DestructorHeading; +begin + Expected(tokDestructor); + DestructorName; + if TokenID = tokRoundOpen then + begin + FormalParameterList; + end; + SEMICOLON; + ClassMethodDirective; +end; + +procedure TmwSimplePasPar.DestructorName; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.ClassMethodDirective; +begin + while ExId in ClassMethodDirectiveEnum do + begin + ProceduralDirective; + if TokenId = tokSemicolon then // DR 2002-01-14 + SEMICOLON; + end; +end; + +procedure TmwSimplePasPar.ObjectMethodHeading; +begin + case TokenID of + tokConstructor: + begin + ObjectConstructorHeading; + end; + tokDestructor: + begin + ObjectDestructorHeading; + end; + tokFunction: + begin + ObjectFunctionHeading; + end; + tokProcedure: + begin + ObjectProcedureHeading; + end; + else + begin + SynError(InvalidMethodHeading); + end; + end; +end; + +procedure TmwSimplePasPar.ObjectFunctionHeading; +begin + Expected(tokFunction); + FunctionMethodName; + if TokenID = tokRoundOpen then + begin + FormalParameterList; + end; + Expected(tokColon); + ReturnType; + if TokenID = tokSemiColon then SEMICOLON; + ObjectMethodDirective; +end; + +procedure TmwSimplePasPar.ObjectProcedureHeading; +begin + Expected(tokProcedure); + ProcedureMethodName; + if TokenID = tokRoundOpen then + begin + FormalParameterList; + end; + if TokenID = tokSemiColon then SEMICOLON; + ObjectMethodDirective; +end; + +procedure TmwSimplePasPar.ObjectConstructorHeading; +begin + Expected(tokConstructor); + ConstructorName; + if TokenID = tokRoundOpen then + begin + FormalParameterList; + end; + if TokenID = tokSemiColon then SEMICOLON; + ObjectMethodDirective; +end; + +procedure TmwSimplePasPar.ObjectDestructorHeading; +begin + Expected(tokDestructor); + DestructorName; + if TokenID = tokRoundOpen then + begin + FormalParameterList; + end; + if TokenID = tokSemiColon then SEMICOLON; + ObjectMethodDirective; +end; + +procedure TmwSimplePasPar.ObjectMethodDirective; +begin + while ExID in [tokAbstract, tokCdecl, tokDynamic, tokExport, tokExternal, tokFar, + tokMessage, tokNear, + tokOverload, // DR 2001-08-07 + tokPascal, tokRegister, tokSafeCall, tokStdCall, tokVirtual, + tokDeprecated, tokLibrary, tokPlatform // DR 2001-10-20 + {$IFDEF D8_NEWER} + , tokStatic + {$ENDIF} + {$IFDEF D9_NEWER} + , tokInline + {$ENDIF} + ] do + begin + ProceduralDirective; + if TokenID = tokSemiColon then SEMICOLON; + end; +end; + +procedure TmwSimplePasPar.Directive16Bit; +begin + case ExID of + tokNear: + begin + NextToken; + end; + tokFar: + begin + NextToken; + end; + tokExport: + begin + NextToken; + end; + else + begin + SynError(InvalidDirective16Bit); + end; + end; +end; + +procedure TmwSimplePasPar.DirectiveBinding; +begin + case ExID of + tokVirtual: + begin + NextToken; + end; + tokDynamic: + begin + NextToken; + end; + tokMessage: + begin + NextToken; + ConstantExpression; + end; + tokOverride: + begin + NextToken; + end; + tokOverload: + begin + NextToken; + end; + tokReintroduce: + begin + NextToken; + end; + else + begin + SynError(InvalidDirectiveBinding); + end; + end; +end; + +procedure TmwSimplePasPar.ReturnType; +begin + {$IFDEF D8_NEWER} + while TokenID = tokSquareOpen do + CustomAttribute; + {$ENDIF} + case TokenID of + tokString: + begin + StringType; + end; + else + begin + TypeID; + end; + end; +end; + +procedure TmwSimplePasPar.FormalParameterList; +begin + Expected(tokRoundOpen); + FormalParameterSection; + while TokenID = tokSemiColon do + begin + SEMICOLON; + FormalParameterSection; + end; + Expected(tokRoundClose); +end; + +procedure TmwSimplePasPar.FormalParameterSection; +begin + {$IFDEF D8_NEWER}//JThurman 2004-03-23 + while TokenID = tokSquareOpen do + CustomAttribute; + {$ENDIF} + case TokenID of + tokConst: + begin + ConstParameter; + end; + tokIdentifier: + case ExID of + tokOut: OutParameter; + else + ParameterFormal; + end; + tokIn: + begin + InParameter; + end; + tokVar: + begin + VarParameter; + end; + end; +end; + +procedure TmwSimplePasPar.ConstParameter; +begin + Expected(tokConst); + ParameterNameList; + case TokenID of + tokColon: + begin + NextToken; + NewFormalParameterType; + if TokenID = tokEqual then + begin + NextToken; + TypedConstant; + end; + end + end; +end; + +procedure TmwSimplePasPar.VarParameter; +begin + Expected(tokVar); + ParameterNameList; + case TokenID of + tokColon: + begin + NextToken; + NewFormalParameterType; + end + end; +end; + +procedure TmwSimplePasPar.OutParameter; +begin + ExpectedEx(tokOut); + ParameterNameList; + case TokenID of + tokColon: + begin + NextToken; + NewFormalParameterType; + end + end; +end; + +procedure TmwSimplePasPar.ParameterFormal; +begin + case TokenID of + tokIdentifier: + begin + ParameterNameList; + + case TokenID of + tokColon: + begin + NextToken; + NewFormalParameterType; + if TokenID = tokEqual then + begin + NextToken; + TypedConstant; + end; + end + end; + + {Expected(tokColon); + NewFormalParameterType; + if TokenID = tokEqual then + begin + NextToken; + TypedConstant; + end;} + end; + else + begin + SynError(InvalidParameter); + end; + end; +end; + +procedure TmwSimplePasPar.ParameterNameList; +begin + ParameterName; + while TokenID = tokComma do + begin + NextToken; + ParameterName; + end; +end; + +procedure TmwSimplePasPar.ParameterName; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.NewFormalParameterType; +begin + case TokenID of + tokArray: + begin + NextToken; + Expected(tokOf); + case TokenID of + tokConst: (*new in ObjectPascal80*) + begin + NextToken; + end; + else + begin + OldFormalParameterType; + end; + end; + end; + else + begin + OldFormalParameterType; + end; + end; +end; + +procedure TmwSimplePasPar.OldFormalParameterType; +begin + case TokenID of + tokString: + begin + NextToken; + end; + tokFile: + begin + FileType; + end; + else + begin + TypeID; + end; + end; +end; + +procedure TmwSimplePasPar.FunctionMethodDeclaration; +begin + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + if (TokenID = tokIdentifier) and (Lexer.ExID = tokOperator) then + NextToken else + {$ENDIF} + Expected(tokFunction); + Lexer.InitAhead; + if Lexer.AheadTokenID in [tokPoint, tokLower] then + begin + ObjectNameOfMethod; + Expected(tokPoint); + end; + FunctionProcedureName; + if TokenID = tokRoundOpen then + begin + FormalParameterList; + end; + case TokenID of + tokSemiColon: + begin + FunctionProcedureBlock; + end; + else + begin + Expected(tokColon); + ReturnType; + FunctionProcedureBlock; + end; + end; +end; + +procedure TmwSimplePasPar.ProcedureMethodDeclaration; +begin + case TokenID of + tokConstructor: + begin + NextToken; + end; + tokDestructor: + begin + NextToken; + end; + tokProcedure: + begin + NextToken; + end; + else + begin + SynError(InvalidProcedureMethodDeclaration); + end; + end; + Lexer.InitAhead; + if Lexer.AheadTokenID in [tokPoint, tokLower] then + begin + ObjectNameOfMethod; + Expected(tokPoint); + end; + FunctionProcedureName; + if TokenID = tokRoundOpen then + begin + FormalParameterList; + end; + FunctionProcedureBlock; +end; + +procedure TmwSimplePasPar.FunctionProcedureName; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.ObjectNameOfMethod; +begin + Expected(tokIdentifier); + {$IFDEF D8_NEWER} //JThurman 2004-03-22 + if TokenId = tokLower then + TypeParams; + Lexer.InitAHead; + Lexer.AheadNext; + if Lexer.AheadTokenID = tokPoint then + begin + Expected(tokPoint); + ObjectNameOfMethod; + end; + {$ENDIF} +end; + +procedure TmwSimplePasPar.FunctionProcedureBlock; +var + NoExternal: Boolean; +begin + NoExternal := True; + if TokenID = tokSemiColon + then SEMICOLON; + case ExID of + tokForward: + ForwardDeclaration; // DR 2001-07-23 + else + while ExID in [tokAbstract, tokCdecl, tokDynamic, tokExport, tokExternal, tokFar, + tokMessage, tokNear, tokOverload, tokOverride, tokPascal, tokRegister, + tokReintroduce, tokSafeCall, tokStdCall, tokVirtual, + tokDeprecated, tokLibrary, tokPlatform, // DR 2001-10-20 + tokLocal, tokVarargs, + tokAssembler //JT 2004-10-29 + {$IFDEF D8_NEWER} + , tokStatic + {$ENDIF} + {$IFDEF D9_NEWER} + , tokInline + {$ENDIF} + ] // DR 2001-11-14 + do + begin + case ExId of + tokExternal: + begin + ProceduralDirective; + if TokenID = tokSemiColon then SEMICOLON; + NoExternal := False; + end; + else + begin + ProceduralDirective; + if TokenID = tokSemiColon then SEMICOLON; + end; + end; + end; + if ExID = tokForward then + ForwardDeclaration // DR 2001-07-23 + else if NoExternal then + begin + if ExId = tokAssembler then + begin + NextToken; + SEMICOLON; + end; + case TokenID of + tokAsm: + begin + AsmStatement; + end; + else + begin + Block; + end; + end; + SEMICOLON; + end; + end; +end; + +procedure TmwSimplePasPar.ExternalDirective; +begin + ExpectedEx(tokExternal); + case TokenID of + tokSemiColon: + begin + SEMICOLON; + end; + else + begin + SimpleExpression; + ExternalDirectiveTwo; + end; + end; +end; + +procedure TmwSimplePasPar.ExternalDirectiveTwo; +begin + case fLexer.ExID of + tokIndex: + begin + NextToken; + end; + tokName: + begin + NextToken; + SimpleExpression; + end; + tokSemiColon: + begin + SEMICOLON; + ExternalDirectiveThree; + end; + end +end; + +procedure TmwSimplePasPar.ExternalDirectiveThree; +begin + case TokenID of + tokMinus: + begin + NextToken; + end; + end; + case TokenID of + tokIdentifier, tokIntegerConst: + begin + NextToken; + end; + end; +end; + +procedure TmwSimplePasPar.ForStatement; +begin + Expected(tokFor); + QualifiedIdentifier; + {$IFDEF D8_NEWER} + if Lexer.TokenID = tokAssign then + begin + Expected(tokAssign); + Expression; + case TokenID of + tokTo: + begin + NextToken; + end; + tokDownTo: + begin + NextToken; + end; + else + begin + SynError(InvalidForStatement); + end; + end; + Expression; + end else + if Lexer.TokenID = tokIn then + begin + Expected(tokIn); + //QualifiedIdentifier; + Expression; + end; + {$ELSE} + Expected(tokAssign); + Expression; + case TokenID of + tokTo: + begin + NextToken; + end; + tokDownTo: + begin + NextToken; + end; + else + begin + SynError(InvalidForStatement); + end; + end; + Expression; + {$ENDIF} + Expected(tokDo); + Statement; +end; + +procedure TmwSimplePasPar.WhileStatement; +begin + Expected(tokWhile); + Expression; + Expected(tokDo); + Statement; +end; + +procedure TmwSimplePasPar.RepeatStatement; +begin + Expected(tokRepeat); + StatementList; + Expected(tokUntil); + Expression; +end; + +procedure TmwSimplePasPar.CaseStatement; +begin + Expected(tokCase); + Expression; + Expected(tokOf); + CaseSelector; + while TokenID = tokSemiColon do + begin + SEMICOLON; + case TokenID of + tokElse, tokEnd: ; + else + CaseSelector; + end; + end; + if TokenID = tokElse then + begin + NextToken; + StatementList; + SEMICOLON; + end; + Expected(tokEnd); +end; + +procedure TmwSimplePasPar.CaseSelector; +begin + CaseLabel; + while TokenID = tokComma do + begin + NextToken; + CaseLabel; + end; + Expected(tokColon); + case TokenID of + tokSemiColon: ; + else + Statement; + end; +end; + +procedure TmwSimplePasPar.CaseLabel; +begin + ConstantExpression; + if TokenID = tokDotDot then + begin + NextToken; + ConstantExpression; + end; +end; + +procedure TmwSimplePasPar.IfStatement; +begin + Expected(tokIf); + Expression; + Expected(tokThen); + Statement; + //This breaks if you have an if statement immediately preceding the else + //clause of a case statement +{ Lexer.InitAhead; + if (TokenID = tokSemicolon) and (Lexer.AheadTokenID = tokElse) then + begin + if Assigned(FOnMessage) then + begin + FOnMessage(Self, meError, ''';'' not allowed before ''ELSE''', + FLexer.PosXY.X, FLexer.PosXY.Y); + end; + end;} + if TokenID = tokElse then + begin + NextToken; + Statement; + end; +end; + +procedure TmwSimplePasPar.ExceptBlock; +begin + case ExID of + tokOn: + begin + ExceptionHandlerList; + ExceptionBlockElseBranch + end; + else + begin + StatementList; + end; + end; +end; + +procedure TmwSimplePasPar.ExceptionHandlerList; +begin + while fLexer.ExID = tokOn do + begin + ExceptionHandler; + SEMICOLON; + end; +end; + +procedure TmwSimplePasPar.ExceptionHandler; +begin + ExpectedEx(tokOn); + ExceptionIdentifier; + Expected(tokDo); + Statement; +end; + +procedure TmwSimplePasPar.ExceptionBlockElseBranch; +begin + case TokenID of + tokElse: + begin + NextToken; + StatementList; + end; + end; +end; + +procedure TmwSimplePasPar.ExceptionIdentifier; +begin + Lexer.InitAhead; + case Lexer.AheadTokenID of + tokPoint: + begin + ExceptionClassTypeIdentifier; + end; + else + begin + ExceptionVariable; + case Lexer.TokenID of + tokColon: + begin + NextToken; + ExceptionClassTypeIdentifier; + end; + end; + end; + end; +end; + +procedure TmwSimplePasPar.ExceptionClassTypeIdentifier; +begin + QualifiedIdentifier; +end; + +procedure TmwSimplePasPar.ExceptionVariable; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.InlineStatement; +begin + Expected(tokInline); + Expected(tokRoundOpen); + Expected(tokIntegerConst); + while (TokenID = tokSlash) do + begin + NextToken; + Expected(tokIntegerConst); + end; + Expected(tokRoundClose); +end; + +procedure TmwSimplePasPar.InParameter; +begin + Expected(tokIn); + ParameterNameList; + case TokenID of + tokColon: + begin + NextToken; + NewFormalParameterType; + if TokenID = tokEqual then + begin + NextToken; + TypedConstant; + end; + end + end; +end; + +procedure TmwSimplePasPar.AsmStatement; +begin + Lexer.AsmCode := True; + Expected(tokAsm); + { should be replaced with a Assembler lexer } + while TokenID <> tokEnd do + case fLexer.TokenID of + tokBegin, tokCase, tokEnd, tokIf, tokFunction, tokProcedure, tokRepeat, tokwhile: break; + tokAddressOp: + begin + NextToken; + NextToken; + end; + tokDoubleAddressOp: + begin + NextToken; + NextToken; + end; + tokNull: //JThurman 10-26-2004. Need another way out of this. + begin + Expected(tokEnd); + Exit; + end; + else + NextToken; + end; + Lexer.AsmCode := False; + Expected(tokEnd); +end; + +procedure TmwSimplePasPar.RaiseStatement; +begin + Expected(tokRaise); + case TokenID of + tokAddressOp, tokDoubleAddressOp, tokIdentifier, tokPointerSymbol, tokRoundOpen: + begin + Designator; + end; + end; + if ExID = tokAt then + begin + NextToken; + Expression; + end; +end; + +procedure TmwSimplePasPar.TryStatement; +begin + Expected(tokTry); + StatementList; + case TokenID of + tokExcept: + begin + NextToken; + ExceptBlock; + + if (TokenID = tokFinally) then + begin + NextToken; + StateMentList; + end; + + Expected(tokEnd); + end; + tokFinally: + begin + NextToken; + StatementList; + + if (TokenID = tokExcept) then + begin + NextToken; + StateMentList; + end; + + Expected(tokEnd); + end; + else + begin + SynError(InvalidTryStatement); + end; + end; +end; + +procedure TmwSimplePasPar.WithStatement; +begin + Expected(tokWith); + VariableList; + Expected(tokDo); + Statement; +end; + +procedure TmwSimplePasPar.VariableList; +begin + VariableReference; (* acessing func.recordfield not allowed here;as well as UNITNAMEID *) + while fLexer.TokenID = tokComma do + begin + NextToken; + VariableReference; + end; +end; + +procedure TmwSimplePasPar.StatementList; +begin {removed tokIntegerConst jdj-Put back in for labels} + while TokenID in [tokAddressOp, tokAsm, tokBegin, tokCase, tokDoubleAddressOp, + tokFor, tokGoTo, tokIdentifier, tokIf, tokInherited, tokInline, tokIntegerConst, + tokPointerSymbol, tokRaise, tokRoundOpen, tokRepeat, tokSemiColon, tokString, + tokTry, tokWhile, tokWith] do + begin + Statement; + SEMICOLON; + end; +end; + +procedure TmwSimplePasPar.SimpleStatement; +begin + case TokenID of + tokAddressOp, tokDoubleAddressOp, tokIdentifier, tokPointerSymbol, tokRoundOpen: + begin + Designator; + if TokenID = tokAssign then + begin + NextToken; + if TokenID = tokInherited then + begin + NextToken; + end; + Expression; + end; + end; + tokGoTo: + begin + NextToken; + LabelId; + end; + end; +end; + +procedure TmwSimplePasPar.Statement; +begin + case TokenID of + tokAsm: + begin + AsmStatement; + end; + tokBegin: + begin + CompoundStatement; + end; + tokCase: + begin + CaseStatement; + end; + tokFor: + begin + ForStatement; + end; + tokIf: + begin + IfStatement; + end; + tokIdentifier: + begin + fLexer.InitAhead; + case Lexer.AheadTokenID of + tokColon: + begin + LabeledStatement; + end; + else + begin + SimpleStatement; + end; + end; + end; + tokInherited: + begin + InheritedStatement; + end; + tokInLine: + begin + InlineStatement; + end; + tokIntegerConst: + begin + fLexer.InitAhead; + case Lexer.AheadTokenID of + tokColon: + begin + LabeledStatement; + end; + else + begin + SynError(InvalidLabeledStatement); + NextToken; + end; + end; + end; + tokRepeat: + begin + RepeatStatement; + end; + tokRaise: + begin + RaiseStatement; + end; + tokSemiColon: + begin + EmptyStatement; + end; + tokString: + begin + StringStatement; + end; + tokTry: + begin + TryStatement; + end; + tokWhile: + begin + WhileStatement; + end; + tokWith: + begin + WithStatement; + end; + else + begin + SimpleStatement; + end; + end; +end; + +procedure TmwSimplePasPar.EmptyStatement; +begin + { Nothing to do here. + The semicolon will be removed in StatementList } +end; + +procedure TmwSimplePasPar.InheritedStatement; +begin + Expected(tokInherited); + case TokenID of + tokSemiColon: ; + else + begin + Statement; + end; + end; +end; + +procedure TmwSimplePasPar.LabeledStatement; +begin + case TokenID of + tokIdentifier: + begin + NextToken; + Expected(tokColon); + Statement; + end; + tokIntegerConst: + begin + NextToken; + Expected(tokColon); + Statement; + end; + else + begin + SynError(InvalidLabeledStatement); + end; + end; +end; + +procedure TmwSimplePasPar.StringStatement; +begin + Expected(tokString); + Statement; +end; + +procedure TmwSimplePasPar.SetElement; +begin + Expression; + if TokenID = tokDotDot then + begin + NextToken; + Expression; + end; +end; + +procedure TmwSimplePasPar.QualifiedIdentifier; +begin //mw 12/7/2000 + Expected(tokIdentifier); + case TokenID of + tokPoint: + begin + while TokenID = tokPoint do + begin //jdj 1/7/2001 + NextToken; + {$IFDEF D8_NEWER} + if TokenID in [tokAnd, tokArray, tokAs, tokASM, tokBegin, tokCase, tokClass, + tokConst, tokConstructor, tokDestructor, tokDispInterface, tokDiv, tokDo, + tokDOwnto, tokElse, tokEnd, tokExcept, tokExports, tokFile, tokFinal, + tokFinalization, tokFinally, tokFor, tokFunction, tokGoto, tokIf, + tokImplementation, tokIn, tokInherited, tokInitialization, tokInline, + tokInterface, tokIs, tokLabel, tokLibrary, tokMod, tokNil, tokNot, tokObject, + tokOf, tokOr, tokOut, tokPacked, tokProcedure, tokProgram, tokProperty, + tokRaise, tokRecord, tokRepeat, tokResourceString, tokSealed, tokSet, + tokShl, tokShr, tokStatic, tokString, tokThen, tokThreadVar, tokTo, tokTry, + tokType, tokUnit, tokUnsafe, tokUntil, tokUses, tokVar, tokWhile, tokWith, + tokXor] then + NextToken + else + {$ENDIF} + Expected(tokIdentifier); + if (TokenID = tokSquareOpen) then + begin + ConstantExpression; + end; + end; + end; + tokSquareOpen: + begin + ConstantExpression; + end; + end; +(* Expected(tokIdentifier); // old code for information removed in next versions + case TokenID of + tokPoint: + begin + NextToken; + Expected(tokIdentifier); + if (TokenID = tokSquareOpen) then + begin + ConstantExpression; + end; + end; + tokSquareOpen: {MW 20001207} + begin + ConstantExpression; + end; + end;*) + +end; + +procedure TmwSimplePasPar.SetConstructor; +begin + Expected(tokSquareOpen); + SetElement; + while TokenID = tokComma do + begin + NextToken; + SetElement; + end; + Expected(tokSquareClose); +end; + +procedure TmwSimplePasPar.Number; +begin + case TokenID of + tokFloat: + begin + NextToken; + end; + tokIntegerConst: + begin + NextToken; + end; + tokIdentifier: + begin + NextToken; + end; + else + begin + SynError(InvalidNumber); + end; + end; +end; + +procedure TmwSimplePasPar.ExpressionList; +begin + Expression; + if TokenID = tokAssign then //JT Nov 26, 2004 - supporting ole automation syntax + begin + Expected(tokAssign); + Expression; + end; + while TokenID = tokComma do + begin + NextToken; + Expression; + if TokenID = tokAssign then //JT Nov 26, 2004 - supporting ole automation syntax + begin + Expected(tokAssign); + Expression; + end; + end; +end; + +procedure TmwSimplePasPar.Designator; +begin + VariableReference; +end; + +procedure TmwSimplePasPar.MultiplicativeOperator; +begin + case TokenID of + tokAnd: + begin + NextToken; + end; + tokDiv: + begin + NextToken; + end; + tokMod: + begin + NextToken; + end; + tokShl: + begin + NextToken; + end; + tokShr: + begin + NextToken; + end; + tokSlash: + begin + NextToken; + end; + tokStar: + begin + NextToken; + end; + else + begin SynError(InvalidMultiplicativeOperator); + end; + end; +end; + +procedure TmwSimplePasPar.Factor; +begin + case TokenID of + tokAsciiChar, tokStringConst: + begin + CharString; + end; + tokAddressOp, tokDoubleAddressOp, tokIdentifier, tokInherited, tokPointerSymbol, + tokRoundOpen: + begin + Designator; + end; + tokIntegerConst, tokFloat: + begin + Number; + end; + tokNil: + begin + NextToken; + end; + tokMinus: + begin + NextToken; + Factor; + end; + tokNot: + begin + NextToken; + Factor; + end; + tokPlus: + begin + NextToken; + Factor; + end; + tokSquareOpen: + begin + SetConstructor; + end; + tokString: + begin + NextToken; + Factor; + end; + tokFunction, tokProcedure: + AnonymousMethod; + end; +end; + +procedure TmwSimplePasPar.AdditiveOperator; +begin + if TokenID in [tokMinus, tokOr, tokPlus, tokXor] then + begin + NextToken; // DR 2001-12-19 + { + case TokenID of + tokMinus, tokPlus: + begin + while TokenID in [tokMinus, tokPlus] do + case TokenID of + tokMinus: + begin + NextToken; + end; + tokPlus: + begin + NextToken; + end; + end; + end; + tokOr: + begin + NextToken; + end; + tokXor: + begin + NextToken; + end; + end;} + end + else + begin + SynError(InvalidAdditiveOperator); + end; +end; + +procedure TmwSimplePasPar.Term; +begin + Factor; + while TokenID in [tokAnd, tokDiv, tokMod, tokShl, tokShr, tokSlash, tokStar] do + begin + MultiplicativeOperator; + Factor; + end; +end; + +procedure TmwSimplePasPar.RelativeOperator; +begin + case TokenID of + tokAs: + begin + NextToken; + end; + tokEqual: + begin + NextToken; + end; + tokGreater: + begin + NextToken; + end; + tokGreaterEqual: + begin + NextToken; + end; + tokIn: + begin + NextToken; + end; + tokIs: + begin + NextToken; + end; + tokLower: + begin + NextToken; + end; + tokLowerEqual: + begin + NextToken; + end; + tokNotEqual: + begin + NextToken; + end; + else + begin + SynError(InvalidRelativeOperator); + end; + end; +end; + +procedure TmwSimplePasPar.SimpleExpression; +begin +(* while TokenID in [tokMinus, tokPlus] do + begin + NextToken; // DR 2001-12-19 + end; +*) + Term; + while TokenID in [tokMinus, tokOr, tokPlus, tokXor] do + begin + AdditiveOperator; + Term; + end; +end; + +procedure TmwSimplePasPar.Expression; +begin + SimpleExpression; + + //JT 2006-07-17 The Delphi language guide has this as + //Expression -> SimpleExpression [RelOp SimpleExpression]... + //So this needs to be able to repeat itself. + case TokenID of + tokEqual, tokGreater, tokGreaterEqual, tokLower, tokLowerEqual, tokIn, tokIs, + tokNotEqual: + begin + while TokenID in [tokEqual, tokGreater, tokGreaterEqual, tokLower, tokLowerEqual, + tokIn, tokIs, tokNotEqual{, tokColon}] do + begin + RelativeOperator; + SimpleExpression; + end; + end; + tokColon: + begin + case fInRound of + False: ; + True: + while TokenID = tokColon do + begin + NextToken; + SimpleExpression; + end; + end; + end; + end; +end; + +procedure TmwSimplePasPar.VarDeclaration; +begin + // !! Changed back to var name list from IdentifierList + VarNameList; + Expected(tokColon); + TypeKind; + while ExID in [tokDeprecated, tokLibrary, tokPlatform] do // DR 2001-10-20 + case ExID of + tokDeprecated: DirectiveDeprecated; + tokLibrary: DirectiveLibrary; + tokPlatform: DirectivePlatform; + end; + case GenID of + tokAbsolute: + begin + VarAbsolute; + end; + tokEqual: + begin + VarEqual; + end; + end; + while ExID in [tokDeprecated, tokLibrary, tokPlatform] do // DR 2001-10-20 + case ExID of + tokDeprecated: DirectiveDeprecated; + tokLibrary: DirectiveLibrary; + tokPlatform: DirectivePlatform; + end; +end; + +procedure TmwSimplePasPar.VarAbsolute; +begin + ExpectedEx(tokAbsolute); + ConstantValue; +end; + +procedure TmwSimplePasPar.VarEqual; +begin + Expected(tokEqual); + ConstantValueTyped; +end; + +procedure TmwSimplePasPar.VarNameList; +begin + VarName; + while TokenID = tokComma do + begin + NextToken; + VarName; + end; +end; + +procedure TmwSimplePasPar.VarName; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.DirectiveCalling; +begin + case ExID of + tokCdecl: + begin + NextToken; + end; + tokPascal: + begin + NextToken; + end; + tokRegister: + begin + NextToken; + end; + tokSafeCall: + begin + NextToken; + end; + tokStdCall: + begin + NextToken; + end; + else + begin + SynError(InvalidDirectiveCalling); + end; + end; +end; + +procedure TmwSimplePasPar.RecordVariant; +begin + ConstantExpression; + while (TokenID = tokComma) do + begin + NextToken; + ConstantExpression; + end; + Expected(tokColon); + Expected(tokRoundOpen); + if TokenID <> tokRoundClose then + begin + FieldList; + end; + Expected(tokRoundClose); +end; + +procedure TmwSimplePasPar.VariantSection; +begin + Expected(tokCase); + TagField; + Expected(tokOf); + RecordVariant; + while TokenID = tokSemiColon do + begin + SEMICOLON; + case TokenID of //DR 2001-12-11 + tokEnd, tokRoundClose: Break; + else + RecordVariant; + end; + end; +end; + +procedure TmwSimplePasPar.TagField; +begin + TagFieldName; + case fLexer.TokenID of + tokColon: + begin + NextToken; + TagFieldTypeName; + end; + end; +end; + +procedure TmwSimplePasPar.TagFieldName; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.TagFieldTypeName; +begin + QualifiedIdentifier; +end; + +procedure TmwSimplePasPar.FieldDeclaration; +begin + //IdentifierList; + FieldNameList; + Expected(tokColon); + TypeKind; + while ExID in [tokDeprecated, tokLibrary, tokPlatform] do // DR 2002-01-09 + case ExID of + tokDeprecated: DirectiveDeprecated; + tokLibrary: DirectiveLibrary; + tokPlatform: DirectivePlatform; + end; +end; + +procedure TmwSimplePasPar.FieldList; +begin + while TokenID = tokIdentifier do + begin + FieldDeclaration; + SEMICOLON; + end; + if TokenID = tokCase then + begin + VariantSection; + end; +end; + +procedure TmwSimplePasPar.FieldName; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.FieldNameList; +begin + FieldName; + while TokenID = tokComma do + begin + NextToken; + FieldName; + end; +end; + +procedure TmwSimplePasPar.RecordType; +begin + Expected(tokRecord); + if TokenID = tokSemicolon then + Exit; + {$IFDEF D8_NEWER1} + if TokenID = tokRoundOpen then + begin + ClassHeritage; + if TokenID = tokSemicolon then + Exit; + end; + ClassMemberList; + {$ELSE} + FieldList; + {$ENDIF} + Expected(tokEnd); +end; + +procedure TmwSimplePasPar.FileType; +begin + Expected(tokFile); + if TokenID = tokOf then + begin + NextToken; + TypeId; + end; +end; + +procedure TmwSimplePasPar.SetType; +begin + Expected(tokSet); + Expected(tokOf); + OrdinalType; +end; + +procedure TmwSimplePasPar.ArrayType; +begin + Expected(tokArray); + if TokenID = tokSquareOpen then + begin + NextToken; + OrdinalType; + while TokenID = tokComma do + begin + NextToken; + OrdinalType; + end; + Expected(tokSquareClose); + end; + Expected(tokOf); + TypeKind; +end; + +procedure TmwSimplePasPar.EnumeratedType; +begin + Expected(tokRoundOpen); + EnumeratedTypeItem; + while TokenID = tokComma do + begin + NextToken; + EnumeratedTypeItem; + end; + Expected(tokRoundClose); +end; + +procedure TmwSimplePasPar.SubrangeType; +begin + ConstantExpression; + if TokenID = tokDotDot then + begin + NextToken; + ConstantExpression; + end; +end; + +procedure TmwSimplePasPar.RealIdentifier; +begin + case ExID of + tokReal48: + begin + NextToken; + end; + tokReal: + begin + NextToken; + end; + tokSingle: + begin + NextToken; + end; + tokDouble: + begin + NextToken; + end; + tokExtended: + begin + NextToken; + end; + tokCurrency: + begin + NextToken; + end; + tokComp: + begin + NextToken; + end; + else + begin + SynError(InvalidRealIdentifier); + end; + end; +end; + +procedure TmwSimplePasPar.RealType; +begin + case TokenID of + tokMinus: + begin + NextToken; + end; + tokPlus: + begin + NextToken; + end; + end; + case TokenId of + tokFloat: + begin + NextToken; + end; + else + begin + VariableReference; + end; + end; +end; + +procedure TmwSimplePasPar.OrdinalIdentifier; +begin + case ExID of + tokBoolean: + begin + NextToken; + end; + tokByte: + begin + NextToken; + end; + tokBytebool: + begin + NextToken; + end; + tokCardinal: + begin + NextToken; + end; + tokChar: + begin + NextToken; + end; + tokDWord: + begin + NextToken; + end; + tokInt64: + begin + NextToken; + end; + tokInteger: + begin + NextToken; + end; + tokLongBool: + begin + NextToken; + end; + tokLongInt: + begin + NextToken; + end; + tokLongWord: + begin + NextToken; + end; + tokPChar: + begin + NextToken; + end; + tokShortInt: + begin + NextToken; + end; + tokSmallInt: + begin + NextToken; + end; + tokWideChar: + begin + NextToken; + end; + tokWord: + begin + NextToken; + end; + tokWordbool: + begin + NextToken; + end; + else + begin + SynError(InvalidOrdinalIdentifier); + end; + end; +end; + +procedure TmwSimplePasPar.OrdinalType; +begin + case TokenID of + tokIdentifier: + begin + Lexer.InitAhead; + case Lexer.AheadTokenID of + tokPoint: + begin + Expression; + end; + tokRoundOpen: + begin //jdj + ConstantExpression; + end; + else + begin + TypeID; + end; + end; + end; + tokRoundOpen: + begin + EnumeratedType; + end; + tokSquareOpen: + begin + NextToken; + SubrangeType; + Expected(tokSquareClose); + end; + else + begin + Expression; + end; + end; + if TokenID = tokDotDot then + begin + NextToken; + ConstantExpression; + end; +end; + +procedure TmwSimplePasPar.VariableReference; +begin + case TokenID of + tokAddressOp: + begin + NextToken; + variable; + end; + tokDoubleAddressOp: + begin + NextToken; + variable; + end; + tokPointerSymbol: + begin + NextToken; + case TokenID of + tokRoundClose, tokSquareClose: ; + else + begin + variable; + end; + end; + end; + else + variable; + end; +end; + +procedure TmwSimplePasPar.Variable; (* Attention: could also came from proc_call ! ! *) +begin + case TokenID of + tokInherited: + begin + NextToken; + QualifiedIdentifier; + end; + tokPoint: + begin + VariableTwo; + end; + tokPointerSymbol: + begin + VariableTwo; + end; + tokRoundOpen: + begin + VariableTwo; + end; + tokSquareOpen: + begin + VariableTwo; + end; +//{$IFDEF D11_NEWER} +// tokLower: +// begin +// VariableTwo; +// end; +//{$ENDIF} + else + QualifiedIdentifier; + end; + VariableTwo; + case TokenID of + tokAs: + begin + NextToken; + QualifiedIdentifier; + end; + end; +end; + +procedure TmwSimplePasPar.VariableTwo; +begin + case TokenID of + tokPoint: + begin + NextToken; + case TokenID of + tokAddressOp, tokDoubleAddressOp, tokIdentifier: + begin + VariableReference; + end; + tokPointerSymbol, tokRoundOpen, tokSquareOpen: + begin + VariableTwo; + end; + end; + end; + tokPointerSymbol: + begin + NextToken; + case TokenID of + tokAddressOp, tokDoubleAddressOp, tokIdentifier: + begin + VariableReference; + end; + tokPoint, tokPointerSymbol, tokRoundOpen, tokSquareOpen: + begin + VariableTwo; + end; + end; + end; + tokRoundOpen: + begin + NextToken; + fInRound := True; + case TokenID of + tokRoundClose: + begin + NextToken; + //Expected(tokRoundClose); + fInRound := False; + end; + else + begin + case TokenID of + tokAddressOp, tokDoubleAddressOp: + begin + VariableReference; + end; + tokPoint, tokPointerSymbol, tokRoundOpen, tokSquareOpen: + begin + VariableTwo; + end; + end; + fInRound := True; + ExpressionList; + fInRound := True; + Expected(tokRoundClose); + fInRound := False; + end; + end; + case TokenID of + tokAddressOp, tokDoubleAddressOp: + begin + VariableReference; + end; + tokPoint, tokPointerSymbol, tokRoundOpen, tokSquareOpen: + begin + VariableTwo; + end; + end; + end; + tokSquareOpen: + begin + Lexer.InitAhead; + while Lexer.AheadTokenID <> tokSemiColon do + begin + case Lexer.AheadTokenID of + tokBegin, tokClass, tokConst, tokEnd, tokDotDot, tokIn, tokNull, tokThreadVar, tokType, + tokVar: break; + else + Lexer.AheadNext; + end; + end; + case Lexer.AheadTokenID of + tokDotDot: + begin + SubrangeType; + end; + else + begin + NextToken; + case TokenID of + tokSquareClose: + begin + NextToken; + end; + else + begin + case TokenID of + tokAddressOp, tokDoubleAddressOp: + begin + VariableReference; + end; + tokPoint, tokPointerSymbol, tokRoundOpen, tokSquareOpen: + begin + VariableTwo; + end; + end; + ExpressionList; + Expected(tokSquareClose); + end; + end; + case TokenID of + tokAddressOp, tokDoubleAddressOp: + begin + VariableReference; + end; + tokPoint, tokPointerSymbol, tokRoundOpen, tokSquareOpen: + begin + VariableTwo; + end; + end; + + end; + end; + end; + {$IFDEF D11_NEWER} + tokLower: + begin + InitAhead; + AheadParse.NextToken; + AheadParse.TypeKind; + + if AheadParse.TokenId = tokGreater then + begin + NextToken; + TypeKind; + Expected(tokGreater); + case TokenID of + tokAddressOp, tokDoubleAddressOp, tokIdentifier: + begin + VariableReference; + end; + tokPoint, tokPointerSymbol, tokRoundOpen, tokSquareOpen: + begin + VariableTwo; + end; + end; + end; + end; + {$ENDIF} + end; +end; + +procedure TmwSimplePasPar.InterfaceType; +begin + case TokenID of + tokInterface: + begin + NextToken; + end; + tokDispInterface: + begin + NextToken; + end + else + begin + SynError(InvalidInterfaceType); + end; + end; + case TokenID of + tokEnd: + begin + NextToken; { Direct descendant without new members } + end; + tokRoundOpen: + begin + InterfaceHeritage; + case TokenID of + tokEnd: + begin + NextToken; { No new members } + end; + tokSemiColon: ; { No new members } + else + begin + if TokenID = tokSquareOpen then + begin + InterfaceGUID; + end; + InterfaceMemberList; + Expected(tokEnd); + end; + end; + end; + else + begin + if TokenID = tokSquareOpen then + begin + InterfaceGUID; + end; + InterfaceMemberList; { Direct descendant } + Expected(tokEnd); + end; + end; +end; + +procedure TmwSimplePasPar.InterfaceMemberList; +begin + while TokenID in [tokFunction, tokProcedure, tokProperty] do + begin + ClassMethodOrProperty; + end; +end; + +procedure TmwSimplePasPar.ClassType; +begin + Expected(tokClass); + {$IFDEF D8_NEWER} //JThurman 2004-03-19 + case TokenID of + tokIdentifier: //NASTY hack because Abstract is generally an ExID, except in this case when it should be a keyword. + case Lexer.ExID of + tokAbstract: ExpectedEx(tokAbstract); + tokHelper: + begin + ExpectedEx(tokHelper); + Expected(tokFor); + Expected(tokIdentifier); + end; + end; + tokSealed: + Expected(tokSealed); + end; + {$ENDIF} + case TokenID of + tokEnd: + begin + ClassTypeEnd; // DR 2001-07-31 + NextToken; { Direct descendant of TObject without new members } + end; + tokRoundOpen: + begin + ClassHeritage; + case TokenID of + tokEnd: + begin + Expected(tokEnd); // DR 2001-07-31 + ClassTypeEnd; // DR 2001-07-31 + end; + tokSemiColon: ClassTypeEnd; // DR 2001-07-31 + else + begin + ClassMemberList; { Direct descendant of TObject } + Expected(tokEnd); // DR 2001-07-31 + ClassTypeEnd; // DR 2001-07-31 + end; + end; + end; + else + begin + ClassMemberList; { Direct descendant of TObject } + Expected(tokEnd); // DR 2001-07-31 + ClassTypeEnd; // DR 2001-07-31 + end; + end; +end; + +procedure TmwSimplePasPar.ClassHeritage; +begin + Expected(tokRoundOpen); + AncestorIdList; + Expected(tokRoundClose); +end; + +procedure TmwSimplePasPar.ClassVisibility; +begin + {$IFDEF D8_NEWER} //JThurman 2004-03-03 + if TokenID = tokStrict then + Expected(tokStrict); + {$ENDIF} + while ExID in [tokAutomated, tokPrivate, tokProtected, tokPublic, tokPublished] do + begin + Lexer.InitAhead; + case Lexer.AheadExID of + tokColon, tokComma: ; + else + case ExID of + tokAutomated: + begin + VisibilityAutomated; + end; + tokPrivate: + begin + VisibilityPrivate; + end; + tokProtected: + begin + VisibilityProtected; + end; + tokPublic: + begin + VisibilityPublic; + end; + tokPublished: + begin + VisibilityPublished; + end; + end; + end; + end; +end; + +procedure TmwSimplePasPar.VisibilityAutomated; +begin + ExpectedEx(tokAutomated); +end; + +procedure TmwSimplePasPar.VisibilityPrivate; +begin + ExpectedEx(tokPrivate); +end; + +procedure TmwSimplePasPar.VisibilityProtected; +begin + ExpectedEx(tokProtected); +end; + +procedure TmwSimplePasPar.VisibilityPublic; +begin + ExpectedEx(tokPublic); +end; + +procedure TmwSimplePasPar.VisibilityPublished; +begin + ExpectedEx(tokPublished); +end; + +procedure TmwSimplePasPar.VisibilityUnknown; +begin + // +end; + +procedure TmwSimplePasPar.ClassMemberList; +begin + ClassVisibility; + while TokenID in [tokClass, tokConstructor, tokDestructor, tokFunction, + tokIdentifier, tokProcedure, tokProperty + {$IFDEF D8_NEWER}, tokType, tokSquareOpen, tokVar, tokConst, tokStrict, + tokCase{$ENDIF}] do + begin + while (TokenID = tokIdentifier) and + not (ExID in [tokPrivate, tokProtected, tokPublished, tokPublic]) do + begin + ClassField; + SEMICOLON; + ClassVisibility; + end; + while TokenID in [tokClass, tokConstructor, tokDestructor, tokFunction, + tokProcedure, tokProperty{$IFDEF D8_NEWER}, tokSquareOpen, tokVar, tokConst{$ENDIF}] do + begin + ClassMethodOrProperty; + end; + {$IFDEF D8_NEWER}//JThurman 2004-03-22 + {Nested types for D8} + while TokenID = tokType do + TypeSection; + while TokenID = tokCase do + begin + VariantSection; + end; + {$ENDIF} + ClassVisibility; + end; +end; + +procedure TmwSimplePasPar.ClassMethodOrProperty; +begin + {$IFDEF D8_NEWER} + if TokenID = tokSquareOpen then + CustomAttribute; + {$ENDIF} + if TokenID = tokClass + then ClassClass; //DR 2001-07-16 + case TokenID of + tokProperty: + begin + ClassProperty; + end; + {$IFDEF D8_NEWER} + tokVar: + begin + NextToken; + while (TokenID = tokIdentifier) and (ExID = tokUnknown) do + begin + ClassField; + SemiColon; + end; + end; + tokConst: + begin + NextToken; + while (TokenID = tokIdentifier) and (ExID = tokUnknown) do + begin + ConstantDeclaration; + SemiColon; + end; + end; + {$ENDIF} + else + begin + ClassMethodHeading; + end; + end; +end; + +procedure TmwSimplePasPar.ClassProperty; +begin + // DR 2001-07-19 -> changed. for array-property override failure + Expected(tokProperty); + PropertyName; + case TokenID of + tokColon, tokSquareOpen: + begin + PropertyInterface; + end; + end; + PropertySpecifiers; + case ExID of + tokDefault: + begin + PropertyDefault; //DR 2001-07-16 + SEMICOLON; + end; + end; +end; + +procedure TmwSimplePasPar.PropertyName; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.ClassField; +begin + //IdentifierList; + FieldNameList; + Expected(tokColon); + TypeKind; + while ExID in [tokDeprecated, tokLibrary, tokPlatform] do // DR 2001-10-20 + case ExID of + tokDeprecated: DirectiveDeprecated; + tokLibrary: DirectiveLibrary; + tokPlatform: DirectivePlatform; + end; +end; + +procedure TmwSimplePasPar.ObjectType; +begin + Expected(tokObject); + case TokenID of + tokEnd: + begin + ObjectTypeEnd; // DR 2001-07-31 + NextToken; { Direct descendant without new members } + end; + tokRoundOpen: + begin + ObjectHeritage; + case TokenID of + tokEnd: + begin + Expected(tokEnd); // DR 2001-07-31 + ObjectTypeEnd; // DR 2001-07-31 + end; + tokSemiColon: ObjectTypeEnd; // DR 2001-07-31 + else + begin + ObjectMemberList; { Direct descendant } + Expected(tokEnd); // DR 2001-07-31 + ObjectTypeEnd; // DR 2001-07-31 + end; + end; + end; + else + begin + ObjectMemberList; { Direct descendant } + Expected(tokEnd); // DR 2001-07-31 + ObjectTypeEnd; // DR 2001-07-31 + end; + end; +end; + +procedure TmwSimplePasPar.ObjectHeritage; +begin + Expected(tokRoundOpen); + AncestorIdList; + Expected(tokRoundClose); +end; + +procedure TmwSimplePasPar.ObjectMemberList; +begin {jdj added tokProperty-call to ObjectProperty 02/07/2001} + ObjectVisibility; + while TokenID in [tokConstructor, tokDestructor, tokFunction, tokIdentifier, + tokProcedure, tokProperty] do + begin + while TokenID = tokIdentifier do + begin + ObjectField; + SEMICOLON; + ObjectVisibility; + end; + while TokenID in [tokConstructor, tokDestructor, tokFunction, tokProcedure, tokProperty] do + begin + case TokenID of + tokConstructor, tokDestructor, tokFunction, tokProcedure: + ObjectMethodHeading; + tokProperty: + ObjectProperty; + end; + end; + ObjectVisibility; + end; +end; + +procedure TmwSimplePasPar.ObjectVisibility; +begin + while ExID in [tokPrivate, tokProtected, tokPublic] do + begin + Lexer.InitAhead; + case Lexer.AheadExID of + tokColon, tokComma: ; + else + case ExID of + tokPrivate: + begin + VisibilityPrivate; + end; + tokProtected: + begin + VisibilityProtected; + end; + tokPublic: + begin + VisibilityPublic; + end; + end; + end; + end; +end; + +procedure TmwSimplePasPar.ObjectField; +begin + IdentifierList; + Expected(tokColon); + TypeKind; + while ExID in [tokDeprecated, tokLibrary, tokPlatform] do // DR 2001-10-20 + case ExID of + tokDeprecated: DirectiveDeprecated; + tokLibrary: DirectiveLibrary; + tokPlatform: DirectivePlatform; + end; +end; + +procedure TmwSimplePasPar.ClassReferenceType; +begin + Expected(tokClass); + Expected(tokOf); + TypeId; +end; + +procedure TmwSimplePasPar.VariantIdentifier; +begin + case ExID of + tokOleVariant: + begin + NextToken; + end; + tokVariant: + begin + NextToken; + end; + else + begin + SynError(InvalidVariantIdentifier); + end; + end; +end; + +procedure TmwSimplePasPar.ProceduralType; +var + TheTokenID: TptTokenKind; +begin + case TokenID of + tokFunction: + begin + NextToken; + if TokenID = tokRoundOpen then + begin + FormalParameterList; + end; + Expected(tokColon); + ReturnType; + end; + tokProcedure: + begin + NextToken; + if TokenID = tokRoundOpen then + begin + FormalParameterList; + end; + end; + else + begin + SynError(InvalidProceduralType); + end; + end; + if TokenID = tokOf then + begin + NextToken; + Expected(tokObject); + end; + Lexer.InitAhead; + case TokenID of + tokSemiColon: TheTokenID := Lexer.AheadExID; + else + TheTokenID := ExID; + end; + while TheTokenID in [tokAbstract, tokCdecl, tokDynamic, tokExport, tokExternal, tokFar, + tokMessage, tokNear, tokOverload, tokOverride, tokPascal, tokRegister, + tokReintroduce, tokSafeCall, tokStdCall, tokVirtual + {$IFDEF D8_NEWER}, tokStatic{$ENDIF}{$IFDEF D9_NEWER}, tokInline{$ENDIF} + ] do + // DR 2001-11-14 no checking for deprecated etc. since it's captured by the typedecl + begin + if TokenID = tokSemiColon then SEMICOLON; + ProceduralDirective; + Lexer.InitAhead; + case TokenID of + tokSemiColon: TheTokenID := Lexer.AheadExID; + else + TheTokenID := ExID; + end; + end; +end; + +procedure TmwSimplePasPar.StringIdentifier; +begin + case ExID of + tokAnsiString: + begin + NextToken; + end; + tokShortString: + begin + NextToken; + end; + tokWideString: + begin + NextToken; + end; + else + begin + SynError(InvalidStringIdentifier); + end; + end; +end; + +procedure TmwSimplePasPar.StringType; +begin + case TokenID of + tokString: + begin + NextToken; + if TokenID = tokSquareOpen then + begin + NextToken; + ConstantExpression; + Expected(tokSquareClose); + end; + end; + else + begin + VariableReference; + end; + end; +end; + +procedure TmwSimplePasPar.PointerType; +begin + Expected(tokPointerSymbol); + TypeId; +end; + +procedure TmwSimplePasPar.StructuredType; +begin + if TokenID = tokPacked then + begin + NextToken; + end; + case TokenID of + tokArray: + begin + ArrayType; + end; + tokFile: + begin + FileType; + end; + tokRecord: + begin + RecordType; + end; + tokSet: + begin + SetType; + end; + else + begin + SynError(InvalidStructuredType); + end; + end; +end; + +procedure TmwSimplePasPar.SimpleType; +begin + case TokenID of + tokMinus: + begin + NextToken; + end; + tokPlus: + begin + NextToken; + end; + end; + case fLexer.TokenID of + tokAsciiChar, tokIntegerConst: + begin + OrdinalType; + end; + tokFloat: + begin + RealType; + end; + tokIdentifier: + begin + fLexer.InitAhead; + case Lexer.AheadTokenID of + tokPoint, tokSemiColon: + begin + TypeID; + end; + else + begin + SimpleExpression; + if fLexer.TokenID = tokDotDot then + begin + NextToken; + SimpleExpression; + end; + end; + end; + end; + tokRoundOpen: + begin + EnumeratedType; + end; + tokSquareOpen: + begin + SubrangeType; + end; + else + begin + VariableReference; + end; + end; +end; + +procedure TmwSimplePasPar.RecordFieldConstant; +begin + Expected(tokIdentifier); + Expected(tokColon); + TypedConstant; +end; + +procedure TmwSimplePasPar.RecordConstant; +begin + Expected(tokRoundOpen); + RecordFieldConstant; + while (TokenID = tokSemiColon) do + begin + SEMICOLON; + if TokenId <> tokRoundClose then //jdj 2.23.2001 + RecordFieldConstant; + end; + Expected(tokRoundClose); +end; + +procedure TmwSimplePasPar.ArrayConstant; +begin + Expected(tokRoundOpen); + TypedConstant; + while (TokenID = tokComma) do + begin + NextToken; + TypedConstant; + end; + Expected(tokRoundClose); +end; + +procedure TmwSimplePasPar.ClassForward; +begin + Expected(tokClass); +end; + +procedure TmwSimplePasPar.DispInterfaceForward; +begin + Expected(tokDispInterface); +end; + +procedure TmwSimplePasPar.InterfaceForward; +begin + Expected(tokInterface); +end; + +procedure TmwSimplePasPar.ObjectForward; +begin + Expected(tokObject); +end; + +procedure TmwSimplePasPar.TypeDeclaration; +begin + TypeName; + //For generics +// if TokenId = tokLower then +// TypeParams; + //end generics + Expected(tokEqual); + if TokenID = tokType then + begin + ExplicitType; + end; + Lexer.InitAhead; + case TokenID of + tokClass: + begin + case Lexer.AheadTokenID of + tokOf: + begin + ClassReferenceType; + end; + tokSemiColon: + begin + ClassForward; + end; + else + begin + ClassType; + end; + end; + end; + tokInterface: + begin + case Lexer.AheadTokenID of + tokSemiColon: + begin + InterfaceForward; + end; + else + begin + InterfaceType; + end; + end; + end; + tokDispInterface: + begin + case Lexer.AheadTokenID of + tokSemiColon: + begin + DispInterfaceForward; + end; + else + begin + InterfaceType; + end; + end; + end; + tokObject: + begin + case Lexer.AheadTokenID of + tokSemiColon: + begin + ObjectForward; + end; + else + begin + ObjectType; + end; + end; + end; + else + begin + {$IFDEF D12_NEWER} + if ExID = tokReference then + AnonymousMethodType + else + {$ENDIF} + TypeKind; + end; + end; + while ExID in [tokDeprecated, tokLibrary, tokPlatform] do // DR 2001-10-20 + case ExID of + tokDeprecated: DirectiveDeprecated; + tokLibrary: DirectiveLibrary; + tokPlatform: DirectivePlatform; + end; +end; + +procedure TmwSimplePasPar.TypeName; +begin + if (TokenID = tokString) then + NextToken + else + begin + Expected(tokIdentifier); + if TokenId = tokLower then + TypeParams; + end; +end; + +procedure TmwSimplePasPar.ExplicitType; +begin + Expected(tokType); +end; + +procedure TmwSimplePasPar.TypeKind; +begin + case TokenID of + tokAsciiChar, tokFloat, tokIntegerConst, tokMinus, tokNil, tokPlus, tokRoundOpen, + tokSquareOpen, tokStringConst: + begin + SimpleType; + end; + tokArray, tokFile, tokPacked, tokRecord, tokSet: + begin + StructuredType; + end; + tokFunction, tokProcedure: + begin + ProceduralType; + end; + tokIdentifier: + begin + Lexer.InitAhead; + case Lexer.AheadTokenID of + tokPoint, tokSemiColon, tokLower: + begin + TypeId; + end; + else + begin + SimpleExpression; + if Lexer.TokenID = tokDotDot then + begin + NextToken; + SimpleExpression; + end; + end; + end; + end; + tokPointerSymbol: + begin + PointerType; + end; + tokString: + begin + StringType; + end; + else + begin + SynError(InvalidTypeKind); + end; + end; +end; + +procedure TmwSimplePasPar.TypeArgs; +begin + Expected(tokLower); + TypeId; + while TokenId = tokComma do + begin + NextToken; + TypeId; + end; + Expected(tokGreater); +end; + +procedure TmwSimplePasPar.TypedConstant; +begin + case TokenID of + tokRoundOpen: + begin + Lexer.InitAhead; + while Lexer.AheadTokenID <> tokSemiColon do + case Lexer.AheadTokenID of + tokAnd, tokBegin, tokCase, tokColon, tokEnd, tokElse, tokIf, tokMinus, tokNull, + tokOr, tokPlus, tokShl, tokShr, tokSlash, tokStar, tokWhile, tokWith, + tokXor: break; + tokRoundOpen: + begin + repeat + case Lexer.AheadTokenID of + tokBegin, tokCase, tokEnd, tokElse, tokIf, tokNull, tokWhile, tokWith: break; + else + begin + case Lexer.AheadTokenID of + tokRoundClose: + begin + NextToken; + break; + end; + else + Lexer.AheadNext; + end; + end; + end; + until Lexer.AheadTokenID = tokRoundClose; + end; + else + Lexer.AheadNext; + end; + case Lexer.AheadTokenID of + tokColon: + begin + RecordConstant; + end; + tokNull: ; + tokAnd, tokMinus, tokOr, tokPlus, tokShl, tokShr, tokSlash, tokStar, tokXor: + begin + ConstantExpression; + end; + else + begin + ArrayConstant; + end; + end; + end; + tokSquareOpen: + ConstantExpression; // DR 2002-01-11 + + { DR: fails with constructed set constants like + WordDelimiters: set of Char = [#0..#255] - ['a'..'z','A'..'Z','1'..'9','0']; + + (*empty; there mustn't be all fields of a record mentioned*) + begin + NextToken; + if TokenID <> tokSquareClose then + begin + case TokenID of + tokDotDot: + begin + NextToken; + NextToken; + end; + else + NextToken; + case TokenID of + tokDotDot: + begin + NextToken; + NextToken; + end; + end; + end; + while TokenID = tokComma do + begin + NextToken; + NextToken; + case TokenID of + tokDotDot: + begin + NextToken; + NextToken; + end; + end; + end; + Expected(tokSquareClose); + end + else NextToken; + end;} + else + begin + ConstantExpression; + end; + end; +end; + +procedure TmwSimplePasPar.TypeId; +begin + Lexer.InitAhead; + {$IFDEF D8_NEWER} //JThurman 2004-03-03 + while Lexer.AheadTokenID = tokPoint do + begin + //UnitId; + NextToken; + Expected(tokPoint); + Lexer.InitAhead; + end; + {$ELSE} + if Lexer.AheadTokenID = tokPoint then + begin + UnitId; + Expected(tokPoint); + end; + {$ENDIF} + case GenID of + tokBoolean, tokByte, tokChar, tokDWord, tokInt64, tokInteger, tokLongInt, + tokLongWord, tokPChar, tokShortInt, tokSmallInt, tokWideChar, tokWord: + begin + OrdinalIdentifier; + end; + tokComp, tokCurrency, tokDouble, tokExtended, tokReal, tokReal48, tokSingle: + begin + RealIdentifier; + end; + tokAnsiString, tokShortString, tokWideString: + begin + StringIdentifier; + end; + tokOleVariant, tokVariant: + begin + VariantIdentifier; + end; + tokString: + begin + StringType; + end; + else + begin + //Problem: Delphi 8 allows things like 'Object' to be types + //when they are fully qualified (as System.Object, etc...), so + //tokIdentifier doesn't quite work right in this context + //TODO: Come up with a more elegant solution to the 'Object' dilemna + {$IFDEF D8_NEWER}//JThurman 2004-03-03 + NextToken; + {$ELSE} + Expected(tokIdentifier); + {$ENDIF} + if TokenId = tokLower then + TypeArgs; + end; + end; +end; + +procedure TmwSimplePasPar.ConstantExpression; +begin + Expression; +end; + +procedure TmwSimplePasPar.ResourceDeclaration; +begin + Identifier; + Expected(tokEqual); + CharString; + while ExID in [tokDeprecated, tokLibrary, tokPlatform] do // DR 2002-01-10 + case ExID of + tokDeprecated: DirectiveDeprecated; + tokLibrary: DirectiveLibrary; + tokPlatform: DirectivePlatform; + end; +end; + +procedure TmwSimplePasPar.ConstantDeclaration; +begin + ConstantName; + case TokenID of + tokEqual: + begin + ConstantEqual; + end; + tokColon: + begin + ConstantColon; + end; + else + begin + SynError(InvalidConstantDeclaration); + end; + end; + while ExID in [tokDeprecated, tokLibrary, tokPlatform] do // DR 2001-10-20 + case ExID of + tokDeprecated: DirectiveDeprecated; + tokLibrary: DirectiveLibrary; + tokPlatform: DirectivePlatform; + end; +end; + +procedure TmwSimplePasPar.ConstantColon; +begin + Expected(tokColon); +//JR changed to constant Type + ConstantType; + Expected(tokEqual); + ConstantValueTyped; +end; + +procedure TmwSimplePasPar.ConstantEqual; +begin + Expected(tokEqual); + ConstantValue; +end; + +procedure TmwSimplePasPar.ConstantValue; +begin + ConstantExpression; +end; + +procedure TmwSimplePasPar.ConstantValueTyped; +begin + TypedConstant; +end; + +procedure TmwSimplePasPar.ConstantName; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.ConstantType; +begin + TypeKind; +end; +procedure TmwSimplePasPar.LabelId; +begin + case TokenID of + tokIntegerConst: + begin + NextToken; + end; + tokIdentifier: + begin + NextToken; + end; + else + begin + SynError(InvalidLabelId); + end; + end; +end; + +procedure TmwSimplePasPar.ProcedureDeclarationSection; +begin + if TokenID = tokClass then + begin + NextToken; + end; + case TokenID of + tokConstructor: + begin + ProcedureMethodDeclaration; + end; + tokDestructor: + begin + ProcedureMethodDeclaration; + end; + tokProcedure: + begin + ProcedureMethodDeclaration; + end; + tokFunction: + begin + FunctionMethodDeclaration; + end; + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + tokIdentifier: + begin + if Lexer.ExID = tokOperator then + begin + FunctionMethodDeclaration; + end + else + SynError(InvalidProcedureDeclarationSection); + end; + {$ENDIF} + else + begin + SynError(InvalidProcedureDeclarationSection); + end; + end; +end; + +procedure TmwSimplePasPar.LabelDeclarationSection; +begin + Expected(tokLabel); + LabelId; + while (TokenID = tokComma) do + begin + NextToken; + LabelId; + end; + SEMICOLON; +end; + +procedure TmwSimplePasPar.ProceduralDirective; //TODO: Add STATIC and FINAL +begin + case ExID of + tokAbstract: + begin + NextToken; + end; + tokCdecl, tokPascal, tokRegister, tokSafeCall, tokStdCall: + begin + DirectiveCalling; + end; + tokExport, tokFar, tokNear: + begin + Directive16Bit; + end; + tokExternal: + begin + ExternalDirective; + end; + tokDynamic, tokMessage, tokOverload, tokOverride, tokReintroduce, tokVirtual: + begin + DirectiveBinding; + end; + tokAssembler: + begin + NextToken; + end; + {$IFDEF D8_NEWER} + tokStatic: + begin + NextToken; + end; + {$ENDIF} + {$IFDEF D9_NEWER} + tokInline: + begin + NextToken; + end; + {$ENDIF} + tokDeprecated: + DirectiveDeprecated; // DR 2001-10-20 + tokLibrary: + DirectiveLibrary; // DR 2001-10-20 + tokPlatform: + DirectivePlatform; // DR 2001-10-20 + tokLocal: + DirectiveLocal; // DR 2001-11-14 + tokVarargs: + DirectiveVarargs; // DR 2001-11-14 + else + begin + SynError(InvalidProceduralDirective); + end; + end; +end; + +procedure TmwSimplePasPar.ExportedHeading; +begin + case TokenID of + tokFunction: + begin + FunctionHeading; + end; + tokProcedure: + begin + ProcedureHeading; + end; + else + begin + SynError(InvalidExportedHeading); + end; + end; + if TokenID = tokSemiColon then SEMICOLON; + case ExID of + tokForward: + begin + ForwardDeclaration; //jdj added 02/07/2001 +// NextToken; +// SEMICOLON; + end; + tokAssembler: + begin + NextToken; + SEMICOLON; + if Exid = tokForward then + ForwardDeclaration; //jdj added 02/07/2001 + end; + else //TODO: Add STATIC and FINAL + while ExID in [tokAbstract, tokCdecl, tokDynamic, tokExport, tokExternal, tokFar, + tokMessage, tokNear, tokOverload, tokOverride, tokPascal, tokRegister, + tokReintroduce, tokSafeCall, tokStdCall, tokVirtual, + tokDeprecated, tokLibrary, tokPlatform, // DR 2001-10-20 + tokLocal, tokVarargs // DR 2001-11-14 + {$IFDEF D8_NEWER}, tokStatic{$ENDIF}{$IFDEF D9_NEWER}, tokInline{$ENDIF} + ] do + begin + ProceduralDirective; + if TokenID = tokSemiColon then SEMICOLON; + end; + if ExId = tokForward then + ForwardDeclaration; //jdj added 02/07/2001 + end; +end; + +procedure TmwSimplePasPar.FunctionHeading; +begin + Expected(tokFunction); + FunctionProcedureName; + if TokenID = tokRoundOpen then + begin + FormalParameterList; + end; + Expected(tokColon); + ReturnType; +end; + +procedure TmwSimplePasPar.ProcedureHeading; +begin + Expected(tokProcedure); + FunctionProcedureName; + if TokenID = tokRoundOpen then + begin + FormalParameterList; + end; + +end; + +procedure TmwSimplePasPar.VarSection; +begin + case TokenID of + tokThreadVar: + begin + NextToken; + end; + tokVar: + begin + NextToken; + end; + else + begin + SynError(InvalidVarSection); + end; + end; + {$IFDEF D8_NEWER}//JThurman 2004-03-22 + while TokenID in [tokIdentifier, tokSquareOpen] do + begin + if TokenID = tokSquareOpen then + CustomAttribute + else + begin + VarDeclaration; + SEMICOLON; + end; + end; + {$ELSE} + while TokenID = tokIdentifier do + begin + VarDeclaration; + SEMICOLON; + end; + {$ENDIF} +end; + +procedure TmwSimplePasPar.TypeSection; +begin + Expected(tokType); + {$IFDEF D8_NEWER} + while ((TokenID = tokIdentifier) and (Lexer.ExID in ExTypes)) or + (Lexer.TokenID = tokSquareOpen) or (Lexer.TokenID = tokString) do + begin + if TokenID = tokSquareOpen then + CustomAttribute + else + begin + TypeDeclaration; + if TokenID = tokEqual then + TypedConstant; + SEMICOLON; + end; + end; + {$ELSE} + while (TokenID = tokIdentifier) or (TokenID = tokString) do + begin + TypeDeclaration; + if TokenId = tokEqual then //jdj 8/2/00 + TypedConstant; + SEMICOLON; + end; + {$ENDIF} +end; + +procedure TmwSimplePasPar.TypeParamDecl; +begin + TypeParamList; + if TokenId = tokColon then + begin + NextToken; + ConstraintList; + end; +end; + +procedure TmwSimplePasPar.TypeParamDeclList; +begin + TypeParamDecl; + while TokenId = tokSemicolon do + begin + NextToken; + TypeParamDecl; + end; +end; + +procedure TmwSimplePasPar.TypeParamList; +begin + {$IFDEF D8_NEWER} + if TokenId = tokSquareOpen then + AttributeSection; + {$ENDIF} + Identifier; + while TokenId = tokComma do + begin + NextToken; + {$IFDEF D8_NEWER} + if TokenId = tokSquareOpen then + AttributeSection; + {$ENDIF} + Identifier; + end; +end; + +procedure TmwSimplePasPar.TypeParams; +begin + Expected(tokLower); + TypeParamDeclList; + Expected(tokGreater); +end; + +procedure TmwSimplePasPar.ConstSection; +begin + case TokenID of + tokConst: + begin + NextToken; + {$IFDEF D8_NEWER} //JThurman 2004-03-22 + while TokenID in [tokIdentifier, tokSquareOpen] do + begin + if TokenID = tokSquareOpen then + CustomAttribute + else + begin + ConstantDeclaration; + SEMICOLON; + end; + end; + {$ELSE} + while (TokenID = tokIdentifier) do + begin + ConstantDeclaration; + SEMICOLON; + end; + {$ENDIF} + end; + tokResourceString: + begin + NextToken; + while (TokenID = tokIdentifier) do + begin + ResourceDeclaration; + SEMICOLON; + end; + end + else + begin + SynError(InvalidConstSection); + end; + end; +end; + +procedure TmwSimplePasPar.InterfaceDeclaration; +begin + case TokenID of + tokConst: + begin + ConstSection; + end; + tokFunction: + begin + ExportedHeading; + end; + tokProcedure: + begin + ExportedHeading; + end; + tokResourceString: + begin + ConstSection; + end; + tokType: + begin + TypeSection; + end; + tokThreadVar: + begin + VarSection; + end; + tokVar: + begin + VarSection; + end; + tokExports: + begin + ExportsClause; + end; + {$IFDEF D8_NEWER} //JThurman 2004-03-03 + tokSquareOpen: + begin + CustomAttribute; + end; + {$ENDIF} + else + begin + SynError(InvalidInterfaceDeclaration); + end; + end; +end; + +procedure TmwSimplePasPar.ExportsElement; +begin + Expected(tokIdentifier); + // if TokenID = tokIndex then + if FLexer.ExID = tokIndex then //jdj 20001207 + begin + NextToken; + Expected(tokIntegerConst); + end; + // if TokenID = tokName then + if FLexer.ExID = tokName then //jdj 20001207 + begin + NextToken; + CharString; + end; + // if TokenID = tokResident then + if FLexer.ExID = tokResident then //jdj 20001207 + begin + NextToken; + end; +end; + +procedure TmwSimplePasPar.CompoundStatement; +begin + Expected(tokBegin); + StatementList; + Expected(tokEnd); +end; + +procedure TmwSimplePasPar.ExportsClause; +begin + Expected(tokExports); + ExportsElement; + while TokenID = tokComma do + begin + NextToken; + ExportsElement; + end; + SEMICOLON; +end; + +procedure TmwSimplePasPar.ContainsClause; +begin + ExpectedEx(tokContains); + ContainsStatement; + while TokenID = tokComma do + begin + NextToken; + ContainsStatement; + end; + SEMICOLON; +end; + +procedure TmwSimplePasPar.ContainsStatement; +begin + ContainsIdentifier; + if fLexer.TokenID = tokIn then + begin + NextToken; + ContainsExpression; + end; +end; + +procedure TmwSimplePasPar.ContainsIdentifier; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.ContainsExpression; +begin + ConstantExpression; +end; + +procedure TmwSimplePasPar.RequiresClause; +begin + ExpectedEx(tokRequires); + RequiresIdentifier; + while TokenID = tokComma do + begin + NextToken; + RequiresIdentifier; + end; + SEMICOLON; +end; + +procedure TmwSimplePasPar.RequiresIdentifier; +begin + Expected(tokIdentifier); + {$IFDEF D8_NEWER} + while Lexer.TokenID = tokPoint do + begin + NextToken; + Expected(tokIdentifier); + end; + {$ENDIF} +end; + +procedure TmwSimplePasPar.InitializationSection; +begin + case TokenID of + tokInitialization: + begin + NextToken; + StatementList; + if TokenID = tokFinalization then + begin + NextToken; + StatementList; + end; + Expected(tokEnd); + end; + tokBegin: + begin + CompoundStatement; + end; + tokEnd: + begin + NextToken; + end; + else + begin + SynError(InvalidInitializationSection); + end; + end; +end; + +procedure TmwSimplePasPar.ImplementationSection; +begin + Expected(tokImplementation); + if TokenID = tokUses then + begin + UsesClause; + end; + while TokenID in [tokClass, tokConst, tokConstructor, tokDestructor, tokFunction, + tokLabel, tokProcedure, tokResourceString, tokThreadVar, tokType, tokVar, + tokExports + {$IFDEF D8_NEWER}//JThurman 2004-03-22 + , tokSquareOpen + {$ENDIF} + ] do //tokResourceString added jdj + begin + DeclarationSection; + end; +end; + +procedure TmwSimplePasPar.InterfaceSection; +begin + Expected(tokInterface); + if TokenID = tokUses then + begin + UsesClause; + end; + while TokenID in [tokConst, tokFunction, tokResourceString, tokProcedure, + tokThreadVar, tokType, tokVar, tokExports + {$IFDEF D8_NEWER} //JThurman 2004-03-03 + , tokSquareOpen + {$ENDIF} + ] do + begin + InterfaceDeclaration; + end; +end; + +procedure TmwSimplePasPar.IdentifierList; +begin + Identifier; // DR 2001-10-20 + while TokenID = tokComma do + begin + NextToken; + Identifier; + end; +end; + +procedure TmwSimplePasPar.QualifiedIdentifierList; +begin + QualifiedIdentifier; + while (TokenID = tokComma) do + begin + NextToken; + QualifiedIdentifier; + end; +end; + +procedure TmwSimplePasPar.CharString; +begin //updated mw 2/22/00, JThurman 6/24/2004 + case TokenID of + tokAsciiChar, tokIdentifier, tokRoundOpen, tokStringConst: + while TokenID in + [tokAsciiChar, tokIdentifier, tokPlus, tokRoundOpen, tokStringConst, + tokString] do + begin + case TokenID of + tokIdentifier, tokRoundOpen: + begin + VariableReference; + end; + tokString: //JT + begin + StringStatement; + end; + else + NextToken; + end; + {$IFDEF D8_NEWER} + if Lexer.TokenID = tokPoint then + begin + NextToken; + VariableReference; + end; + {$ENDIF} + end; + else + begin + SynError(InvalidCharString); + end; + end; +end; + +(*procedure TmwSimplePasPar.CharString; +begin //updated mw 2/22/00 + case TokenID of + tokAsciiChar, tokIdentifier, tokRoundOpen, tokStringConst: + while TokenID in + [tokAsciiChar, tokIdentifier, tokPlus, tokRoundOpen, tokStringConst] do + begin + case TokenID of + tokIdentifier, tokRoundOpen: + begin + VariableReference; + end; + else + NextToken; + end; + end; + else + begin + SynError(InvalidCharString); + end; + end; +end;*) + +(*procedure TmwSimplePasPar.CharString; +begin + case TokenID of + tokAsciiChar, tokStringConst: + while TokenID in [tokAsciiChar, tokPlus, tokStringConst] do + begin + case TokenID of + tokPlus: + begin + NextToken; + if TokenID = tokIdentifier then + begin + VariableReference; + end; + end; + else + begin + NextToken; + end; + end; + end; + tokIdentifier: + begin + VariableReference; + case TokenID of + tokPlus: + begin + NextToken; + while TokenID in [tokAsciiChar, tokPlus, tokStringConst] do + begin + case TokenID of + tokPlus: + begin + NextToken; + if TokenID = tokIdentifier then + begin + VariableReference; + end; + end; + else + begin + NextToken; + end; + end; + end; + end; + end; + end + else + begin + SynError(InvalidCharString); + end; + end; +end;*) + +procedure TmwSimplePasPar.IncludeFile; +begin + while TokenID <> tokNull do + case TokenID of + tokClass: + begin + ProcedureDeclarationSection; + end; + tokConst: + begin + ConstSection; + end; + tokConstructor: + begin + ProcedureDeclarationSection; + end; + tokDestructor: + begin + ProcedureDeclarationSection; + end; + tokExports: + begin + ExportsClause; + end; + tokFunction: + begin + ProcedureDeclarationSection; + end; + tokIdentifier: + begin + Lexer.InitAhead; + if Lexer.AheadTokenID in [tokColon, tokEqual] then + begin + ConstantDeclaration; + if TokenID = tokSemiColon then SEMICOLON; + end + else + NextToken; + end; + tokLabel: + begin + LabelDeclarationSection; + end; + tokProcedure: + begin + ProcedureDeclarationSection; + end; + tokResourceString: + begin + ConstSection; + end; + tokType: + begin + TypeSection; + end; + tokThreadVar: + begin + VarSection; + end; + tokVar: + begin + VarSection; + end; + else + begin + NextToken; + end; + end; +end; + +procedure TmwSimplePasPar.SkipSpace; //XM Jul-2000 +begin + Expected(tokSpace); + while TokenID in [tokSpace] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.SkipCRLFco; //XM Jul-2000 +begin + Expected(tokCRLFCo); + while TokenID in [tokCRLFCo] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.SkipCRLF; //XM Jul-2000 +begin + Expected(tokCRLF); + while TokenID in [tokCRLF] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.ClassClass; +begin + Expected(tokClass); +end; + +procedure TmwSimplePasPar.PropertyDefault; +begin + ExpectedEx(tokDefault); +end; + +procedure TmwSimplePasPar.DispIDSpecifier; // DR 2001-07-26 +begin + ExpectedEx(tokDispid); + ConstantExpression; +end; + +procedure TmwSimplePasPar.IndexSpecifier; +begin + ExpectedEx(tokIndex); + ConstantExpression; +end; + +procedure TmwSimplePasPar.ClassTypeEnd; +begin +end; + +procedure TmwSimplePasPar.ObjectTypeEnd; +begin +end; + +procedure TmwSimplePasPar.DirectiveDeprecated; +begin + ExpectedEx(tokDeprecated); + if TokenID = tokStringConst then + NextToken; +end; + +procedure TmwSimplePasPar.DirectiveLibrary; +begin + ExpectedEx(tokLibrary); +end; + +procedure TmwSimplePasPar.DirectivePlatform; +begin + ExpectedEx(tokPlatform); +end; + +procedure TmwSimplePasPar.EnumeratedTypeItem; +begin + QualifiedIdentifier; + if TokenID = tokEqual then + begin + Expected(tokEqual); + ConstantExpression; + end; +end; + +procedure TmwSimplePasPar.Identifier; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.DirectiveLocal; +begin + ExpectedEx(tokLocal); +end; + +procedure TmwSimplePasPar.DirectiveVarargs; +begin + ExpectedEx(tokVarargs); +end; + +procedure TmwSimplePasPar.AncestorId; +begin + // !! Although I re-added this function I modified it + // so that it now calls QualifiedIdentifier, per DR's change + QualifiedIdentifier; +end; + +procedure TmwSimplePasPar.AncestorIdList; +begin + // !! Added this function back in + AncestorId; + while(TokenID = tokComma) do + begin + NextToken; + AncestorId; + end; +end; + + + +procedure TmwSimplePasPar.AnonymousMethod; +begin + case TokenID of + tokFunction: + begin + NextToken; + if TokenID = tokRoundOpen then + FormalParameterList; + Expected(tokColon); + ReturnType; + end; + tokProcedure: + begin + NextToken; + if TokenId = tokRoundOpen then + FormalParameterList; + end; + end; + Block; +end; + +procedure TmwSimplePasPar.AnonymousMethodType; +begin +{$IFDEF D11_NEWER} + ExpectedEx(tokReference); //ExID = tokReference + Expected(tokTo); + case TokenID of + tokProcedure: + begin + NextToken; + if TokenID = tokRoundOpen then + FormalParameterList; + end; + tokFunction: + begin + NextToken; + if TokenID = tokRoundOpen then + FormalParameterList; + Expected(tokColon); + ReturnType; + end; + end; +{$ENDIF} +end; + +procedure TmwSimplePasPar.InitAhead; +begin + if AheadParse = nil then + AheadParse := TmwSimplePasPar.Create; + AheadParse.Lexer.InitFrom(Lexer); +end; + +{$IFDEF D8_NEWER} //JThurman 2004-03-03 + +procedure TmwSimplePasPar.GlobalAttributes; +begin + GlobalAttributeSections; +end; + +procedure TmwSimplePasPar.GlobalAttributeSections; +begin + while TokenID = tokSquareOpen do + GlobalAttributeSection; +end; + +procedure TmwSimplePasPar.GlobalAttributeSection; +begin + Expected(tokSquareOpen); + GlobalAttributeTargetSpecifier; + AttributeList; + while TokenID = tokComma do + begin + Expected(tokComma); + GlobalAttributeTargetSpecifier; + AttributeList; + end; + Expected(tokSquareClose); +end; + +procedure TmwSimplePasPar.GlobalAttributeTargetSpecifier; +begin + GlobalAttributeTarget; + Expected(tokColon); +end; + +procedure TmwSimplePasPar.GlobalAttributeTarget; +begin + Expected(tokIdentifier); +end; + +procedure TmwSimplePasPar.Attributes; +begin + AttributeSections; +end; + +procedure TmwSimplePasPar.AttributeSections; +begin + while TokenID = tokSquareOpen do + AttributeSection; +end; + +procedure TmwSimplePasPar.AttributeSection; +begin + Expected(tokSquareOpen); + Lexer.InitAhead; + if Lexer.AheadTokenID = tokColon then + AttributeTargetSpecifier; + AttributeList; + while TokenID = tokComma do + begin + Lexer.InitAhead; + if Lexer.AheadTokenID = tokColon then + AttributeTargetSpecifier; + AttributeList; + end; + Expected(tokSquareClose); +end; + +procedure TmwSimplePasPar.AttributeTargetSpecifier; +begin + AttributeTarget; + Expected(tokColon); +end; + +procedure TmwSimplePasPar.AttributeTarget; +begin + case TokenID of + tokProperty: + Expected(tokProperty); + tokType: + Expected(tokType); + else + Expected(tokIdentifier); + end; +end; + +procedure TmwSimplePasPar.AttributeList; +begin + Attribute; + while TokenID = tokComma do + begin + Expected(tokComma); + AttributeList; + end; +end; + +procedure TmwSimplePasPar.Attribute; +begin + AttributeName; + if TokenID = tokRoundOpen then + AttributeArguments; +end; + +procedure TmwSimplePasPar.AttributeName; +begin + case TokenID of + tokIn, tokOut, tokConst, tokVar: + NextToken; + else + Expected(tokIdentifier); + end; +end; + +procedure TmwSimplePasPar.AttributeArguments; +begin + Expected(tokRoundOpen); + if TokenID <> tokRoundClose then + begin + Lexer.InitAhead; + if Lexer.AheadTokenID = tokEqual then + NamedArgumentList + else + PositionalArgumentList; + if Lexer.TokenID = tokEqual then + NamedArgumentList; + end; + Expected(tokRoundClose); +end; + +procedure TmwSimplePasPar.PositionalArgumentList; +begin + PositionalArgument; + while TokenID = tokComma do + begin + Expected(tokComma); + PositionalArgument; + end; +end; + +procedure TmwSimplePasPar.PositionalArgument; +begin + AttributeArgumentExpression; +end; + +procedure TmwSimplePasPar.NamedArgumentList; +begin + NamedArgument; + while TokenID = tokComma do + begin + Expected(tokComma); + NamedArgument; + end; +end; + +procedure TmwSimplePasPar.NamedArgument; +begin + Expected(tokIdentifier); + Expected(tokEqual); + AttributeArgumentExpression; +end; + +procedure TmwSimplePasPar.AttributeArgumentExpression; +begin + Expression; +end; + +procedure TmwSimplePasPar.CustomAttribute; +begin + AttributeSection;//TODO: Global vs. Local attributes +{ Lexer.InitAhead; + if (Lexer.AheadToken = 'assembly') or (Lexer.AheadToken = 'module') then + GlobalAttributeSections + else} + AttributeSections; + +end; +{$ENDIF} + +end. + diff --git a/Projects/SAMufasaGUI/CastaliaSimplePasParTypes.pas b/Projects/SAMufasaGUI/CastaliaSimplePasParTypes.pas new file mode 100644 index 0000000..20027f4 --- /dev/null +++ b/Projects/SAMufasaGUI/CastaliaSimplePasParTypes.pas @@ -0,0 +1,330 @@ +{--------------------------------------------------------------------------- +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/NPL/NPL-1_1Final.html + +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 Original Code is: mwSimplePasParTypes, released November 14, 1999. + +The Initial Developer of the Original Code is Martin Waldenburg +unit CastaliaPasLexTypes; + +----------------------------------------------------------------------------} + +unit CastaliaSimplePasParTypes; + +{$include ValistusDefines.inc} + +interface + +uses SysUtils, TypInfo; + +type + TmwParseError = ( + InvalidAdditiveOperator, + InvalidAccessSpecifier, + InvalidCharString, + InvalidClassMethodHeading, + InvalidConstantDeclaration, + InvalidConstSection, + InvalidDeclarationSection, + InvalidDirective16Bit, + InvalidDirectiveBinding, + InvalidDirectiveCalling, + InvalidExportedHeading, + InvalidForStatement, + InvalidInitializationSection, + InvalidInterfaceDeclaration, + InvalidInterfaceType, + InvalidLabelId, + InvalidLabeledStatement, + InvalidMethodHeading, + InvalidMultiplicativeOperator, + InvalidNumber, + InvalidOrdinalIdentifier, + InvalidParameter, + InvalidParseFile, + InvalidProceduralDirective, + InvalidProceduralType, + InvalidProcedureDeclarationSection, + InvalidProcedureMethodDeclaration, + InvalidRealIdentifier, + InvalidRelativeOperator, + InvalidStorageSpecifier, + InvalidStringIdentifier, + InvalidStructuredType, + InvalidTryStatement, + InvalidTypeKind, + InvalidVariantIdentifier, + InvalidVarSection, + vchInvalidClass, //vch + vchInvalidMethod, //vch + vchInvalidProcedure,//vch + vchInvalidCircuit, //vch + vchInvalidIncludeFile //vch + ); + + TmwPasCodeInfo = ( + ciNone, //: @BUG heresy ! + ciAccessSpecifier, + ciAdditiveOperator, + ciArrayConstant, + ciArrayType, + ciAsmStatement, + ciBlock, + ciCaseLabel, + ciCaseSelector, + ciCaseStatement, + ciCharString, + ciClassClass, //DR 2001-07-16 + ciClassField, + ciClassForward, + ciClassFunctionHeading, + ciClassHeritage, + ciClassMemberList, + ciClassMethodDirective, + ciClassMethodHeading, + ciClassMethodOrProperty, + ciClassMethodResolution, + ciClassProcedureHeading, + ciClassProperty, + ciClassReferenceType, + ciClassType, + ciClassTypeEnd, // DR 2001-07-31 + ciClassVisibility, + ciCompoundStatement, + ciConstantColon, + ciConstantDeclaration, + ciConstantEqual, + ciConstantExpression, + ciConstantName, + ciConstantValue, + ciConstantValueTyped, + ciConstParameter, + ciConstructorHeading, + ciConstructorName, + ciConstSection, + ciContainsClause, + ciContainsExpression, + ciContainsIdentifier, + ciContainsStatement, + ciDeclarationSection, + ciDesignator, + ciDestructorHeading, + ciDestructorName, + ciDirective16Bit, + ciDirectiveBinding, + ciDirectiveCalling, + ciDirectiveDeprecated, // DR 2001-10-20 + ciDirectiveLibrary, // DR 2001-10-20 + ciDirectiveLocal, // DR 2001-11-14 + ciDirectivePlatform, // DR 2001-10-20 + ciDirectiveVarargs, // DR 2001-11-14 + ciDispIDSpecifier, // DR 2001-07-26 + ciDispInterfaceForward, + ciEmptyStatement, + ciEnumeratedType, + ciEnumeratedTypeItem, // DR 2001-10-29 + ciExceptBlock, + ciExceptionBlockElseBranch, + ciExceptionClassTypeIdentifier, + ciExceptionHandler, + ciExceptionHandlerList, + ciExceptionIdentifier, + ciExceptionVariable, + ciExpliciteType, + ciExportedHeading, + ciExportsClause, + ciExportsElement, + ciExpression, + ciExpressionList, + ciExternalDirective, + ciExternalDirectiveThree, + ciExternalDirectiveTwo, + ciFactor, + ciFieldDeclaration, + ciFieldList, + ciFileType, + ciFormalParameterList, + ciFormalParameterSection, + ciForStatement, + ciForwardDeclaration, // DR 2001-07-23 + ciFunctionHeading, + ciFunctionMethodDeclaration, + ciFunctionMethodName, + ciFunctionProcedureBlock, + ciFunctionProcedureName, + ciHandlePtCompDirect, //XM 20001125 + ciHandlePtDefineDirect, //XM 20001125 + ciHandlePtElseDirect, //XM 20001125 + ciHandlePtIfDefDirect, //XM 20001125 + ciHandlePtEndIfDirect, //XM 20001125 + ciHandlePtIfNDefDirect, //XM 20001125 + ciHandlePtIfOptDirect, //XM 20001125 + ciHandlePtIncludeDirect,//XM 20001125 + ciHandlePtResourceDirect,//XM 20001125 + ciHandlePtUndefDirect, //XM 20001125 + ciIdentifier, + ciIdentifierList, + ciIfStatement, + ciImplementationSection, + ciIncludeFile, + ciIndexSpecifier, // DR 2001-07-26 + ciInheritedStatement, + ciInitializationSection, + ciInlineStatement, + ciInterfaceDeclaration, + ciInterfaceForward, + ciInterfaceGUID, + ciInterfaceHeritage, + ciInterfaceMemberList, + ciInterfaceSection, + ciInterfaceType, + ciLabelDeclarationSection, + ciLabeledStatement, + ciLabelId, + ciLibraryFile, + ciMainUsedUnitExpression, + ciMainUsedUnitName, + ciMainUsedUnitStatement, + ciMainUsesClause, + ciMultiplicativeOperator, + ciNewFormalParameterType, + ciNumber, + ciNextToken, //XM 20002512 + ciObjectConstructorHeading, + ciObjectDestructorHeading, + ciObjectField, + ciObjectForward, + ciObjectFunctionHeading, + ciObjectHeritage, + ciObjectMemberList, + ciObjectMethodDirective, + ciObjectMethodHeading, + ciObjectNameOfMethod, + ciObjectProcedureHeading, + ciObjectProperty, // DR 2001-08-07 + ciObjectPropertySpecifiers, // DR 2001-08-07 + ciObjectType, + ciObjectTypeEnd, // DR 2001-08-07 + ciObjectVisibility, + ciOldFormalParameterType, + ciOrdinalIdentifier, + ciOrdinalType, + ciOutParameter, + ciPackageFile, + ciParameterFormal, + ciParameterName, + ciParameterNameList, + ciParseFile, + ciPointerType, + ciProceduralDirective, + ciProceduralType, + ciProcedureDeclarationSection, + ciProcedureHeading, + ciProcedureMethodDeclaration, + ciProcedureMethodName, + ciProgramBlock, + ciProgramFile, + ciPropertyDefault, // DR 2001-07-16 + ciPropertyInterface, + ciPropertyName, + ciPropertyParameterConst, + ciPropertyParameterList, + ciPropertySpecifiers, + ciQualifiedIdentifier, + ciQualifiedIdentifierList, + ciRaiseStatement, + ciReadAccessIdentifier, + ciRealIdentifier, + ciRealType, + ciRecordConstant, + ciRecordFieldConstant, + ciRecordType, + ciRecordVariant, + ciRelativeOperator, + ciRepeatStatement, + ciRequiresClause, + ciRequiresIdentifier, + ciResolutionInterfaceName, + ciResourceDeclaration, + ciReturnType, + ciSEMICOLON, //XM 20002512 + ciSetConstructor, + ciSetElement, + ciSetType, + ciSimpleExpression, + ciSimpleStatement, + ciSimpleType, + ciSkipAnsiComment, + ciSkipBorComment, + ciSkipSlashesComment, + ciSkipSpace, //XM 20002511 + ciSkipCRLFco, //XM 20002511 + ciSkipCRLF, //XM 20002511 + ciStatement, + ciStatementList, + ciStorageExpression, + ciStorageIdentifier, + ciStorageDefault, + ciStorageNoDefault, + ciStorageSpecifier, + ciStorageStored, + ciStringIdentifier, + ciStringStatement, + ciStringType, + ciStructuredType, + ciSubrangeType, + ciTagField, + ciTagFieldName, + ciTagFieldTypeName, + ciTerm, + ciTryStatement, + ciTypedConstant, + ciTypeDeclaration, + ciTypeId, + ciTypeKind, + ciTypeName, + ciTypeSection, + ciUnitFile, + ciUnitId, + ciUsedUnitName, + ciUsedUnitsList, + ciUsesClause, + ciVarAbsolute, + ciVarEqual, + ciVarDeclaration, + ciVariable, + ciVariableList, + ciVariableReference, + ciVariableTwo, + ciVariantIdentifier, + ciVariantSection, + ciVarParameter, + ciVarSection, + ciVisibilityAutomated, + ciVisibilityPrivate, + ciVisibilityProtected, + ciVisibilityPublic, + ciVisibilityPublished, + ciVisibilityUnknown, + ciWhileStatement, + ciWithStatement, + ciWriteAccessIdentifier + ); + +function ParserErrorName(Value: TmwParseError): string; + +implementation + +function ParserErrorName(Value: TmwParseError): string; +begin + result := GetEnumName(TypeInfo(TmwParseError), Integer(Value)); +end; + +end. + diff --git a/Projects/SAMufasaGUI/PSDump.pas b/Projects/SAMufasaGUI/PSDump.pas new file mode 100644 index 0000000..b3cbc08 --- /dev/null +++ b/Projects/SAMufasaGUI/PSDump.pas @@ -0,0 +1,343 @@ +{ +@abstract(Component wrapper for IFPS3 compiler and executer) +A component wrapper for IFPS3, including debugging support. + +} +//{$I PascalScript.inc} + +unit PSDump; + +interface + +uses + {$IFNDEF LINUX} Windows, {$ENDIF} SysUtils, Classes, uPSRuntime, uPSUtils, uPSComponent, + uPSCompiler, uPSC_dll, typInfo; + +type + TPSOnCompCleanup = function (Sender: TObject; aComp: TPSPascalCompiler): Boolean of object; + TPSOnException = procedure (Sender: TPSExec; ExError: TPSError; const ExParam: tbtstring; ExObject: TObject; ProcNo, Position: Cardinal) of object; + + TPSScriptExtension = class(TPSScriptDebugger) + private + FOnBeforeCleanUp: TPSOnCompCleanup; + FNeedCompiling: Boolean; + FOnScriptChange: TNotifyEvent; + FOnException: TPSOnException; + fItems: TStrings; + + procedure GetCodeProps; + protected + function DoBeforeCleanup(Sender: TObject; aComp: TPSPascalCompiler):Boolean; + procedure DoScriptChange(sender:TObject); + public + constructor Create(AOwner: TComponent); override; + function Compile: Boolean; override; + function Execute: Boolean; override; + procedure GetValueDefs(aItems: TStrings); + procedure CompileIfNeeded; + + property NeedCompiling : Boolean read FNeedCompiling; + published + property OnBeforeCleanUp: TPSOnCompCleanup read FOnBeforeCleanUp write FOnBeforeCleanUp; + Property OnScriptChange: TNotifyEvent read FOnScriptChange write fOnScriptChange; + property OnException: TPSOnException read FOnException write FOnException; + end; + + +implementation + +function BeforeCleanup(Sender: TPSPascalCompiler): Boolean; +begin + Result := TPSScriptExtension(Sender.ID).DoBeforeCleanUp(TObject(Sender.ID),Sender); +end; + +procedure CEException(Sender: TPSExec; ExError: TIFError; const ExParam: tbtstring; ExObject: TObject; ProcNo, Position: Cardinal); +begin + if (@TPSScriptExtension(Sender.ID).FOnException <> nil) then + TPSScriptExtension(Sender.ID).FOnException(Sender, ExError, ExParam, ExObject, ProcNo, Position); +end; + +{ TPSScriptExtension } + +function TPSScriptExtension.Compile: Boolean; +begin + Result := inherited Compile; + FNeedCompiling := not result; +end; + +constructor TPSScriptExtension.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + Comp.OnBeforeCleanup := {$IFDEF FPC}@{$ENDIF}BeforeCleanup; + Exec.OnException := {$IFDEF FPC}@{$ENDIF}CEException; + + TStringList(script).OnChange := {$IFDEF FPC}@{$ENDIF}DoScriptChange; + FNeedCompiling := True; +end; + +type + _TMyPascalCompiler = class(TPSPascalCompiler); +procedure TPSScriptExtension.GetCodeProps; + + function TypeToString(t: TPSType; Definition: Boolean = False): string; forward; + + function FunctionType(f: TObject): string; + const + FuncStr: array[Boolean] of string = ('procedure', 'function'); + begin + if (f is TPSDelphiClassItemConstructor) then + Result := 'constructor' + else if (f is TPSDelphiClassItemMethod) then + Result := FuncStr[TPSDelphiClassItemMethod(f).Decl.Result <> nil] + else if (f is TPSProceduralType) then + Result := FuncStr[TPSProceduralType(f).ProcDef.Result <> nil] + else if (f is TPSRegProc) then + Result := FuncStr[TPSRegProc(f).Decl.Result <> nil] + else if (f is TPSInternalProcedure) then + Result := FuncStr[TPSInternalProcedure(f).Decl.Result <> nil] + else + Result := ''; + end; + + function ParamsToString(d: TPSParametersDecl; CheckResult: Boolean = True): string; + const + ParamStr: array [pmIn..pmInOut] of tbtstring = ('','out ','var '); + var + i: Integer; + begin + Result := ''; + for i := 0 to d.ParamCount - 1 do + begin + if (Result <> '') then + Result := Result + '; '; + Result := Result + ParamStr[d.Params[i].Mode] + d.Params[i].OrgName; + if (d.Params[i].aType <> nil) then + Result := Result +': '+ TypeToString(d.Params[i].aType); + end; + + if (Result <> '') then + Result := '('+Result+')'; + if CheckResult and (d.Result <> nil) then + Result := Result + ': ' + TypeToString(d.Result); + end; + + function ClassItemsToString(c: TPSCompileTimeClass; DoneList: TStrings = nil): string; + var + ci: TPSDelphiClassItem; + i, ii: Integer; + s: string; + Def: Cardinal; + ListFree: Boolean; + begin + Result := ''; + if (c = nil) then + Exit; + + if (DoneList = nil) then + begin + DoneList := TStringList.Create; + TStringList(DoneList).Sorted := True; + ListFree := True; + end + else + ListFree := False; + + if (not c.Property_Find('', Def)) then + Def := 0; + + for i := 0 to c.Count - 1 do + begin + ci := c.Items[i]; + If (ci = nil) or (DoneList.IndexOf(ci.OrgName) > -1) then + Continue; + DoneList.Add(ci.OrgName); + + if (ci is TPSDelphiClassItemConstructor) or (ci is TPSDelphiClassItemMethod) then + Result := Result + FunctionType(ci) + ' ' + ci.OrgName + ParamsToString(ci.Decl, not (ci is TPSDelphiClassItemConstructor)) + '; ' + else if (ci is TPSDelphiClassItemProperty) then + begin + s := ''; + for ii := 0 to ci.Decl.ParamCount - 1 do + begin + if (s <> '') then + s := s + ', '; + s := s + 'Index'; + if (ii > 0) then + s := s + IntToStr(ii + 1); + s := s + ': ' + TypeToString(ci.Decl.Params[ii].aType); + end; + if (s <> '') then + s := '['+s+']'; + Result := Result + 'property ' + ci.OrgName + s; + if (ci.Decl.Result <> nil) then + Result := Result + ': '+ TypeToString(ci.Decl.Result); + if (Cardinal(ci) = Def) then + Result := Result + '; default'; + Result := Result + '; '; + end; + end; + + Result := Result + ClassItemsToString(c.ClassInheritsFrom, DoneList); + if ListFree then + DoneList.Free; + end; + + function TypeToString(t: TPSType; Definition: Boolean = False): string; + var + r: PIFPSRecordFieldTypeDef; + i: Integer; + begin + if (not Definition) and (t.OriginalName <> '') and (t.OriginalName[1] <> '!') then + Result := t.OriginalName + else if (t is TPSRecordType) then + begin + Result := 'record '; + for i := 0 to (t as TPSRecordType).RecValCount - 1 do + begin + r := (t as TPSRecordType).RecVal(i); + Result := Result + r.FieldOrgName + ': ' + TypeToString(r.aType) + '; '; + end; + Result := Result + 'end'; + end + else if (t is TPSClassType) then + Result := 'class ' + ClassItemsToString((t as TPSClassType).Cl) + 'end' + else if (t is TPSProceduralType) then + Result := FunctionType(t) + ParamsToString((t as TPSProceduralType).ProcDef) + else if (t is TPSArrayType) then + Result := 'array of ' + TypeToString((t as TPSArrayType).ArrayTypeNo) + else if (t is TPSStaticArrayType) then + with (t as TPSStaticArrayType) do + Result := 'array[' + IntToStr(StartOffset) + '..' + IntToStr(StartOffset + Length) + ' of ' + TypeToString(ArrayTypeNo) + else if (t is TPSSetType) then + Result := 'set of ' + TypeToString((t as TPSSetType).SetType) + else if (t is TPSTypeLink) then + Result := TypeToString((t as TPSTypeLink).LinkTypeNo) + else if (t is TPSEnumType) then + begin + Result := ''; + for i := 0 to t.Attributes.Count - 1 do + begin + if (Result <> '') then + Result := Result + ', '; + Result := Result + TPSConstant(t.Attributes[i].AType).OrgName; + end; + + if (Result <> '') then + Result := '('+Result+')' + else + Result := 'enum'; + end + else + Result := t.OriginalName; + end; + + function IfRVariantToString(v: TIfRVariant): string; + begin + case v.FType.BaseType of + btU8: Result := IntToStr(v.tu8); + btS8: Result := IntToStr(v.ts8); + btU16: Result := IntToStr(v.tu16); + btS16: Result := IntToStr(v.ts16); + btU32: Result := IntToStr(v.tu32); + btS32: Result := IntToStr(v.ts32); + btSingle: Result := FloatToStr(v.tsingle); + btDouble: Result := FloatToStr(v.tdouble); + btExtended: Result := FloatToStr(v.textended); + btString: Result := tbtString(v.tstring); + {$IFNDEF PS_NOINT64} + btS64: Result := IntToStr(v.ts64); + {$ENDIF} + btChar: Result := '#' + IntToStr(Ord(v.tchar)); + {$IFNDEF PS_NOWIDESTRING} + btWideString: Result := tbtwidestring(v.twidestring); + btWideChar: Result := '#' + IntToStr(Ord(v.twidechar)); + {$ENDIF} + btCurrency: Result := FloatToStr(v.tcurrency); + btUnicodeString: Result := tbtunicodestring(v.tunistring); + else + Result := v.FType.OriginalName; + end; + end; + +var + i : Integer; +begin + if (fItems = nil) then + Exit; + + fItems.BeginUpdate; + try + fItems.Clear; + + with _TMyPascalCompiler(Comp) do + begin + for i := 0 to FConstants.Count - 1 do + with TPSConstant(FConstants[i]) do + if (Value^.FType is TPSEnumType) then + Value^.FType.Attributes.Add(TPSAttributeType(FConstants[i])) + else + fItems.Add('const ' + OrgName + ' = ' + IfRVariantToString(Value^) + ';'); + + for i := 0 to FTypes.Count - 1 do + with TPSType(FTypes[i]) do + if (OriginalName <> '') and (OriginalName[1] <> '!') then + fItems.Add('type ' + OriginalName + ' = ' + TypeToString(TPSType(FTypes[i]), True) + ';'); + + for i := 0 to FVars.Count - 1 do + with TPSVar(FVars[i]) do + fItems.Add('var ' + OrgName + ': ' + TypeToString(TPSType(FVars[i]), True) + ';'); + + for i := 0 to FRegProcs.Count - 1 do + with TPSRegProc(FRegProcs[i]) do + fItems.Add(FunctionType(TObject(FRegProcs[i])) + ' ' + OrgName + ParamsToString(Decl) + '; forward;'); + + for i := 0 to FProcs.Count - 1 do + if (TPSProcedure(FProcs[i]) is TPSInternalProcedure) then + with TPSInternalProcedure(FProcs[i]) do + if (Name <> '') and (Name[1] <> '!') then + fItems.Add(FunctionType(TObject(FProcs[i])) + ' ' + OriginalName + ParamsToString(Decl) + '; forward;'); + end; + finally + fItems.EndUpdate; + end; +end; + +procedure TPSScriptExtension.GetValueDefs(aItems: TStrings); +begin + fItems := aItems; + try + Compile; + finally + fItems := nil; + end; +end; + +function TPSScriptExtension.DoBeforeCleanup(Sender: TObject; aComp: TPSPascalCompiler): Boolean; +begin + Result := True; + if (fItems <> nil) then + GetCodeProps; + if (@FOnBeforeCleanUp <> nil) then + Result := FOnBeforeCleanUp(Sender, aComp); +end; + +function TPSScriptExtension.Execute: Boolean; +begin + CompileIfNeeded; + Result := inherited Execute; +end; + +procedure TPSScriptExtension.DoScriptChange(sender: TObject); +begin + FNeedCompiling := True; + if (@FOnScriptChange <> nil) then + FOnScriptChange(sender); +end; + +procedure TPSScriptExtension.CompileIfNeeded; +begin + if FNeedCompiling then + Compile; +end; + +end. diff --git a/Projects/SAMufasaGUI/ValistusDefines.inc b/Projects/SAMufasaGUI/ValistusDefines.inc new file mode 100644 index 0000000..b886044 --- /dev/null +++ b/Projects/SAMufasaGUI/ValistusDefines.inc @@ -0,0 +1,11 @@ +//Code Insight +{$DEFINE ciCHECKDUPLICATES} +{$DEFINE D8_NEWER1} +{$DEFINE D9_NEWER} +{$DEFINE D10_NEWER} +{.$DEFINE D11_NEWER} +{.$DEFINE D12_NEWER} + +{$IFDEF FPC} + {$H+} +{$ENDIF} diff --git a/Projects/SAMufasaGUI/v_Constants.pas b/Projects/SAMufasaGUI/v_Constants.pas new file mode 100644 index 0000000..ac6209a --- /dev/null +++ b/Projects/SAMufasaGUI/v_Constants.pas @@ -0,0 +1,18 @@ +unit v_Constants; + +interface + +//Code Insight Constants +const + {$IFNDEF FPC} + LineEnding = #13#10; + {$ENDIF} + + ci_RangeError = 'Array range error at "%s" in statement: "%s"'; + ci_UnknownMember = 'Unknown member "%s" in statement: "%s"'; + ci_UnknownStruct = 'Cannot find proper structure for "%s" in statement: "%s"'; + ci_UnknownInclude = 'Unknown include "%s"'; + +implementation + +end. diff --git a/Projects/SAMufasaGUI/v_MiscFunctions.pas b/Projects/SAMufasaGUI/v_MiscFunctions.pas new file mode 100644 index 0000000..8aa1e2d --- /dev/null +++ b/Projects/SAMufasaGUI/v_MiscFunctions.pas @@ -0,0 +1,145 @@ +unit v_MiscFunctions; + +interface + +type + TStringArray = array of string; + +function Explode(Sep, s: string): TStringArray; +function PrePrepareString(s: string): string; +function PrepareString(s: string; out ArrayCount: Integer): string; overload; +function PrepareString(s: string): string; overload; +function GetFirstWord(s: string): string; +function CompressWhiteSpace(s: string): string; + +implementation + +uses + SysUtils, StrUtils; + +function Explode(Sep, s: string): TStringArray; +var + p1, p2: Integer; +begin + SetLength(Result, 0); + s := s + Sep; + p1 := 1; + p2 := Pos(Sep, s); + while (p1 > 0) and (p2 > 0) do + begin + SetLength(Result, Length(Result) + 1); + Result[High(Result)] := Copy(s, p1, p2 - p1); + p1 := p2 + Length(Sep); + p2 := PosEx(Sep, s, p1 + 1); + end; +end; + +function PrePrepareString(s: string): string; +var + i: Integer; + BraceCount: Integer; +begin + Result := ''; + BraceCount := 0; + for i := 1 to Length(s) do + if (BraceCount = 0) and (s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '.', '[', ']']) then + Result := Result + s[i] + else if (s[i] = '(') then + Inc(BraceCount) + else if (s[i] = ')') then + Dec(BraceCount); +end; + +function PrepareString(s: string; out ArrayCount: Integer): string; overload; +var + i: Integer; + BraceCount, BracketCount: Integer; +begin + Result := ''; + BraceCount := 0; + BracketCount := 0; + ArrayCount := 0; + s := UpperCase(s); + for i := 1 to Length(s) do + if (BraceCount = 0) and (BracketCount = 0) and (s[i] in ['A'..'Z', '0'..'9', '_']) then + Result := Result + s[i] + else if (s[i] = '[') then + begin + if (BracketCount = 0) then + Inc(ArrayCount); + Inc(BracketCount); + end + else if (s[i] = ']') then + Dec(BracketCount) + else if (s[i] = '(') then + Inc(BraceCount) + else if (s[i] = ')') then + Dec(BraceCount); +end; + +function PrepareString(s: string): string; overload; +var + a: Integer; +begin + Result := PrepareString(s, a); +end; + +function GetFirstWord(s: string): string; +var + i: Integer; +begin + i := 1; + while (i <= Length(s)) and (s[i] in ['a'..'z', 'A'..'Z']) do + Inc(i); + Result := Copy(s, 1, i - 1); +end; + +function CompressWhiteSpace(s: string): string; + + function GetNextChar(s: string; i: Integer; out c: Char): Boolean; + begin + Result := True; + c := #0; + + while (i <= Length(s)) and (s[i] in [#10, #11, #13, #32]) do + Inc(i); + if (i <= Length(s)) then + c := s[i] + else + Result := False; + end; + +var + i: Integer; + c: Char; + LastSpace: Boolean; +begin + Result := ''; + i := 1; + LastSpace := False; + while (i <= Length(s)) do + begin + if (s[i] in [#10, #11, #13, #32]) then + begin + if (not LastSpace) and (GetNextChar(s, i, c) and (c in ['a'..'z', 'A'..'Z', '0'..'9', '_'])) then + Result := Result + ' '; + Inc(i); + while (i <= Length(s)) and (s[i] in [#10, #11, #13, #32]) do + Inc(i); + LastSpace := True; + end + else + begin + LastSpace := False; + Result := Result + s[i]; + if (s[i] in [':', ';']) then + begin + Result := Result + ' '; + LastSpace := True; + end; + Inc(i); + end; + end; +end; + +end. diff --git a/Projects/SAMufasaGUI/v_autocompleteform.pas b/Projects/SAMufasaGUI/v_autocompleteform.pas new file mode 100644 index 0000000..acccd71 --- /dev/null +++ b/Projects/SAMufasaGUI/v_autocompleteform.pas @@ -0,0 +1,585 @@ +unit v_AutoCompleteForm; + +interface + +{$IFDEF FPC} +{$mode objfpc}{$H+} +{$ENDIF} + +uses + Classes, SysUtils, Forms, Controls, Graphics, Dialogs, + StdCtrls, ExtCtrls, + + {$IFDEF FPC} + LMessages, + lcltype + {$ELSE} + Windows, + Messages + {$ENDIF}; + +type + TInsertProc = procedure(Str: string) of object; + + TAutoCompleteListBox = class(TListBox) + protected + fIndexList: array of Integer; + fList: TStrings; + fInsertList: TStrings; + fFilter: string; + + procedure setItemList(List: TStrings); + procedure setInsertList(List: TStrings); + procedure setFilter(Filter: string); + + procedure DblClick; override; + procedure DrawItem(Index: Integer; ARect: TRect; State: TOwnerDrawState); override; + {$IFDEF FPC} + procedure WMEraseBkgnd(var message: TLMEraseBkgnd); message LM_ERASEBKGND; + procedure WMVScroll(var message: TLMVScroll); message LM_VSCROLL; + procedure CNChar(var message: TLMessage); message CN_CHAR; + {$ELSE} + procedure WMEraseBkgnd(var message: TWMEraseBkgnd); message WM_ERASEBKGND; + procedure WMVScroll(var message: TWMVScroll); message WM_VSCROLL; + procedure CNChar(var message: TMessage); message CN_CHAR; + {$ENDIF} + public + ColumnSizes: array of Integer; + Redirect: TWinControl; + InsertProc: TInsertProc; + + procedure setLists(ItemList, InsertList: TStrings); + function getInsert: string; + constructor Create(TheOwner: TComponent); override; + destructor Destroy; override; + published + property ItemList: TStrings read fList write setItemList; + property InsertList: TStrings read fInsertList write setInsertList; + property Filter: string read fFilter write setFilter; + end; + + TAutoCompletePopup = class(TForm) + protected + l: TAutoCompleteListBox; + procedure DoShow; override; + + function getRedirect: TWinControl; + procedure setRedirect(Control: TWinControl); + function getInsertProc: TInsertProc; + procedure setInsertProc(Proc: TInsertProc); + public + constructor Create(TheOwner: TComponent); override; + procedure Show(Pos: TPoint; ItemList, InsertList: TStrings; Filter: string = ''; Editor: TWinControl = nil); reintroduce; + procedure DoHide; override; + + procedure HandleKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + procedure HandleKeyPress(Sender: TObject; var Key: char); + published + property ListBox: TAutoCompleteListBox read l; + property Redirect: TWinControl read getRedirect write setRedirect; + property InsertProc: TInsertProc read getInsertProc write setInsertProc; + end; + + TParamHint = class(THintWindow) + public + constructor Create(TheOwner: TComponent); override; + procedure Paint; override; + end; + +implementation + +uses + StrUtils {$IFDEF FPC}, lclintf{$ENDIF}, Themes; + +procedure TAutoCompleteListBox.setItemList(List: TStrings); +begin + fList.Assign(List); +end; + +procedure TAutoCompleteListBox.setInsertList(List: TStrings); +begin + fInsertList.Assign(List); +end; + +procedure TAutoCompleteListBox.setLists(ItemList, InsertList: TStrings); +var + i: Integer; +begin + //fList.Assign(ItemList); + //fInsertList.Assign(InsertList); + {$IFDEF FPC}LockSelectionChange;{$ENDIF} + + fList.BeginUpdate; + try + fList.Clear; + fList.AddStrings(ItemList); + finally + fList.EndUpdate; + end; + + fInsertList.BeginUpdate; + try + fInsertList.Clear; + fInsertList.AddStrings(InsertList); + finally + fInsertList.EndUpdate; + end; + + Items.BeginUpdate; + try + Items.Clear; + Items.AddStrings(ItemList); + finally + Items.EndUpdate; + end; + + fFilter := ''; + + SetLength(fIndexList, fList.Count); + for i := 0 to fList.Count - 1 do + fIndexList[i] := i; + + if (fList.Count > 0) then + ItemIndex := 0 + else + ItemIndex := -1; + + {$IFDEF FPC}UnlockSelectionChange;{$ENDIF} +end; + +procedure TAutoCompleteListBox.setFilter(Filter: string); +var + i, c, l, del: Integer; +begin + Filter := LowerCase(Filter); + if (Filter = fFilter) then + Exit; + + {$IFDEF FPC}LockSelectionChange;{$ENDIF} + + c := 0; + if (LeftStr(Filter, Length(fFilter)) = fFilter) then + begin + fFilter := Filter; + + Items.BeginUpdate; + try + l := Length(fFilter); + del := 0; + + for i := 0 to Items.Count - 1 do + if (LowerCase(LeftStr(fInsertList[fIndexList[i]], l)) <> fFilter) then + begin + Items.Delete(i - del); + Inc(del); + end + else + begin + if (ItemIndex = i) or (LowerCase(fInsertList[fIndexList[i]]) = fFilter) then + ItemIndex := c; + + fIndexList[c] := fIndexList[i]; + Inc(c); + end; + + SetLength(fIndexList, c + 1); + finally + Items.EndUpdate; + end; + end + else + begin + fFilter := Filter; + + Items.BeginUpdate; + try + Items.Clear; + l := Length(fFilter); + SetLength(fIndexList, fInsertList.Count); + + for i := 0 to fInsertList.Count - 1 do + if (LowerCase(LeftStr(fInsertList[i], l)) = fFilter) then + begin + Items.Append(fList[i]); + + if (LowerCase(fInsertList[i]) = fFilter) then + ItemIndex := i; + + fIndexList[c] := i; + Inc(c); + end; + SetLength(fIndexList, c + 1); + finally + Items.EndUpdate; + end; + end; + + {$IFDEF FPC}UnlockSelectionChange;{$ENDIF} +end; + +function TAutoCompleteListBox.getInsert: string; +begin + if (ItemIndex < 0) or (ItemIndex > Length(fIndexList)) then + Result := '' + else + Result := fInsertList[fIndexList[ItemIndex]]; +end; + +{$IFDEF FPC} +procedure TAutoCompleteListBox.WMEraseBkgnd(var message: TLMEraseBkgnd); +{$ELSE} +procedure TAutoCompleteListBox.WMEraseBkgnd(var message: TWMEraseBkgnd); +{$ENDIF} +begin + if (Count < Round(Height / ItemHeight)) then + begin + Canvas.Brush.Color := clYellow; + FillRect(message.DC, Rect(0, Count * ItemHeight, Width, Height), HBRUSH({$IFDEF FPC}Brush.Reference.Handle{$ELSE}Parent.Brush.Handle{$ENDIF})); + end; + + message.Result := 1; +end; + +{$IFDEF FPC} +procedure TAutoCompleteListBox.WMVScroll(var message: TLMVScroll); +{$ELSE} +procedure TAutoCompleteListBox.WMVScroll(var message: TWMVScroll); +{$ENDIF} +var + c: Integer; +begin + {$IFDEF FPC}LockSelectionChange;{$ENDIF} + if (ItemIndex < TopIndex) then + ItemIndex := TopIndex + else + begin + c := Round(Height / ItemHeight) - 1; + if (ItemIndex > TopIndex + c) then + ItemIndex := TopIndex + c; + end; + {$IFDEF FPC}UnlockSelectionChange;{$ENDIF} +end; + +{$IFDEF FPC} +procedure TAutoCompleteListBox.CNChar(var message: TLMessage); +{$ELSE} +procedure TAutoCompleteListBox.CNChar(var message: TMessage); +{$ENDIF} +begin + inherited; + + {$IFDEF FPC} + if (message.Result = 0) and (Redirect <> nil) and (TLMChar(message).CharCode <> VK_DOWN) and (TLMChar(message).CharCode <> VK_UP) and (TLMChar(message).CharCode <> VK_RETURN) then + {$ELSE} + if (message.Result = 0) and (Redirect <> nil) and (TWMChar(message).CharCode <> VK_DOWN) and (TWMChar(message).CharCode <> VK_UP) and (TWMChar(message).CharCode <> VK_RETURN) then + {$ENDIF} + begin + Redirect.SetFocus; + Application.ProcessMessages; + SendMessage(Redirect.Handle, CN_Char, message.wParam, message.lParam); + end; +end; + +procedure TAutoCompleteListBox.DblClick; +begin + if (Assigned(InsertProc)) then + InsertProc(GetInsert); + if (Owner is TForm) then + TForm(Owner).Hide; +end; + +procedure TAutoCompleteListBox.DrawItem(Index: Integer; ARect: TRect; State: TOwnerDrawState); +var + p1, p2, p3, tl, col: Integer; + s, c: string; +begin + if (ItemIndex = -1) and (Count > 0) then + begin + {$IFDEF FPC}LockSelectionChange;{$ENDIF} + ItemIndex := TopIndex; + {$IFDEF FPC}UnlockSelectionChange;{$ENDIF} + end; + + if {$IFDEF FPC}(odPainted in State) or{$ENDIF} (not Visible) or (ARect.Left > ClientRect.Right) or (ARect.Top > ClientRect.Bottom) or (Index < 0) or (Index >= Items.Count) then + Exit; + + tl := ARect.Left; + col := 0; + with Canvas do + begin + Font.Style := []; + Font.Color := clBlack; + if (odSelected in State) then + Brush.Color := clHighlight + else if (odHotLight in State) then + Brush.Color := clHotLight + else if Odd(Index) then + Brush.Color := $F0F0F0 + else + Brush.Color := clWhite; + FillRect(ARect); + + s := Items[Index]; + p1 := Pos('{', s); + p3 := 1; + while (p1 > 0) do + begin + p2 := PosEx('}', s, p1 + 1); + if (p2 > 0) then + begin + if (s[p2 - 1] <> '\') then + begin + c := Copy(s, p3, p1 - p3); + TextOut(tl, ARect.Top + Round((ItemHeight - TextHeight(c) + 0.001) / 2) , c); + tl := tl + TextWidth(c) + 1; + + p3 := p2 + 1; + if ((p2 - p1 - 2) > 0) then + begin + c := LowerCase(Copy(s, p1 + 2, p2 - p1 - 2)); + case Char(CharUpper({$IFNDEF FPC}PChar{$ELSE}Char{$ENDIF}(s[p1 + 1]))) of + '#', 'C': Font.Color := StringToColor(c); + 'B': + if (c = '+') then + Font.Style := Font.Style + [fsBold] + else + Font.Style := Font.Style - [fsBold]; + 'I': + if (c = '+') then + Font.Style := Font.Style + [fsItalic] + else + Font.Style := Font.Style - [fsItalic]; + 'U': + if (c = '+') then + Font.Style := Font.Style + [fsUnderline] + else + Font.Style := Font.Style - [fsUnderline]; + end; + end + else if (s[p1 + 1] = '|') then + begin + if (ColumnSizes[col] = -1) then + ColumnSizes[col] := Canvas.TextWidth('constructor') + 5; + tl := ColumnSizes[col]; + Inc(Col); + end; + p1 := PosEx('{', s, p2 + 1); + end; + end + else + Break; + end; + + if ((Length(s) - p3 + 1) > 0) then + begin + c := Copy(s, p3, Length(s) - p3 + 1); + TextOut(tl, ARect.Top + Round((ItemHeight - TextHeight(c) + 0.001) / 2), c); + end; + end; +end; + +constructor TAutoCompleteListBox.Create(TheOwner: TComponent); +begin + inherited; + + DoubleBuffered := True; + ControlStyle := ControlStyle + [csOpaque]; + BorderStyle := bsNone; + Style := lbOwnerDrawFixed; + + IntegralHeight := True; + {$IFDEF FPC} + ItemHeight := CalculateStandardItemHeight + 4; + {$ELSE} + ItemHeight := 19; + {$ENDIF} + Constraints.MinHeight := ItemHeight; + + SetLength(ColumnSizes, 1); + ColumnSizes[0] := -1; + Redirect := nil; + InsertProc := nil; + + Items.Clear; + fList := TStringList .Create; + fInsertList := TStringList.Create; + fFilter := ''; +end; + +destructor TAutoCompleteListBox.Destroy; +begin + FreeAndNil(fList); + FreeAndNil(fInsertList); + + inherited; +end; + +procedure TAutoCompletePopup.DoShow; +begin + //ClientHeight := Max(Min(Round(ClientHeight / l.ItemHeight), l.Count), 1) * l.ItemHeight; + //ClientHeight := Max(Round(ClientHeight / l.ItemHeight), 1) * l.ItemHeight; +end; + +function TAutoCompletePopup.getRedirect: TWinControl; +begin + Result := ListBox.Redirect; +end; + +procedure TAutoCompletePopup.setRedirect(Control: TWinControl); +begin + ListBox.Redirect := Control; +end; + +function TAutoCompletePopup.getInsertProc: TInsertProc; +begin + Result := ListBox.InsertProc; +end; + +procedure TAutoCompletePopup.setInsertProc(Proc: TInsertProc); +begin + ListBox.InsertProc := Proc; +end; + +constructor TAutoCompletePopup.Create(TheOwner: TComponent); +begin + inherited; + + l := TAutoCompleteListBox.Create(Self); + with l do + begin + Parent := Self; + Align := alClient; + OnKeyDown := {$IFDEF FPC}@{$ENDIF}HandleKeyDown; + OnKeyPress := {$IFDEF FPC}@{$ENDIF}HandleKeyPress; + end; + + DefaultMonitor := dmMainForm; + FormStyle := fsStayOnTop; + + {$IFDEF FPC} + ShowInTaskBar := stNever; + {$ENDIF} + + BorderStyle := bsSizeToolWin; + BorderIcons := []; + SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) and (not WS_CAPTION) or WS_BORDER); + Height := Height - GetSystemMetrics(SM_CYCAPTION); + + DoubleBuffered := True; + ControlStyle := ControlStyle + [csOpaque]; + + ClientHeight := Round(ClientHeight / l.ItemHeight) * l.ItemHeight; + Constraints.MinHeight := l.ItemHeight; + Constraints.MinWidth := 100; +end; + +procedure TAutoCompletePopup.DoHide; +begin + ListBox.Clear; + inherited; +end; + +procedure TAutoCompletePopup.HandleKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); +begin + if Visible then + begin + case Key of + VK_UP: + if (ListBox.Count > 0) and (ListBox.ItemIndex > 0) then + ListBox.ItemIndex := ListBox.ItemIndex - 1; + VK_DOWN: + if (ListBox.Count > 0) and (ListBox.ItemIndex + 1 < ListBox.Count) then + ListBox.ItemIndex := ListBox.ItemIndex + 1; + VK_RETURN: + ListBox.DblClick; + VK_ESCAPE: + Hide; + else + Exit; + end; + Key := 0; + end; +end; + +procedure TAutoCompletePopup.HandleKeyPress(Sender: TObject; var Key: char); +begin + if Visible and (not (Key in ['a'..'z', 'A'..'Z', '0'..'9', '_'])) then + if (Key in ['.', '(', '[', ';', ':']) then + ListBox.DblClick + else + Hide; +end; + +procedure TAutoCompletePopup.Show(Pos: TPoint; ItemList, InsertList: TStrings; Filter: string = ''; Editor: TWinControl = nil); +begin + ListBox.setLists(ItemList, InsertList); + ListBox.Redirect := Editor; + ListBox.Filter := Filter; + Left := Pos.x; + Top := Pos.y; + + inherited Show; + + if (Editor <> nil) then + Editor.SetFocus; +end; + +constructor TParamHint.Create(TheOwner: TComponent); +begin + inherited; + + {$IFDEF FPC} + AutoHide := False; + {$ENDIF} +end; + +procedure TParamHint.Paint; + + function GetDrawTextFlags: Cardinal; + var + EffectiveAlignment: TAlignment; + begin + Result := DT_NOPREFIX or DT_VCENTER or DT_WORDBREAK; + EffectiveAlignment := Alignment; + if BiDiMode <> bdLeftToRight then + begin + Result := Result or DT_RTLREADING; + //change alignment if is RTL + if BiDiMode = bdRightToLeft then + begin + case Alignment of + taLeftJustify: EffectiveAlignment := taRightJustify; + taRightJustify: EffectiveAlignment := taLeftJustify; + end; + end; + end; + case EffectiveAlignment of + taLeftJustify: Result := Result or DT_LEFT; + taCenter: Result := Result or DT_CENTER; + taRightJustify: Result := Result or DT_RIGHT; + end; +end; + +var + ARect: TRect; + Details: TThemedElementDetails; +begin + ARect := ClientRect; + if Color = clInfoBk then // draw using themes + begin + Details := ThemeServices.GetElementDetails(tttStandardLink); + ThemeServices.DrawElement(Canvas.Handle, Details, ARect); + end + else + begin + Canvas.Brush.Color := Color; + Canvas.Pen.Width := 1; + Canvas.FillRect(ARect); + DrawEdge(Canvas.Handle, ARect, BDR_RAISEDOUTER, BF_RECT); + end; + InflateRect(ARect, - 4, - 4); + Canvas.TextOut(ARect.Left, ARect.Top, Caption); +end; + +end. + diff --git a/Projects/SAMufasaGUI/v_ideCodeInsight.pas b/Projects/SAMufasaGUI/v_ideCodeInsight.pas new file mode 100644 index 0000000..c81f261 --- /dev/null +++ b/Projects/SAMufasaGUI/v_ideCodeInsight.pas @@ -0,0 +1,1259 @@ +unit v_ideCodeInsight; + +{$include ValistusDefines.inc} + +interface + +uses + SysUtils, Classes, + CastaliaPasLex, + CastaliaPasLexTypes, + v_ideCodeParser; + +type + TCodeInsight = class; + TCodeInsightArray = array of TCodeInsight; + + TOnFindInclude = function(Sender: TObject; var FileName: string): Boolean of object; + + TCodeInsight = class(TCodeParser) + protected + fFileName: string; + fMemoryStream: TMemoryStream; + fOwnStream: Boolean; + + fPos: Integer; + fDeclarationAtPos: TDeclaration; + + fOnFindInclude: TOnFindInclude; + fIncludes: TCodeInsightArray; + + InFunc: TDeclarationArray; + InWith: TDeclarationArray; + InClassFunction: Integer; + + Proposal_Filled: Boolean; + Proposal_ItemList: TStrings; + Proposal_InsertList: TStrings; + + procedure SetPos(APos: Integer); + + procedure Reset; + procedure Init; + + function FindInclude(var FileName: string): Boolean; + procedure ParseInclude(FileName: string); + procedure OnInclude(Sender: TmwBasePasLex); override; + + function GetVarType(s: string; out Decl: TDeclaration; Return: TVarBase): Boolean; + function GetFuncType(FuncName, FuncClass: string; out Decl: TDeclaration; Return: TVarBase): Boolean; + function FindStruct(s: string; out Decl: TDeclaration; Return: TVarBase; var ArrayCount: Integer): Boolean; + public + function GetExpressionAtPos(var BraceCount, BracketCount, CommaCount: Integer; IgnoreBrackets: Boolean = False): string; overload; + function GetExpressionAtPos: string; overload; + function FindVarBase(s: string; GetStruct: Boolean = False; Return: TVarBase = vbName): TDeclaration; + + constructor Create(FileName: string = ''); reintroduce; + destructor Destroy; override; + procedure Assign(From: TObject); override; + procedure Run(SourceStream: TCustomMemoryStream = nil; BaseDefines: TStringList = nil; MaxPos: Integer = -1); reintroduce; + + procedure Proposal_AddDeclaration(Item: TDeclaration; ItemList, InsertList: TStrings); + procedure FillProposal; + procedure FillSynCompletionProposal(ItemList, InsertList: TStrings; Prefix: string = ''); + + property OnFindInclude: TOnFindInclude read fOnFindInclude write fOnFindInclude; + property FileName: string read fFileName write fFileName; + property Position: Integer read fPos write SetPos; + property DeclarationAtPos: TDeclaration read fDeclarationAtPos; + property Includes: TCodeInsightArray read fIncludes; + end; + + TIncludeBuffer = record + Script: string; + DefinesIn, DefinesOut: TSaveDefinesRec; + LastChanged: Integer; + CodeInsight: TCodeInsight; + end; + TIncludeBufferArray = array of TIncludeBuffer; + +var + CoreBuffer: TCodeInsightArray; + IncludeBuffer: TIncludeBufferArray; + +implementation + +uses + v_Constants, v_MiscFunctions; + +procedure ClearCoreBuffer; +var + i: Integer; +begin + for i := 0 to High(CoreBuffer) do + FreeAndNil(CoreBuffer[i]); + + SetLength(IncludeBuffer, 0); +end; + +procedure DeleteIncludeBufferIndex(Index: Integer); +var + i: Integer; +begin + IncludeBuffer[Index].CodeInsight.Free; + + for i := Index to High(IncludeBuffer) - 1 do + IncludeBuffer[i] := IncludeBuffer[i + 1]; + + SetLength(IncludeBuffer, Length(IncludeBuffer) - 1); +end; + +procedure ClearIncludeBuffer; +var + i: Integer; +begin + for i := 0 to High(IncludeBuffer) do + IncludeBuffer[i].CodeInsight.Free; + + SetLength(IncludeBuffer, 0); +end; + +function GetIncludeBuffer(FileName: string; ci: TCodeInsight): TIncludeBuffer; +var + i, l, lc: Integer; + Defines: TSaveDefinesRec; + DefineMatch: Boolean; +begin + lc := 1;//FileAge(FileName); + Defines := ci.Lexer.SaveDefines; + l := Length(IncludeBuffer); + + for i := l - 1 downto 0 do + begin + if (IncludeBuffer[i].CodeInsight.FileName = FileName) then + begin + DefineMatch := (IncludeBuffer[i].DefinesIn.Defines = Defines.Defines) and (IncludeBuffer[i].DefinesIn.Stack = Defines.Stack); + + if (ci.FileName = IncludeBuffer[i].Script) and (not DefineMatch) then + begin + DeleteIncludeBufferIndex(i); + Dec(l); + Break; + end + else if DefineMatch then + begin + + //if (IncludeBuffer[i].LastChanged = lc) then + begin + ci.Lexer.LoadDefines(IncludeBuffer[i].DefinesOut); + Result := IncludeBuffer[i]; + Exit; + end; + + DeleteIncludeBufferIndex(i); + Dec(l); + Break; + end; + end; + end; + + SetLength(IncludeBuffer, l + 1); + with IncludeBuffer[l] do + begin + Script := ci.FileName; + DefinesIn := Defines; + LastChanged := lc; + CodeInsight := TCodeInsight.Create(FileName); + + with CodeInsight do + begin + Assign(ci); + //Lexer.CloneDefinesFrom(ci.Lexer); + Run; + //DefinesOut := Lexer.SaveDefines; Weird bug, so moved out of the with statement + ci.Lexer.CloneDefinesFrom(Lexer); + end; + + end; + + IncludeBuffer[l].DefinesOut := IncludeBuffer[l].CodeInsight.Lexer.SaveDefines; + Result := IncludeBuffer[l]; +end; + +function TCodeInsight.FindInclude(var FileName: string): Boolean; +var + s: string; +begin + s := FileName; + if Assigned(OnFindInclude) and OnFindInclude(Self, s) then + begin + FileName := s; + Exit(True); + end; + + s := ExtractFilePath(fFileName); + if (s <> '') and FileExists(s + FileName) then + begin + FileName := s + FileName; + Exit(True); + end; + + {s := ExtractFilePath(ParamStr(0)); + if (s <> '') and FileExists(s + FileName) then + begin + FileName := s + FileName; + Exit(True); + end; + + Result := FileExists(FileName);} + + Result := False; +end; + +procedure TCodeInsight.ParseInclude(FileName: string); +var + l: Integer; +begin + l := Length(fIncludes); + SetLength(fIncludes, l + 1); + fIncludes[l] := GetIncludeBuffer(FileName, Self).CodeInsight; +end; + +procedure TCodeInsight.OnInclude(Sender: TmwBasePasLex); +var + Param: string; + i: Integer; +begin + Param := Sender.DirectiveParam; + Param := StringReplace(Param, '/', '\', [rfReplaceAll]); + if (not Sender.IsJunk) and (Param <> '') then + begin + if FindInclude(Param) then + begin + if (LowerCase(Sender.Token) = 'include_once') then + for i := High(fIncludes) downto 0 do + if (fIncludes[i].FileName = Param) then + begin + Param := ''; + Break; + end; + + if (Param <> '') then + ParseInclude(Param); + end + else if Assigned(OnMessage) then + OnMessage(Self, meError, Format(ci_UnknownInclude, [Param]), Sender.PosXY.X, Sender.PosXY.Y); + end; + + inherited; +end; + +procedure TCodeInsight.SetPos(APos: Integer); +begin + if (fPos = APos) then + Exit; + Reset; + fPos := APos; + Init; +end; + +procedure TCodeInsight.Init; +var + a, b: TDeclarationArray; + d: TDeclaration; + i, ii: Integer; + s: string; +begin + if (fPos >= 0) then + fDeclarationAtPos := fItems.GetItemInPos(fPos, fPos, True) + else + fDeclarationAtPos := nil; + + (*if (fDeclarationatPos is TciJunk) and (fDeclarationatPos.Owner <> nil) {and (fDeclarationatPos.EndPos = fPos)} then + fDeclarationAtPos := fDeclarationatPos.Owner;*) + + if (fDeclarationAtPos <> nil) and (not (fDeclarationAtPos is TciJunk)) then + begin + InFunc := fDeclarationAtPos.GetOwnersOfClass(TciProcedureDeclaration); + if (fDeclarationAtPos is TciProcedureDeclaration) then + begin + SetLength(InFunc, Length(InFunc) + 1); + InFunc[High(InFunc)] := fDeclarationAtPos; + end; + + if (Length(InFunc) > 0) and (InFunc[0].Owner = nil) then + begin + d := InFunc[0].Items.GetFirstItemOfClass(TciProcedureClassName); + if (d <> nil) then + d := FindVarBase(d.CleanText, True, vbType); + if (d <> nil) and (d is TciStruct) then + begin + SetLength(InWith, Length(InWith) + 1); + InClassFunction := High(InWith); + InWith[InClassFunction] := d; + end; + end; + + a := fDeclarationAtPos.GetOwnersOfClass(TciWithStatement); + if (fDeclarationAtPos is TciWithStateMent) then + begin + SetLength(a, Length(a) + 1); + a[High(a)] := fDeclarationAtPos; + end + else if fDeclarationAtPos.HasOwnerClass(TciClassType, d, True) then + begin + SetLength(InWith, Length(InWith) + 1); + InWith[High(InWith)] := d; + end; + + for i := High(a) downto Low(a) do + begin + b := a[i].Items.GetItemsOfClass(TciVariable); + for ii := Low(b) to High(b) do + begin + if (fDeclarationAtPos is TciVariable) and (b[ii].EndPos >= fPos) then + Continue; + s := b[ii].CleanText; + d := FindVarBase(s, True, vbType); + if (d <> nil) and (d is TciStruct) then + begin + SetLength(InWith, Length(InWith) + 1); + InWith[High(InWith)] := d; + end; + end; + end; + end; +end; + +procedure TCodeInsight.Reset; +begin + Lexer.Init; + + //SetLength(fIncludes, 0); + SetLength(InFunc, 0); + SetLength(InWith, 0); + InClassFunction := -1; + + Proposal_ItemList.Clear; + Proposal_InsertList.Clear; + Proposal_Filled := False; + + fDeclarationAtPos := nil; +end; + +function TCodeInsight.GetVarType(s: string; out Decl: TDeclaration; Return: TVarBase): Boolean; +var + a, b: TDeclarationArray; + i, ii, iii, iiii, FuncOffset, SetOffset: Integer; + c: array [1..3] of TDeclarationClass; + d: TDeclaration; +begin + Result := False; + FuncOffset := 0; + SetOffset := 0; + + if (s = 'RESULT') and (Length(InFunc) > 0) then + begin + Decl := InFunc[Low(InFunc)].Items.GetFirstItemOfClass(TciReturnType); + if (Decl <> nil) then + begin + Result := True; + Exit; + end; + end; + + if (s = 'SELF') and (InClassFunction <> -1) and InWith[InClassFunction].HasOwnerClass(TciTypeDeclaration, d, True) then + begin + Decl := d.Items.GetFirstItemOfClass(TciTypeName); + if (Decl <> nil) then + begin + Result := True; + Exit; + end; + end; + + for i := Low(InFunc) to High(InFunc) + 1 do + begin + for iiii := 1 to 3 do + begin + case iiii of + 1: + begin + c[1] := TciVarDeclaration; + c[2] := TciVarName; + c[3] := TciTypeKind; + end; + 2: + begin + if (Return = vbType) then + Continue; + c[1] := TciConstantDeclaration; + c[2] := TciConstantName; + c[3] := TciExpression; + end; + 3: + begin + if (Return = vbType) then + Continue; + c[1] := TciLabelDeclaration; + c[2] := TciLabelName; + c[3] := nil; + end; + else + Continue; + end; + if (i = High(InFunc) + 1) then + a := fItems.GetItemsOfClass(c[1]) + else + a := InFunc[i].Items.GetItemsOfClass(c[1]); + for ii := Low(a) to High(a) do + begin + b := a[ii].Items.GetItemsOfClass(c[2]); + for iii := Low(b) to High(b) do + if (PrepareString(b[iii].CleanText) = s) then + begin + Result := True; + if (Return = vbType) and (c[3] <> nil) then + Decl := a[ii].Items.GetFirstItemOfClass(c[3]) + else + Decl := b[iii]; + Exit; + end; + end; + end; + + if (Return = vbName) then + begin + if (i = High(InFunc) + 1) then + a := fItems.GetItemsOfClass(TciQualifiedIdentifier, True) + else + a := InFunc[i].Items.GetItemsOfClass(TciQualifiedIdentifier, True); + for ii := Low(a) to High(a) - SetOffset do + begin + if (i = High(InFunc) + 1) then + if a[ii].HasOwnerClass(TciTypeDeclaration, d, True) then + begin + if d.HasOwnerClass(TciProcedureDeclaration, d, True) then + Continue; + end + else if a[ii].HasOwnerClass(TciProcedureDeclaration, d, True) and (d.Owner <> nil) then + Continue; + + if (PrepareString(a[ii].CleanText) = s) then + begin + Result := True; + Decl := a[ii]; + Exit; + end; + end; + SetOffset := Length(a); + end; + + if (i <= High(InFunc)) then + begin + a := InFunc[i].Items.GetItemsOfClass(TciParameterName, True); + for ii := Low(a) to High(a) - FuncOffset do + if (PrepareString(a[ii].CleanText) = s) then + begin + Result := True; + if (Return = vbType) then + Decl := a[ii].Owner.Items.GetFirstItemOfClass(TciParameterType) + else + Decl := a[ii]; + Exit; + end; + FuncOffset := Length(a); + end; + end; +end; + +function TCodeInsight.GetFuncType(FuncName, FuncClass: string; out Decl: TDeclaration; Return: TVarBase): Boolean; +var + a: TDeclarationArray; + b: TDeclaration; + i, ii: Integer; +begin + Result := False; + + for ii := Low(InFunc) to High(InFunc) + 1 do + begin + if (ii = High(InFunc) + 1) then + a := fItems.GetItemsOfClass(TciProcedureDeclaration) + else + a := InFunc[ii].Items.GetItemsOfClass(TciProcedureDeclaration); + for i := Low(a) to High(a) do + begin + b := nil; + if (FuncClass <> '') then + b := a[i].Items.GetFirstItemOfClass(TciProcedureClassName); + if ((FuncClass = '') and (b = nil)) or ((b <> nil) and (PrepareString(b.CleanText) = FuncClass)) then + begin + b := a[i].Items.GetFirstItemOfClass(TciProcedureName); + if (b <> nil) and (PrepareString(b.CleanText) = FuncName) then + begin + Result := True; + if (Return = vbType) then + Decl := a[i].Items.GetFirstItemOfClass(TciReturnType) + else + Decl := b; + + if (a[i].Items.GetFirstItemOfClass(TciForward) = nil) then + Exit; + end; + end; + end; + end; +end; + +function TCodeInsight.FindStruct(s: string; out Decl: TDeclaration; Return: TVarBase; var ArrayCount: Integer): Boolean; +var + a, b: TDeclarationArray; + i, ii: Integer; +begin + Result := False; + s := PrepareString(s); + a := fItems.GetItemsOfClass(TciTypeDeclaration); + + for i := Low(a) to High(a) do + begin + b := a[i].Items.GetItemsOfClass(TciTypeName); + for ii := Low(b) to High(b) do + if (PrepareString(b[ii].CleanText) = s) then + begin + Result := True; + if (Return = vbType) then + begin + Decl := a[i].Items.GetFirstItemOfClass(TciTypeKind); + if (Decl = nil) then + Decl := a[i].Items.GetFirstItemOfClass(TciClassType); + if (Decl is TciTypeKind) then + Decl := TciTypeKind(Decl).GetRealType(ArrayCount); + if (Decl is TciStruct) then + Result := True + else + Result := (Decl <> nil) and FindStruct(Decl.CleanText, Decl, Return, ArrayCount); + end + else + Decl := b[ii]; + if (Decl <> nil) then + Exit; + end; + end; +end; + +function TCodeInsight.GetExpressionAtPos(var BraceCount, BracketCount, CommaCount: Integer; IgnoreBrackets: Boolean = False): string; +var + i, StartPos, EndPos: Integer; + s: string; + a: TDeclarationArray; + d: TDeclaration; + LastWasDot: Boolean; +begin + Result := ''; + d := nil; + if (fDeclarationAtPos = nil) or + (fDeclarationAtPos is TciJunk) or + (not ( + (fDeclarationAtPos.HasOwnerClass(TciCompoundStatement, d, True) or (fDeclarationAtPos is TciCompoundStatement)) or + (fDeclarationAtPos.HasOwnerClass(TciConstantDeclaration, d, True) or (fDeclarationAtPos is TciConstantDeclaration)) or + (fDeclarationAtPos.HasOwnerClass(TciVarDeclaration, d, True) or (fDeclarationAtPos is TciVarDeclaration)) or + (fDeclarationAtPos.HasOwnerClass(TciLabelDeclaration, d, True) or (fDeclarationAtPos is TciLabelDeclaration)) or + (fDeclarationAtPos.HasOwnerClass(TciTypeDeclaration, d, True) or (fDeclarationAtPos is TciTypeDeclaration)) or + (fDeclarationAtPos.HasOwnerClass(TciProcedureDeclaration, d, True) or (fDeclarationAtPos is TciProcedureDeclaration)) + )) then + Exit; + if (d = nil) then + d := fDeclarationAtPos; + a := d.Items.GetItemsOfClass(TciJunk, True); + EndPos := fPos - d.StartPos; + s := d.CleanText; + + for i := Low(a) to High(a) do + if (fPos > a[i].EndPos) then + if (Pos(LineEnding, a[i].RawText) > 0) then + EndPos := EndPos - a[i].EndPos + a[i].StartPos + Length(LineEnding) + else + EndPos := EndPos - a[i].EndPos + a[i].StartPos + 1; + + StartPos := EndPos; + LastWasDot := False; + while (StartPos > 0) do + begin + if (BraceCount = 0) and ((BracketCount = 0) or IgnoreBrackets) and (s[StartPos] in ['a'..'z', 'A'..'Z', '0'..'9', '_']) then + {nothing} + else if (BraceCount = 0) and ((BracketCount = 0) or IgnoreBrackets) and (s[StartPos] in [#10, #11, #13, #32]) then + begin + i := StartPos; + Dec(StartPos); + while (StartPos > 0) and (s[StartPos] in [#10, #11, #13, #32]) do + Dec(StartPos); + if not ((LastWasDot and (s[StartPos] in ['a'..'z', 'A'..'Z', '0'..'9', '_', ']', ')'])) or ((not LastWasDot) and (s[StartPos] = '.'))) then + begin + StartPos := i; + Break; + end; + Inc(StartPos); + end + else if (s[StartPos] = '.') then + begin + LastWasDot := True; + Dec(StartPos); + Continue; + end + else if (s[StartPos] = ']') then + Inc(BracketCount) + else if (s[StartPos] = '[') then + begin + Dec(BracketCount); + LastWasDot := True; + Dec(StartPos); + Continue; + end + else if (s[StartPos] = ')') then + Inc(BraceCount) + else if (s[StartPos] = '(') then + begin + Dec(BraceCount); + LastWasDot := True; + Dec(StartPos); + Continue; + end + else if (BraceCount = 1) and (BracketCount = 0) and (s[StartPos] = ',') then + Inc(CommaCount) + else if (BraceCount = 0) and ((BracketCount = 0) or IgnoreBrackets) then + Break; + + if (BraceCount < 0) or ((BracketCount < 0) and (not IgnoreBrackets)) then + begin + Dec(StartPos, BraceCount); + Dec(StartPos, BracketCount); + Break; + end; + LastWasDot := False; + Dec(StartPos); + end; + + Result := CompressWhiteSpace(Copy(s, StartPos + 1, EndPos - StartPos)); +end; + +function TCodeInsight.GetExpressionAtPos: string; +var + bcc, bkc, cc: Integer; +begin + bcc := 0; + bkc := 0; + cc := 0; + Result := GetExpressionAtPos(bcc, bkc, cc); +end; + +function TCodeInsight.FindVarBase(s: string; GetStruct: Boolean = False; Return: TVarBase = vbName): TDeclaration; + + function PartOfWith(s: string; out Decl: TDeclaration; Return: TVarBase; CheckClass: Boolean): Boolean; + var + i: Integer; + begin + Result := False; + for i := High(InWith) downto Low(InWith) do + if CheckClass xor (i <> InClassFunction) then + if TciStruct(InWith[i]).HasField(s, Decl, Return) then + begin + Result := True; + Break; + end; + end; + + function DoGetVarType(s: string; out Decl: TDeclaration; Return: TVarBase): Boolean; + + function CheckIt(s: string; Item: TCodeInsight; out Decl: TDeclaration; Return: TVarBase): Boolean; + var + i: Integer; + begin + Result := False; + if Item.GetVarType(s, Decl, Return) then + begin + Result := True; + Exit; + end; + + for i := High(Item.Includes) downto Low(Item.Includes) do + if CheckIt(s, Item.Includes[i], Decl, Return) then + begin + Result := True; + Break; + end; + + for i := High(CoreBuffer) downto Low(CoreBuffer) do + if CheckIt(s, CoreBuffer[i], Decl, Return) then + begin + Result := True; + Break; + end; + end; + + begin + Result := CheckIt(s, Self, Decl, Return); + end; + + function DoGetFuncType(FuncName, FuncClass: string; out Decl: TDeclaration; Return: TVarBase): Boolean; + + function CheckIt(FuncName, FuncClass: string; Item: TCodeInsight; out Decl: TDeclaration; Return: TVarBase): Boolean; + var + i: Integer; + begin + Result := False; + if Item.GetFuncType(FuncName, FuncClass, Decl, Return) then + begin + Result := True; + Exit; + end; + + for i := High(Item.Includes) downto Low(Item.Includes) do + if CheckIt(FuncName, FuncClass, Item.Includes[i], Decl, Return) then + begin + Result := True; + Break; + end; + + for i := High(CoreBuffer) downto Low(CoreBuffer) do + if CheckIt(FuncName, FuncClass, CoreBuffer[i], Decl, Return) then + begin + Result := True; + Break; + end; + end; + + begin + Result := CheckIt(FuncName, FuncClass, Self, Decl, Return); + end; + + function DoFindStruct(s: string; out Decl: TDeclaration; Return: TVarBase; var ArrayCount: Integer): Boolean; + + function CheckIt(s: string; Item: TCodeInsight; out Decl: TDeclaration; Return: TVarBase; var ArrayCount: Integer): Boolean; + var + i: Integer; + begin + Result := False; + if Item.FindStruct(s, Decl, Return, ArrayCount) then + begin + Result := True; + Exit; + end; + + for i := High(Item.Includes) downto Low(Item.Includes) do + if CheckIt(s, Item.Includes[i], Decl, Return, ArrayCount) then + begin + Result := True; + Break; + end; + + for i := High(CoreBuffer) downto Low(CoreBuffer) do + if CheckIt(s, CoreBuffer[i], Decl, Return, ArrayCount) then + begin + Result := True; + Break; + end; + end; + + begin + Result := CheckIt(s, Self, Decl, Return, ArrayCount); + end; + +var + f, NameClass: string; + sa: TStringArray; + d: TDeclaration; + i, NeedArrayCount, ArrayCount: Integer; + InStruct: TciStruct; + VarBase: TVarBase; + Found, CheckVar, IsForward: Boolean; +begin + Result := nil; + if (fDeclarationAtPos is TciJunk) or (PrepareString(s) = '') then + Exit; + + InStruct := nil; + NameClass := ''; + IsForward := False; + CheckVar := (fPos < 0); + sa := Explode('.', PrePrepareString(s)); + + if (fDeclarationAtPos <> nil) then + begin + if (fDeclarationAtPos is TciProcedureName) and (fDeclarationAtPos.Owner <> nil) then + begin + if fDeclarationAtPos.HasOwnerClass(TciClassType, d, True) and (d.Owner <> nil) then + begin + d := d.Owner.Items.GetFirstItemOfClass(TciTypeName); + if (d <> nil) then + NameClass := PrepareString(d.CleanText); + end + else if (fDeclarationAtPos.Owner.Items.GetFirstItemOfClass(TciForward) <> nil) then + IsForward := True; + end; + + if (Return = vbName) and ( + (fDeclarationAtPos is TciVarName) or + (fDeclarationAtPos is TciConstantName) or + (fDeclarationAtPos is TciTypeName) or + (fDeclarationAtPos is TciLabelName) or + ((fDeclarationAtPos is TciProcedureName) and + (NameClass = '') and + (fDeclarationAtPos.Owner <> nil) and + (not IsForward) and + (fDeclarationAtPos.Owner.Items.GetFirstItemOfClass(TciProcedureClassName) = nil)) or + (fDeclarationAtPos is TciParameterName) or + (fDeclarationAtPos is TciFieldName) or + (fDeclarationAtPos is TciQualifiedIdentifier)) then + Exit; + CheckVar := (NameClass = '') and (( + (Length(InFunc) > 0) or + (Length(InWith) > 0) or + (fDeclarationAtPos is TciCompoundStatement) or + (fDeclarationAtPos is TciExpression) or + fDeclarationAtPos.HasOwnerClass(TciCompoundStatement, d, True)) or ( + (Return = vbType) and ( + (fDeclarationAtPos is TciTypeKind) or + (fDeclarationAtPos is TciParameterType) or + (fDeclarationAtPos is TciReturnType) or + (fDeclarationAtPos is TciQualifiedIdentifier) or + (fDeclarationAtPos is TciExpression)))); + end; + + for i := Low(sa) to High(sa) do + begin + f := PrepareString(sa[i], ArrayCount); + NeedArrayCount := 0; + + if (Return = vbName) and (i = High(sa)) then + VarBase := vbName + else + VarBase := vbType; + + if (InStruct <> nil) then + Found := InStruct.HasField(f, Result, VarBase) + else + begin + Found := CheckVar and PartOfWith(f, Result, VarBase, False); + if (not Found) and (i = Low(sa)) then + begin + Found := + (CheckVar and DoGetVarType(f, Result, VarBase)) or + ((CheckVar or (NameClass <> '') or IsForward) and DoGetFuncType(f, NameClass, Result, VarBase)) or + DoFindStruct(f, Result, VarBase, NeedArrayCount); + end; + if (not Found) and CheckVar then + Found := PartOfWith(f, Result, VarBase, True); + end; + + if Found and (Result is TciTypeKind) then + Result := TciTypeKind(Result).GetRealType(NeedArrayCount); + + if Found and (Result <> nil) and (not (Result is TciStruct)) and ((i < High(sa)) or GetStruct) then + Found := DoFindStruct(Result.CleanText, Result, VarBase, NeedArrayCount); + + if Found and (Result <> nil) and (ArrayCount <> NeedArrayCount) and ((Result is TciStruct) or (InStruct <> nil)) and ((i < High(sa)) or GetStruct) then + begin + if (InStruct <> nil) then + Result := InStruct.GetDefault(VarBase) + else + Result := TciStruct(Result).GetDefault(VarBase); + + Found := (Result <> nil); + + if Found and (Result is TciTypeKind) then + Result := TciTypeKind(Result).GetRealType(NeedArrayCount); + + if Found and (not (Result is TciStruct)) and ((i < High(sa)) or GetStruct) then + Found := DoFindStruct(Result.CleanText, Result, VarBase, NeedArrayCount); + + if (not Found) then + begin + if Assigned(OnMessage) then + OnMessage(Self, meError, Format(ci_RangeError, [sa[i], s]), -1, -1); + Result := nil; + Exit; + end; + end; + + if (not Found) or (Result = nil) then + begin + if Assigned(OnMessage) then + if (i > Low(sa)) then + OnMessage(Self, meError, Format(ci_UnknownMember, [sa[i], s]), -1, -1) + else + OnMessage(Self, meError, Format(ci_UnknownStruct, [sa[i], s]), -1, -1); + Result := nil; + Exit; + end; + + InStruct := TciStruct(Result); + end; +end; + +constructor TCodeInsight.Create(FileName: string = ''); +begin + inherited Create; + + Proposal_InsertList := TStringList.Create; + //TStringList(Proposal_InsertList).Sorted := True; + Proposal_ItemList := TStringList.Create; + + fOnFindInclude := nil; + fFileName := FileName; + if (fFileName <> '') and (not FileExists(fFileName)) then + fFileName := ''; + fPos := -1; + Reset; + + fOwnStream := (fFileName <> ''); + if fOwnStream then + begin + fMemoryStream := TMemoryStream.Create; + fMemoryStream.LoadFromFile(fFileName); + end + else + fMemoryStream := nil; +end; + +destructor TCodeInsight.Destroy; +begin + if fOwnStream then + FreeAndNil(fMemoryStream); + + FreeAndNil(Proposal_InsertList); + FreeAndNil(Proposal_ItemList); + + inherited; +end; + +procedure TCodeInsight.Assign(From: TObject); +begin + if (From is TCodeInsight) then + with From as TCodeInsight do + begin + Self.OnFindInclude := OnFindInclude; + end; + + inherited; +end; + +procedure TCodeInsight.Run(SourceStream: TCustomMemoryStream = nil; BaseDefines: TStringList = nil; MaxPos: Integer = -1); +begin + if Assigned(BaseDefines) then + begin + Lexer.ClearDefines; + Lexer.Defines.Assign(BaseDefines); + end; + SetLength(fIncludes, 0); + + if fOwnStream then + inherited Run(fMemoryStream, MaxPos - 1) + else if Assigned(SourceStream) then + inherited Run(SourceStream, MaxPos - 1); + + if (MaxPos > -1) then + Position := MaxPos; +end; + +procedure TCodeInsight.Proposal_AddDeclaration(Item: TDeclaration; ItemList, InsertList: TStrings); + + function FormatFirstColumn(s: string): string; inline; + begin + Result := '{#clNavy}' + LowerCase(s) + '{#0} {|}' + end; + + function FormatTypeName(s: string): string; inline; + begin + Result := '{#clBlue}' + s; + end; + + function FormatMainName(s: string): string; inline; + begin + Result := '{B+}' + s + '{B-}'; + end; + + function FormatMainExtra(s: string): string; inline; + begin + Result := '{I+}' + s + '{I-}' + end; + + function GetEnumTypeName(Item: TDeclaration): string; + begin + Result := 'Enumeration'; + if (Item.Items.Count > 0) then + Result := Result + '(' + Item.Items[0].ShortText; + if (Item.Items.Count > 1) then + Result := Result + '..' + Item.Items[Item.Items.Count - 1].ShortText + ')'; + end; + + procedure AddEnums(Item: {TCodeInsight}TDeclaration; ItemList, InsertList: TStrings); overload; + var + {i,} ii, SetOffset: Integer; + a: TDeclarationArray; + d: TDeclaration; + s: string; + begin + SetOffset := 0; + //for i := Low(Item.InFunc) to High(Item.InFunc) + 1 do + begin + //if (i = High(Item.InFunc) + 1) then + a := Item.Items.GetItemsOfClass(TciQualifiedIdentifier, True); + //else + // a := Item.InFunc[i].Items.GetItemsOfClass(TciQualifiedIdentifier, True); + for ii := Low(a) to High(a) - SetOffset do + begin + {if (i = High(Item.InFunc) + 1) then + if a[ii].HasOwnerClass(TciTypeDeclaration, d, True) then + begin + if d.HasOwnerClass(TciProcedureDeclaration, d, True) then + Continue; + end + else if a[ii].HasOwnerClass(TciProcedureDeclaration, d, True) and (d.Owner <> nil) then + Continue;} + + s := FormatFirstColumn('enum') + FormatMainName(a[ii].ShortText); + if a[ii].HasOwnerClass(TciTypeDeclaration, d, True) then + begin + d := d.Items.GetFirstItemOfClass(TciTypeName); + if (d <> nil) then + s := s + ' ' + FormatMainExtra('(' + d.ShortText + ')'); + end; + ItemList.Insert(InsertList.Add(a[ii].ShortText), s); + end; + //SetOffset := Length(a); + end; + end; + + procedure AddEnums(a: TDeclarationArray; ItemList, InsertList: TStrings); overload; + var + i: Integer; + begin + for i := Low(a) to High(a) do + AddEnums(a[i], ItemList, InsertList); + end; + + procedure AddFuncDeclaration(Item: TciProcedureDeclaration; ItemList, InsertList: TStrings); + var + s, n: string; + d: TDeclaration; + begin + s := FormatFirstColumn(Item.ProcType); + d := Item.Items.GetFirstItemOfClass(TciProcedureName); + if (d = nil) then + Exit; + n := d.ShortText; + s := s + FormatMainName(n); + if (Item.Params <> '') then + begin + s := s + FormatMainExtra('(' + Item.Params + ')'); + //n := n {+ '('}; + end; + d := Item.Items.GetFirstItemOfClass(TciReturnType); + if (d <> nil) then + s := s + ': ' + FormatTypeName(d.ShortText) + {else + s := s + ';'}; + ItemList.Insert(InsertList.Add(n), s); + + AddEnums(Item.GetParamDeclarations, ItemList, InsertList); + if (d <> nil) then + AddEnums(d, ItemList, InsertList); + end; + +var + i: Integer; + FirstColumn, s, n: string; + a: TDeclarationArray; + b: array[1..2] of TDeclaration; + c: array[0..2] of TDeclarationClass; +begin + if (Item is TciProcedureDeclaration) then + begin + AddFuncDeclaration(TciProcedureDeclaration(Item), ItemList, InsertList); + Exit; + end; + + c[0] := nil; + c[1] := nil; + c[2] := nil; + if (Item is TciVarDeclaration) then + begin + FirstColumn := FormatFirstColumn('variable'); + c[0] := TciVarName; + c[2] := TciTypeKind; + end + else if (Item is TciConstantDeclaration) then + begin + FirstColumn := FormatFirstColumn('constant'); + c[0] := TciConstantName; + c[1] := TciExpression; + end + else if (Item is TciLabelDeclaration) then + begin + FirstColumn := FormatFirstColumn('label'); + c[0] := TciLabelName; + end + else if (Item is TciTypeDeclaration) then + begin + FirstColumn := FormatFirstColumn('type'); + c[0] := TciTypeName; + c[2] := TciTypeKind; + end + else if (Item is TciClassField) then + begin + FirstColumn := FormatFirstColumn('variable'); + c[0] := TciFieldName; + c[2] := TciTypeKind; + end + else if (Item is TciClassProperty) then + begin + FirstColumn := FormatFirstColumn('property'); + c[0] := TciFieldName; + c[2] := TciTypeKind; + end + else if (Item is TciConstParameter) or + (Item is TciOutParameter) or + (Item is TciFormalParameter) or + (Item is TciInParameter) or + (Item is TciVarParameter) then + begin + FirstColumn := FormatFirstColumn('param'); + c[0] := TciParameterName; + c[2] := TciParameterType; + end; + + if (c[0] = nil) then + Exit; + + a := Item.Items.GetItemsOfClass(c[0]); + if (c[1] <> nil) then + b[1] := Item.Items.GetFirstItemOfClass(c[1]) + else + b[1] := nil; + if (c[2] <> nil) then + begin + b[2] := Item.Items.GetFirstItemOfClass(c[2]); + if (b[2] is TciTypeKind) and (b[2].Items.Count > 0) and (not (b[2].Items[0] is TciArrayType)) then + b[2] := b[2].Items[0]; + end + else + b[2] := nil; + for i := Low(a) to High(a) do + begin + n := a[i].ShortText; + (*{$IFDEF ciCHECKDUPLICATES} + if (InsertList.IndexOf(n) > -1) then + Continue; + {$ENDIF}*) + s := FirstColumn + FormatMainName(n); + if (b[1] <> nil) then + s := s + FormatMainExtra(' = ' + b[1].ShortText); + if (b[2] <> nil) then + if (b[2] is TciEnumType) then + s := s + ': ' + FormatTypeName(GetEnumTypeName(b[2])) + else + s := s + ': ' + FormatTypeName(b[2].ShortText) + {else + s := s + ';'}; + + ItemList.Insert(InsertList.Add(n), s); + if (b[2] <> nil) and (b[2].Items.Count > 0) then + AddEnums(b[2], ItemList, InsertList); + end; +end; + +procedure TCodeInsight.FillProposal; +var + i: Integer; +begin + if (not Proposal_Filled) then + begin + Proposal_ItemList.BeginUpdate; + Proposal_InsertList.BeginUpdate; + + try + for i := 0 to Items.Count - 1 do + Proposal_AddDeclaration(Items[i], Proposal_ItemList, Proposal_InsertList); + Proposal_Filled := True; + finally + Proposal_ItemList.EndUpdate; + Proposal_InsertList.EndUpdate; + end; + end; +end; + +procedure TCodeInsight.FillSynCompletionProposal(ItemList, InsertList: TStrings; Prefix: string = ''); + + procedure AddFile(Item: TCodeInsight; ItemList, InsertList: TStrings); + var + i: Integer; + begin + if (not Item.Proposal_Filled) then + Item.FillProposal; + + {$IFNDEF ciCHECKDUPLICATES} + ItemList.AddStrings(Item.Proposal_ItemList); + InsertList.AddStrings(Item.Proposal_InsertList); + {$ELSE} + for i := 0 to Item.Proposal_InsertList.Count - 1 do + if (InsertList.IndexOf(Item.Proposal_InsertList[i]) = -1) then + begin + ItemList.Insert(InsertList.Add(Item.Proposal_InsertList[i]), Item.Proposal_ItemList[i]); + //ItemList.Add(Item.Proposal_ItemList[i]); + end; + {$ENDIF} + + //AddEnums(Item, ItemList, InsertList); + for i := Low(Item.Includes) to High(Item.Includes) do + AddFile(Item.Includes[i], ItemList, InsertList); + end; + +var + i, ii: Integer; + d: TDeclaration; +begin + ItemList.BeginUpdate; + InsertList.BeginUpdate; + try + ItemList.Clear; + InsertList.Clear; + + if (PrepareString(Prefix) <> '') then + begin + d := FindVarBase(Prefix, True, vbType); + if (d <> nil) then + for i := 0 to d.Items.Count - 1 do + Proposal_AddDeclaration(d.Items[i], ItemList, InsertList); + end + else + begin + for i := High(InWith) downto Low(InWith) do + if (i <> InClassFunction) then + for ii := 0 to InWith[i].Items.Count - 1 do + Proposal_AddDeclaration(InWith[i].Items[ii], ItemList, InsertList); + + for i := Low(InFunc) to High(InFunc) do + for ii := 0 to InFunc[i].Items.Count - 1 do + Proposal_AddDeclaration(InFunc[i].Items[ii], ItemList, InsertList); + + if (InClassFunction <> -1) then + for i := 0 to InWith[InClassFunction].Items.Count - 1 do + Proposal_AddDeclaration(InWith[InClassFunction].Items[i], ItemList, InsertList); + + AddFile(Self, ItemList, InsertList); + for i := 0 to High(CoreBuffer) do + AddFile(CoreBuffer[i], ItemList, InsertList); + end; + finally + ItemList.EndUpdate; + InsertList.EndUpdate; + end; +end; + +initialization + {nothing} +finalization + ClearIncludeBuffer; + ClearCoreBuffer; + +end. diff --git a/Projects/SAMufasaGUI/v_ideCodeParser.pas b/Projects/SAMufasaGUI/v_ideCodeParser.pas new file mode 100644 index 0000000..0d028aa --- /dev/null +++ b/Projects/SAMufasaGUI/v_ideCodeParser.pas @@ -0,0 +1,1675 @@ +unit v_ideCodeParser; + +{$include ValistusDefines.inc} + +interface + +uses + SysUtils, Classes, + CastaliaPasLex, CastaliaSimplePasPar, + v_MiscFunctions; + +type + TDeclaration = class; + TDeclarationArray = array of TDeclaration; + TDeclarationClass = class of TDeclaration; + + TVarBase = (vbName, vbType); + + TDeclarationStack = class + private + fItems: TList; + fTop: TDeclaration; + public + procedure Push(Item: TDeclaration); + function Pop: TDeclaration; + + constructor Create; + destructor Destroy; override; + + property Top: TDeclaration read fTop; + end; + + TDeclarationList = class + private + fItems: TList; + + function GetItem(Index: Integer): TDeclaration; + function GetCount: Integer; + public + procedure AddItem(AItem: TDeclaration); + procedure DeleteItem(AItem: TDeclaration); + function GetItemsOfClass(AClass: TDeclarationClass; SubSearch: Boolean = False): TDeclarationArray; + function GetFirstItemOfClass(AClass: TDeclarationClass; SubSearch: Boolean = False): TDeclaration; + function GetItemsInPos(AStart, AEnd: Integer; SubSearch: Boolean = False): TDeclarationArray; + function GetItemInPos(AStart, AEnd: Integer; SubSearch: Boolean = False): TDeclaration; + + procedure Clear; + + constructor Create; + destructor Destroy; override; + + property Items[Index: Integer]: TDeclaration read GetItem; default; + property Count: Integer read GetCount; + end; + + TDeclaration = class + private + fParser: TmwSimplePasPar; + fOwner: TDeclaration; + fOrigin: PAnsiChar; + fRawText: string; + fCleanText: string; + fShortText: string; + fStartPos: Integer; + fEndPos: Integer; + fItems: TDeclarationList; + + function GetRawText: string; virtual; + function GetCleanText: string; virtual; + function GetShortText: string; virtual; + public + function HasOwnerClass(AClass: TDeclarationClass; out Declaration: TDeclaration; Recursive: Boolean = False): Boolean; + function GetOwnersOfClass(AClass: TDeclarationClass): TDeclarationArray; + + constructor Create(AParser: TmwSimplePasPar; AOwner: TDeclaration; AOrigin: PAnsiChar; AStart: Integer; AEnd: Integer = -1); overload; virtual; + constructor Create(AssignFrom: TDeclaration); overload; virtual; + destructor Destroy; override; + + property Parser: TmwSimplePasPar read fParser; + property Owner: TDeclaration read fOwner; + property Origin: PAnsiChar read fOrigin; + + property RawText: string read GetRawText write fRawText; + property CleanText: string read GetCleanText; + property ShortText: string read GetShortText; + property StartPos: Integer read fStartPos write fStartPos; + property EndPos: Integer read fEndPos write fEndPos; + property Items: TDeclarationList read fItems; + end; + + TciStruct = class(TDeclaration) + private + function GetShortText: string; override; + public + function HasField(Name: string; out Decl: TDeclaration; Return: TVarBase = vbName): Boolean; + function GetDefault(Return: TVarBase = vbName): TDeclaration; + end; + + TciTypeKind = class(TDeclaration) + private + function GetShortText: string; override; + public + function GetRealType(var ArrayCount: Integer): TDeclaration; overload; + function GetRealType: TDeclaration; overload; + end; + + TciProcedureDeclaration = class(TDeclaration) + private + fProcType: string; + fParams: string; + fSynParams: string; + + function GetProcType: string; + function GetParams: string; + function GetSynParams: string; + + function GetShortText: string; override; + public + function GetParamDeclarations: TDeclarationArray; + + property ProcType: string read GetProcType; + property Params: string read GetParams; + property SynParams: string read GetSynParams; + end; + + TciUsedUnit = class(TDeclaration); //Included Units + TciInclude = class(TDeclaration); //Includes + TciJunk = class(TDeclaration); //Junk + + TciCompoundStatement = class(TDeclaration); //Begin-End + TciWithStatement = class(TDeclaration); //With + TciSimpleStatement = class(TDeclaration); //Begin-End + With + TciVariable = class(TDeclaration); //With + + //TciTypeKind = class(TciVarType); //Var + Const + Array + Record + TciTypedConstant = class(TDeclaration); //Var + Procedure/Function Parameters + TciExpression = class(TDeclaration); //Var + Const + Enum + TciProceduralType = class(TciProcedureDeclaration); //Var + Tciype + Procedure/Function Parameters + + TciTypeDeclaration = class(TDeclaration); //Type + TciTypeName = class(TDeclaration); //Type + + TciVarDeclaration = class(TDeclaration); //Var + TciVarName = class(TDeclaration); //Var + + TciConstantDeclaration = class(TDeclaration); //Const + TciConstantName = class(TDeclaration); //Const + + TciLabelDeclaration = class(TDeclaration); //Label + TciLabelName = class(TDeclaration); //Label + + //TciProcedureDeclaration = class(TDeclaration); //Procedure/Function + TciProcedureName = class(TDeclaration); //Procedure/Function + TciProcedureClassName = class(TDeclaration); //Class Procedure/Function + TciReturnType = class(TciTypeKind); //Function Result + TciForward = class(TciTypeKind); //Forwarding + TciConstParameter = class(TDeclaration); //Procedure/Function Parameters + TciOutParameter = class(TDeclaration); //Procedure/Function Parameters + TciFormalParameter = class(TDeclaration); //Procedure/Function Parameters + TciInParameter = class(TDeclaration); //Procedure/Function Parameters + TciVarParameter = class(TDeclaration); //Procedure/Function Parameters + TciParameterName = class(TDeclaration); //Procedure/Function Parameters + TciParameterType = class(TciTypeKind); //Procedure/Function Parameters + + TciArrayType = class(TDeclaration); //Array + TciArrayConstant = class(TDeclaration); //Array + + TciRecordType = class(TciStruct); //Record + TciClassField = class(TDeclaration); //Record + TciFieldName = class(TDeclaration); //Record + TciRecordConstant = class(TDeclaration); //Record + TciRecordFieldConstant = class(TDeclaration); //Record + + TciClassType = class(TciStruct); //Class + TciAncestorId = class(TDeclaration); //Class + TciClassMethodHeading = class(TciProcedureDeclaration); //Record + Class + TciClassProperty = class(TDeclaration); //Record + Class + TciPropertyDefault = class(TDeclaration); //Record + Class + + TciSetType = class(TDeclaration); //Set + TciOrdinalType = class(TDeclaration); //Set + + TciEnumType = class(TDeclaration); //Enum + TciQualifiedIdentifier = class(TDeclaration); //Enum + + TCodeParser = class(TmwSimplePasPar) + protected + fStack: TDeclarationStack; + fItems: TDeclarationList; + + function InDeclaration(AClass: TDeclarationClass): Boolean; + function InDeclarations(AClassArray: array of TDeclarationClass): Boolean; + procedure PushStack(AClass: TDeclarationClass; AStart: Integer = -1); + procedure PopStack(AEnd: Integer = -1); + + procedure ParseFile; override; + procedure OnInclude(Sender: TmwBasePasLex); virtual; //Includes + procedure UsedUnitName; override; //Included Units + procedure NextToken; override; //Junk + procedure OnDirect(Sender: TmwBasePasLex); //Junk + + procedure CompoundStatement; override; //Begin-End + procedure WithStatement; override; //With + procedure SimpleStatement; override; //Begin-End + With + procedure Variable; override; //With + + procedure TypeKind; override; //Var + Const + Array + Record + procedure TypedConstant; override; //Var + Procedure/Function Parameters + procedure Expression; override; //Var + Const + ArrayConst + procedure ProceduralType; override; //Var + Tciype + Procedure/Function Parameters + + procedure TypeDeclaration; override; //Type + procedure TypeName; override; //Type + + procedure VarDeclaration; override; //Var + procedure VarName; override; //Var + + procedure ConstantDeclaration; override; //Const + procedure ConstantName; override; //Const + + procedure LabelDeclarationSection; override; //Label + procedure LabelId; override; //Label + + procedure ProcedureDeclarationSection; override; //Procedure/Function + procedure FunctionProcedureName; override; //Procedure/Function + procedure ObjectNameOfMethod; override; //Class Procedure/Function + procedure ReturnType; override; //Function Result + procedure ForwardDeclaration; override; //Forwarding + procedure ConstParameter; override; //Procedure/Function Parameters + procedure OutParameter; override; //Procedure/Function Parameters + procedure ParameterFormal; override; //Procedure/Function Parameters + procedure InParameter; override; //Procedure/Function Parameters + procedure VarParameter; override; //Procedure/Function Parameters + procedure ParameterName; override; //Procedure/Function Parameters + procedure NewFormalParameterType; override; //Procedure/Function Parameters + + procedure ArrayType; override; //Array + procedure ArrayConstant; override; //Array Const + + procedure RecordType; override; //Record + procedure ClassField; override; //Record + Class + procedure FieldName; override; //Record + Class + procedure RecordConstant; override; //Record Const + procedure RecordFieldConstant; override; //Record Const + + procedure ClassType; override; //Class + procedure AncestorId; override; //Class + procedure ClassMethodHeading; override; //Class + procedure ConstructorName; override; //Class + procedure DestructorName; override; //Class + procedure FunctionMethodName; override; //Class + procedure ProcedureMethodName; override; //Class + procedure ClassProperty; override; //Record + Class + procedure PropertyName; override; //Record + Class + procedure TypeId; override; //Record + Class + procedure PropertyDefault; override; //Record + Class + + procedure SetType; override; //Set + procedure OrdinalType; override; //Set + Array Range + + procedure EnumeratedType; override; //Enum + procedure QualifiedIdentifier; override; //Enum + public + constructor Create; virtual; + destructor Destroy; override; + + property Items: TDeclarationList read fItems; + end; + +implementation + +uses + CastaliaPasLexTypes; + +procedure TDeclarationStack.Push(Item: TDeclaration); +begin + fItems.Add(Item); + fTop := Item; +end; + +function TDeclarationStack.Pop: TDeclaration; +begin + with fItems do + begin + if (Count > 0) then + Delete(Count - 1); + if (Count > 0) then + fTop := TDeclaration(Items[Count - 1]) + else + fTop := nil; + end; + Result := fTop; +end; + +constructor TDeclarationStack.Create; +begin + fItems := TList.Create; + fTop := nil; +end; + +destructor TDeclarationStack.Destroy; +begin + FreeAndNil(fItems); + + inherited; +end; + +function TDeclarationList.GetItem(Index: Integer): TDeclaration; +begin + Result := TDeclaration(fItems[Index]); +end; + +function TDeclarationList.GetCount: Integer; +begin + Result := fItems.Count; +end; + +procedure TDeclarationList.AddItem(AItem: TDeclaration); +begin + fItems.Add(AItem); +end; + +procedure TDeclarationList.DeleteItem(AItem: TDeclaration); +var + i: Integer; +begin + for i := 0 to fItems.Count - 1 do + if (TDeclaration(fItems[i]) = AItem) then + begin + TDeclaration(fItems[i]).Free; + fItems.Delete(i); + Break; + end; +end; + +function TDeclarationList.GetItemsOfClass(AClass: TDeclarationClass; SubSearch: Boolean = False): TDeclarationArray; + + procedure SearchItem( + AClass: TDeclarationClass; + SubSearch: Boolean; + Item: TDeclaration; + var Res: TDeclarationArray; + var ResIndex: Integer); + var + i: Integer; + begin + if (Item is AClass) then + begin + SetLength(Res, ResIndex + 1); + Res[ResIndex] := Item; + Inc(ResIndex); + end; + if SubSearch then + for i := 0 to Item.Items.Count - 1 do + SearchItem(AClass, SubSearch, Item.Items[i], Res, ResIndex); + end; + +var + i, l: Integer; +begin + l := 0; + SetLength(Result, 0); + + for i := 0 to fItems.Count - 1 do + SearchItem(AClass, SubSearch, TDeclaration(fItems[i]), Result, l); +end; + +function TDeclarationList.GetFirstItemOfClass(AClass: TDeclarationClass; SubSearch: Boolean = False): TDeclaration; + + function SearchItem(AClass: TDeclarationClass; SubSearch: Boolean; Item: TDeclaration; out Res: TDeclaration): Boolean; + var + i: Integer; + begin + Result := False; + if (Item is AClass) then + begin + Res := Item; + Result := True; + Exit; + end; + if SubSearch then + for i := 0 to Item.Items.Count - 1 do + if SearchItem(AClass, SubSearch, Item.Items[i], Res) then + begin + Result := True; + Break; + end; + end; + +var + i: Integer; +begin + Result := nil; + for i := 0 to fItems.Count - 1 do + SearchItem(AClass, SubSearch, TDeclaration(fItems[i]), Result); +end; + +function TDeclarationList.GetItemsInPos(AStart, AEnd: Integer; SubSearch: Boolean = False): TDeclarationArray; + + procedure SearchItem( + AStart, AEnd: Integer; + SubSearch: Boolean; + Item: TDeclaration; + var Res: TDeclarationArray; + var ResIndex: Integer); + var + i: Integer; + b: Boolean; + begin + b := False; + if (AStart >= Item.StartPos) and (AEnd <= Item.EndPos) then + begin + SetLength(Res, ResIndex + 1); + Res[ResIndex] := Item; + Inc(ResIndex); + b := True; + end; + if SubSearch and b then + for i := 0 to Item.Items.Count - 1 do + SearchItem(AStart, AEnd, SubSearch, Item.Items[i], Res, ResIndex); + end; + +var + i, l: Integer; +begin + l := 0; + SetLength(Result, 0); + + for i := 0 to fItems.Count - 1 do + SearchItem(AStart, AEnd, SubSearch, TDeclaration(fItems[i]), Result, l); +end; + +function TDeclarationList.GetItemInPos(AStart, AEnd: Integer; SubSearch: Boolean = False): TDeclaration; + + function SearchItem(AStart, AEnd: Integer; SubSearch: Boolean; Item: TDeclaration; out Res: TDeclaration): Boolean; + var + i: Integer; + b: Boolean; + begin + Result := False; + b := (AStart >= Item.StartPos) and (AEnd <= Item.EndPos); + if b and ((Item.Items.Count < 1) or (not SubSearch)) then + begin + Res := Item; + Result := True; + Exit; + end; + if SubSearch and b then + for i := 0 to Item.Items.Count - 1 do + if SearchItem(AStart, AEnd, SubSearch, Item.Items[i], Res) then + begin + Result := True; + Break; + end; + if b and (not Result) then + begin + Res := Item; + Result := True; + end; + end; + +var + i: Integer; +begin + Result := nil; + for i := 0 to fItems.Count - 1 do + SearchItem(AStart, AEnd, SubSearch, TDeclaration(fItems[i]), Result); +end; + +procedure TDeclarationList.Clear; +var + i: Integer; +begin + for i := 0 to fItems.Count - 1 do + if (Assigned(fItems[i])) then + TDeclaration(fItems[i]).Free; + fItems.Clear; +end; + +constructor TDeclarationList.Create; +begin + fItems := TList.Create; +end; + +destructor TDeclarationList.Destroy; +begin + Clear; + + FreeAndNil(fItems); + inherited; +end; + +function TDeclaration.GetRawText: string; +begin + Result := ''; + if (fRawText <> '') then + Result := fRawText + else if (fStartPos <> fEndPos) and (fOrigin <> nil) then + begin + SetString(fRawText, fOrigin + fStartPos, fEndPos - fStartPos); + Result := fRawText; + end; +end; + +function TDeclaration.GetCleanText: string; +var + i: Integer; + a: TDeclarationArray; +begin + Result := ''; + if (fCleanText <> '') then + Result := fCleanText + else if (fStartPos <> fEndPos) and (fOrigin <> nil) then + begin + fCleanText := RawText; + a := Items.GetItemsOfClass(TciJunk, True); + for i := High(a) downto 0 do + begin + Delete(fCleanText, a[i].StartPos - fStartPos + 1, a[i].EndPos - a[i].StartPos); + if (Pos(LineEnding, a[i].GetRawText) > 0) then + Insert(LineEnding, fCleanText, a[i].StartPos - fStartPos + 1) + else + Insert(' ', fCleanText, a[i].StartPos - fStartPos + 1); + end; + Result := fCleanText; + end; +end; + +function TDeclaration.GetShortText: string; +begin + if (fShortText = '') then + fShortText := CompressWhiteSpace(CleanText); + Result := fShortText; +end; + +function TDeclaration.HasOwnerClass(AClass: TDeclarationClass; out Declaration: TDeclaration; Recursive: Boolean = False): Boolean; + + function IsOwner(Item: TDeclaration; AClass: TDeclarationClass; out Decl: TDeclaration; Recursive: Boolean): Boolean; + begin + if (Item.Owner is AClass) then + begin + Result := True; + Decl := Item.Owner; + end + else if (Item.Owner <> nil) and Recursive then + Result := IsOwner(Item.Owner, AClass, Decl, True) + else + Result := False; + end; + +begin + Declaration := nil; + if (AClass = nil) then + Result := True + else + Result := IsOwner(Self, Aclass, Declaration, Recursive); +end; + +function TDeclaration.GetOwnersOfClass(AClass: TDeclarationClass): TDeclarationArray; + + procedure IsOwner( + AClass: TDeclarationClass; + Item: TDeclaration; + var Res: TDeclarationArray; + var ResIndex: Integer); + begin + if (Item.Owner is AClass) then + begin + SetLength(Res, ResIndex + 1); + Res[ResIndex] := Item.Owner; + Inc(ResIndex); + end; + if (Item.Owner <> nil) then + IsOwner(AClass, Item.Owner, Res, ResIndex); + end; + +var + l: Integer; +begin + l := 0; + SetLength(Result, 0); + + IsOwner(AClass, Self, Result, l); +end; + +constructor TDeclaration.Create(AParser: TmwSimplePasPar; AOwner: TDeclaration; AOrigin: PAnsiChar; AStart, AEnd: Integer); +begin + fParser := AParser; + fOwner := AOwner; + fOrigin := AOrigin; + fRawText := ''; + fCleanText := ''; + fStartPos := AStart; + if (AEnd > -1) then + fEndPos := AEnd + else + fEndPos := AStart; + + fItems := TDeclarationList.Create; +end; + +constructor TDeclaration.Create(AssignFrom: TDeclaration); +begin + if (AssignFrom <> nil) then + Create(AssignFrom.Parser, AssignFrom.Owner, AssignFrom.Origin, AssignFrom.StartPos, AssignFrom.EndPos) + else + Create(nil, nil, nil, -1); +end; + +destructor TDeclaration.Destroy; +begin + FreeAndNil(fItems); + + inherited; +end; + +function TciStruct.GetShortText: string; +begin + if (fShortText = '') then + fShortText := GetFirstWord(CleanText); + Result := fShortText; +end; + +function TciStruct.HasField(Name: string; out Decl: TDeclaration; Return: TVarBase = vbName): Boolean; +var + a, b: TDeclarationArray; + i, ii: Integer; +begin + Result := False; + Name := PrepareString(Name); + + a := fItems.GetItemsOfClass(TciClassField); + for i := Low(a) to High(a) do + begin + b := a[i].Items.GetItemsOfClass(TciFieldName); + for ii := Low(b) to High(b) do + begin + if (PrepareString(b[ii].CleanText) = Name) then + begin + Result := True; + if (Return = vbType) then + Decl := b[ii].Owner.Items.GetFirstItemOfClass(TciTypeKind) + else + Decl := b[ii]; + Exit; + end; + end; + end; + + a := fItems.GetItemsOfClass(TciClassProperty); + for i := Low(a) to High(a) do + begin + b := a[i].Items.GetItemsOfClass(TciFieldName); + for ii := Low(b) to High(b) do + begin + if (PrepareString(b[ii].CleanText) = Name) then + begin + Result := True; + if (Return = vbType) then + Decl := b[ii].Owner.Items.GetFirstItemOfClass(TciTypeKind) + else + Decl := b[ii]; + Exit; + end; + end; + end; + + a := fItems.GetItemsOfClass(TciClassMethodHeading); + for i := Low(a) to High(a) do + begin + b := a[i].Items.GetItemsOfClass(TciProcedureName); + for ii := Low(b) to High(b) do + if (PrepareString(b[ii].CleanText) = Name) then + begin + Result := True; + if (Return = vbType) then + Decl := b[ii].Owner + else + Decl := b[ii]; + Exit; + end; + end; +end; + +function TciStruct.GetDefault(Return: TVarBase = vbName): TDeclaration; +var + d: TDeclaration; +begin + Result := nil; + d := fItems.GetFirstItemOfClass(TciPropertyDefault, True); + if (d <> nil) then + if (Return = vbType) then + Result := d.Owner.Items.GetFirstItemOfClass(TciTypeKind) + else + Result := d.Owner.Items.GetFirstItemOfClass(TciFieldName) +end; + +function TciTypeKind.GetShortText: string; +var + d: TDeclaration; +begin + if (fShortText = '') then + begin + d := GetRealType; + if (d = nil) or (not (d is TciStruct)) then + fShortText := CompressWhiteSpace(CleanText) + else + fShortText := CompressWhiteSpace(StringReplace(CleanText, d.CleanText, GetFirstWord(d.CleanText), [])); + end; + Result := fShortText; +end; + +function TciTypeKind.GetRealType(var ArrayCount: Integer): TDeclaration; +var + d, t: TDeclaration; +begin + d := Self; + while (d <> nil) do + begin + if (d.Items.Count > 0) then + begin + d := d.Items[0]; + if (d is TciArrayType) then + begin + d := d.Items.GetFirstItemOfClass(TciTypeKind); + Inc(ArrayCount); + Continue; + end; + + if (d is TciProceduralType) then + begin + t := d.Items.GetFirstItemOfClass(TciReturnType); + if (t <> nil) then + begin + d := t; + Continue; + end + else + Break; + end; + + if (d is TciTypeKind) then + Continue; + end; + + Break; + end; + + Result := d; +end; + +function TciTypeKind.GetRealType: TDeclaration; +var + a: Integer; +begin + Result := GetRealType(a); +end; + +function TciProcedureDeclaration.GetProcType: string; +var + s: string; +begin + if (fProcType = '') then + begin + s := CleanText; + fProcType := GetFirstWord(s); + if (LowerCase(fProcType) = 'class') then + begin + Delete(s, 1, 6); + fProcType := GetFirstWord(s); + end; + end; + + Result := fProcType; +end; + +function TciProcedureDeclaration.GetParams: string; +var + i: Integer; + a: TDeclarationArray; +begin + Result := ''; + if (fParams <> '') then + Result := fParams + else if (fItems.Count > 0) then + begin + a := GetParamDeclarations; + for i := Low(a) to High(a) do + if (fParams <> '') then + fParams := fParams + '; ' + a[i].ShortText + else + fParams := fParams + a[i].ShortText; + Result := fParams; + end; +end; + +function TciProcedureDeclaration.GetSynParams: string; +var + i, ii: Integer; + a, b: TDeclarationArray; + d: TDeclaration; + s, t: string; +begin + Result := ''; + if (fSynParams <> '') then + Result := fSynParams + else if (fItems.Count > 0) then + begin + a := GetParamDeclarations; + for i := Low(a) to High(a) do + begin + if (fItems[i] is TciConstParameter) then + s := 'const ' + else if (fItems[i] is TciOutParameter) then + s := 'out ' + else if (fItems[i] is TciInParameter) then + s := 'in ' + else if (fItems[i] is TciVarParameter) then + s := 'var ' + else + s := ''; + + d := a[i].Items.GetFirstItemOfClass(TciParameterType); + if (d <> nil) then + t := ': ' + d.ShortText + else + t := ''; + b := a[i].Items.GetItemsOfClass(TciParameterName); + for ii := Low(b) to High(b) do + begin + if (fSynParams <> '') then + fSynParams := fSynParams + ';","' + s + b[ii].ShortText + t + else + fSynParams := '"' + s + b[ii].ShortText + t; + end; + end; + if (fSynParams <> '') then + fSynParams := fSynParams + '"'; + Result := fSynParams; + end; +end; + +function TciProcedureDeclaration.GetShortText: string; +begin + if (fShortText = '') then + fShortText := ProcType; + Result := fShortText; +end; + +function TciProcedureDeclaration.GetParamDeclarations: TDeclarationArray; +var + i: Integer; +begin + SetLength(Result, 0); + + for i := 0 to fItems.Count - 1 do + if (fItems[i] is TciConstParameter) or + (fItems[i] is TciOutParameter) or + (fItems[i] is TciFormalParameter) or + (fItems[i] is TciInParameter) or + (fItems[i] is TciVarParameter) then + begin + SetLength(Result, Length(Result) + 1); + Result[High(Result)] := fItems[i]; + end; +end; + +function TCodeParser.InDeclaration(AClass: TDeclarationClass): Boolean; +begin + if (fStack.Top = nil) then + Result := (AClass = nil) + else + Result := (fStack.Top is AClass); +end; + +function TCodeParser.InDeclarations(AClassArray: array of TDeclarationClass): Boolean; +var + i: Integer; + t: TDeclaration; +begin + Result := False; + t := fStack.Top; + if (t = nil) then + begin + for i := Low(AClassArray) to High(AClassArray) do + if (AClassArray[i] = nil) then + begin + Result := True; + Break; + end; + Exit; + end; + for i := Low(AClassArray) to High(AClassArray) do + if (t is AClassArray[i]) then + begin + Result := True; + Break; + end; +end; + +procedure TCodeParser.PushStack(AClass: TDeclarationClass; AStart: Integer = -1); +var + t: TDeclaration; +begin + if (AStart = -1) then + AStart := Lexer.TokenPos; + t := AClass.Create(Self, fStack.Top, Lexer.Origin, AStart); + if (fStack.Top <> nil) then + fStack.Top.Items.AddItem(t) + else + fItems.AddItem(t); + fStack.Push(t); +end; + +procedure TCodeParser.PopStack(AEnd: Integer = -1); +begin + if (AEnd = -1) then + AEnd := Lexer.TokenPos; + if (fStack.Top <> nil) then + fStack.Top.EndPos := AEnd; + fStack.Pop; +end; + +constructor TCodeParser.Create; +begin + inherited; + + fStack := TDeclarationStack.Create; + fItems := TDeclarationList.Create; + + Lexer.OnIncludeDirect := {$IFDEF FPC}@{$ENDIF}OnInclude; + Lexer.OnDefineDirect := {$IFDEF FPC}@{$ENDIF}OnDirect; + Lexer.OnElseDirect := {$IFDEF FPC}@{$ENDIF}OnDirect; + Lexer.OnEndIfDirect := {$IFDEF FPC}@{$ENDIF}OnDirect; + Lexer.OnIfDefDirect := {$IFDEF FPC}@{$ENDIF}OnDirect; + Lexer.OnIfNDefDirect := {$IFDEF FPC}@{$ENDIF}OnDirect; + Lexer.OnUnDefDirect := {$IFDEF FPC}@{$ENDIF}OnDirect; + Lexer.OnIfDirect := {$IFDEF FPC}@{$ENDIF}OnDirect; + Lexer.OnIfEndDirect := {$IFDEF FPC}@{$ENDIF}OnDirect; + Lexer.OnElseIfDirect := {$IFDEF FPC}@{$ENDIF}OnDirect; +end; + +destructor TCodeParser.Destroy; +begin + FreeAndNil(fStack); + FreeAndNil(fItems); + + inherited; +end; + +procedure TCodeParser.ParseFile; +begin + SkipJunk; + case GenID of + TokLibrary: + begin + LibraryFile; + end; + TokPackage: + begin + PackageFile; + end; + TokUnit: + begin + UnitFile; + end; + else + begin + if (Lexer.GenID = TokProgram) then + begin + Expected(TokProgram); + QualifiedIdentifier; + if TokenID = TokRoundOpen then + begin + NextToken; + IdentifierList; + Expected(TokRoundClose); + end; + SEMICOLON; + end; + if (TokenID = TokUses) then + MainUsesClause; + + while TokenID in [TokClass, TokConst, TokConstructor, TokDestructor, TokExports, + TokFunction, TokLabel, TokProcedure, TokResourceString, TokThreadVar, TokType, + TokVar{$IFDEF D8_NEWER}, TokSquareOpen{$ENDIF}] do + begin + DeclarationSection; + end; + + if (TokenID = TokBegin) then + begin + CompoundStatement; + Expected(TokPoint); + end; + end; + end; +end; + +procedure TCodeParser.OnInclude(Sender: TmwBasePasLex); +begin + if (not Sender.IsJunk) then + begin + PushStack(TciInclude, Sender.TokenPos); + fStack.Top.RawText := Sender.DirectiveParam; + PopStack(Sender.TokenPos + Sender.TokenLen); + end; + + Sender.Next; +end; + +procedure TCodeParser.UsedUnitName; +begin + PushStack(TciUsedUnit); + inherited; + PopStack; +end; + +procedure TCodeParser.NextToken; +var + ValidJunk: Boolean; +begin + ValidJunk := False; + Lexer.Next; + if Lexer.IsJunk and (not InDeclaration(TciJunk)) then + begin + {if (not InDeclaration(nil)) then + PushStack(TciJunk); + while (Lexer.IsJunk) do + begin + if (not (Lexer.TokenID in [TokCRLF, TokCRLFCo, TokSpace])) then + ValidJunk := True; + Lexer.Next; + end; + if InDeclaration(TciJunk) then + begin + if ValidJunk then + PopStack + else + begin + if (fStack.Top.Owner <> nil) then + fStack.Top.Owner.Items.DeleteItem(fStack.Top) + else + fStack.Top.Free; + fStack.Pop; + end; + end;} + + while Lexer.IsJunk do + begin + if (Lexer.TokenID in [tokAnsiComment, tokBorComment, tokSlashesComment]) then + begin + if (not InDeclaration(TciJunk)) then + PushStack(TciJunk); + end + else if InDeclaration(TciJunk) then + PopStack; + Lexer.Next; + end; + end; +end; + +procedure TCodeParser.OnDirect(Sender: TmwBasePasLex); +begin + if (Sender.TokenID = TokElseDirect) then + begin + Sender.Next; + Exit; + end; + if InDeclaration(TciJunk) then + Exit; + if (not InDeclaration(nil)) then + PushStack(TciJunk, Sender.TokenPos); + + if (not (Sender.TokenID in [TokEndIfDirect, TokIfEndDirect])) then + if Sender = Lexer then + NextToken + else + Sender.Next; + + if InDeclaration(TciJunk) then + PopStack(Sender.TokenPos + Sender.TokenLen); +end; + +procedure TCodeParser.CompoundStatement; +begin + if (not InDeclarations([nil, TciProcedureDeclaration, TciWithStatement])) then + begin + inherited; + Exit; + end; + + PushStack(TciCompoundStatement); + inherited; + PopStack; +end; + +procedure TCodeParser.WithStatement; +begin + if (not InDeclarations([TciProcedureDeclaration, TciCompoundStatement])) then + begin + inherited; + Exit; + end; + + PushStack(TciWithStatement); + inherited; + PopStack; +end; + +procedure TCodeParser.SimpleStatement; +begin + if (not InDeclaration(TciWithStatement)) then + begin + inherited; + Exit; + end; + + PushStack(TciSimpleStatement); + inherited; + PopStack; +end; + +procedure TCodeParser.Variable; +begin + if (not InDeclaration(TciWithStatement)) then + begin + inherited; + Exit; + end; + + PushStack(TciVariable); + inherited; + PopStack; +end; + +procedure TCodeParser.TypeKind; +var + n: Boolean; +begin + if (not InDeclarations([TciVarDeclaration, TciConstantDeclaration, TciTypeDeclaration, TciArrayType, TciClassField])) then + begin + inherited; + Exit; + end; + + n := (InDeclaration(TciArrayType)) and (TokenID = tokConst); + PushStack(TciTypeKind); + if n then + NextToken + else + inherited; + PopStack; +end; + +procedure TCodeParser.TypedConstant; +begin + if (not InDeclarations([TciVarDeclaration, TciConstParameter, TciOutParameter, TciFormalParameter, TciInParameter, TciVarParameter])) then + begin + inherited; + Exit; + end; + + PushStack(TciTypedConstant); + inherited; + PopStack; +end; + +procedure TCodeParser.Expression; +begin + if (not InDeclarations([TciVarDeclaration, TciConstantDeclaration, TciOrdinalType])) then + begin + inherited; + Exit; + end; + + PushStack(TciExpression); + inherited; + PopStack; +end; + +procedure TCodeParser.ProceduralType; +begin + if (not InDeclaration(TciTypeKind)) then + begin + inherited; + Exit; + end; + + PushStack(TciProceduralType); + inherited; + PopStack; +end; + +procedure TCodeParser.TypeDeclaration; +begin + PushStack(TciTypeDeclaration); + inherited; + PopStack; +end; + +procedure TCodeParser.TypeName; +begin + if (not InDeclaration(TciTypeDeclaration)) then + Exit; + PushStack(TciTypeName); + inherited; + PopStack; +end; + +procedure TCodeParser.VarDeclaration; +begin + PushStack(TciVarDeclaration); + inherited; + PopStack; +end; + +procedure TCodeParser.VarName; +begin + if (not InDeclaration(TciVarDeclaration)) then + Exit; + PushStack(TciVarName); + inherited; + PopStack; +end; + +procedure TCodeParser.ConstantDeclaration; +begin + PushStack(TciConstantDeclaration); + inherited; + PopStack; +end; + +procedure TCodeParser.ConstantName; +begin + if (not InDeclaration(TciConstantDeclaration)) then + begin + inherited; + Exit; + end; + + PushStack(TciConstantName); + inherited; + PopStack; +end; + +procedure TCodeParser.LabelDeclarationSection; +begin + PushStack(TciLabelDeclaration); + inherited; + PopStack; +end; + +procedure TCodeParser.LabelId; +begin + if (not InDeclaration(TciLabelDeclaration)) then + begin + inherited; + Exit; + end; + + PushStack(TciLabelName); + inherited; + PopStack; +end; + +procedure TCodeParser.ProcedureDeclarationSection; +begin + PushStack(TciProcedureDeclaration); + inherited; + PopStack; +end; + +procedure TCodeParser.FunctionProcedureName; +begin + if (not InDeclaration(TciProcedureDeclaration)) then + begin + inherited; + Exit; + end; + + PushStack(TciProcedureName); + inherited; + PopStack; +end; + +procedure TCodeParser.ObjectNameOfMethod; +begin + if (not InDeclaration(TciProcedureDeclaration)) then + begin + inherited; + Exit; + end; + + PushStack(TciProcedureClassName); + inherited; + PopStack; +end; + +procedure TCodeParser.ReturnType; +begin + if (not InDeclarations([TciProcedureDeclaration, TciProceduralType, TciClassMethodHeading])) then + begin + inherited; + Exit; + end; + + PushStack(TciReturnType); + //inherited; + TypeKind; + PopStack; +end; + +procedure TCodeParser.ForwardDeclaration; +begin + if (not InDeclaration(TciProcedureDeclaration)) then + begin + inherited; + Exit; + end; + + PushStack(TciForward); + inherited; + PopStack; +end; + +procedure TCodeParser.ConstParameter; +begin + if (not InDeclarations([TciProcedureDeclaration, TciProceduralType, TciClassMethodHeading])) then + begin + inherited; + Exit; + end; + + PushStack(TciConstParameter); + inherited; + PopStack; +end; + +procedure TCodeParser.OutParameter; +begin + if (not InDeclarations([TciProcedureDeclaration, TciProceduralType, TciClassMethodHeading])) then + begin + inherited; + Exit; + end; + + PushStack(TciOutParameter); + inherited; + PopStack; +end; + +procedure TCodeParser.ParameterFormal; +begin + if (not InDeclarations([TciProcedureDeclaration, TciProceduralType, TciClassMethodHeading])) then + begin + inherited; + Exit; + end; + + PushStack(TciFormalParameter); + inherited; + PopStack; +end; + +procedure TCodeParser.InParameter; +begin + if (not InDeclarations([TciProcedureDeclaration, TciProceduralType, TciClassMethodHeading])) then + begin + inherited; + Exit; + end; + + PushStack(TciInParameter); + inherited; + PopStack; +end; + +procedure TCodeParser.VarParameter; +begin + if (not InDeclarations([TciProcedureDeclaration, TciProceduralType, TciClassMethodHeading])) then + begin + inherited; + Exit; + end; + + PushStack(TciVarParameter); + inherited; + PopStack; +end; + +procedure TCodeParser.ParameterName; +begin + if (not InDeclarations([TciConstParameter, TciOutParameter, TciFormalParameter, TciInParameter, TciVarParameter])) then + begin + inherited; + Exit; + end; + + PushStack(TciParameterName); + inherited; + PopStack; +end; + +procedure TCodeParser.NewFormalParameterType; +begin + if (not InDeclarations([TciConstParameter, TciOutParameter, TciFormalParameter, TciInParameter, TciVarParameter])) then + begin + inherited; + Exit; + end; + + PushStack(TciParameterType); + //inherited; + TypeKind; + PopStack; +end; + +procedure TCodeParser.ArrayType; +begin + PushStack(TciArrayType); + inherited; + PopStack; +end; + +procedure TCodeParser.ArrayConstant; +begin + if (not InDeclaration(TciTypedConstant)) then + begin + inherited; + Exit; + end; + + PushStack(TciArrayConstant); + inherited; + PopStack; +end; + +procedure TCodeParser.RecordType; +begin + PushStack(TciRecordType); + inherited; + PopStack; +end; + +procedure TCodeParser.ClassField; +begin + if (not InDeclarations([TciRecordType, TciClassType])) then + begin + inherited; + Exit; + end; + + PushStack(TciClassField); + inherited; + PopStack; +end; + +procedure TCodeParser.FieldName; +begin + if (not InDeclaration(TciClassField)) then + begin + inherited; + Exit; + end; + + PushStack(TciFieldName); + inherited; + PopStack; +end; + +procedure TCodeParser.RecordConstant; +begin + if (not InDeclarations([TciTypedConstant, TciArrayConstant])) then + begin + inherited; + Exit; + end; + + PushStack(TciRecordConstant); + inherited; + PopStack; +end; + +procedure TCodeParser.RecordFieldConstant; +begin + if (not InDeclaration(TciRecordConstant)) then + begin + inherited; + Exit; + end; + + PushStack(TciRecordFieldConstant); + inherited; + PopStack; +end; + +procedure TCodeParser.ClassType; +begin + PushStack(TciClassType); + inherited; + PopStack; +end; + +procedure TCodeParser.AncestorId; +begin + if (not InDeclaration(TciClassType)) then + begin + inherited; + Exit; + end; + + PushStack(TciAncestorID); + inherited; + PopStack; +end; + +procedure TCodeParser.ClassMethodHeading; +begin + if (not InDeclarations([TciRecordType, TciClassType])) then + begin + inherited; + Exit; + end; + + PushStack(TciClassMethodHeading); + inherited; + PopStack; +end; + +procedure TCodeParser.ConstructorName; +begin + if (not InDeclaration(TciClassMethodHeading)) then + begin + inherited; + Exit; + end; + + PushStack(TciProcedureName); + inherited; + PopStack; +end; + +procedure TCodeParser.DestructorName; +begin + if (not InDeclaration(TciClassMethodHeading)) then + begin + inherited; + Exit; + end; + + PushStack(TciProcedureName); + inherited; + PopStack; +end; + +procedure TCodeParser.FunctionMethodName; +begin + if (not InDeclaration(TciClassMethodHeading)) then + begin + inherited; + Exit; + end; + + PushStack(TciProcedureName); + inherited; + PopStack; +end; + +procedure TCodeParser.ProcedureMethodName; +begin + if (not InDeclaration(TciClassMethodHeading)) then + begin + inherited; + Exit; + end; + + PushStack(TciProcedureName); + inherited; + PopStack; +end; + +procedure TCodeParser.ClassProperty; +begin + if (not InDeclarations([TciRecordType, TciClassType])) then + begin + inherited; + Exit; + end; + + PushStack(TciClassProperty); + inherited; + PopStack; +end; + +procedure TCodeParser.PropertyName; +begin + if (not InDeclaration(TciClassProperty)) then + begin + inherited; + Exit; + end; + + PushStack(TciFieldName); + inherited; + PopStack; +end; + +procedure TCodeParser.TypeId; +begin + if (not InDeclaration(TciClassProperty)) then + begin + inherited; + Exit; + end; + + PushStack(TciTypeKind); + inherited; + PopStack; +end; + +procedure TCodeParser.PropertyDefault; +begin + if (not InDeclaration(TciClassProperty)) then + begin + inherited; + Exit; + end; + + PushStack(TciPropertyDefault); + inherited; + PopStack; +end; + +procedure TCodeParser.SetType; +begin + PushStack(TciSetType); + inherited; + PopStack; +end; + +procedure TCodeParser.OrdinalType; +begin + if (not InDeclarations([TciSetType, TciArrayType])) then + begin + inherited; + Exit; + end; + + PushStack(TciOrdinalType); + inherited; + PopStack; +end; + +procedure TCodeParser.EnumeratedType; +begin + PushStack(TciEnumType); + inherited; + PopStack; +end; + +procedure TCodeParser.QualifiedIdentifier; +begin + if (not InDeclarations([TciEnumType])) then + begin + inherited; + Exit; + end; + + PushStack(TciQualifiedIdentifier); + inherited; + PopStack; +end; + +end.