{ *************************************************************************** * * * 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+} {$I codetools.inc} { $DEFINE ShowIgnoreErrorAfter} // debugging { $DEFINE ShowUpdateCleanedSrc} { $DEFINE VerboseIncludeSearch} { $DEFINE VerboseUpdateNeeded} interface uses {$IFDEF MEM_CHECK} MemCheck, {$ENDIF} Classes, SysUtils, CodeToolsStrConsts, CodeToolMemManager, FileProcs, AVL_Tree, ExprEval, SourceLog, KeywordFuncLists, BasicCodeTools; const PascalCompilerDefine = ExternalMacroStart+'Compiler'; 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; TSourceLinkMacro = record Name: PChar; Code: Pointer; Src: string; SrcFilename: string; StartPos, EndPos: integer; end; PSourceLinkMacro = ^TSourceLinkMacro; { TSourceChangeStep is used to save the ChangeStep of every used file A ChangeStep is switching to or from an include file } PSourceChangeStep = ^TSourceChangeStep; TSourceChangeStep = record Code: Pointer; ChangeStep: integer; Next: PSourceChangeStep; end; TLinkScannerRange = ( lsrNone, // undefined lsrInit, // init, but do not scan any code lsrSourceType, // read till source type (e.g. keyword program or unit) lsrSourceName, // read till source name lsrInterfaceStart, // read till keyword interface lsrMainUsesSectionStart, // uses section of interface/program lsrMainUsesSectionEnd, // uses section of interface/program lsrImplementationStart, // scan only interface lsrImplementationUsesSectionStart, // uses section of implementation lsrImplementationUsesSectionEnd, // uses section of implementation lsrInitializationStart, lsrFinalizationStart, lsrEnd // scan till 'end.' ); TCommentStyle = (CommentNone, CommentTP, CommentOldTP, CommentDelphi); TCompilerMode = (cmFPC, cmDELPHI, cmGPC, cmTP, cmOBJFPC, cmMacPas); TCompilerModeSwitch = ( cmsDefault, cmsClass, cmsObjpas, cmsResult, cmsString_pchar, cmsCvar_support, cmsNested_comment, cmsTp_procvar, cmsMac_procvar, cmsRepeat_forward, cmsPointer_2_procedure, cmsAutoderef, cmsInitfinal, cmsAdd_pointer, cmsDefault_ansistring, cmsOut, cmsDefault_para, cmsHintdirective, cmsDuplicate_names, cmsProperty, cmsDefault_inline, cmsExcept, cmsObjectiveC1, cmsObjectiveC2, cmsNestedProcVars, cmsNonLocalGoto, cmsAdvancedRecords ); 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; DynamicExtension: boolean; constructor Create(const AFilename, AIncludePath: string; aDynamicExtension: boolean); function CalcMemSize: PtrUInt; 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); function CalcMemSize: PtrUInt; property Items[Index: Integer]: TMissingIncludeFile read GetIncFile write SetIncFile; default; end; { LinkScanner Token Types } TLSTokenType = ( lsttNone, lsttSrcEnd, // no more tokens lsttWord, lsttEqual, lsttPoint, lsttSemicolon, lsttComma, lsttStringConstant, lsttEnd ); { 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; 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; {$IFDEF UseInline}inline;{$ENDIF} procedure IncCommentLevel; {$IFDEF UseInline}inline;{$ENDIF} procedure DecCommentLevel; {$IFDEF UseInline}inline;{$ENDIF} procedure HandleDirectives; procedure UpdateCleanedSource(SourcePos: integer); function ReturnFromIncludeFile: boolean; function ParseKeyWord(StartPos, WordLen: integer; LastTokenType: TLSTokenType ): boolean; function DoEndToken: boolean; {$IFDEF UseInline}inline;{$ENDIF} function DoSourceTypeToken: boolean; {$IFDEF UseInline}inline;{$ENDIF} function DoInterfaceToken: boolean; {$IFDEF UseInline}inline;{$ENDIF} function DoImplementationToken: boolean; {$IFDEF UseInline}inline;{$ENDIF} function DoFinalizationToken: boolean; {$IFDEF UseInline}inline;{$ENDIF} function DoInitializationToken: boolean; {$IFDEF UseInline}inline;{$ENDIF} function DoUsesToken: boolean; {$IFDEF UseInline}inline;{$ENDIF} function IsUsesToken: boolean; function TokenIsWord(p: PChar): boolean; private // directives FDirectiveName: shortstring; FMacrosOn: boolean; FMissingIncludeFiles: TMissingIncludeFiles; FIncludeStack: TFPList; // list of TSourceLink FSkippingDirectives: TLSSkippingDirective; FSkipIfLevel: integer; FCompilerMode: TCompilerMode; FCompilerModeSwitch: TCompilerModeSwitch; FPascalCompiler: TPascalCompiler; FMacros: PSourceLinkMacro; FMacroCount, fMacroCapacity: integer; procedure SetCompilerMode(const AValue: TCompilerMode); procedure SetCompilerModeSwitch(const AValue: TCompilerModeSwitch); procedure SkipTillEndifElse(SkippingUntil: TLSSkippingDirective); 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 MacroDirective: boolean; function ModeDirective: boolean; function ModeSwitchDirective: boolean; function ThreadingDirective: boolean; function DoDirective(StartPos, DirLen: integer): boolean; function IncludeFile(const AFilename: string; DynamicExtension: boolean): boolean; function SearchIncludeFile(AFilename: string; DynamicExtension: boolean; out NewCode: Pointer; var MissingIncludeFile: TMissingIncludeFile): boolean; procedure PushIncludeLink(ACleanedPos, ASrcPos: integer; ACode: Pointer); function PopIncludeLink: TSourceLink; function GetIncludeFileIsMissing: boolean; function MissingIncludeFilesNeedsUpdate: boolean; procedure ClearMissingIncludeFiles; procedure AddMacroValue(MacroName: PChar; ValueStart, ValueEnd: integer); procedure ClearMacros; function IndexOfMacro(MacroName: PChar; InsertPos: boolean): integer; procedure AddMacroSource(MacroID: integer); protected // error: the error is in range Succ(ScannedRange) 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 CompilerModeSwitch: TCompilerModeSwitch read FCompilerModeSwitch write SetCompilerModeSwitch; property PascalCompiler: TPascalCompiler read FPascalCompiler write FPascalCompiler; property ScanTill: TLinkScannerRange read FScanTill write SetScanTill; procedure Clear; procedure ConsistencyCheck; procedure WriteDebugReport; procedure CalcMemSize(Stats: TCTMemStats); 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; const CompilerModeNames: array[TCompilerMode] of shortstring=( 'FPC', 'DELPHI', 'GPC', 'TP', 'OBJFPC', 'MACPAS' ); CompilerModeSwitchNames: array[TCompilerModeSwitch] of shortstring=( 'Default', 'CLASS', 'OBJPAS', 'RESULT', 'PCHARTOSTRING', 'CVAR', 'NESTEDCOMMENTS', 'CLASSICPROCVARS', 'MACPROCVARS', 'REPEATFORWARD', 'POINTERTOPROCVAR', 'AUTODEREF', 'INITFINAL', 'POINTERARITHMETICS', 'ANSISTRINGS', 'OUT', 'DEFAULTPARAMETERS', 'HINTDIRECTIVE', 'DUPLICATELOCALS', 'PROPERTIES', 'ALLOWINLINE', 'EXCEPTIONS', 'OBJECTIVEC1', 'OBJECTIVEC2', 'NESTEDPROCVARS', 'NONLOCALGOTO', 'ADVANCEDRECORDS'); PascalCompilerNames: array[TPascalCompiler] of shortstring=( 'FPC', 'DELPHI' ); var CompilerModeVars: array[TCompilerMode] of shortstring; PSourceLinkMemManager: TPSourceLinkMemManager; PSourceChangeStepMemManager: TPSourceChangeStepMemManager; const LinkScannerRangeNames: array[TLinkScannerRange] of string = ( 'lsrNone', 'lsrInit', 'lsrSourceType', 'lsrSourceName', 'lsrInterfaceStart', 'lsrMainUsesSectionStart', 'lsrMainUsesSectionEnd', 'lsrImplementationStart', 'lsrImplementationUsesSectionStart', 'lsrImplementationUsesSectionEnd', 'lsrInitializationStart', 'lsrFinalizationStart', 'lsrEnd' ); procedure AddCodeToUniqueList(ACode: Pointer; UniqueSortedCodeList: TFPList); function IndexOfCodeInUniqueList(ACode: Pointer; UniqueSortedCodeList: TList): integer; function IndexOfCodeInUniqueList(ACode: Pointer; UniqueSortedCodeList: TFPList): integer; function dbgs(r: TLinkScannerRange): string; overload; 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; function dbgs(r: TLinkScannerRange): string; overload; begin Result:=LinkScannerRangeNames[r]; 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; //DebugLn([' TLinkScanner.ReadNextToken SrcPos=',SrcPos,' SrcLen=',SrcLen,' "',copy(Src,SrcPos,5),'"']); // Skip all spaces and comments p:=@Src[SrcPos]; while true do begin case p^ of #0: begin SrcPos:=p-PChar(Src)+1; if (SrcPos>SrcLen) then begin if ReturnFromIncludeFileAndIsEnd then exit; if (SrcPos>SrcLen) then break; end; p:=@Src[SrcPos]; end; '{' : begin SrcPos:=p-PChar(Src)+1; SkipComment; p:=@Src[SrcPos]; end; '/': if p[1]='/' then begin SrcPos:=p-PChar(Src)+1; SkipDelphiComment; p:=@Src[SrcPos]; end else break; '(': if p[1]='*' then begin SrcPos:=p-PChar(Src)+1; SkipOldTPComment; p:=@Src[SrcPos]; end else break; ' ',#9,#10,#13: repeat inc(p); until not (p^ in [' ',#9,#10,#13]); else break; end; end; TokenStart:=p-PChar(Src)+1; // read token c1:=p^; case c1 of '_','A'..'Z','a'..'z': begin // keyword or identifier inc(p); while IsIdentChar[p^] do inc(p); TokenType:=lsttWord; SrcPos:=p-PChar(Src)+1; if FMacrosOn then begin MacroID:=IndexOfMacro(@Src[TokenStart],false); if MacroID>=0 then begin AddMacroSource(MacroID); end; end; end; '''','#': begin TokenType:=lsttStringConstant; while true do begin case p^ of #0: begin SrcPos:=p-PChar(Src)+1; if SrcPos>SrcLen then break; inc(p); end; '#': begin inc(p); while IsNumberChar[p^] do inc(p); end; '''': begin inc(p); while true do begin case p^ of #0: begin SrcPos:=p-PChar(Src)+1; if SrcPos>SrcLen then break; inc(p); end; '''': begin inc(p); break; end; #10,#13: break; else inc(p); end; end; end; else break; end; end; SrcPos:=p-PChar(Src)+1; end; '0'..'9': begin TokenType:=lsttNone; inc(p); while IsNumberChar[p^] do inc(p); if (p^='.') and (p[1]<>'.') then begin // real type number inc(p); while IsNumberChar[p^] do inc(p); if (p^ in ['E','e']) then begin // read exponent inc(p); if (p^ in ['-','+']) then inc(p); while IsNumberChar[p^] do inc(p); end; end; SrcPos:=p-PChar(Src)+1; end; '%': // boolean begin TokenType:=lsttNone; inc(p); while p^ in ['0'..'1'] do inc(p); SrcPos:=p-PChar(Src)+1; end; '$': // hex begin TokenType:=lsttNone; inc(p); while IsHexNumberChar[p^] do inc(p); SrcPos:=p-PChar(Src)+1; end; '=': begin SrcPos:=p-PChar(Src)+2; TokenType:=lsttEqual; end; '.': begin SrcPos:=p-PChar(Src)+2; TokenType:=lsttPoint; end; ';': begin SrcPos:=p-PChar(Src)+2; TokenType:=lsttSemicolon; end; ',': begin SrcPos:=p-PChar(Src)+2; TokenType:=lsttComma; end; else TokenType:=lsttNone; inc(p); c2:=p^; // 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(p); SrcPos:=p-PChar(Src)+1; end; {$IFDEF RangeChecking}{$R+}{$UNDEF RangeChecking}{$ENDIF} 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 and it was in a needed range, raise it again if LastErrorIsValid then begin // the error has happened in ScannedRange if ord(ScannedRange)>ord(Range) then begin // error was not in needed range end else if (ScannedRange=Range) and ((not IgnoreErrorAfterValid) or (not IgnoreErrAfterPositionIsInFrontOfLastErrMessage)) then RaiseLastError; end; exit; end; {$IFDEF CTDEBUG} DebugLn('TLinkScanner.Scan A -------- Range=',dbgs(Range)); {$ENDIF} ScanTill:=Range; Clear; {$IFDEF CTDEBUG} DebugLn('TLinkScanner.Scan B '); {$ENDIF} SetSource(FMainCode); NewSrcLen:=length(Src); if NewSrcLen'0'); if Src='' then exit; // begin scanning AddLink(1,SrcPos,Code); LastTokenType:=lsttNone; LastProgressPos:=0; CheckForAbort:=Assigned(OnProgress); {$IFDEF CTDEBUG} DebugLn('TLinkScanner.Scan F ',dbgs(SrcLen)); {$ENDIF} ScannedRange:=lsrInit; if ScanTill=lsrInit then exit; try try ReadNextToken; if IsUsesToken then DoUsesToken else SrcPos:=TokenStart; while ord(ScanTill)>ord(ScannedRange) do begin // check every 100.000 bytes for abort if CheckForAbort and ((LastProgressPos-LastCleanSrcPos)>100000) then begin LastProgressPos:=LastCleanSrcPos; DoCheckAbort; end; ReadNextToken; if TokenType=lsttWord then ParseKeyWord(TokenStart,SrcPos-TokenStart,LastTokenType); //writeln('TLinkScanner.Scan G "',copy(Src,TokenStart,SrcPos-TokenStart),'" LastTokenType=',LastTokenType,' TokenType=',TokenType); if (LastTokenType=lsttEnd) and (TokenType=lsttPoint) then begin //DebugLn(['TLinkScanner.Scan END. ',MainFilename]); ScannedRange:=lsrEnd; break; end; if (SrcPos>SrcLen) and ReturnFromIncludeFileAndIsEnd then break; LastTokenType:=TokenType; end; 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),' ',dbgs(ScannedRange)); {$ENDIF} end; procedure TLinkScanner.SetLinks(Index: integer; const Value: TSourceLink); begin FLinks[Index]:=Value; end; procedure TLinkScanner.SkipComment; // a normal pascal {} comment var p: PChar; begin CommentStyle:=CommentTP; CommentStartPos:=SrcPos; IncCommentLevel; inc(SrcPos); p:=@Src[SrcPos]; CommentInnerStartPos:=SrcPos; { HandleSwitches can dec CommentLevel } while true do begin case p^ of #0: begin SrcPos:=p-PChar(Src)+1; if SrcPos>SrcLen then break; end; '{' : IncCommentLevel; '}' : begin DecCommentLevel; if CommentLevel=0 then begin inc(p); break; end; end; end; inc(p); end; SrcPos:=p-PChar(Src)+1; 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 var p: PChar; begin CommentStyle:=CommentDelphi; CommentStartPos:=SrcPos; IncCommentLevel; inc(SrcPos,2); CommentInnerStartPos:=SrcPos; p:=@Src[SrcPos]; while true do begin case p^ of #0: begin SrcPos:=p-PChar(Src)+1; if SrcPos>SrcLen then break; end; '*': begin inc(p); if p^=')' then begin inc(p); DecCommentLevel; if CommentLevel=0 then break; end; end; '(': begin inc(p); if FNestedComments and (p^='*') then begin inc(p); IncCommentLevel; end; end; else inc(p); end; end; SrcPos:=p-PChar(Src)+1; 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: 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 1024 SetLength(FCleanedSrc,length(FCleanedSrc)+SrcLen+1024); end; System.Move(Src[LastCleanSrcPos+1],FCleanedSrc[CleanedLen+1],AddLen); inc(CleanedLen,AddLen); {$IFDEF ShowUpdateCleanedSrc} DebugLn('TLinkScanner.UpdateCleanedSource A ', DbgS(LastCleanSrcPos),'-',DbgS(SourcePos),'="', StringToPascalConst(copy(Src,LastCleanSrcPos+1,20)), '".."',StringToPascalConst(copy(Src,SourcePos-19,20)),'"'); {$ENDIF} LastCleanSrcPos:=SourcePos; end; procedure TLinkScanner.AddSourceChangeStep(ACode: pointer; AChangeStep: integer); procedure RaiseCodeNil; begin RaiseException('TLinkScanner.AddSourceChangeStep ACode=nil'); end; var l,r,m: integer; NewSrcChangeStep: PSourceChangeStep; c: pointer; begin //DebugLn('[TLinkScanner.AddSourceChangeStep] ',DbgS(ACode)); if ACode=nil then RaiseCodeNil; l:=0; r:=FSourceChangeSteps.Count-1; m:=0; c:=nil; while (l<=r) do begin m:=(l+r) shr 1; c:=PSourceChangeStep(FSourceChangeSteps[m])^.Code; if cACode 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; procedure TLinkScanner.CalcMemSize(Stats: TCTMemStats); begin Stats.Add('TLinkScanner', PtrUInt(InstanceSize) +MemSizeString(FMainSourceFilename) +length(FDirectiveName) +MemSizeString(LastErrorMessage) +MemSizeString(SrcFilename)); Stats.Add('TLinkScanner.CleanedSrc',MemSizeString(FCleanedSrc)); // Note: Src belongs to the codebuffer if FLinks<>nil then Stats.Add('TLinkScanner.FLinks', FLinkCapacity*SizeOf(TSourceLink)); if FInitValues<>nil then Stats.Add('TLinkScanner.FInitValues', FInitValues.CalcMemSize(false)); // FInitValues are copies of strings of TDefineTree if FSourceChangeSteps<>nil then Stats.Add('TLinkScanner.FSourceChangeSteps', FSourceChangeSteps.InstanceSize +FSourceChangeSteps.Capacity*SizeOf(TSourceChangeStep)); if FIncludeStack<>nil then Stats.Add('TLinkScanner.FIncludeStack', FIncludeStack.InstanceSize+FIncludeStack.Capacity*SizeOf(TSourceLink)); if Values<>nil then Stats.Add('TLinkScanner.Values', Values.CalcMemSize(true,FInitValues)); if FMissingIncludeFiles<>nil then Stats.Add('TLinkScanner.FMissingIncludeFiles', FMissingIncludeFiles.InstanceSize); end; function TLinkScanner.UpdateNeeded( Range: TLinkScannerRange; CheckFilesOnDisk: boolean): boolean; { the clean source must be rebuilt if 1. scanrange increased 2. unit source changed 3. one of its include files changed 4. init values changed (e.g. initial compiler defines) 5. FForceUpdateNeeded is set 6. a missing include file can now be found } 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 ScanRange has increased if (ord(Range)>ord(ScannedRange)) and (not LastErrorIsValid) then begin {$IFDEF VerboseUpdateNeeded} DebugLn(['TLinkScanner.UpdateNeeded because range increased Range=',ord(Range),' ScannedRange=',ord(ScannedRange)]); {$ENDIF} exit; end; // check if any input has changed ... FForceUpdateNeeded:=true; // check all used files if Assigned(FOnGetSource) then begin 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 begin {$IFDEF VerboseUpdateNeeded} DebugLn(['TLinkScanner.UpdateNeeded because file changed: ',OnGetFileName(Self,SrcLog),' MainFilename=',MainFilename]); {$ENDIF} exit; end; end; 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; 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 begin {$IFDEF VerboseUpdateNeeded} DebugLn(['TLinkScanner.UpdateNeeded because InitValues changed ',MainFilename]); {$ENDIF} exit; end; end; // check missing include files if MissingIncludeFilesNeedsUpdate then begin {$IFDEF VerboseUpdateNeeded} DebugLn(['TLinkScanner.UpdateNeeded because MissingIncludeFilesNeedsUpdate']); {$ENDIF} exit; end; // 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; function TLinkScanner.DoDirective(StartPos, DirLen: integer): boolean; var p: PChar; begin Result:=false; if StartPos>SrcLen then exit; p:=@Src[StartPos]; //DebugLn(['TLinkScanner.DoDirective ',copy(Src,StartPos,DirLen),' FSkippingDirectives=',ord(FSkippingDirectives)]); if FSkippingDirectives=lssdNone then begin if DirLen=1 then begin Result:=(CompilerSwitchesNames[UpChars[p^]]<>'') and ShortSwitchDirective; end else begin case UpChars[p^] of 'A': case UpChars[p[1]] of 'L': if CompareIdentifiers(p,'ALIGN')=0 then Result:=true; 'S': if CompareIdentifiers(p,'ASSERTIONS')=0 then Result:=true; end; 'B': if CompareIdentifiers(p,'BOOLEVAL')=0 then Result:=true; 'D': case UpChars[p[1]] of 'E': case UpChars[p[2]] of 'F': if CompareIdentifiers(p,'DEFINE')=0 then Result:=DefineDirective; 'B': if CompareIdentifiers(p,'DEBUGINFO')=0 then Result:=true; end; end; 'E': case UpChars[p[1]] of 'L': case UpChars[p[2]] of 'I': if CompareIdentifiers(p,'ELIFC')=0 then Result:=ElIfCDirective; 'S': case UpChars[p[3]] of 'E': if CompareIdentifiers(p,'ELSE')=0 then Result:=ElseDirective else if CompareIdentifiers(p,'ELSEC')=0 then Result:=ElseCDirective else if CompareIdentifiers(p,'ELSEIF')=0 then Result:=ElseIfDirective; end; end; 'N': if CompareIdentifiers(p,'ENDC')=0 then Result:=EndCDirective else if CompareIdentifiers(p,'ENDIF')=0 then Result:=EndIfDirective; 'X': if CompareIdentifiers(p,'EXTENDEDSYNTAX')=0 then Result:=true; end; 'I': case UpChars[p[1]] of 'F': case UpChars[p[2]] of 'C': if CompareIdentifiers(p,'IFC')=0 then Result:=IfCDirective; 'D': if CompareIdentifiers(p,'IFDEF')=0 then Result:=IfDefDirective; 'E': if CompareIdentifiers(p,'IFEND')=0 then Result:=IfEndDirective; 'N': if CompareIdentifiers(p,'IFNDEF')=0 then Result:=IfndefDirective; 'O': if CompareIdentifiers(p,'IFOPT')=0 then Result:=IfOptDirective; else if DirLen=2 then Result:=IfDirective; end; 'N': if CompareIdentifiers(p,'INCLUDE')=0 then Result:=IncludeDirective else if CompareIdentifiers(p,'INCLUDEPATH')=0 then Result:=IncludePathDirective; 'O': if CompareIdentifiers(p,'IOCHECKS')=0 then Result:=true; end; 'L': if CompareIdentifiers(p,'LOCALSYMBOLS')=0 then Result:=true else if CompareIdentifiers(p,'LONGSTRINGS')=0 then Result:=true; 'M': if CompareIdentifiers(p,'MODE')=0 then Result:=ModeDirective else if CompareIdentifiers(p,'MODESWITCH')=0 then Result:=ModeSwitchDirective else if CompareIdentifiers(p,'MACRO')=0 then Result:=MacroDirective; 'O': if CompareIdentifiers(p,'OPENSTRINGS')=0 then Result:=true else if CompareIdentifiers(p,'OVERFLOWCHECKS')=0 then Result:=true; 'R': if CompareIdentifiers(p,'RANGECHECKS')=0 then Result:=true else if CompareIdentifiers(p,'REFERENCEINFO')=0 then Result:=true; 'S': if CompareIdentifiers(p,'SETC')=0 then Result:=SetCDirective else if CompareIdentifiers(p,'STACKFRAMES')=0 then Result:=true; 'T': if CompareIdentifiers(p,'THREADING')=0 then Result:=ThreadingDirective else if CompareIdentifiers(p,'TYPEADDRESS')=0 then Result:=true else if CompareIdentifiers(p,'TYPEINFO')=0 then Result:=true; 'U': if CompareIdentifiers(p,'UNDEF')=0 then Result:=UndefDirective; 'V': if CompareIdentifiers(p,'VARSTRINGCHECKS')=0 then Result:=true; end; end; end else begin // skipping code, but still have to read if directives case UpChars[p^] of 'E': case UpChars[p[1]] of 'L': case UpChars[p[2]] of 'I': if CompareIdentifiers(p,'ELIFC')=0 then Result:=ElIfCDirective; 'S': case UpChars[p[3]] of 'E': if CompareIdentifiers(p,'ELSE')=0 then Result:=ElseDirective else if CompareIdentifiers(p,'ELSEC')=0 then Result:=ElseCDirective else if CompareIdentifiers(p,'ELSEIF')=0 then Result:=ElseIfDirective; end; end; 'N': if CompareIdentifiers(p,'ENDC')=0 then Result:=EndCDirective else if CompareIdentifiers(p,'ENDIF')=0 then Result:=EndIfDirective; end; 'I': case UpChars[p[1]] of 'F': case UpChars[p[2]] of 'C': if CompareIdentifiers(p,'IFC')=0 then Result:=IfCDirective; 'D': if CompareIdentifiers(p,'IFDEF')=0 then Result:=IfDefDirective; 'E': if CompareIdentifiers(p,'IFEND')=0 then Result:=IfEndDirective; 'N': if CompareIdentifiers(p,'IFNDEF')=0 then Result:=IfndefDirective; 'O': if CompareIdentifiers(p,'IFOPT')=0 then Result:=IfOptDirective; else if DirLen=2 then Result:=IfDirective; end; end; end; 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.MacroDirective: boolean; var ValStart: LongInt; begin SkipSpace; ValStart:=SrcPos; while (SrcPos<=SrcLen) and (IsWordChar[Src[SrcPos]]) do inc(SrcPos); if CompareUpToken('ON',Src,ValStart,SrcPos) then FMacrosOn:=true else if CompareUpToken('OFF',Src,ValStart,SrcPos) then FMacrosOn:=false else RaiseExceptionFmt(ctsInvalidFlagValueForDirective, [copy(Src,ValStart,SrcPos-ValStart),FDirectiveName]); Result:=true; 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.ModeSwitchDirective: boolean; // $MODESWITCH objectivec1 var ValStart: LongInt; ModeSwitch: TCompilerModeSwitch; begin SkipSpace; ValStart:=SrcPos; while (SrcPos<=SrcLen) and (IsIdentChar[Src[SrcPos]]) do inc(SrcPos); Result:=false; for ModeSwitch := Succ(Low(ModeSwitch)) to High(ModeSwitch) do begin if CompareUpToken(CompilerModeSwitchNames[ModeSwitch],Src,ValStart,SrcPos) then begin Result:=true; CompilerModeSwitch:=ModeSwitch; break; end; end; if not Result then RaiseExceptionFmt(ctsInvalidModeSwitch,[copy(Src,ValStart,SrcPos-ValStart)]); 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 (IsIdentChar[Src[SrcPos]]) do inc(SrcPos); DirLen:=SrcPos-DirStart; if DirLen>255 then DirLen:=255; FDirectiveName:=UpperCaseStr(copy(Src,DirStart,DirLen)); Result:=DoDirective(DirStart,DirLen); end else Result:=true; end; function TLinkScanner.IfdefDirective: boolean; // {$ifdef name comment} var VariableName: string; begin inc(IfLevel); if FSkippingDirectives<>lssdNone then exit(true); 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); if FSkippingDirectives<>lssdNone then exit(true); 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); if FSkippingDirectives<>lssdNone then exit(true); 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 store the value inc(SrcPos,2); SkipSpace; NewValue:=copy(Src,SrcPos,CommentInnerEndPos-SrcPos); if CompareIdentifiers(PChar(NewValue),'false')=0 then NewValue:='0' else if CompareIdentifiers(PChar(NewValue),'true')=0 then NewValue:='1'; Values.Variables[VariableName]:=NewValue; AddMacroValue(@Src[NamePos],SrcPos,CommentInnerEndPos); end else begin // flag Values.Variables[VariableName]:='1'; end; end; Result:=true; end; function TLinkScanner.UndefDirective: boolean; // {$undefine name} var VariableName: string; begin SkipSpace; VariableName:=ReadUpperIdentifier; if (VariableName<>'') 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); DynamicExtension:=false; if PascalCompiler<>pcDelphi then begin // default is fpc behaviour (default extension is .pp) if ExtractFileExt(IncFilename)='' then begin IncFilename:=IncFilename+'.pp'; DynamicExtension:=true; end; 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,DynamicExtension); 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; DynamicExtension: boolean; out 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); if (NewCode=nil) and DynamicExtension then begin if CompareFileExt(ExpFilename,'.pp',true)=0 then ExpFilename:=ChangeFileExt(ExpFilename,'.pas'); NewCode:=LoadSourceCaseLoUp(ExpFilename); end; Result:=NewCode<>nil; end; procedure SetMissingIncludeFile; begin if MissingIncludeFile=nil then MissingIncludeFile:=TMissingIncludeFile.Create(AFilename,'',DynamicExtension); MissingIncludeFile.IncludePath:=IncludePath; end; begin {$IFDEF VerboseIncludeSearch} DebugLn('TLinkScanner.SearchIncludeFile Filename="',AFilename,'"'); {$ENDIF} NewCode:=nil; 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 begin // main source is 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; DynamicExtension: boolean): boolean; var NewCode: Pointer; MissingIncludeFile: TMissingIncludeFile; begin MissingIncludeFile:=nil; Result:=SearchIncludeFile(AFilename, DynamicExtension, 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); if FSkippingDirectives<>lssdNone then exit(true); Result:=InternalIfDirective; end; function TLinkScanner.IfOptDirective: boolean; // {$ifopt o+} or {$ifopt o-} var Option, c: char; begin inc(IfLevel); if FSkippingDirectives<>lssdNone then exit(true); 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, MissingIncludeFile.DynamicExtension,NewCode,MissingIncludeFile) then begin Result:=true; exit; end; end; end; procedure TLinkScanner.ClearMissingIncludeFiles; begin FreeAndNil(FMissingIncludeFiles); end; procedure TLinkScanner.AddMacroValue(MacroName: PChar; ValueStart, ValueEnd: integer); var i: LongInt; Macro: PSourceLinkMacro; begin i:=IndexOfMacro(MacroName,false); if i<0 then begin // insert new macro i:=IndexOfMacro(MacroName,true); if FMacroCount=fMacroCapacity then begin fMacroCapacity:=fMacroCapacity*2; if fMacroCapacity<4 then fMacroCapacity:=4; ReAllocMem(FMacros,SizeOf(TSourceLinkMacro)*fMacroCapacity); end; if i0 then l:=m+1 else begin Result:=m; exit; end; end; if InsertPos then begin if cmp>0 then inc(m); Result:=m; end else begin Result:=-1; end; end; procedure TLinkScanner.AddMacroSource(MacroID: integer); var Macro: PSourceLinkMacro; OldCode: Pointer; OldSrc: String; OldSrcFilename: String; begin Macro:=@FMacros[MacroID]; //DebugLn(['TLinkScanner.AddMacroSource ID=',MacroID,' ',GetIdentifier(Macro^.Name)]); // update cleaned source UpdateCleanedSource(TokenStart-1); // store old code pos OldCode:=Code; OldSrc:=Src; OldSrcFilename:=SrcFilename; //DebugLn(['TLinkScanner.AddMacroSource BEFORE CleanedSrc=',dbgstr(copy(FCleanedSrc,CleanedLen-19,20))]); // add macro source AddLink(CleanedLen+1,Macro^.StartPos,Macro^.Code); Code:=Macro^.Code; Src:=Macro^.Src; SrcLen:=length(Src); SrcFilename:=Macro^.SrcFilename; LastCleanSrcPos:=Macro^.StartPos-1; UpdateCleanedSource(Macro^.EndPos-1); //DebugLn(['TLinkScanner.AddMacroSource MACRO CleanedSrc=',dbgstr(copy(FCleanedSrc,CleanedLen-19,20))]); // restore code pos Code:=OldCode; Src:=OldSrc; SrcLen:=length(Src); SrcFilename:=OldSrcFilename; LastCleanSrcPos:=SrcPos-1; AddLink(CleanedLen+1,SrcPos,Code); // clear token type TokenType:=lsttNone; // SrcPos was not touched and still stands behind the macro name //DebugLn(['TLinkScanner.AddMacroSource END Token=',copy(Src,TokenStart,SrcPos-TokenStart)]); 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; function TLinkScanner.ParseKeyWord(StartPos, WordLen: integer; LastTokenType: TLSTokenType): boolean; var p: PChar; begin if StartPos>SrcLen then exit(false); p:=@Src[StartPos]; //writeln('TLinkScanner.ParseKeyWord ',copy(Src,StartPos,WordLen)); case UpChars[p^] of 'E': if CompareIdentifiers(p,'END')=0 then exit(DoEndToken); 'F': if CompareIdentifiers(p,'FINALIZATION')=0 then exit(DoFinalizationToken); 'I': case UpChars[p[1]] of 'M': if CompareIdentifiers(p,'IMPLEMENTATION')=0 then exit(DoImplementationToken); 'N': case UpChars[p[2]] of 'I': if CompareIdentifiers(p,'INITIALIZATION')=0 then exit(DoInitializationToken); 'T': if (LastTokenType<>lsttEqual) and (CompareIdentifiers(p,'INTERFACE')=0) then exit(DoInterfaceToken); end; end; 'L': if CompareIdentifiers(p,'LIBRARY')=0 then exit(DoSourceTypeToken); 'P': case UpChars[p[1]] of 'R': if CompareIdentifiers(p,'PROGRAM')=0 then exit(DoSourceTypeToken); 'A': if CompareIdentifiers(p,'PACKAGE')=0 then exit(DoSourceTypeToken); end; 'U': case UpChars[p[1]] of 'N': if CompareIdentifiers(p,'UNIT')=0 then exit(DoSourceTypeToken); 'S': if CompareIdentifiers(p,'USES')=0 then exit(DoUsesToken); end; end; Result:=false; end; function TLinkScanner.DoEndToken: boolean; begin TokenType:=lsttEnd; Result:=true; end; function TLinkScanner.DoSourceTypeToken: boolean; // program, unit, library, package // unit unit1; // unit unit1 platform; // unit unit1 unimplemented; begin if ScannedRange<>lsrInit then exit(false); Result:=true; ScannedRange:=lsrSourceType; if ScannedRange=ScanTill then exit; ReadNextToken; ScannedRange:=lsrSourceName; if ScannedRange=ScanTill then exit; ReadNextToken; if IsUsesToken then Result:=DoUsesToken; end; function TLinkScanner.DoInterfaceToken: boolean; begin if ord(ScannedRange)>=ord(lsrInterfaceStart) then exit(false); ScannedRange:=lsrInterfaceStart; Result:=true; end; function TLinkScanner.DoFinalizationToken: boolean; begin if ord(ScannedRange)>=ord(lsrFinalizationStart) then exit(false); ScannedRange:=lsrFinalizationStart; Result:=true; end; function TLinkScanner.DoInitializationToken: boolean; begin if ord(ScannedRange)>=ord(lsrInitializationStart) then exit(false); ScannedRange:=lsrInitializationStart; Result:=true; end; function TLinkScanner.DoUsesToken: boolean; // uses name, name in 'string'; begin if ord(ScannedRange)<=ord(lsrInterfaceStart) then ScannedRange:=lsrMainUsesSectionStart else if ScannedRange=lsrImplementationStart then ScannedRange:=lsrImplementationUsesSectionStart else exit(false); repeat // read unit name ReadNextToken; if (TokenType<>lsttWord) or WordIsKeyWord.DoItCaseInsensitive(@Src[SrcPos]) then exit(false); ReadNextToken; if TokenIs('in') then begin // read "in" filename ReadNextToken; if TokenType=lsttStringConstant then ReadNextToken; end; if TokenType=lsttSemicolon then break; if TokenType<>lsttComma then begin // syntax error -> this token does not belong to the uses section SrcPos:=TokenStart; break; end; until false; ScannedRange:=succ(ScannedRange); // lsrMainUsesSectionEnd, lsrImplementationUsesSectionEnd; Result:=true; end; function TLinkScanner.IsUsesToken: boolean; begin Result:=(TokenType=lsttWord) and (CompareIdentifiers(@Src[SrcPos],'USES')=0); end; function TLinkScanner.TokenIsWord(p: PChar): boolean; begin Result:=(TokenType=lsttWord) and (CompareIdentifiers(p,@Src[SrcPos])=0); end; function TLinkScanner.DoImplementationToken: boolean; begin if ord(ScannedRange)>=ord(lsrImplementationStart) then exit(false); ScannedRange:=lsrImplementationStart; 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 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); // 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 begin CommentStartPos:=0; break; end; end; end; end; if CommentStartPos>0 then begin LastCleanSrcPos:=CommentStartPos-1; AddLink(CleanedLen+1,CommentStartPos,Code); end else begin LastCleanSrcPos:=SrcLen+1; end; {$IFDEF ShowUpdateCleanedSrc} DebugLn('TLinkScanner.SkipTillEndifElse B Continuing after: ', ' Src=',DbgStr(copy(Src,CommentStartPos-15,15))+'|'+DbgStr(copy(Src,CommentStartPos,15))); {$ENDIF} 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]); FCompilerModeSwitch:=cmsDefault; end; procedure TLinkScanner.SetCompilerModeSwitch(const AValue: TCompilerModeSwitch ); begin if FCompilerModeSwitch=AValue then exit; FCompilerModeSwitch:=AValue; end; function TLinkScanner.InternalIfDirective: boolean; // {$if expression} or {$ifc expression} or indirectly called by {$elifc expression} var ExprResult: Boolean; begin //DebugLn(['TLinkScanner.InternalIfDirective FSkippingDirectives=',ord(FSkippingDirectives),' IfLevel=',IfLevel]); inc(SrcPos); ExprResult:=Values.EvalBoolean(@Src[SrcPos],CommentInnerEndPos-SrcPos); Result:=true; //DebugLn(['TLinkScanner.InternalIfDirective ExprResult=',ExprResult]); if Values.ErrorPosition>=0 then begin inc(SrcPos,Values.ErrorPosition); RaiseException(Values.ErrorMsg) end else if ExprResult then FSkippingDirectives:=lssdNone else SkipTillEndifElse(lssdTillElse); 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,FMainCode) 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; aDynamicExtension: boolean); begin inherited Create; Filename:=AFilename; IncludePath:=AIncludePath; DynamicExtension:=aDynamicExtension; end; function TMissingIncludeFile.CalcMemSize: PtrUInt; begin Result:=PtrUInt(InstanceSize) +MemSizeString(IncludePath) +MemSizeString(Filename); 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; function TMissingIncludeFiles.CalcMemSize: PtrUInt; var i: Integer; begin Result:=PtrUInt(InstanceSize) +SizeOf(Pointer)*PtrUInt(Capacity); for i:=0 to Count-1 do inc(Result,Items[i].CalcMemSize); 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.