{ *************************************************************************** * * * This source is free software; you can redistribute it and/or modify * * it under the terms of the GNU General Public License as published by * * the Free Software Foundation; either version 2 of the License, or * * (at your option) any later version. * * * * This code is distributed in the hope that it will be useful, but * * WITHOUT ANY WARRANTY; without even the implied warranty of * * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * * General Public License for more details. * * * * A copy of the GNU General Public License is available on the World * * Wide Web at . You can also * * obtain it by writing to the Free Software Foundation, * * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. * * * *************************************************************************** Author: Mattias Gaertner Abstract: TLinkScanner scans a source file, reacts to compiler directives, replaces macros and reads include files. It builds one source and a link list. The resulting source is called the cleaned source. A link points from a position of the cleaned source to its position in the real source. The link list makes it possible to change scanned code in the source files. ToDo: - macros } unit LinkScanner; {$ifdef FPC} {$mode objfpc} {$endif}{$H+} {$ifdef UseInline}{$inline on}{$endif} {$I codetools.inc} { $DEFINE ShowIgnoreErrorAfter} // debugging { $DEFINE ShowUpdateCleanedSrc} { $DEFINE VerboseIncludeSearch} interface uses {$IFDEF MEM_CHECK} MemCheck, {$ENDIF} Classes, SysUtils, CodeToolsStrConsts, CodeToolMemManager, FileProcs, AVL_Tree, ExprEval, SourceLog, KeywordFuncLists, BasicCodeTools; const PascalCompilerDefine = ExternalMacroStart+'Compiler'; NestedCompilerDefine = ExternalMacroStart+'NestedComments'; MissingIncludeFileCode = Pointer(1); type TLinkScanner = class; //---------------------------------------------------------------------------- TOnGetSource = function(Sender: TObject; Code: Pointer): TSourceLog of object; TOnLoadSource = function(Sender: TObject; const AFilename: string; OnlyIfExists: boolean): pointer of object; TOnGetSourceStatus = procedure(Sender: TObject; Code: Pointer; var ReadOnly: boolean) of object; TOnDeleteSource = procedure(Sender: TObject; Code: Pointer; Pos, Len: integer) of object; TOnGetFileName = function(Sender: TObject; Code: Pointer): string of object; TOnCheckFileOnDisk = function(Code: Pointer): boolean of object; TOnGetInitValues = function(Code: Pointer; out ChangeStep: integer): TExpressionEvaluator of object; TOnIncludeCode = procedure(ParentCode, IncludeCode: Pointer) of object; TOnSetWriteLock = procedure(Lock: boolean) of object; TOnGetWriteLockInfo = procedure(out WriteLockIsSet: boolean; out WriteLockStep: integer) of object; { TSourceLink is used to map between the codefiles and the cleaned source } PSourceLink = ^TSourceLink; TSourceLink = record CleanedPos: integer; SrcPos: integer; Code: Pointer; Next: PSourceLink; end; { TSourceChangeStep is used save the ChangeStep of every used file } PSourceChangeStep = ^TSourceChangeStep; TSourceChangeStep = record Code: Pointer; ChangeStep: integer; Next: PSourceChangeStep; end; TLinkScannerRange = ( lsrNone, // undefined lsrInit, // init, but do not scan any code lsrInterface, // scan only interface lsrEnd // scan till 'end.' ); TCommentStyle = (CommentNone, CommentTP, CommentOldTP, CommentDelphi); TCompilerMode = (cmFPC, cmDELPHI, cmGPC, cmTP, cmOBJFPC, cmMacPas); TPascalCompiler = (pcFPC, pcDelphi); TLSSkippingDirective = ( lssdNone, lssdTillElse, lssdTillEndIf ); { TMissingIncludeFile is a missing include file together with all params involved in the search } TMissingIncludeFile = class public IncludePath: string; Filename: string; constructor Create(const AFilename, AIncludePath: string); end; { TMissingIncludeFiles is a list of TMissingIncludeFile } TMissingIncludeFiles = class(TList) private function GetIncFile(Index: Integer): TMissingIncludeFile; procedure SetIncFile(Index: Integer; const AValue: TMissingIncludeFile); public procedure Clear; override; procedure Delete(Index: Integer); property Items[Index: Integer]: TMissingIncludeFile read GetIncFile write SetIncFile; default; end; { LinkScanner Token Types } TLSTokenType = ( lsttNone, lsttSrcEnd, lsttIdentifier, lsttEqual, lsttPoint, lsttEnd, lsttEndOfInterface); { Error handling } ELinkScannerError = class(Exception) Sender: TLinkScanner; constructor Create(ASender: TLinkScanner; const AMessage: string); end; ELinkScannerErrors = class of ELinkScannerError; TLinkScannerProgress = function(Sender: TLinkScanner): boolean of object; ELinkScannerAbort = class(ELinkScannerError) end; ELinkScannerEditError = class(ELinkScannerError) Buffer: Pointer; BufferPos: integer; constructor Create(ASender: TLinkScanner; const AMessage: string; ABuffer: Pointer; ABufferPos: integer); end; { TLinkScanner } TLinkScanner = class(TObject) private FLinks: PSourceLink; // list of TSourceLink FLinkCount: integer; FLinkCapacity: integer; FCleanedSrc: string; FLastCleanedSrcLen: integer; FOnGetSource: TOnGetSource; FOnGetFileName: TOnGetFileName; FOnGetSourceStatus: TOnGetSourceStatus; FOnLoadSource: TOnLoadSource; FOnDeleteSource: TOnDeleteSource; FOnCheckFileOnDisk: TOnCheckFileOnDisk; FOnGetInitValues: TOnGetInitValues; FOnIncludeCode: TOnIncludeCode; FOnProgress: TLinkScannerProgress; FIgnoreErrorAfterCode: Pointer; FIgnoreErrorAfterCursorPos: integer; FInitValues: TExpressionEvaluator; FInitValuesChangeStep: integer; FSourceChangeSteps: TFPList; // list of PSourceChangeStep sorted with Code FChangeStep: integer; FMainSourceFilename: string; FMainCode: pointer; FScanTill: TLinkScannerRange; FIgnoreMissingIncludeFiles: boolean; FNestedComments: boolean; FForceUpdateNeeded: boolean; // global write lock FLastGlobalWriteLockStep: integer; FOnGetGlobalWriteLockInfo: TOnGetWriteLockInfo; FOnSetGlobalWriteLock: TOnSetWriteLock; function GetLinks(Index: integer): TSourceLink; procedure SetLinks(Index: integer; const Value: TSourceLink); procedure SetSource(ACode: Pointer); // set current source procedure AddSourceChangeStep(ACode: pointer; AChangeStep: integer); procedure AddLink(ACleanedPos, ASrcPos: integer; ACode: Pointer); procedure IncreaseChangeStep; procedure SetMainCode(const Value: pointer); procedure SetScanTill(const Value: TLinkScannerRange); procedure SetIgnoreMissingIncludeFiles(const Value: boolean); function TokenIs(const AToken: shortstring): boolean; function UpTokenIs(const AToken: shortstring): boolean; private // parsing CommentStyle: TCommentStyle; CommentLevel: integer; CommentStartPos: integer; // position of '{', '(*', '//' CommentInnerStartPos: integer; // position after '{', '(*', '//' CommentInnerEndPos: integer; // position of '}', '*)', #10 CommentEndPos: integer; // postion after '}', '*)', #10 LastCleanSrcPos: integer; IfLevel: integer; KeywordFuncList: TKeyWordFunctionList; procedure ReadNextToken; function ReturnFromIncludeFileAndIsEnd: boolean; function ReadIdentifier: string; function ReadUpperIdentifier: string; procedure SkipSpace; {$IFDEF UseInline}inline;{$ENDIF} procedure SkipComment; procedure SkipDelphiComment; procedure SkipOldTPComment; procedure CommentEndNotFound; procedure EndComment; procedure IncCommentLevel; procedure DecCommentLevel; procedure HandleDirectives; procedure UpdateCleanedSource(SourcePos: integer); function ReturnFromIncludeFile: boolean; procedure InitKeyWordList; function DoEndToken: boolean; {$IFDEF UseInline}inline;{$ENDIF} function DoDefaultIdentToken: boolean; {$IFDEF UseInline}inline;{$ENDIF} function DoEndOfInterfaceToken: boolean; {$IFDEF UseInline}inline;{$ENDIF} private // directives FDirectiveName: shortstring; FDirectiveFuncList: TKeyWordFunctionList; FDefaultDirectiveFuncList: TKeyWordFunctionList; FSkipDirectiveFuncList: TKeyWordFunctionList; FMacrosOn: boolean; FMissingIncludeFiles: TMissingIncludeFiles; FIncludeStack: TFPList; // list of TSourceLink FSkippingDirectives: TLSSkippingDirective; FSkipIfLevel: integer; FCompilerMode: TCompilerMode; FPascalCompiler: TPascalCompiler; procedure SetCompilerMode(const AValue: TCompilerMode); procedure SkipTillEndifElse(SkippingUntil: TLSSkippingDirective); function SkipIfDirective: boolean; function InternalIfDirective: boolean; function IfdefDirective: boolean; function IfCDirective: boolean; function IfndefDirective: boolean; function IfDirective: boolean; function IfOptDirective: boolean; function EndifDirective: boolean; function EndCDirective: boolean; function IfEndDirective: boolean; function ElseDirective: boolean; function ElseCDirective: boolean; function ElseIfDirective: boolean; function ElIfCDirective: boolean; function DefineDirective: boolean; function UndefDirective: boolean; function SetCDirective: boolean; function IncludeDirective: boolean; function IncludePathDirective: boolean; function ShortSwitchDirective: boolean; function ReadNextSwitchDirective: boolean; function LongSwitchDirective: boolean; function ModeDirective: boolean; function ThreadingDirective: boolean; procedure BuildDirectiveFuncList; function IncludeFile(const AFilename: string): boolean; function SearchIncludeFile(AFilename: string; var NewCode: Pointer; var MissingIncludeFile: TMissingIncludeFile): boolean; procedure PushIncludeLink(ACleanedPos, ASrcPos: integer; ACode: Pointer); function PopIncludeLink: TSourceLink; function GetIncludeFileIsMissing: boolean; function MissingIncludeFilesNeedsUpdate: boolean; procedure ClearMissingIncludeFiles; protected // errors LastErrorMessage: string; LastErrorSrcPos: integer; LastErrorCode: pointer; LastErrorIsValid: boolean; LastErrorBehindIgnorePosition: boolean; LastErrorCheckedForIgnored: boolean; CleanedIgnoreErrorAfterPosition: integer;// ignore if valid and >= procedure RaiseExceptionFmt(const AMessage: string; Args: array of const); procedure RaiseException(const AMessage: string); procedure RaiseExceptionClass(const AMessage: string; ExceptionClass: ELinkScannerErrors); procedure RaiseEditException(const AMessage: string; ABuffer: Pointer; ABufferPos: integer); procedure ClearLastError; procedure RaiseLastError; procedure DoCheckAbort; public // current values, positions, source, flags CleanedLen: integer; Src: string; // current parsed source SrcPos: integer; // current position TokenStart: integer; // start position of current token TokenType: TLSTokenType; SrcLen: integer; // length of current source Code: pointer; // current code object Values: TExpressionEvaluator; SrcFilename: string;// current parsed filename ScannedRange: TLinkScannerRange; function MainFilename: string; // links property Links[Index: integer]: TSourceLink read GetLinks write SetLinks; property LinkCount: integer read FLinkCount; function LinkIndexAtCleanPos(ACleanPos: integer): integer; function LinkIndexAtCursorPos(ACursorPos: integer; ACode: Pointer): integer; function LinkSize(Index: integer): integer; function LinkCleanedEndPos(Index: integer): integer; function FindFirstSiblingLink(LinkIndex: integer): integer; function FindParentLink(LinkIndex: integer): integer; function LinkIndexNearCursorPos(ACursorPos: integer; ACode: Pointer; var CursorInLink: boolean): integer; function CreateTreeOfSourceCodes: TAVLTree; // source mapping (Cleaned <-> Original) function CleanedSrc: string; function CursorToCleanPos(ACursorPos: integer; ACode: pointer; out ACleanPos: integer): integer; // 0=valid CleanPos //-1=CursorPos was skipped, CleanPos between two links // 1=CursorPos beyond scanned code function CleanedPosToCursor(ACleanedPos: integer; var ACursorPos: integer; var ACode: Pointer): boolean; function LastErrorIsInFrontOfCleanedPos(ACleanedPos: integer): boolean; procedure RaiseLastErrorIfInFrontOfCleanedPos(ACleanedPos: integer); // ranges function WholeRangeIsWritable(CleanStartPos, CleanEndPos: integer; ErrorOnFail: boolean): boolean; procedure FindCodeInRange(CleanStartPos, CleanEndPos: integer; UniqueSortedCodeList: TFPList); procedure DeleteRange(CleanStartPos,CleanEndPos: integer); // scanning procedure Scan(Range: TLinkScannerRange; CheckFilesOnDisk: boolean); function UpdateNeeded(Range: TLinkScannerRange; CheckFilesOnDisk: boolean): boolean; procedure SetIgnoreErrorAfter(ACursorPos: integer; ACode: Pointer); procedure ClearIgnoreErrorAfter; function IgnoreErrAfterPositionIsInFrontOfLastErrMessage: boolean; function IgnoreErrorAfterCleanedPos: integer;// before using this, check if valid! function IgnoreErrorAfterValid: boolean; function CleanPosIsAfterIgnorePos(CleanPos: integer): boolean; function LoadSourceCaseLoUp(const AFilename: string): pointer; function GuessMisplacedIfdefEndif(StartCursorPos: integer; StartCode: pointer; out EndCursorPos: integer; out EndCode: Pointer): boolean; property ChangeStep: integer read FChangeStep; // global write lock procedure ActivateGlobalWriteLock; procedure DeactivateGlobalWriteLock; property OnGetGlobalWriteLockInfo: TOnGetWriteLockInfo read FOnGetGlobalWriteLockInfo write FOnGetGlobalWriteLockInfo; property OnSetGlobalWriteLock: TOnSetWriteLock read FOnSetGlobalWriteLock write FOnSetGlobalWriteLock; // properties property OnGetSource: TOnGetSource read FOnGetSource write FOnGetSource; property OnLoadSource: TOnLoadSource read FOnLoadSource write FOnLoadSource; property OnDeleteSource: TOnDeleteSource read FOnDeleteSource write FOnDeleteSource; property OnGetSourceStatus: TOnGetSourceStatus read FOnGetSourceStatus write FOnGetSourceStatus; property OnGetFileName: TOnGetFileName read FOnGetFileName write FOnGetFileName; property OnCheckFileOnDisk: TOnCheckFileOnDisk read FOnCheckFileOnDisk write FOnCheckFileOnDisk; property OnGetInitValues: TOnGetInitValues read FOnGetInitValues write FOnGetInitValues; property OnIncludeCode: TOnIncludeCode read FOnIncludeCode write FOnIncludeCode; property OnProgress: TLinkScannerProgress read FOnProgress write FOnProgress; property IgnoreMissingIncludeFiles: boolean read FIgnoreMissingIncludeFiles write SetIgnoreMissingIncludeFiles; property InitialValues: TExpressionEvaluator read FInitValues write FInitValues; property MainCode: pointer read FMainCode write SetMainCode; property IncludeFileIsMissing: boolean read GetIncludeFileIsMissing; property NestedComments: boolean read FNestedComments; property CompilerMode: TCompilerMode read FCompilerMode write SetCompilerMode; property PascalCompiler: TPascalCompiler read FPascalCompiler write FPascalCompiler; property ScanTill: TLinkScannerRange read FScanTill write SetScanTill; procedure Clear; procedure ConsistencyCheck; procedure WriteDebugReport; constructor Create; destructor Destroy; override; end; //---------------------------------------------------------------------------- // memory system for PSourceLink(s) TPSourceLinkMemManager = class(TCodeToolMemManager) protected procedure FreeFirstItem; override; public procedure DisposePSourceLink(Link: PSourceLink); function NewPSourceLink: PSourceLink; end; // memory system for PSourceLink(s) TPSourceChangeStepMemManager = class(TCodeToolMemManager) protected procedure FreeFirstItem; override; public procedure DisposePSourceChangeStep(Step: PSourceChangeStep); function NewPSourceChangeStep: PSourceChangeStep; end; //---------------------------------------------------------------------------- // compiler switches const CompilerSwitchesNames: array['A'..'Z'] of shortstring=( 'ALIGN' // A ,'BOOLEVAL' // B ,'ASSERTIONS' // C ,'DEBUGINFO' // D ,'' // E ,'' // F ,'' // G ,'LONGSTRINGS' // H ,'IOCHECKS' // I ,'' // J ,'' // K ,'LOCALSYMBOLS' // L ,'TYPEINFO' // M ,'' // N ,'' // O ,'OPENSTRINGS' // P ,'OVERFLOWCHECKS' // Q ,'RANGECHECKS' // R ,'' // S ,'TYPEADDRESS' // T ,'' // U ,'VARSTRINGCHECKS'// V ,'STACKFRAMES' // W ,'EXTENDEDSYNTAX' // X ,'REFERENCEINFO' // Y ,'' // Z ); const CompilerModeNames: array[TCompilerMode] of shortstring=( 'FPC', 'DELPHI', 'GPC', 'TP', 'OBJFPC', 'MACPAS' ); PascalCompilerNames: array[TPascalCompiler] of shortstring=( 'FPC', 'DELPHI' ); var CompilerModeVars: array[TCompilerMode] of shortstring; PSourceLinkMemManager: TPSourceLinkMemManager; PSourceChangeStepMemManager: TPSourceChangeStepMemManager; procedure AddCodeToUniqueList(ACode: Pointer; UniqueSortedCodeList: TFPList); function IndexOfCodeInUniqueList(ACode: Pointer; UniqueSortedCodeList: TList): integer; function IndexOfCodeInUniqueList(ACode: Pointer; UniqueSortedCodeList: TFPList): integer; implementation // useful procs ---------------------------------------------------------------- function IndexOfCodeInUniqueList(ACode: Pointer; UniqueSortedCodeList: TList): integer; var l,m,r: integer; begin l:=0; r:=UniqueSortedCodeList.Count-1; m:=0; while r>=l do begin m:=(l+r) shr 1; if ACodeUniqueSortedCodeList[m] then l:=m+1 else begin Result:=m; exit; end; end; Result:=-1; end; function IndexOfCodeInUniqueList(ACode: Pointer; UniqueSortedCodeList: TFPList): integer; var l,m,r: integer; begin l:=0; r:=UniqueSortedCodeList.Count-1; m:=0; while r>=l do begin m:=(l+r) shr 1; if ACodeUniqueSortedCodeList[m] then l:=m+1 else begin Result:=m; exit; end; end; Result:=-1; end; procedure AddCodeToUniqueList(ACode: Pointer; UniqueSortedCodeList: TFPList); var l,m,r: integer; begin l:=0; r:=UniqueSortedCodeList.Count-1; m:=0; while r>=l do begin m:=(l+r) shr 1; if ACodeUniqueSortedCodeList[m] then l:=m+1 else exit; end; if (mUniqueSortedCodeList[m]) then inc(m); UniqueSortedCodeList.Insert(m,ACode); end; function CompareUpToken(const UpToken: shortstring; const Txt: string; TxtStartPos, TxtEndPos: integer): boolean; var len, i: integer; begin Result:=false; len:=TxtEndPos-TxtStartPos; if len<>length(UpToken) then exit; i:=1; while iUpChars[Txt[TxtStartPos]]) then exit; inc(i); inc(TxtStartPos); end; Result:=true; end; function CompareUpToken(const UpToken: ansistring; const Txt: string; TxtStartPos, TxtEndPos: integer): boolean; var len, i: integer; begin Result:=false; len:=TxtEndPos-TxtStartPos; if len<>length(UpToken) then exit; i:=1; while iUpChars[Txt[TxtStartPos]]) then exit; inc(i); inc(TxtStartPos); end; Result:=true; end; { TLinkScanner } procedure TLinkScanner.AddLink(ACleanedPos, ASrcPos: integer; ACode: pointer); var NewCapacity: Integer; begin if FLinkCount=FLinkCapacity then begin NewCapacity:=FLinkCapacity*2; if NewCapacity<16 then NewCapacity:=16; ReAllocMem(FLinks,NewCapacity*SizeOf(TSourceLink)); FLinkCapacity:=NewCapacity; end; with FLinks[FLinkCount] do begin CleanedPos:=ACleanedPos; SrcPos:=ASrcPos; Code:=ACode; end; inc(FLinkCount); end; function TLinkScanner.CleanedSrc: string; begin if length(FCleanedSrc)<>CleanedLen then begin SetLength(FCleanedSrc,CleanedLen); end; Result:=FCleanedSrc; if FLastCleanedSrcLen=LinkCount) then IndexOutOfBounds; if Index=0 then begin LastIndex:=LinkIndex; while (Result>=0) do begin if FLinks[Result].Code=FLinks[LinkIndex].Code then begin if Links[Result].SrcPos>FLinks[LastIndex].SrcPos then begin // the include file was (in-)directly included by itself // -> skip Result:=FindParentLink(Result); end else if FLinks[Result].SrcPos=1 then begin // start found exit; end; LastIndex:=Result; end; dec(Result); end; end; end; function TLinkScanner.FindParentLink(LinkIndex: integer): integer; // a parent link is the link of the include directive // or in other words: the link in front of the first sibling link begin Result:=FindFirstSiblingLink(LinkIndex); if Result>=0 then dec(Result); end; function TLinkScanner.LinkIndexNearCursorPos(ACursorPos: integer; ACode: Pointer; var CursorInLink: boolean): integer; // returns the nearest link at cursorpos // (either covering the cursorpos or in front) var CurLinkSize: integer; BestLinkIndex: integer; begin BestLinkIndex:=-1; Result:=0; CursorInLink:=false; while Result=FLinks[Result].SrcPos) then begin CurLinkSize:=LinkSize(Result); if ACursorPosCleanedLen) then exit; // binary search through the links l:=0; r:=LinkCount-1; while l<=r do begin m:=(l+r) div 2; if m=FLinks[m+1].CleanedPos then l:=m+1 else begin Result:=m; exit; end; end else begin if ACleanPos>=FLinks[m].CleanedPos then begin Result:=m; exit; end else ConsistencyError2; end; end; ConsistencyError1; end; function TLinkScanner.LinkIndexAtCursorPos(ACursorPos: integer; ACode: Pointer ): integer; var CurLinkSize: integer; begin Result:=0; while Result=FLinks[Result].SrcPos) then begin CurLinkSize:=LinkSize(Result); if ACursorPosSrcLen) and ReturnFromIncludeFileAndIsEnd then exit; c1:=Src[SrcPos]; if IsCommentStartChar[c1] or IsSpaceChar[c1] then begin while true do begin if IsCommentStartChar[c1] then begin case c1 of '{' : SkipComment; '/': if (SrcPosSrcLen) or (not (IsSpaceChar[Src[SrcPos]])); end else break; if (SrcPos>SrcLen) and ReturnFromIncludeFileAndIsEnd then exit; c1:=Src[SrcPos]; end; end; TokenStart:=SrcPos; TokenType:=lsttNone; // read token case c1 of '_','A'..'Z','a'..'z': begin // identifier inc(SrcPos); while (SrcPos<=SrcLen) and (IsIdentChar[Src[SrcPos]]) do inc(SrcPos); KeywordFuncList.DoItCaseInsensitive(Src,TokenStart,SrcPos-TokenStart); end; '''','#': begin while (SrcPos<=SrcLen) do begin case (Src[SrcPos]) of '#': begin inc(SrcPos); while (SrcPos<=SrcLen) and (IsNumberChar[Src[SrcPos]]) do inc(SrcPos); end; '''': begin inc(SrcPos); while (SrcPos<=SrcLen) do begin case Src[SrcPos] of '''': begin inc(SrcPos); break; end; #10,#13: break; else inc(SrcPos); end; end; end; else break; end; end; end; '0'..'9': begin inc(SrcPos); while (SrcPos<=SrcLen) and (IsNumberChar[Src[SrcPos]]) do inc(SrcPos); if (SrcPos'.') then begin // real type number inc(SrcPos); while (SrcPos<=SrcLen) and (IsNumberChar[Src[SrcPos]]) do inc(SrcPos); if (SrcPos<=SrcLen) and (Src[SrcPos] in ['E','e']) then begin // read exponent inc(SrcPos); if (SrcPos<=SrcLen) and (Src[SrcPos] in ['-','+']) then inc(SrcPos); while (SrcPos<=SrcLen) and (IsNumberChar[Src[SrcPos]]) do inc(SrcPos); end; end; end; '%': begin inc(SrcPos); while (SrcPos<=SrcLen) and (Src[SrcPos] in ['0'..'1']) do inc(SrcPos); end; '$': begin inc(SrcPos); while (SrcPos<=SrcLen) and (IsHexNumberChar[Src[SrcPos]]) do inc(SrcPos); end; '=': begin inc(SrcPos); TokenType:=lsttEqual; end; '.': begin inc(SrcPos); TokenType:=lsttPoint; end; else inc(SrcPos); if SrcPos<=SrcLen then begin c2:=Src[SrcPos]; // test for double char operators // :=, +=, -=, /=, *=, <>, <=, >=, **, ><, .. if ((c2='=') and (IsEqualOperatorStartChar[c1])) or ((c1='<') and (c2='>')) or ((c1='>') and (c2='<')) or ((c1='.') and (c2='.')) or ((c1='*') and (c2='*')) then inc(SrcPos); end; end; end; procedure TLinkScanner.Scan(Range: TLinkScannerRange; CheckFilesOnDisk: boolean); var LastTokenType: TLSTokenType; cm: TCompilerMode; pc: TPascalCompiler; s: string; LastProgressPos: integer; CheckForAbort: boolean; NewSrcLen: Integer; begin if (not UpdateNeeded(Range,CheckFilesOnDisk)) then begin // input is the same as last time -> output is the same // -> if there was an error, raise it again if LastErrorIsValid and ((not IgnoreErrorAfterValid) or (not IgnoreErrAfterPositionIsInFrontOfLastErrMessage)) then RaiseLastError; exit; end; {$IFDEF CTDEBUG} DebugLn('TLinkScanner.Scan A -------- TillInterfaceEnd=',dbgs(TillInterfaceEnd)); {$ENDIF} ScanTill:=Range; Clear; IncreaseChangeStep; {$IFDEF CTDEBUG} DebugLn('TLinkScanner.Scan B '); {$ENDIF} SetSource(FMainCode); NewSrcLen:=length(Src); if NewSrcLen'0'); if Src='' then exit; // beging scanning InitKeyWordList; AddLink(1,SrcPos,Code); LastTokenType:=lsttNone; LastProgressPos:=0; CheckForAbort:=Assigned(OnProgress); {$IFDEF CTDEBUG} DebugLn('TLinkScanner.Scan F ',dbgs(SrcLen)); {$ENDIF} if ScanTill=lsrInit then exit; try try repeat // check every 10.000 bytes for abort if CheckForAbort and ((LastProgressPos-LastCleanSrcPos)>10000) then begin LastProgressPos:=LastCleanSrcPos; DoCheckAbort; end; ReadNextToken; //DebugLn('TLinkScanner.Scan G "',copy(Src,TokenStart,SrcPos-TokenStart),'"'); if (TokenType=lsttEndOfInterface) and (LastTokenType<>lsttEqual) then begin ScannedRange:=lsrInterface; if ScanTill=lsrInterface then break; end else if (LastTokenType=lsttEnd) and (TokenType=lsttPoint) then begin ScannedRange:=lsrEnd; break; end else if (SrcPos>SrcLen) and ReturnFromIncludeFileAndIsEnd then break; LastTokenType:=TokenType; until false; finally if FSkippingDirectives=lssdNone then begin {$IFDEF ShowUpdateCleanedSrc} DebugLn('TLinkScanner.Scan UpdatePos=',DbgS(SrcPos-1)); {$ENDIF} UpdateCleanedSource(SrcPos-1); end else begin {$IFDEF ShowUpdateCleanedSrc} DebugLn(['TLinkScanner.Scan missing $ENDIF']); {$ENDIF} end; end; IncreaseChangeStep; FForceUpdateNeeded:=false; FLastCleanedSrcLen:=CleanedLen; except on E: ELinkScannerError do begin if (not IgnoreErrorAfterValid) or (not IgnoreErrAfterPositionIsInFrontOfLastErrMessage) then raise; {$IFDEF ShowIgnoreErrorAfter} DebugLn('TLinkScanner.Scan IGNORING ERROR: ',LastErrorMessage); {$ENDIF} end; end; {$IFDEF CTDEBUG} DebugLn('TLinkScanner.Scan END ',dbgs(CleanedLen)); {$ENDIF} end; procedure TLinkScanner.SetLinks(Index: integer; const Value: TSourceLink); begin FLinks[Index]:=Value; end; procedure TLinkScanner.SkipComment; // a normal pascal {} comment begin CommentStyle:=CommentTP; CommentStartPos:=SrcPos; IncCommentLevel; inc(SrcPos); CommentInnerStartPos:=SrcPos; { HandleSwitches can dec CommentLevel } while (SrcPos<=SrcLen) and (CommentLevel>0) do begin case Src[SrcPos] of '{' : IncCommentLevel; '}' : DecCommentLevel; end; inc(SrcPos); end; CommentEndPos:=SrcPos; CommentInnerEndPos:=SrcPos-1; if (CommentLevel>0) then CommentEndNotFound; { handle compiler switches } if Src[CommentInnerStartPos]='$' then HandleDirectives; EndComment; end; procedure TLinkScanner.SkipDelphiComment; // a // newline comment begin CommentStyle:=CommentDelphi; CommentStartPos:=SrcPos; IncCommentLevel; inc(SrcPos,2); CommentInnerStartPos:=SrcPos; while (SrcPos<=SrcLen) and (Src[SrcPos]<>#10) do inc(SrcPos); DecCommentLevel; inc(SrcPos); CommentEndPos:=SrcPos; CommentInnerEndPos:=SrcPos-1; { handle compiler switches (ignore) } EndComment; end; procedure TLinkScanner.SkipOldTPComment; // a (* *) comment begin CommentStyle:=CommentDelphi; CommentStartPos:=SrcPos; IncCommentLevel; inc(SrcPos,2); CommentInnerStartPos:=SrcPos; while (SrcPos'*') or (Src[SrcPos+1]<>')')) then inc(SrcPos) else begin DecCommentLevel; inc(SrcPos,2); break; end; end; CommentEndPos:=SrcPos; CommentInnerEndPos:=SrcPos-2; if (CommentLevel>0) then CommentEndNotFound; { handle compiler switches } if Src[CommentInnerStartPos]='$' then HandleDirectives; EndComment; end; procedure TLinkScanner.CommentEndNotFound; begin SrcPos:=CommentStartPos; RaiseException(ctsCommentEndNotFound); end; procedure TLinkScanner.UpdateCleanedSource(SourcePos: integer); // add new parsed code to cleaned source string var AddLen, i: integer; begin if SourcePos=LastCleanSrcPos then exit; if SourcePos>SrcLen then SourcePos:=SrcLen; AddLen:=SourcePos-LastCleanSrcPos; if AddLen>length(FCleanedSrc)-CleanedLen then begin // expand cleaned source string by at least OldLen+1024 i:=length(FCleanedSrc)+1024; if AddLenACode then r:=m-1 else exit; end; NewSrcChangeStep:=PSourceChangeStepMemManager.NewPSourceChangeStep; NewSrcChangeStep^.Code:=ACode; NewSrcChangeStep^.ChangeStep:=AChangeStep; if (FSourceChangeSteps.Count>0) and (c=1) then begin ATokenLen:=length(AToken); if ATokenLen=SrcPos-TokenStart then begin for i:=1 to ATokenLen do if AToken[i]<>Src[TokenStart-1+i] then exit; Result:=true; end; end; end; function TLinkScanner.UpTokenIs(const AToken: shortstring): boolean; var ATokenLen: integer; i: integer; begin Result:=false; if (SrcPos<=SrcLen+1) and (TokenStart>=1) then begin ATokenLen:=length(AToken); if ATokenLen=SrcPos-TokenStart then begin for i:=1 to ATokenLen do if AToken[i]<>UpChars[Src[TokenStart-1+i]] then exit; Result:=true; end; end; end; procedure TLinkScanner.ConsistencyCheck; var i: integer; begin if (FLinks=nil) xor (FLinkCapacity=0) then RaiseCatchableException(''); if FLinks<>nil then begin for i:=0 to FLinkCount-1 do begin if FLinks[i].Code=nil then RaiseCatchableException(''); if (FLinks[i].CleanedPos<1) or (FLinks[i].CleanedPos>SrcLen) then RaiseCatchableException(''); end; end; if SrcLen<>length(Src) then RaiseCatchableException(''); if Values<>nil then Values.ConsistencyCheck; end; procedure TLinkScanner.WriteDebugReport; var i: integer; begin // header DebugLn(''); DebugLn('[TLinkScanner.WriteDebugReport]', ' ChangeStepCount=',dbgs(FSourceChangeSteps.Count), ' LinkCount=',dbgs(LinkCount), ' CleanedLen=',dbgs(CleanedLen)); // time stamps for i:=0 to FSourceChangeSteps.Count-1 do begin DebugLn(' ChangeStep ',dbgs(i),': ' ,' Code=',dbgs(PSourceChangeStep(FSourceChangeSteps[i])^.Code) ,' ChangeStep=',dbgs(PSourceChangeStep(FSourceChangeSteps[i])^.ChangeStep)); end; // links for i:=0 to LinkCount-1 do begin DebugLn(' Link ',dbgs(i),':' ,' CleanedPos=',dbgs(FLinks[i].CleanedPos) ,' SrcPos=',dbgs(FLinks[i].SrcPos) ,' Code=',dbgs(FLinks[i].Code) ); end; end; function TLinkScanner.UpdateNeeded( Range: TLinkScannerRange; CheckFilesOnDisk: boolean): boolean; { the clean source must be rebuilt if 1. scanrange changed from only interface to whole source 2. unit source changed 3. one of its include files changed 4. init values changed (e.g. initial compiler defines) } var i: integer; SrcLog: TSourceLog; NewInitValues: TExpressionEvaluator; GlobalWriteLockIsSet: boolean; GlobalWriteLockStep: integer; NewInitValuesChangeStep: integer; SrcChange: PSourceChangeStep; begin Result:=true; if FForceUpdateNeeded then exit; // do a quick test: check the GlobalWriteLockStep if Assigned(OnGetGlobalWriteLockInfo) then begin OnGetGlobalWriteLockInfo(GlobalWriteLockIsSet,GlobalWriteLockStep); if GlobalWriteLockIsSet then begin // The global write lock is set. That means, input variables and code are // frozen if (FLastGlobalWriteLockStep=GlobalWriteLockStep) then begin // source and values did not change since last UpdateNeeded check // -> check only if ScanTill has increased if ord(Range)>ord(ScannedRange) then exit; Result:=false; exit; end else begin // this is the first check in this GlobalWriteLockStep FLastGlobalWriteLockStep:=GlobalWriteLockStep; // proceed normally ... end; end; end; // check if any input has changed ... FForceUpdateNeeded:=true; // check if ScanRange has increased if ord(Range)>ord(ScannedRange) then exit; // check all used files if Assigned(FOnGetSource) then begin if CheckFilesOnDisk and Assigned(FOnCheckFileOnDisk) then begin // if files changed on disk, reload them for i:=0 to FSourceChangeSteps.Count-1 do begin SrcChange:=PSourceChangeStep(FSourceChangeSteps[i]); SrcLog:=FOnGetSource(Self,SrcChange^.Code); FOnCheckFileOnDisk(SrcLog); end; end; for i:=0 to FSourceChangeSteps.Count-1 do begin SrcChange:=PSourceChangeStep(FSourceChangeSteps[i]); SrcLog:=FOnGetSource(Self,SrcChange^.Code); //debugln(['TLinkScanner.UpdateNeeded ',ExtractFilename(MainFilename),' i=',i,' File=',FOnGetFileName(Self,SrcLog),' Last=',SrcChange^.ChangeStep,' Now=',SrcLog.ChangeStep]); if SrcChange^.ChangeStep<>SrcLog.ChangeStep then exit; end; end; // check initvalues if Assigned(FOnGetInitValues) then begin if FInitValues=nil then exit; NewInitValues:=FOnGetInitValues(Code,NewInitValuesChangeStep); if (NewInitValues<>nil) and (NewInitValuesChangeStep<>FInitValuesChangeStep) and (not FInitValues.Equals(NewInitValues)) then exit; end; // check missing include files if MissingIncludeFilesNeedsUpdate then exit; // no update needed :) FForceUpdateNeeded:=false; //DebugLn('TLinkScanner.UpdateNeeded END'); Result:=false; end; procedure TLinkScanner.SetIgnoreErrorAfter(ACursorPos: integer; ACode: Pointer ); begin if (FIgnoreErrorAfterCode=ACode) and (FIgnoreErrorAfterCursorPos=ACursorPos) then exit; FIgnoreErrorAfterCode:=ACode; FIgnoreErrorAfterCursorPos:=ACursorPos; LastErrorCheckedForIgnored:=false; {$IFDEF ShowIgnoreErrorAfter} DbgOut('TLinkScanner.SetIgnoreErrorAfter '); if FIgnoreErrorAfterCode<>nil then DbgOut(OnGetFileName(Self,FIgnoreErrorAfterCode)) else DbgOut('nil'); DbgOut(' ',dbgs(FIgnoreErrorAfterCursorPos)); DebugLn(''); {$ENDIF} end; procedure TLinkScanner.ClearIgnoreErrorAfter; begin SetIgnoreErrorAfter(0,nil); end; function TLinkScanner.IgnoreErrAfterPositionIsInFrontOfLastErrMessage: boolean; var CleanResult: integer; begin //DebugLn('TLinkScanner.IgnoreErrAfterPositionIsInFrontOfLastErrMessage'); //DebugLn([' LastErrorCheckedForIgnored=',LastErrorCheckedForIgnored, // ' LastErrorBehindIgnorePosition=',LastErrorBehindIgnorePosition]); if LastErrorCheckedForIgnored then Result:=LastErrorBehindIgnorePosition else begin CleanedIgnoreErrorAfterPosition:=-1; if (FIgnoreErrorAfterCode<>nil) and (FIgnoreErrorAfterCursorPos>0) then begin CleanResult:=CursorToCleanPos(FIgnoreErrorAfterCursorPos, FIgnoreErrorAfterCode,CleanedIgnoreErrorAfterPosition); //DebugLn([' CleanResult=',CleanResult, // ' CleanedIgnoreErrorAfterPosition=',CleanedIgnoreErrorAfterPosition, // ' FIgnoreErrorAfterCursorPos=',FIgnoreErrorAfterCursorPos, // ' CleanedLen=',CleanedLen, // ' LastErrorIsValid=',LastErrorIsValid]); if (CleanResult=0) or (CleanResult=-1) or (not LastErrorIsValid) then begin Result:=true; end else begin Result:=false; end; end else begin Result:=false; end; LastErrorBehindIgnorePosition:=Result; LastErrorCheckedForIgnored:=true; end; {$IFDEF ShowIgnoreErrorAfter} DebugLn('TLinkScanner.IgnoreErrAfterPositionIsInFrontOfLastErrMessage Result=',dbgs(Result)); {$ENDIF} end; function TLinkScanner.IgnoreErrorAfterCleanedPos: integer; begin if IgnoreErrAfterPositionIsInFrontOfLastErrMessage then Result:=CleanedIgnoreErrorAfterPosition else Result:=-1; {$IFDEF ShowIgnoreErrorAfter} DebugLn('TLinkScanner.IgnoreErrorAfterCleanedPos Result=',dbgs(Result)); {$ENDIF} end; function TLinkScanner.IgnoreErrorAfterValid: boolean; begin Result:=(FIgnoreErrorAfterCode<>nil); {$IFDEF ShowIgnoreErrorAfter} DebugLn('TLinkScanner.IgnoreErrorAfterValid Result=',dbgs(Result)); {$ENDIF} end; function TLinkScanner.CleanPosIsAfterIgnorePos(CleanPos: integer): boolean; var p: LongInt; begin if IgnoreErrorAfterValid then begin p:=IgnoreErrorAfterCleanedPos; if p<1 then Result:=false else Result:=CleanPos>=p; end else begin Result:=false end; end; function TLinkScanner.LastErrorIsInFrontOfCleanedPos(ACleanedPos: integer ): boolean; begin Result:=LastErrorIsValid and (CleanedLen>ACleanedPos); {$IFDEF ShowIgnoreErrorAfter} DebugLn('TLinkScanner.LastErrorIsInFrontOfCleanedPos Result=',dbgs(Result)); {$ENDIF} end; procedure TLinkScanner.RaiseLastErrorIfInFrontOfCleanedPos(ACleanedPos: integer ); begin if LastErrorIsInFrontOfCleanedPos(ACleanedPos) then RaiseLastError; end; {------------------------------------------------------------------------------- function TLinkScanner.GuessMisplacedIfdefEndif Params: StartCursorPos: integer; StartCode: pointer; var EndCursorPos: integer; var EndCode: Pointer; Result: boolean; -------------------------------------------------------------------------------} function TLinkScanner.GuessMisplacedIfdefEndif(StartCursorPos: integer; StartCode: pointer; out EndCursorPos: integer; out EndCode: Pointer): boolean; type TIf = record StartPos: integer; // comment start e.g. { EndPos: integer; // comment end e.g. the char behind } Expression: string; HasElse: boolean; end; PIf = ^TIf; TTokenType = (ttNone, ttCommentStart, ttCommentEnd, // '{' '}' ttTPCommentStart, ttTPCommentEnd, // '(*' '*)' ttDelphiCommentStart, // '//' ttLineEnd ); TTokenRange = (trCode, trComment, trTPComment, trDelphiComment); TToken = record StartPos: integer; EndPos: integer; TheType: TTokenType; Range: TTokenRange; NestedComments: boolean; end; TDirectiveType = (dtUnknown, dtIf, dtIfDef, dtIfNDef, dtIfOpt, dtElse, dtEndif); function FindNextToken(const ASrc: string; var AToken: TToken): boolean; var ASrcLen: integer; OldRange: TTokenRange; begin Result:=true; AToken.StartPos:=AToken.EndPos; ASrcLen:=length(ASrc); OldRange:=AToken.Range; while (AToken.StartPos<=ASrcLen) do begin case ASrc[AToken.StartPos] of '{': // pascal comment start begin AToken.EndPos:=AToken.StartPos+1; AToken.TheType:=ttCommentStart; AToken.Range:=trComment; if (OldRange=trCode) then exit else if AToken.NestedComments then begin if (not FindNextToken(ASrc,AToken)) then begin Result:=false; exit; end; AToken.StartPos:=AToken.EndPos-1; AToken.Range:=OldRange; end; end; '(': // check if Turbo Pascal comment start if (AToken.StartPos skip rest of code AToken.StartPos:=ASrcLen; end; else // in different kind of comment -> ignore end; '*': // turbo pascal comment end if (AToken.StartPos skip rest of code AToken.StartPos:=ASrcLen; end; else // in different kind of comment -> ignore end; end; #10,#13: // line end if AToken.Range in [trDelphiComment] then begin AToken.EndPos:=AToken.StartPos+1; if (AToken.StartPosASrc[AToken.StartPos]) then inc(AToken.EndPos); AToken.TheType:=ttLineEnd; AToken.Range:=trCode; exit; end else begin // in different kind of comment -> ignore end; '''': // skip string constant begin inc(AToken.StartPos); while (AToken.StartPos<=ASrcLen) do begin if (not (ASrc[AToken.StartPos] in ['''',#10,#13])) then begin inc(AToken.StartPos); end else begin break; end; end; end; end; inc(AToken.StartPos); end; // at the end of the code AToken.EndPos:=AToken.StartPos; AToken.TheType:=ttNone; Result:=false; end; procedure FreeIfStack(var IfStack: TFPList); var i: integer; AnIf: PIf; begin if IfStack=nil then exit; for i:=0 to IfStack.Count-1 do begin AnIf:=PIf(IfStack[i]); AnIf^.Expression:=''; Dispose(AnIf); end; IfStack.Free; IfStack:=nil; end; function InitGuessMisplaced(var CurToken: TToken; ACode: Pointer; var ASrc: string; var ASrcLen: integer): boolean; var ASrcLog: TSourceLog; begin Result:=false; // get source if (FOnGetSource=nil) then exit; ASrcLog:=FOnGetSource(Self,ACode); if ASrcLog=nil then exit; ASrc:=ASrcLog.Source; ASrcLen:=length(ASrc); CurToken.StartPos:=1; CurToken.EndPos:=1; CurToken.Range:=trCode; CurToken.TheType:=ttNone; CurToken.NestedComments:=NestedComments; Result:=true; end; function ReadDirectiveType(const ASrc: string; AToken: TToken): TDirectiveType; const DIR_RST: array[0..5] of TDirectiveType = ( dtIfDef, dtIfNDef, dtIfOpt, dtIf, dtElse, dtEndif ); DIR_TXT: array[0..5] of PChar = ( 'IFDEF', 'IFNDEF', 'IFOPT', 'IF', 'ELSE', 'ENDIF' ); var ASrcLen, p: integer; n: Integer; begin Result:=dtUnknown; ASrcLen:=length(ASrc); p:=AToken.EndPos; if (p misplaced directive found EndCursorPos:=CurToken.EndPos; EndCode:=ACode; DebugLn('GuessMisplacedIfdefEndif $ELSE has no $IF'); Result:=true; exit; end; PIf(IfStack[IfStack.Count-1])^.HasElse:=true; end; dtEndif: begin if (IfStack.Count=0) then begin // this $ENDIF has no $IF // -> misplaced directive found EndCursorPos:=CurToken.EndPos; EndCode:=ACode; DebugLn('GuessMisplacedIfdefEndif $ENDIF has no $IF'); Result:=true; exit; end; PopIfFromStack(IfStack); end; end; end; until CurToken.TheType=ttNone; if IfStack.Count>0 then begin // there is an $IF without $ENDIF // -> misplaced directive found EndCursorPos:=PIf(IfStack[IfStack.Count-1])^.StartPos+1; EndCode:=ACode; DebugLn('GuessMisplacedIfdefEndif $IF without $ENDIF'); Result:=true; exit; end; finally FreeIfStack(IfStack); end; end; var LinkID, i, BestSrcPos: integer; LastCode: Pointer; SearchedCodes: TFPList; begin Result:=false; EndCursorPos:=0; EndCode:=nil; // search link before start position LinkID:=-1; BestSrcPos:=0; i:=0; while i=FLinks[i].SrcPos) then begin if (LinkID<0) or (BestSrcPos=LinkCount then exit; until (FLinks[LinkID].Code<>LastCode) and (SearchedCodes.IndexOf(FLinks[LinkID].Code)<0); end; finally SearchedCodes.Free; end; end; procedure TLinkScanner.SetMainCode(const Value: pointer); begin if FMainCode=Value then exit; FMainCode:=Value; FMainSourceFilename:=FOnGetFileName(Self,FMainCode); Clear; end; procedure TLinkScanner.SetScanTill(const Value: TLinkScannerRange); var OldScanRange: TLinkScannerRange; begin if FScanTill=Value then exit; OldScanRange:=FScanTill; FScanTill := Value; if ord(OldScanRange)'' then begin if (SrcPos<=SrcLen) and (Src[SrcPos] in ['-','+']) then begin if Src[SrcPos]='-' then Values.Variables[FDirectiveName]:='0' else Values.Variables[FDirectiveName]:='1'; Result:=ReadNextSwitchDirective; end else begin if FDirectiveName<>CompilerSwitchesNames['I'] then Result:=LongSwitchDirective else Result:=IncludeDirective; end; end else Result:=true; end; procedure TLinkScanner.BuildDirectiveFuncList; var c: char; begin FDefaultDirectiveFuncList:=TKeyWordFunctionList.Create; with FDefaultDirectiveFuncList do begin for c:='A' to 'Z' do begin if CompilerSwitchesNames[c]<>'' then begin Add(c,{$ifdef FPC}@{$endif}ShortSwitchDirective); Add(CompilerSwitchesNames[c],{$ifdef FPC}@{$endif}LongSwitchDirective); end; end; Add('IFDEF',{$ifdef FPC}@{$endif}IfdefDirective); Add('IFC',{$ifdef FPC}@{$endif}IfCDirective); Add('IFNDEF',{$ifdef FPC}@{$endif}IfndefDirective); Add('IF',{$ifdef FPC}@{$endif}IfDirective); Add('IFOPT',{$ifdef FPC}@{$endif}IfOptDirective); Add('ENDIF',{$ifdef FPC}@{$endif}EndIfDirective); Add('ENDC',{$ifdef FPC}@{$endif}EndCDirective); Add('ELSE',{$ifdef FPC}@{$endif}ElseDirective); Add('ELSEC',{$ifdef FPC}@{$endif}ElseCDirective); Add('ELSEIF',{$ifdef FPC}@{$endif}ElseIfDirective); Add('ELIFC',{$ifdef FPC}@{$endif}ElIfCDirective); Add('IFEND',{$ifdef FPC}@{$endif}IfEndDirective); Add('DEFINE',{$ifdef FPC}@{$endif}DefineDirective); Add('UNDEF',{$ifdef FPC}@{$endif}UndefDirective); Add('SETC',{$ifdef FPC}@{$endif}SetCDirective); Add('INCLUDE',{$ifdef FPC}@{$endif}IncludeDirective); Add('INCLUDEPATH',{$ifdef FPC}@{$endif}IncludePathDirective); Add('MODE',{$ifdef FPC}@{$endif}ModeDirective); Add('THREADING',{$ifdef FPC}@{$endif}ThreadingDirective); end; FSkipDirectiveFuncList:=TKeyWordFunctionList.Create; with FSkipDirectiveFuncList do begin Add('IFDEF',{$ifdef FPC}@{$endif}SkipIfDirective); Add('IFNDEF',{$ifdef FPC}@{$endif}SkipIfDirective); Add('IF',{$ifdef FPC}@{$endif}SkipIfDirective); Add('IFOPT',{$ifdef FPC}@{$endif}SkipIfDirective); Add('IFC',{$ifdef FPC}@{$endif}SkipIfDirective); Add('ENDIF',{$ifdef FPC}@{$endif}EndIfDirective); Add('ENDC',{$ifdef FPC}@{$endif}EndCDirective); Add('ELSE',{$ifdef FPC}@{$endif}ElseDirective); Add('ELSEC',{$ifdef FPC}@{$endif}ElseCDirective); Add('ELSEIF',{$ifdef FPC}@{$endif}ElseIfDirective); Add('ELIFC',{$ifdef FPC}@{$endif}ElIfCDirective); Add('IFEND',{$ifdef FPC}@{$endif}IfEndDirective); end; end; function TLinkScanner.LongSwitchDirective: boolean; // example: {$ASSERTIONS ON comment} var ValStart: integer; begin SkipSpace; ValStart:=SrcPos; while (SrcPos<=SrcLen) and IsWordChar[Src[SrcPos]] do inc(SrcPos); if CompareUpToken('ON',Src,ValStart,SrcPos) then Values.Variables[FDirectiveName]:='1' else if CompareUpToken('OFF',Src,ValStart,SrcPos) then Values.Variables[FDirectiveName]:='0' else if CompareUpToken('PRELOAD',Src,ValStart,SrcPos) and (FDirectiveName='ASSERTIONS') then Values.Variables[FDirectiveName]:='PRELOAD' else if (FDirectiveName='LOCALSYMBOLS') then // ignore link object directive else if (FDirectiveName='RANGECHECKS') then // ignore link object directive else if (FDirectiveName='ALIGN') then // set record align size else begin RaiseExceptionFmt(ctsInvalidFlagValueForDirective, [copy(Src,ValStart,SrcPos-ValStart),FDirectiveName]); end; Result:=ReadNextSwitchDirective; end; function TLinkScanner.ModeDirective: boolean; // $MODE DEFAULT, OBJFPC, TP, FPC, GPC, DELPHI var ValStart: integer; AMode: TCompilerMode; ModeValid: boolean; begin SkipSpace; ValStart:=SrcPos; while (SrcPos<=SrcLen) and (IsWordChar[Src[SrcPos]]) do inc(SrcPos); // undefine all mode macros for AMode:=Low(TCompilerMode) to High(TCompilerMode) do Values.Undefine(CompilerModeVars[AMode]); // define new mode macro if CompareUpToken('DEFAULT',Src,ValStart,SrcPos) then begin // set mode to initial mode for AMode:=Low(TCompilerMode) to High(TCompilerMode) do if FInitValues.IsDefined(CompilerModeVars[AMode]) then begin CompilerMode:=AMode; end; end else begin ModeValid:=false; for AMode:=Low(TCompilerMode) to High(TCompilerMode) do if CompareUpToken(CompilerModeNames[AMode],Src,ValStart,SrcPos) then begin CompilerMode:=AMode; Values.Variables[CompilerModeVars[AMode]]:='1'; ModeValid:=true; break; end; if not ModeValid then RaiseExceptionFmt(ctsInvalidMode,[copy(Src,ValStart,SrcPos-ValStart)]); end; Result:=true; end; function TLinkScanner.ThreadingDirective: boolean; // example: {$threading on} var ValStart: integer; begin SkipSpace; ValStart:=SrcPos; while (SrcPos<=SrcLen) and (IsWordChar[Src[SrcPos]]) do inc(SrcPos); if CompareUpToken('ON',Src,ValStart,SrcPos) then begin // define THREADING Values.Variables[ExternalMacroStart+'UseSysThrds']:='1'; end else begin // undefine THREADING Values.Undefine(ExternalMacroStart+'UseSysThrds'); end; Result:=true; end; function TLinkScanner.ReadNextSwitchDirective: boolean; var DirStart, DirLen: integer; begin SkipSpace; if (SrcPos<=SrcLen) and (Src[SrcPos]=',') then begin inc(SrcPos); DirStart:=SrcPos; while (SrcPos<=SrcLen) and (IsIdentStartChar[Src[SrcPos]]) do inc(SrcPos); DirLen:=SrcPos-DirStart; if DirLen>255 then DirLen:=255; FDirectiveName:=UpperCaseStr(copy(Src,DirStart,DirLen)); Result:=FDirectiveFuncList.DoItCaseInsensitive(Src,DirStart,DirLen); end else Result:=true; end; function TLinkScanner.IfdefDirective: boolean; // {$ifdef name comment} var VariableName: string; begin inc(IfLevel); SkipSpace; VariableName:=ReadUpperIdentifier; if (VariableName<>'') and (not Values.IsDefined(VariableName)) then SkipTillEndifElse(lssdTillElse); Result:=true; end; function TLinkScanner.IfCDirective: boolean; // {$ifc expression} or indirectly called by {$elifc expression} begin //DebugLn(['TLinkScanner.IfCDirective FSkippingDirectives=',ord(FSkippingDirectives),' IfLevel=',IfLevel]); inc(IfLevel); Result:=InternalIfDirective; end; procedure TLinkScanner.SkipSpace; begin while (SrcPos<=SrcLen) and (IsSpaceChar[Src[SrcPos]]) do inc(SrcPos); end; function TLinkScanner.ReadIdentifier: string; var StartPos: integer; begin StartPos:=SrcPos; if (SrcPos<=SrcLen) and (IsIdentStartChar[Src[SrcPos]]) then begin inc(SrcPos); while (SrcPos<=SrcLen) and (IsIdentChar[Src[SrcPos]]) do inc(SrcPos); Result:=copy(Src,StartPos,SrcPos-StartPos); end else Result:=''; end; function TLinkScanner.ReadUpperIdentifier: string; var StartPos: integer; begin StartPos:=SrcPos; if (SrcPos<=SrcLen) and (IsIdentStartChar[Src[SrcPos]]) then begin inc(SrcPos); while (SrcPos<=SrcLen) and (IsIdentChar[Src[SrcPos]]) do inc(SrcPos); Result:=UpperCaseStr(copy(Src,StartPos,SrcPos-StartPos)); end else Result:=''; end; procedure TLinkScanner.EndComment; begin CommentStyle:=CommentNone; end; function TLinkScanner.IfndefDirective: boolean; // {$ifndef name comment} var VariableName: string; begin inc(IfLevel); SkipSpace; VariableName:=ReadUpperIdentifier; if (VariableName<>'') and (Values.IsDefined(VariableName)) then SkipTillEndifElse(lssdTillElse); Result:=true; end; function TLinkScanner.EndifDirective: boolean; // {$endif comment} procedure RaiseAWithoutB; begin RaiseExceptionFmt(ctsAwithoutB,['$ENDIF','$IF']) end; begin if IfLevel<=0 then RaiseAWithoutB; dec(IfLevel); if IfLevel'') then Values.Undefine(VariableName); Result:=true; end; function TLinkScanner.SetCDirective: boolean; // {$setc name} or {$setc name:=value} var VariableName, NewValue: string; begin SkipSpace; VariableName:=ReadUpperIdentifier; if (VariableName<>'') then begin SkipSpace; if FMacrosOn and (SrcPos'%') then begin IncFilename:=Trim(copy(Src,SrcPos,CommentInnerEndPos-SrcPos)); if (IncFilename<>'') and (IncFilename[1]='''') and (IncFilename[length(IncFilename)]='''') then IncFilename:=copy(IncFilename,2,length(IncFilename)-2); if PascalCompiler<>pcDelphi then begin // default is fpc behaviour (default extension is .pp) if ExtractFileExt(IncFilename)='' then IncFilename:=IncFilename+'.pp'; end else begin // delphi understands quoted include files and default extension is .pas if ExtractFileExt(IncFilename)='' then IncFilename:=IncFilename+'.pas'; end; {$IFDEF ShowUpdateCleanedSrc} DebugLn('TLinkScanner.IncludeDirective A IncFilename=',IncFilename,' UpdatePos=',DbgS(CommentEndPos-1)); {$ENDIF} UpdateCleanedSource(CommentEndPos-1); // put old position on stack PushIncludeLink(CleanedLen,CommentEndPos,Code); // load include file Result:=IncludeFile(IncFilename); if Result then begin if (SrcPos<=SrcLen) then CommentEndPos:=SrcPos else ReturnFromIncludeFile; end else begin PopIncludeLink; end; end; //DebugLn('[TLinkScanner.IncludeDirective] END ',CommentEndPos,',',SrcPos,',',SrcLen); end; function TLinkScanner.IncludePathDirective: boolean; // {$includepath path_addition} var AddPath, PathDivider: string; begin inc(SrcPos); AddPath:=Trim(copy(Src,SrcPos,CommentInnerEndPos-SrcPos)); PathDivider:=':'; Values.Variables[ExternalMacroStart+'INCPATH']:= Values.Variables[ExternalMacroStart+'INCPATH']+PathDivider+AddPath; Result:=true; end; function TLinkScanner.LoadSourceCaseLoUp( const AFilename: string): pointer; var Path, FileNameOnly: string; SecondaryFileNameOnly: String; begin Path:=ExtractFilePath(AFilename); if (Path<>'') and (not FilenameIsAbsolute(Path)) then Path:=ExpandFileNameUTF8(Path); FileNameOnly:=ExtractFilename(AFilename); Result:=nil; Result:=FOnLoadSource(Self,TrimFilename(Path+FileNameOnly),true); if (Result<>nil) then exit; SecondaryFileNameOnly:=lowercase(FileNameOnly); if (SecondaryFileNameOnly<>FileNameOnly) then begin Result:=FOnLoadSource(Self,TrimFilename(Path+SecondaryFileNameOnly),true); if (Result<>nil) then exit; end; SecondaryFileNameOnly:=UpperCaseStr(FileNameOnly); if (SecondaryFileNameOnly<>FileNameOnly) then begin Result:=FOnLoadSource(Self,TrimFilename(Path+SecondaryFileNameOnly),true); if (Result<>nil) then exit; end; end; function TLinkScanner.SearchIncludeFile(AFilename: string; var NewCode: Pointer; var MissingIncludeFile: TMissingIncludeFile): boolean; var PathStart, PathEnd: integer; IncludePath, PathDivider, CurPath: string; ExpFilename: string; SecondaryFilename: String; HasPathDelims: Boolean; function SearchPath(const APath: string): boolean; begin Result:=false; if APath='' then exit; if APath[length(APath)]<>PathDelim then ExpFilename:=APath+PathDelim+AFilename else ExpFilename:=APath+AFilename; if not FilenameIsAbsolute(ExpFilename) then ExpFilename:=ExtractFilePath(FMainSourceFilename)+ExpFilename; NewCode:=LoadSourceCaseLoUp(ExpFilename); Result:=NewCode<>nil; end; procedure SetMissingIncludeFile; begin if MissingIncludeFile=nil then MissingIncludeFile:=TMissingIncludeFile.Create(AFilename,''); MissingIncludeFile.IncludePath:=IncludePath; end; begin {$IFDEF VerboseIncludeSearch} DebugLn('TLinkScanner.SearchIncludeFile Filename="',AFilename,'"'); {$ENDIF} IncludePath:=''; if not Assigned(FOnLoadSource) then begin NewCode:=nil; SetMissingIncludeFile; Result:=false; exit; end; // if include filename is absolute then load it directly if FilenameIsAbsolute(AFilename) then begin NewCode:=LoadSourceCaseLoUp(AFilename); Result:=(NewCode<>nil); if not Result then SetMissingIncludeFile; exit; end; // include filename is relative // beware of 'dir/file.inc' HasPathDelims:=(System.Pos('/',AFilename)>0) or (System.Pos('\',AFilename)>0); if HasPathDelims then DoDirSeparators(AFilename); // first search include file in the directory of the current source {$IFDEF VerboseIncludeSearch} DebugLn('TLinkScanner.SearchIncludeFile MainSourceFilename="',FMainSourceFilename,'"'); {$ENDIF} if FilenameIsAbsolute(SrcFilename) then begin // main source has absolute filename ExpFilename:=ExtractFilePath(SrcFilename)+AFilename; NewCode:=LoadSourceCaseLoUp(ExpFilename); Result:=(NewCode<>nil); if Result then exit; end else if (not HasPathDelims) then begin // main source has relative filename (= virtual) NewCode:=FOnLoadSource(Self,TrimFilename(AFilename),true); if NewCode=nil then begin SecondaryFilename:=lowercase(AFilename); if SecondaryFilename<>AFilename then NewCode:=FOnLoadSource(Self,TrimFilename(SecondaryFilename),true); end; if NewCode=nil then begin SecondaryFilename:=UpperCaseStr(AFilename); if SecondaryFilename<>AFilename then NewCode:=FOnLoadSource(Self,TrimFilename(SecondaryFilename),true); end; Result:=(NewCode<>nil); if Result then exit; end; // then search the include file in the include path if not HasPathDelims then begin if MissingIncludeFile=nil then IncludePath:=Values.Variables[ExternalMacroStart+'INCPATH'] else IncludePath:=MissingIncludeFile.IncludePath; if Values.IsDefined('DELPHI') then PathDivider:=':' else PathDivider:=':;'; {$IFDEF VerboseIncludeSearch} DebugLn('TLinkScanner.SearchIncludeFile IncPath="',IncludePath,'" PathDivider="',PathDivider,'"'); {$ENDIF} PathStart:=1; PathEnd:=PathStart; while PathEnd<=length(IncludePath) do begin if ((Pos(IncludePath[PathEnd],PathDivider))>0) {$IFDEF MSWindows} and (not ((PathEnd-PathStart=1) // ignore colon in drive and (IncludePath[PathEnd]=':') and (IsWordChar[IncludePath[PathEnd-1]]))) {$ENDIF} then begin if PathEnd>PathStart then begin CurPath:=TrimFilename(copy(IncludePath,PathStart,PathEnd-PathStart)); Result:=SearchPath(CurPath); if Result then exit; end; PathStart:=PathEnd+1; PathEnd:=PathStart; end else inc(PathEnd); end; if PathEnd>PathStart then begin CurPath:=TrimFilename(copy(IncludePath,PathStart,PathEnd-PathStart)); Result:=SearchPath(CurPath); if Result then exit; end; end; SetMissingIncludeFile; end; function TLinkScanner.IncludeFile(const AFilename: string): boolean; var NewCode: Pointer; MissingIncludeFile: TMissingIncludeFile; begin MissingIncludeFile:=nil; Result:=SearchIncludeFile(AFilename, NewCode, MissingIncludeFile); if Result then begin // change source if Assigned(FOnIncludeCode) then FOnIncludeCode(FMainCode,NewCode); SetSource(NewCode); AddLink(CleanedLen+1,SrcPos,Code); end else begin if MissingIncludeFile<>nil then begin if FMissingIncludeFiles=nil then FMissingIncludeFiles:=TMissingIncludeFiles.Create; FMissingIncludeFiles.Add(MissingIncludeFile); end; if (not IgnoreMissingIncludeFiles) then begin RaiseExceptionFmt(ctsIncludeFileNotFound,[AFilename]) end else begin // add a dummy link AddLink(CleanedLen+1,SrcPos,MissingIncludeFileCode); AddLink(CleanedLen+1,SrcPos,Code); end; end; end; function TLinkScanner.IfDirective: boolean; // {$if expression} or indirectly called by {$elseif expression} begin inc(IfLevel); Result:=InternalIfDirective; end; function TLinkScanner.IfOptDirective: boolean; // {$ifopt o+} or {$ifopt o-} var Option, c: char; begin inc(IfLevel); Result:=true; inc(SrcPos); Option:=UpChars[Src[SrcPos]]; if (IsWordChar[Option]) and (CompilerSwitchesNames[Option]<>'') then begin inc(SrcPos); if (SrcPos<=SrcLen) then begin c:=Src[SrcPos]; if c in ['+','-'] then begin if (c='-')<>(Values.Variables[CompilerSwitchesNames[Option]]='0') then begin SkipTillEndifElse(lssdTillElse); exit; end; end; end; end; end; procedure TLinkScanner.SetIgnoreMissingIncludeFiles(const Value: boolean); begin FIgnoreMissingIncludeFiles := Value; end; procedure TLinkScanner.PushIncludeLink(ACleanedPos, ASrcPos: integer; ACode: pointer); procedure RaiseIncludeCircleDetected; begin RaiseException(ctsIncludeCircleDetected); end; var NewLink: PSourceLink; i: integer; begin for i:=0 to FIncludeStack.Count-1 do if PSourceLink(FIncludeStack[i])^.Code=ACode then RaiseIncludeCircleDetected; NewLink:=PSourceLinkMemManager.NewPSourceLink; with NewLink^ do begin CleanedPos:=ACleanedPos; SrcPos:=ASrcPos; Code:=ACode; end; FIncludeStack.Add(NewLink); end; function TLinkScanner.PopIncludeLink: TSourceLink; var PLink: PSourceLink; begin PLink:=PSourceLink(FIncludeStack[FIncludeStack.Count-1]); Result:=PLink^; PSourceLinkMemManager.DisposePSourceLink(PLink); FIncludeStack.Delete(FIncludeStack.Count-1); end; function TLinkScanner.GetIncludeFileIsMissing: boolean; begin Result:=(FMissingIncludeFiles<>nil); end; function TLinkScanner.MissingIncludeFilesNeedsUpdate: boolean; var i: integer; MissingIncludeFile: TMissingIncludeFile; NewCode: Pointer; begin Result:=false; if (not IncludeFileIsMissing) or IgnoreMissingIncludeFiles then exit; { last scan missed an include file (i.e. was not in searchpath) -> Check all missing include files again } for i:=0 to FMissingIncludeFiles.Count-1 do begin MissingIncludeFile:=FMissingIncludeFiles[i]; if SearchIncludeFile(MissingIncludeFile.Filename,NewCode,MissingIncludeFile) then begin Result:=true; exit; end; end; end; procedure TLinkScanner.ClearMissingIncludeFiles; begin FreeAndNil(FMissingIncludeFiles); end; function TLinkScanner.ReturnFromIncludeFile: boolean; var OldPos: TSourceLink; begin if FSkippingDirectives=lssdNone then begin {$IFDEF ShowUpdateCleanedSrc} DebugLn('TLinkScanner.ReturnFromIncludeFile A UpdatePos=',DbgS(SrcPos-1)); {$ENDIF} UpdateCleanedSource(SrcPos-1); end; while SrcPos>SrcLen do begin Result:=FIncludeStack.Count>0; if not Result then exit; OldPos:=PopIncludeLink; SetSource(OldPos.Code); SrcPos:=OldPos.SrcPos; LastCleanSrcPos:=SrcPos-1; AddLink(CleanedLen+1,SrcPos,Code); end; Result:=SrcPos<=SrcLen; end; procedure TLinkScanner.InitKeyWordList; begin if KeywordFuncList<>nil then exit; KeywordFuncList:=TKeyWordFunctionList.Create; with KeywordFuncList do begin Add('END' ,@DoEndToken); Add('IMPLEMENTATION' ,@DoEndOfInterfaceToken); Add('INITIALIZIATION',@DoEndOfInterfaceToken); Add('FINALIZATION' ,@DoEndOfInterfaceToken); DefaultKeyWordFunction:=@DoDefaultIdentToken; end; end; function TLinkScanner.DoEndToken: boolean; begin TokenType:=lsttEnd; Result:=true; end; function TLinkScanner.DoDefaultIdentToken: boolean; begin TokenType:=lsttIdentifier; Result:=true; end; function TLinkScanner.DoEndOfInterfaceToken: boolean; begin TokenType:=lsttEndOfInterface; Result:=true; end; procedure TLinkScanner.SkipTillEndifElse(SkippingUntil: TLSSkippingDirective); procedure RaiseAlreadySkipping; begin raise Exception.Create('TLinkScanner.SkipTillEndifElse inconsistency: already skipping ' +' Old='+dbgs(ord(FSkippingDirectives)) +' New='+dbgs(ord(SkippingUntil))); end; var OldDirectiveFuncList: TKeyWordFunctionList; c1: Char; begin if FSkippingDirectives<>lssdNone then begin FSkippingDirectives:=SkippingUntil; exit; end; FSkippingDirectives:=SkippingUntil; SrcPos:=CommentEndPos; {$IFDEF ShowUpdateCleanedSrc} DebugLn('TLinkScanner.SkipTillEndifElse A UpdatePos=',DbgS(SrcPos-1),' Src=',DbgStr(copy(Src,SrcPos-15,15))+'|'+DbgStr(copy(Src,SrcPos,15))); {$ENDIF} UpdateCleanedSource(SrcPos-1); OldDirectiveFuncList:=FDirectiveFuncList; FDirectiveFuncList:=FSkipDirectiveFuncList; // parse till $else, $elseif or $endif without adding the code to FCleanedSrc FSkipIfLevel:=IfLevel; if (SrcPos<=SrcLen) then begin while true do begin c1:=Src[SrcPos]; if IsCommentStartChar[c1] then begin case c1 of '{': begin SkipComment; if FSkippingDirectives=lssdNone then break; end; '/': if (Src[SrcPos+1]='/') then begin SkipDelphiComment; if FSkippingDirectives=lssdNone then break; end else inc(SrcPos); '(': if (Src[SrcPos+1]='*') then begin SkipOldTPComment; if FSkippingDirectives=lssdNone then break; end else inc(SrcPos); end; end else if c1='''' then begin // skip string constant inc(SrcPos); while (SrcPos<=SrcLen) and (Src[SrcPos]<>'''') do inc(SrcPos); inc(SrcPos); end else begin inc(SrcPos); if (SrcPos>SrcLen) and not ReturnFromIncludeFile then break; end; end; end; LastCleanSrcPos:=CommentStartPos-1; AddLink(CleanedLen+1,CommentStartPos,Code); {$IFDEF ShowUpdateCleanedSrc} DebugLn('TLinkScanner.SkipTillEndifElse B Continuing after: ', ' Src=',DbgStr(copy(Src,CommentStartPos-15,15))+'|'+DbgStr(copy(Src,CommentStartPos,15))); {$ENDIF} FDirectiveFuncList:=OldDirectiveFuncList; FSkippingDirectives:=lssdNone; end; procedure TLinkScanner.SetCompilerMode(const AValue: TCompilerMode); begin if FCompilerMode=AValue then exit; FCompilerMode:=AValue; FNestedComments:=(PascalCompiler=pcFPC) and (FCompilerMode in [cmFPC,cmOBJFPC]); //DebugLn(['TLinkScanner.SetCompilerMode ',MainFilename,' ',PascalCompilerNames[PascalCompiler],' Mode=',CompilerModeNames[CompilerMode],' FNestedComments=',FNestedComments]); end; function TLinkScanner.SkipIfDirective: boolean; begin inc(IfLevel); Result:=true; end; function TLinkScanner.InternalIfDirective: boolean; // {$if expression} or {$ifc expression} or indirectly called by {$elifc expression} var Expr, ResultStr: string; begin //DebugLn(['TLinkScanner.InternalIfDirective FSkippingDirectives=',ord(FSkippingDirectives),' IfLevel=',IfLevel]); inc(SrcPos); Expr:=UpperCaseStr(copy(Src,SrcPos,CommentInnerEndPos-SrcPos)); ResultStr:=Values.Eval(Expr); Result:=true; //DebugLn(['TLinkScanner.InternalIfDirective ResultStr=',ResultStr]); if Values.ErrorPosition>=0 then begin inc(SrcPos,Values.ErrorPosition); RaiseException(ctsErrorInDirectiveExpression) end else if ResultStr='0' then SkipTillEndifElse(lssdTillElse) else FSkippingDirectives:=lssdNone; end; function TLinkScanner.CursorToCleanPos(ACursorPos: integer; ACode: pointer; out ACleanPos: integer): integer; // 0=valid CleanPos //-1=CursorPos was skipped, CleanPos is between two links // 1=CursorPos beyond scanned code var i, j, SkippedCleanPos: integer; SkippedPos: boolean; begin i:=0; SkippedPos:=false; SkippedCleanPos:=-1; ACleanPos:=0; while i=1) and (ACleanedPos<=CleanedLen); if Result then begin // ACleanedPos in Cleaned Code -> binary search through the links l:=0; r:=LinkCount-1; while l<=r do begin m:=(l+r) div 2; if m=FLinks[m+1].CleanedPos then l:=m+1 else begin ACode:=FLinks[m].Code; ACursorPos:=ACleanedPos-FLinks[m].CleanedPos+FLinks[m].SrcPos; exit; end; end else begin if ACleanedPos>=FLinks[m].CleanedPos then begin ACode:=FLinks[m].Code; ACursorPos:=ACleanedPos-FLinks[m].CleanedPos+FLinks[m].SrcPos; exit; end else ConsistencyCheckI(2); end; end; ConsistencyCheckI(1); end; end; function TLinkScanner.WholeRangeIsWritable(CleanStartPos, CleanEndPos: integer; ErrorOnFail: boolean): boolean; procedure EditError(const AMessage: string; ACode: Pointer); begin if ErrorOnFail then RaiseEditException(AMessage,ACode,0); end; var ACode: Pointer; LinkIndex: integer; CodeIsReadOnly: boolean; begin Result:=false; if (CleanStartPos<1) or (CleanStartPos>=CleanEndPos) or (CleanEndPos>CleanedLen+1) or (not Assigned(FOnGetSourceStatus)) then begin EditError('TLinkScanner.WholeRangeIsWritable: Invalid range',nil); exit; end; LinkIndex:=LinkIndexAtCleanPos(CleanStartPos); if LinkIndex<0 then begin EditError('TLinkScanner.WholeRangeIsWritable: position out of scan range',nil); exit; end; ACode:=FLinks[LinkIndex].Code; FOnGetSourceStatus(Self,ACode,CodeIsReadOnly); if CodeIsReadOnly then begin EditError(ctsfileIsReadOnly, ACode); exit; end; repeat inc(LinkIndex); if (LinkIndex>=LinkCount) or (FLinks[LinkIndex].CleanedPos>CleanEndPos) then begin Result:=true; exit; end; if ACode<>FLinks[LinkIndex].Code then begin ACode:=FLinks[LinkIndex].Code; FOnGetSourceStatus(Self,ACode,CodeIsReadOnly); if CodeIsReadOnly then begin EditError(ctsfileIsReadOnly, ACode); exit; end; end; until false; end; procedure TLinkScanner.FindCodeInRange(CleanStartPos, CleanEndPos: integer; UniqueSortedCodeList: TFPList); var ACode: Pointer; LinkIndex: integer; begin if (CleanStartPos<1) or (CleanStartPos>CleanEndPos) or (CleanEndPos>CleanedLen+1) or (UniqueSortedCodeList=nil) then exit; LinkIndex:=LinkIndexAtCleanPos(CleanStartPos); if LinkIndex<0 then exit; ACode:=FLinks[LinkIndex].Code; AddCodeToUniqueList(ACode,UniqueSortedCodeList); repeat inc(LinkIndex); if (LinkIndex>=LinkCount) or (FLinks[LinkIndex].CleanedPos>CleanEndPos) then exit; if ACode<>FLinks[LinkIndex].Code then begin ACode:=FLinks[LinkIndex].Code; AddCodeToUniqueList(ACode,UniqueSortedCodeList); end; until false; end; procedure TLinkScanner.DeleteRange(CleanStartPos,CleanEndPos: integer); { delete all code in links (=parsed code) starting with the last link before you call this, test with WholeRangeIsWritable this can do unexpected things if - include files are included twice - compiler directives like IFDEF - ENDIF are partially destroyed ToDo: keep include directives } var LinkIndex, StartPos, Len, aLinkSize: integer; begin if (CleanStartPos<1) or (CleanStartPos>=CleanEndPos) or (CleanEndPos>CleanedLen+1) or (not Assigned(FOnDeleteSource)) then exit; LinkIndex:=LinkIndexAtCleanPos(CleanEndPos-1); while LinkIndex>=0 do begin StartPos:=CleanStartPos-FLinks[LinkIndex].CleanedPos; if StartPos<0 then StartPos:=0; aLinkSize:=LinkSize(LinkIndex); if CleanEndPosnil) then Result:=OnGetFileName(Self,Code) else Result:=''; end; { ELinkScannerError } constructor ELinkScannerError.Create(ASender: TLinkScanner; const AMessage: string); begin inherited Create(AMessage); Sender:=ASender; end; { TPSourceLinkMemManager } procedure TPSourceLinkMemManager.FreeFirstItem; var Link: PSourceLink; begin Link:=PSourceLink(FFirstFree); PSourceLink(FFirstFree):=Link^.Next; Dispose(Link); end; procedure TPSourceLinkMemManager.DisposePSourceLink(Link: PSourceLink); begin if (FFreeCount free Link Dispose(Link); {$IFDEF DebugCTMemManager} inc(FFreedCount); {$ENDIF} end; dec(FCount); end; function TPSourceLinkMemManager.NewPSourceLink: PSourceLink; begin if FFirstFree<>nil then begin // take from free list Result:=PSourceLink(FFirstFree); PSourceLink(FFirstFree):=Result^.Next; Result^.Next:=nil; dec(FFreeCount); end else begin // free list empty -> create new PSourceLink New(Result); FillChar(Result^,SizeOf(TSourceLink),0); {$IFDEF DebugCTMemManager} inc(FAllocatedCount); {$ENDIF} end; inc(FCount); end; { TPSourceChangeStep } procedure TPSourceChangeStepMemManager.FreeFirstItem; var Step: PSourceChangeStep; begin Step:=PSourceChangeStep(FFirstFree); PSourceChangeStep(FFirstFree):=Step^.Next; Dispose(Step); end; procedure TPSourceChangeStepMemManager.DisposePSourceChangeStep( Step: PSourceChangeStep); begin if (FFreeCount free Step Dispose(Step); {$IFDEF DebugCTMemManager} inc(FFreedCount); {$ENDIF} end; dec(FCount); end; function TPSourceChangeStepMemManager.NewPSourceChangeStep: PSourceChangeStep; begin if FFirstFree<>nil then begin // take from free list Result:=PSourceChangeStep(FFirstFree); PSourceChangeStep(FFirstFree):=Result^.Next; Result^.Next:=nil; dec(FFreeCount); end else begin // free list empty -> create new PSourceChangeStep New(Result); FillChar(Result^,SizeOf(TSourceChangeStep),0); {$IFDEF DebugCTMemManager} inc(FAllocatedCount); {$ENDIF} end; inc(FCount); end; { TMissingIncludeFile } constructor TMissingIncludeFile.Create(const AFilename, AIncludePath: string); begin inherited Create; Filename:=AFilename; IncludePath:=AIncludePath; end; { TMissingIncludeFiles } function TMissingIncludeFiles.GetIncFile(Index: Integer): TMissingIncludeFile; begin Result:=TMissingIncludeFile(Get(Index)); end; procedure TMissingIncludeFiles.SetIncFile(Index: Integer; const AValue: TMissingIncludeFile); begin Put(Index,AValue); end; procedure TMissingIncludeFiles.Clear; var i: integer; begin for i:=0 to Count-1 do Items[i].Free; inherited Clear; end; procedure TMissingIncludeFiles.Delete(Index: Integer); begin Items[Index].Free; inherited Delete(Index); end; //------------------------------------------------------------------------------ procedure InternalInit; var CompMode: TCompilerMode; begin for CompMode:=Low(TCompilerMode) to High(TCompilerMode) do CompilerModeVars[CompMode]:='FPC_'+CompilerModeNames[CompMode]; PSourceLinkMemManager:=TPSourceLinkMemManager.Create; PSourceChangeStepMemManager:=TPSourceChangeStepMemManager.Create; end; procedure InternalFinal; begin PSourceChangeStepMemManager.Free; PSourceLinkMemManager.Free; end; { ELinkScannerEditError } constructor ELinkScannerEditError.Create(ASender: TLinkScanner; const AMessage: string; ABuffer: Pointer; ABufferPos: integer); begin inherited Create(ASender,AMessage); Buffer:=ABuffer; BufferPos:=ABufferPos; end; initialization InternalInit; finalization InternalFinal; end.