Why Gemfury?
Push, build, and install
RubyGems
npm packages
Python packages
Maven artifacts
PHP packages
Go Modules
Debian packages
RPM packages
NuGet packages
beefree / lazarus-project deb
Repository URL to install this package:
|
Version:
2.0.10 ▾
|
{
***************************************************************************
* *
* 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 <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
* *
***************************************************************************
Author: Mattias Gaertner
Abstract:
Functions to parse and edit compiler directives.
}
unit DirectivesTree;
{$ifdef FPC}{$mode objfpc}{$endif}{$H+}
{ $DEFINE VerboseDisableUnreachableIFDEFs}
interface
{$I codetools.inc}
uses
{$IFDEF MEM_CHECK}
MemCheck,
{$ENDIF}
Classes, SysUtils, Laz_AVL_Tree,
// Codetools
FileProcs, BasicCodeTools, KeywordFuncLists, CodeCache, ExprEval, CodeTree;
type
TCompilerDirectiveNodeDesc = word;
const
// descriptors
cdnBase = 1000;
cdnNone = 0+cdnBase;
cdnRoot = 1+cdnBase;
cdnDefine = 11+cdnBase;
cdnInclude = 12+cdnBase;
cdnIf = 21+cdnBase;
cdnElseIf = 22+cdnBase;
cdnElse = 23+cdnBase;
cdnEnd = 24+cdnBase;
// sub descriptors
cdnsBase = 10000;
cdnsNone = 0+cdnsBase;
cdnsIfdef = 1+cdnsBase;
cdnsIfC = 2+cdnsBase;
cdnsIfndef = 3+cdnsBase;
cdnsIf = 4+cdnsBase;
cdnsIfOpt = 5+cdnsBase;
cdnsEndif = 11+cdnsBase;
cdnsEndC = 12+cdnsBase;
cdnsIfEnd = 13+cdnsBase;
cdnsElse = 21+cdnsBase;
cdnsElseC = 22+cdnsBase;
cdnsElseIf = 23+cdnsBase;
cdnsElIfC = 24+cdnsBase;
cdnsDefine = 31+cdnsBase;
cdnsUndef = 32+cdnsBase;
cdnsSetC = 33+cdnsBase;
cdnsInclude = 41+cdnsBase;
cdnsIncludePath = 42+cdnsBase;
cdnsShortSwitch = 51+cdnsBase;
cdnsLongSwitch = 52+cdnsBase;
cdnsMode = 53+cdnsBase;
cdnsThreading = 54+cdnsBase;
cdnsOther = 55+cdnsBase;
const
H2Pas_Function_Prefix = 'H2PAS_FUNCTION_';
type
TCompilerDirectivesTree = class;
{ ECDirectiveParserException }
ECDirectiveParserException = class(Exception)
public
Sender: TCompilerDirectivesTree;
Id: int64;
constructor Create(ASender: TCompilerDirectivesTree; TheId: int64; const AMessage: string);
end;
TCompilerMacroStatus = (
cmsUnknown, // never seen
cmsDefined, // set to a specific value e.g. by $Define or by $IfDef
cmsUndefined, // undefined e.g. by $Undef
cmsComplex // value depends on complex expressions. e.g. {$if A or B}.
);
TCompilerMacroStats = class
public
Name: string;
Value: string;
Status: TCompilerMacroStatus;
LastDefineNode: TCodeTreeNode;// define or undef node
LastReadNode: TCodeTreeNode;// if node
end;
{ TH2PasFunction }
TH2PasFunction = class
public
Name: string;
HeaderStart: integer;
HeaderEnd: integer;
BeginStart: integer;
BeginEnd: integer;
IsForward: boolean;
IsExternal: boolean;
InInterface: boolean;
DefNode: TH2PasFunction;// the corresponding node
function NeedsBody: boolean;
procedure AdjustPositionsAfterInsert(FromPos, ToPos, DiffPos: integer);
end;
{ TCompilerDirectivesTree }
TCompilerDirectivesTree = class
private
FChangeStep: integer;
FDefaultDirectiveFuncList: TKeyWordFunctionList;
FDisableUnusedDefines: boolean;
FNestedComments: boolean;
FParseChangeStep: integer;
FRemoveDisabledDirectives: boolean;
FSimplifyExpressions: boolean;
FUndefH2PasFunctions: boolean;
FLastErrorMsg: string;
fLastErrorPos: integer;
fLastErrorXY: TPoint;
fLastErrorId: int64;
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;
procedure SetNestedComments(AValue: 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;
function OtherDirective: boolean;
procedure InitKeyWordList;
procedure InitParser;
procedure CreateChildNode(Desc: TCompilerDirectiveNodeDesc;
SubDesc: TCompilerDirectiveNodeDesc = cdnNone);
procedure EndChildNode;
procedure EndIFNode(const ErrorMsg: string);
procedure InternalRemoveNode(Node: TCodeTreeNode);
procedure RaiseException(id: int64; const ErrorMsg: string);
procedure RaiseLastError;
public
Code: TCodeBuffer;
Src: string;
SrcLen: integer;
Tree: TCodeTree;
CurNode: TCodeTreeNode;
SrcPos: Integer;
AtomStart: integer;
Macros: TAVLTree;// tree of TCompilerMacroStats
constructor Create;
destructor Destroy; override;
procedure Clear;
// parsing
procedure Parse;
procedure Parse(aCode: TCodeBuffer; aNestedComments: boolean);
property NestedComments: boolean read FNestedComments write SetNestedComments;
property ParseChangeStep: integer read FParseChangeStep;
function UpdateNeeded: boolean;
procedure MoveCursorToPos(p: integer);
procedure ReadNextAtom;
function ReadTilBracketClose(CloseBracket: char): boolean;
function AtomIs(const s: shortstring): boolean;
function UpAtomIs(const s: shortstring): boolean;
function AtomIsIdentifier: boolean;
function GetAtom: string;
// errors
property ErrorMsg: string read FLastErrorMsg;
property ErrorPos: integer read fLastErrorPos;
property ErrorLine: integer read fLastErrorXY.Y;
property ErrorColumn: integer read fLastErrorXY.X;
property ErrorId: int64 read fLastErrorId;
function SrcPosToStr(p: integer; WithFilename: boolean = false): string;
// search
function FindResourceDirective(const Filename: string = '';
StartPos: integer = 1): TCodeTreeNode;
function IsResourceDirective(Node: TCodeTreeNode;
const Filename: string = ''): boolean;
function FindIncludeDirective(const Filename: string = '';
StartPos: integer = 1): TCodeTreeNode;
function IsIncludeDirective(Node: TCodeTreeNode;
const Filename: string = ''): boolean;
// explore
function GetDirectiveName(Node: TCodeTreeNode): string;
function GetDirective(Node: TCodeTreeNode): string;
function GetIfExpression(Node: TCodeTreeNode;
out ExprStart, ExprEnd: integer): boolean;
function GetIfExpressionString(Node: TCodeTreeNode): string;
function IsIfExpressionSimple(Node: TCodeTreeNode; out NameStart: integer
): boolean;
function FindNameInIfExpression(Node: TCodeTreeNode; Identifier: PChar
): integer;
function GetDefineNameAndValue(DefineNode: TCodeTreeNode;
out NameStart: integer; out HasValue: boolean; out ValueStart: integer
): boolean;
function DefineUsesName(DefineNode: TCodeTreeNode;
Identifier: PChar): boolean;
function NodeIsEmpty(Node: TCodeTreeNode; IgnoreComments: boolean = true): boolean;
function FindNodeAtPos(p: integer): TCodeTreeNode;
function NodeStartToCodePos(Node: TCodeTreeNode;
out CodePos: TCodeXYPosition): boolean;
// refactoring
procedure ReduceCompilerDirectives(Undefines, Defines: TStrings;
var Changed: boolean);
procedure GatherH2PasFunctions(out ListOfH2PasFunctions: TFPList;
FindDefNodes: boolean);
procedure FixMissingH2PasDirectives(var Changed: boolean);
procedure CheckAndImproveExpr_Brackets(Node: TCodeTreeNode;
var Changed: boolean);
procedure CheckAndImproveExpr_IfDefinedMacro(Node: TCodeTreeNode;
var Changed: boolean);
procedure DisableAllUnusedDefines(var Changed: boolean);
procedure MoveIfNotThenDefsUp(var Changed: boolean);
procedure DisableUnreachableBlocks(Undefines, Defines: TStrings;
var Changed: boolean);
procedure DisableNode(Node: TCodeTreeNode; var Changed: boolean;
WithContent: boolean);
procedure DisableDefineNode(Node: TCodeTreeNode; var Changed: boolean);
procedure DisableIfNode(Node: TCodeTreeNode; WithContent: boolean;
var Changed: boolean);
function InsertDefine(Position: integer; const NewSrc: string;
SubDesc: TCompilerDirectiveNodeDesc): TCodeTreeNode;
procedure RemoveEmptyNodes(var Changed: boolean);
procedure Replace(FromPos, ToPos: integer; const NewSrc: string);
procedure IncreaseChangeStep;
procedure ResetMacros;
procedure ClearMacros;
procedure WriteDebugReport;
public
property SimplifyExpressions: boolean read FSimplifyExpressions
write FSimplifyExpressions;
property DisableUnusedDefines: boolean read FDisableUnusedDefines
write FDisableUnusedDefines;
property RemoveDisabledDirectives: boolean read FRemoveDisabledDirectives
write FRemoveDisabledDirectives;
property UndefH2PasFunctions: boolean read FUndefH2PasFunctions
write FUndefH2PasFunctions;
property ChangeStep: integer read FChangeStep;
end;
function CompareCompilerMacroStats(Data1, Data2: Pointer): integer;
function ComparePCharWithCompilerMacroStats(Name, MacroStats: Pointer): integer;
function CompareH2PasFuncByNameAndPos(Data1, Data2: Pointer): integer;
function ComparePCharWithH2PasFuncName(Name, H2PasFunc: Pointer): integer;
function CDNodeDescAsString(Desc: TCompilerDirectiveNodeDesc): string;
function CDNodeSubDescAsString(Desc: TCompilerDirectiveNodeDesc): string;
implementation
type
TDefineStatus = (
dsUnknown,
dsDefined,
dsNotDefined
);
TDefineValue = class
Name: string;
Status: TDefineStatus;
Value: string;
end;
{$IFDEF VerboseDisableUnreachableIFDEFs}
const
DefineStatusNames: array[TDefineStatus] of string = (
'dsUnknown','dsDefined','dsNotDefined'
);
{$ENDIF}
function CompareDefineValues(Data1, Data2: Pointer): integer;
begin
Result:=CompareIdentifierPtrs(Pointer(TDefineValue(Data1).Name),
Pointer(TDefineValue(Data2).Name));
end;
function ComparePCharWithDefineValue(Name, DefValue: Pointer): integer;
begin
Result:=CompareIdentifierPtrs(Name,
Pointer(TDefineValue(DefValue).Name));
end;
function CompareCompilerMacroStats(Data1, Data2: Pointer): integer;
begin
Result:=CompareIdentifierPtrs(Pointer(TCompilerMacroStats(Data1).Name),
Pointer(TCompilerMacroStats(Data2).Name));
end;
function ComparePCharWithCompilerMacroStats(Name, MacroStats: Pointer): integer;
begin
Result:=CompareIdentifierPtrs(Name,
Pointer(TCompilerMacroStats(MacroStats).Name));
end;
function CompareH2PasFuncByNameAndPos(Data1, Data2: Pointer): integer;
var
F1: TH2PasFunction;
F2: TH2PasFunction;
begin
F1:=TH2PasFunction(Data1);
F2:=TH2PasFunction(Data2);
Result:=CompareIdentifierPtrs(Pointer(F1.Name),Pointer(F2.Name));
if Result<>0 then exit;
if F1.HeaderStart>F2.HeaderStart then
exit(1)
else if F1.HeaderStart<F2.HeaderStart then
exit(-1)
else
exit(0);
end;
function ComparePCharWithH2PasFuncName(Name, H2PasFunc: Pointer): integer;
begin
Result:=CompareIdentifierPtrs(Name,Pointer(TH2PasFunction(H2PasFunc).Name));
end;
function CDNodeDescAsString(Desc: TCompilerDirectiveNodeDesc): string;
begin
case Desc of
cdnNone : Result:='None';
cdnRoot : Result:='Root';
cdnDefine : Result:='Define';
cdnIf : Result:='If';
cdnElseIf : Result:='ElseIf';
cdnElse : Result:='Else';
cdnEnd : Result:='End';
else Result:='?';
end;
end;
function CDNodeSubDescAsString(Desc: TCompilerDirectiveNodeDesc): string;
begin
case Desc of
cdnsIfdef : Result:='IfDef';
cdnsIfC : Result:='IfC';
cdnsIfndef : Result:='IfNDef';
cdnsIf : Result:='If';
cdnsIfOpt : Result:='IfOpt';
cdnsEndif : Result:='EndIf';
cdnsEndC : Result:='EndC';
cdnsIfEnd : Result:='IfEnd';
cdnsElse : Result:='Else';
cdnsElseC : Result:='ElseC';
cdnsElseIf : Result:='ElseIf';
cdnsElIfC : Result:='ElIfC';
cdnsDefine : Result:='Define';
cdnsUndef : Result:='UnDef';
cdnsSetC : Result:='SetC';
cdnsInclude : Result:='Include';
cdnsIncludePath : Result:='IncludePath';
cdnsShortSwitch : Result:='ShortSwitch';
cdnsLongSwitch : Result:='LongSwitch';
cdnsMode : Result:='Mode';
cdnsThreading : Result:='Threading';
cdnsOther : Result:='Other';
else Result:='?';
end;
end;
{ TCompilerDirectivesTree }
function TCompilerDirectivesTree.IfdefDirective: boolean;
// example: {$IFDEF macroname}
begin
Result:=true;
CreateChildNode(cdnIf,cdnsIfdef);
end;
function TCompilerDirectivesTree.IfCDirective: boolean;
// example: {$IFC expression}
begin
Result:=true;
CreateChildNode(cdnIf,cdnsIfC);
end;
function TCompilerDirectivesTree.IfndefDirective: boolean;
// example: {$IFNDEF macroname}
begin
Result:=true;
CreateChildNode(cdnIf,cdnsIfndef);
end;
function TCompilerDirectivesTree.IfDirective: boolean;
// example: {$IF expression}
begin
Result:=true;
CreateChildNode(cdnIf,cdnsIf);
end;
function TCompilerDirectivesTree.IfOptDirective: boolean;
// {$ifopt o+} or {$ifopt o-}
begin
Result:=true;
CreateChildNode(cdnIf,cdnsIfOpt);
end;
function TCompilerDirectivesTree.EndifDirective: boolean;
// example: {$ENDIF comment}
begin
Result:=true;
EndIFNode('EndIf without IfDef');
CreateChildNode(cdnEnd,cdnsEndif);
AtomStart:=SrcPos;
EndChildNode;
end;
function TCompilerDirectivesTree.EndCDirective: boolean;
// example: {$ENDC comment}
begin
Result:=true;
EndIFNode('EndC without IfC');
CreateChildNode(cdnEnd,cdnsEndC);
AtomStart:=SrcPos;
EndChildNode;
end;
function TCompilerDirectivesTree.IfEndDirective: boolean;
// {$IfEnd comment}
begin
Result:=true;
EndIFNode('IfEnd without IfDef');
CreateChildNode(cdnEnd,cdnsIfEnd);
AtomStart:=SrcPos;
EndChildNode;
end;
function TCompilerDirectivesTree.ElseDirective: boolean;
// {$Else comment}
begin
Result:=true;
EndIFNode('Else without IfDef');
CreateChildNode(cdnElse,cdnsElse);
end;
function TCompilerDirectivesTree.ElseCDirective: boolean;
// {$elsec comment}
begin
Result:=true;
EndIFNode('ElseC without IfC');
CreateChildNode(cdnElse,cdnsElseC);
end;
function TCompilerDirectivesTree.ElseIfDirective: boolean;
// {$elseif expression}
begin
Result:=true;
EndIFNode('ElseIf without IfDef');
CreateChildNode(cdnElseIf,cdnsElseIf);
end;
function TCompilerDirectivesTree.ElIfCDirective: boolean;
// {$elifc expression}
begin
Result:=true;
EndIFNode('ElIfC without IfC');
CreateChildNode(cdnElseIf,cdnsElIfC);
end;
function TCompilerDirectivesTree.DefineDirective: boolean;
// {$define name} or {$define name:=value}
begin
Result:=true;
CreateChildNode(cdnDefine,cdnsDefine);
AtomStart:=SrcPos;
EndChildNode;
end;
procedure TCompilerDirectivesTree.SetNestedComments(AValue: boolean);
begin
if FNestedComments=AValue then Exit;
FNestedComments:=AValue;
FParseChangeStep:=CTInvalidChangeStamp;
IncreaseChangeStep;
end;
function TCompilerDirectivesTree.UndefDirective: boolean;
// {$undefine macroname}
begin
Result:=true;
CreateChildNode(cdnDefine,cdnsUndef);
AtomStart:=SrcPos;
EndChildNode;
end;
function TCompilerDirectivesTree.SetCDirective: boolean;
// {$setc macroname} or {$setc macroname:=value}
begin
Result:=true;
CreateChildNode(cdnDefine,cdnsSetC);
AtomStart:=SrcPos;
EndChildNode;
end;
function TCompilerDirectivesTree.IncludeDirective: boolean;
begin
Result:=true;
CreateChildNode(cdnInclude,cdnsInclude);
AtomStart:=SrcPos;
EndChildNode;
end;
function TCompilerDirectivesTree.IncludePathDirective: boolean;
// {$includepath path_addition}
begin
Result:=true;
end;
function TCompilerDirectivesTree.ShortSwitchDirective: boolean;
// example: {$H+} or {$H+, R- comment}
begin
Result:=true;
if Src[AtomStart+3] in ['+','-'] then
CreateChildNode(cdnDefine,cdnsShortSwitch)
else begin
if (Src[AtomStart+2] in ['I','i']) then
CreateChildNode(cdnInclude,cdnsInclude)
else
CreateChildNode(cdnDefine,cdnsOther);
end;
AtomStart:=SrcPos;
EndChildNode;
end;
function TCompilerDirectivesTree.ReadNextSwitchDirective: boolean;
begin
Result:=true;
end;
function TCompilerDirectivesTree.LongSwitchDirective: boolean;
// example: {$ASSERTIONS ON comment}
begin
Result:=true;
CreateChildNode(cdnDefine,cdnsLongSwitch);
AtomStart:=SrcPos;
EndChildNode;
end;
function TCompilerDirectivesTree.ModeDirective: boolean;
// example: {$MODE ObjFPC comment}
begin
Result:=true;
CreateChildNode(cdnDefine,cdnsMode);
AtomStart:=SrcPos;
EndChildNode;
end;
function TCompilerDirectivesTree.ThreadingDirective: boolean;
// example: {$threading on}
begin
Result:=true;
CreateChildNode(cdnDefine,cdnsThreading);
AtomStart:=SrcPos;
EndChildNode;
end;
function TCompilerDirectivesTree.OtherDirective: boolean;
begin
Result:=true;
CreateChildNode(cdnDefine,cdnsOther);
AtomStart:=SrcPos;
EndChildNode;
end;
procedure TCompilerDirectivesTree.InitKeyWordList;
var
c: Char;
begin
if FDefaultDirectiveFuncList=nil then begin
FDefaultDirectiveFuncList:=TKeyWordFunctionList.Create('TCompilerDirectivesTree.DefaultDirectiveFuncList');
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);
DefaultKeyWordFunction:={$ifdef FPC}@{$endif}OtherDirective;
end;
end;
end;
procedure TCompilerDirectivesTree.InitParser;
begin
FParseChangeStep:=Code.ChangeStep;
IncreaseChangeStep;
InitKeyWordList;
Src:=Code.Source;
SrcLen:=length(Src);
if Tree=nil then
Tree:=TCodeTree.Create
else
Tree.Clear;
SrcPos:=1;
AtomStart:=1;
CurNode:=nil;
CreateChildNode(cdnRoot);
end;
procedure TCompilerDirectivesTree.CreateChildNode(
Desc: TCompilerDirectiveNodeDesc;
SubDesc: TCompilerDirectiveNodeDesc);
var NewNode: TCodeTreeNode;
begin
NewNode:=TCodeTreeNode.Create;
Tree.AddNodeAsLastChild(CurNode,NewNode);
NewNode.Desc:=Desc;
NewNode.SubDesc:=SubDesc;
CurNode:=NewNode;
CurNode.StartPos:=AtomStart;
//DebugLn([GetIndentStr(CurNode.GetLevel*2),'TCompilerDirectivesTree.CreateChildNode ']);
end;
procedure TCompilerDirectivesTree.EndChildNode;
begin
//DebugLn([GetIndentStr(CurNode.GetLevel*2),'TCompilerDirectivesTree.EndChildNode ']);
CurNode.EndPos:=AtomStart;
CurNode:=CurNode.Parent;
end;
procedure TCompilerDirectivesTree.EndIFNode(const ErrorMsg: string);
begin
if (CurNode.Desc<>cdnIf) and (CurNode.Desc<>cdnElse)
and (CurNode.Desc<>cdnElseIf) then
RaiseException(20170422131836,ErrorMsg);
EndChildNode;
end;
procedure TCompilerDirectivesTree.CheckAndImproveExpr_Brackets(
Node: TCodeTreeNode; var Changed: boolean);
// improve (MacroName) to MacroName
var
ExprStart: integer;
ExprEnd: integer;
NameStart: LongInt;
FromPos: LongInt;
ToPos: LongInt;
begin
if not SimplifyExpressions then exit;
if (Node.SubDesc<>cdnsIf) and (Node.SubDesc<>cdnElseIf) then exit;
if not GetIfExpression(Node,ExprStart,ExprEnd) then exit;
// improve (MacroName) to MacroName
MoveCursorToPos(ExprStart);
repeat
ReadNextAtom;
if UpAtomIs('DEFINED') then begin
// the function defined(): skip keyword and bracket
ReadNextAtom;
ReadNextAtom;
end;
if AtomIs('(') then begin
FromPos:=AtomStart;
ReadNextAtom;
if AtomIsIdentifier then begin
NameStart:=AtomStart;
ReadNextAtom;
if AtomIs(')') then begin
ToPos:=SrcPos;
DebugLn(['TCompilerDirectivesTree.CheckAndImproveExpr_Brackets removing unneeded brackets']);
Changed:=true;
Replace(FromPos,ToPos,GetIdentifier(@Src[NameStart]));
MoveCursorToPos(FromPos);
end;
end;
end;
until SrcPos>=ExprEnd;
end;
procedure TCompilerDirectivesTree.CheckAndImproveExpr_IfDefinedMacro(
Node: TCodeTreeNode; var Changed: boolean);
// check if {$IF defined(MacroName)}
// or {$IF !defined(MacroName)}
// or {$IF not defined(MacroName)}
// or {$IF not (defined(MacroName))}
var
ExprStart: integer;
ExprEnd: integer;
MacroNameStart: LongInt;
Negated: Boolean;
NewDirective: String;
BracketLvl: Integer;
begin
if not SimplifyExpressions then exit;
if (Node.SubDesc<>cdnsIf) then exit;
if not GetIfExpression(Node,ExprStart,ExprEnd) then exit;
Negated:=false;
MoveCursorToPos(ExprStart);
ReadNextAtom;
if UpAtomIs('NOT') or AtomIs('!') then begin
Negated:=true;
ReadNextAtom;
end;
BracketLvl:=0;
while AtomIs('(') do begin
inc(BracketLvl);
ReadNextAtom;
end;
if not UpAtomIs('DEFINED') then exit;
ReadNextAtom;
if not AtomIs('(') then exit;
inc(BracketLvl);
ReadNextAtom;
if not AtomIsIdentifier then exit;
MacroNameStart:=AtomStart;
ReadNextAtom;
while AtomIs(')') do begin
dec(BracketLvl);
ReadNextAtom;
end;
if BracketLvl>0 then exit;
if SrcPos<=ExprEnd then exit;
if Negated then
NewDirective:='IFNDEF'
else
NewDirective:='IFDEF';
NewDirective:='{$'+NewDirective+' '+GetIdentifier(@Src[MacroNameStart])+'}';
DebugLn(['TCompilerDirectivesTree.CheckAndImproveExpr_IfDefinedMacro simplifying expression']);
Replace(Node.StartPos,FindCommentEnd(Src,Node.StartPos,NestedComments),NewDirective);
if Negated then
Node.SubDesc:=cdnsIfNdef
else
Node.SubDesc:=cdnsIfdef;
Changed:=true;
end;
procedure TCompilerDirectivesTree.DisableAllUnusedDefines(var Changed: boolean);
var
AVLNode: TAVLTreeNode;
MacroNode: TCompilerMacroStats;
NextAVLNode: TAVLTreeNode;
begin
if Macros=nil then exit;
if not DisableUnusedDefines then exit;
AVLNode:=Macros.FindLowest;
while AVLNode<>nil do begin
NextAVLNode:=Macros.FindSuccessor(AVLNode);
MacroNode:=TCompilerMacroStats(AVLNode.Data);
if (MacroNode.LastDefineNode<>nil)
and (MacroNode.LastReadNode=nil) then begin
// this Define/Undef is not used
DebugLn(['TCompilerDirectivesTree.DisableAllUnusedDefines']);
DisableDefineNode(MacroNode.LastDefineNode,Changed);
end;
AVLNode:=NextAVLNode;
end;
end;
procedure TCompilerDirectivesTree.MoveIfNotThenDefsUp(var Changed: boolean);
(* 1. Search for
{$IFNDEF Name}
{$DEFINE Name}
.. name is not used here ..
{$ENDIF}
And move the define behind the IF block
2. And check for
{$IFDEF Name}
.. name is not set here ..
{$DEFINE Name}
{$ENDIF}
And remove the define
*)
function IdentifierIsReadAfterNode(Identifier: PChar;
StartNode: TCodeTreeNode): boolean;
var
Node: TCodeTreeNode;
ParentNode: TCodeTreeNode;
begin
Node:=StartNode;
while Node<>nil do begin
case Node.Desc of
cdnIf,cdnElseIf:
if FindNameInIfExpression(Node,Identifier)>0 then begin
exit(true);
end;
cdnDefine:
if DefineUsesName(Node,Identifier) then begin
ParentNode:=StartNode;
while (ParentNode<>nil) do begin
if ParentNode=Node.Parent then exit(false);
ParentNode:=ParentNode.Parent;
end;
end;
end;
Node:=Node.Next;
end;
Result:=false;
end;
var
Node: TCodeTreeNode;
NextNode: TCodeTreeNode;
SubNode: TCodeTreeNode;
NameStart: integer;
LastDefineNode: TCodeTreeNode;
LastIFNode: TCodeTreeNode;
NextSubNode: TCodeTreeNode;
EndNode: TCodeTreeNode;
InsertPos: LongInt;
NewSrc: String;
LastChildDefineNode: TCodeTreeNode;
begin
Node:=Tree.Root;
while Node<>nil do begin
NextNode:=Node.Next;
if ((Node.Desc=cdnIf) or (Node.Desc=cdnElseIf))
and IsIfExpressionSimple(Node,NameStart) then begin
// an IF with a single test
LastIFNode:=nil;
LastDefineNode:=nil;
LastChildDefineNode:=nil;
SubNode:=Node.FirstChild;
while (SubNode<>nil) and (SubNode.HasAsParent(Node)) do begin
NextSubNode:=SubNode.Next;
case SubNode.Desc of
cdnIf, cdnElseIf:
if FindNameInIfExpression(SubNode,@Src[NameStart])>0 then begin
// this sub IF block uses the macro
LastIFNode:=SubNode;
end;
cdnDefine:
if ((SubNode.SubDesc=cdnsDefine) or (SubNode.SubDesc=cdnsUndef))
and DefineUsesName(SubNode,@Src[NameStart]) then begin
// this sub Define/Undef sets the macro
if (LastIFNode=nil) and (LastDefineNode=nil) then begin
(* This is
{$IF(N)DEF Name}
... Name not used ...
{$DEFINE|UNDEF Name}
*)
if (Node.SubDesc=cdnsIfndef) = (SubNode.SubDesc=cdnsUndef) then
begin
{ this is
IFNDEF then UNDEF
or IFDEF then DEFINE
-> remove define
}
NextSubNode:=SubNode.NextSkipChilds;
DebugLn(['TCompilerDirectivesTree.MoveIfNotThenDefsUp IFDEF + DEFINE => the define is not needed']);
if NextNode=SubNode then
NextNode:=NextNode.NextSkipChilds;
DisableDefineNode(SubNode,Changed);
SubNode:=nil;
end;
end;
if SubNode<>nil then begin
LastDefineNode:=SubNode;
LastIFNode:=nil;
if SubNode.Parent=Node then begin
// this define is valid for end of the IF block
LastChildDefineNode:=SubNode;
end else if (LastChildDefineNode<>nil)
and (LastChildDefineNode.SubDesc<>SubNode.SubDesc) then begin
// this sub define can cancel the higher level define
LastChildDefineNode:=nil;
end;
end;
end;
end;
SubNode:=NextSubNode;
end;
if (LastChildDefineNode<>nil) then begin
(* this is
{$IFNDEF Name}
...
{$DEFINE Name}
... Name only read ...
{$ENDIF}
or IFDEF and UNDEF
-> move define behind IF block
*)
EndNode:=Node;
while (EndNode<>nil) and (EndNode.Desc<>cdnEnd) do
EndNode:=EndNode.NextBrother;
if (EndNode<>nil)
and IdentifierIsReadAfterNode(@Src[NameStart],EndNode) then begin
InsertPos:=FindLineEndOrCodeAfterPosition(Src,EndNode.EndPos,SrcLen,
NestedComments);
NewSrc:=LineEnding+GetDirective(LastDefineNode);
DebugLn(['TCompilerDirectivesTree.MoveIfNotThenDefsUp IFNDEF + DEFINE => add define after block']);
InsertDefine(InsertPos,NewSrc,LastDefineNode.SubDesc);
if (LastDefineNode=LastChildDefineNode)
and (LastIFNode=nil) then begin
// the name was not read after it was set -> disable the define
// in the block
DebugLn(['TCompilerDirectivesTree.MoveIfNotThenDefsUp old DEFINE is not needed anymore']);
if NextNode=LastDefineNode then
NextNode:=NextNode.NextSkipChilds;
DisableDefineNode(LastDefineNode,Changed);
end;
end;
end;
end;
Node:=NextNode;
end;
end;
procedure TCompilerDirectivesTree.DisableUnreachableBlocks(Undefines,
Defines: TStrings; var Changed: boolean);
type
PDefineChange = ^TDefineChange;
TDefineChange = record
Name: string;
OldStatus: TDefineStatus;
Next: PDefineChange;
end;
var
CurDefines: TAVLTree;
Stack: array of PDefineChange;// stack of lists of PDefineChange
StackPointer: integer;
procedure InitStack;
begin
SetLength(Stack,1);
StackPointer:=0;
Stack[0]:=nil;
end;
procedure FreeStack;
var
i: Integer;
Item: PDefineChange;
DeleteItem: PDefineChange;
begin
for i:=0 to StackPointer do begin
Item:=Stack[i];
while Item<>nil do begin
DeleteItem:=Item;
Item:=DeleteItem^.Next;
Dispose(DeleteItem);
end;
end;
Setlength(Stack,0);
end;
procedure AddStackChange(const MacroName: string; OldStatus: TDefineStatus);
var
Change: PDefineChange;
begin
{$IFDEF VerboseDisableUnreachableIFDEFs}
DebugLn(['AddStackChange ',MacroName,' ',DefineStatusNames[OldStatus]]);
{$ENDIF}
// check if MacroName was already changed
Change:=Stack[StackPointer];
while (Change<>nil) do begin
if (CompareIdentifierPtrs(Pointer(MacroName),Pointer(Change^.Name))=0)
then begin
// old status is already saved
exit;
end;
Change:=Change^.Next;
end;
{$IFDEF VerboseDisableUnreachableIFDEFs}
DebugLn(['AddStackChange ADD ',MacroName,' ',DefineStatusNames[OldStatus]]);
{$ENDIF}
New(Change);
FillChar(Change^,SizeOf(TDefineChange),0);
Change^.Name:=MacroName;
Change^.OldStatus:=OldStatus;
Change^.Next:=Stack[StackPointer];
Stack[StackPointer]:=Change;
end;
function GetStatus(Identifier: PChar): TDefineStatus;
var
AVLNode: TAVLTreeNode;
begin
AVLNode:=CurDefines.FindKey(Identifier,@ComparePCharWithDefineValue);
if AVLNode<>nil then
Result:=TDefineValue(AVLNode.Data).Status
else
Result:=dsUnknown;
end;
procedure SetStatus(Identifier: PChar; NewStatus: TDefineStatus;
SaveOnStack, SetGlobal: boolean);
var
AVLNode: TAVLTreeNode;
DefValue: TDefineValue;
i: Integer;
Change: PDefineChange;
begin
{$IFDEF VerboseDisableUnreachableIFDEFs}
DebugLn(['SetStatus ',GetIdentifier(Identifier),' Old=',DefineStatusNames[GetStatus(Identifier)],' New=',DefineStatusNames[NewStatus],' SaveOnStack=',SaveOnStack,' SetGlobal=',SetGlobal]);
{$ENDIF}
AVLNode:=CurDefines.FindKey(Identifier,@ComparePCharWithDefineValue);
if AVLNode=nil then begin
if NewStatus<>dsUnknown then begin
DefValue:=TDefineValue.Create;
DefValue.Name:=GetIdentifier(Identifier);
DefValue.Status:=NewStatus;
CurDefines.Add(DefValue);
if SaveOnStack then
AddStackChange(DefValue.Name,dsUnknown);
end else begin
// no change
end;
end else begin
DefValue:=TDefineValue(AVLNode.Data);
if NewStatus<>dsUnknown then begin
if NewStatus<>DefValue.Status then begin
if SaveOnStack then
AddStackChange(DefValue.Name,DefValue.Status);
DefValue.Status:=NewStatus;
end;
end else begin
if SaveOnStack then
AddStackChange(DefValue.Name,DefValue.Status);
CurDefines.Delete(AVLNode);
DefValue.Free;
end;
end;
if SetGlobal then begin
for i:=StackPointer downto 0 do begin
Change:=Stack[i];
while Change<>nil do begin
if CompareIdentifiers(PChar(Change^.Name),Identifier)=0 then begin
if (Change^.OldStatus=dsUnknown)
or (Change^.OldStatus=NewStatus) then begin
// ok
end else begin
Change^.OldStatus:=dsUnknown;
end;
end;
Change:=Change^.Next;
end;
end;
end;
{$IFDEF VerboseDisableUnreachableIFDEFs}
DebugLn(['SetStatus ',GetIdentifier(Identifier),' Cur=',DefineStatusNames[GetStatus(Identifier)],' Should=',DefineStatusNames[NewStatus]]);
{$ENDIF}
end;
procedure InitDefines;
var
i: Integer;
CurName: string;
Node: TCodeTreeNode;
ExprStart: integer;
ExprEnd: integer;
begin
CurDefines:=TAVLTree.Create(@CompareDefineValues);
{$IFDEF VerboseDisableUnreachableIFDEFs}
DebugLn(['InitDefines ',Defines<>nil,' ',Undefines<>nil]);
{$ENDIF}
if Undefines<>nil then begin
for i:=0 to Undefines.Count-1 do
if Undefines[i]<>'' then
SetStatus(PChar(Undefines[i]),dsNotDefined,false,false);
end;
if Defines<>nil then begin
for i:=0 to Defines.Count-1 do begin
CurName:=Defines[i];
if System.Pos('=',CurName)>0 then
CurName:=Defines.Names[i];
if CurName='' then continue;
SetStatus(PChar(CurName),dsDefined,false,false);
end;
end;
if UndefH2PasFunctions then begin
Node:=Tree.Root;
while Node<>nil do begin
if ((Node.Desc=cdnIf) or (Node.Desc=cdnElseIf)) then begin
if GetIfExpression(Node,ExprStart,ExprEnd) then begin
MoveCursorToPos(ExprStart);
repeat
ReadNextAtom;
if AtomStart>=ExprEnd then break;
if ComparePrefixIdent(H2Pas_Function_Prefix,@Src[AtomStart]) then
SetStatus(@Src[AtomStart],dsNotDefined,false,false);
until false;
end;
end;
Node:=Node.Next;
end;
end;
end;
procedure FreeDefines;
begin
if CurDefines=nil then exit;
CurDefines.FreeAndClear;
FreeAndNil(CurDefines);
end;
procedure Push;
begin
inc(StackPointer);
if StackPointer=length(Stack) then
SetLength(Stack,length(Stack)*2+10);
Stack[StackPointer]:=nil;
end;
procedure Pop;
var
Change: PDefineChange;
begin
if StackPointer=0 then
RaiseException(20170422131842,'TCompilerDirectivesTree.DisableUnreachableBlocks.Pop without Push');
// undo all changes
while Stack[StackPointer]<>nil do begin
Change:=Stack[StackPointer];
SetStatus(PChar(Change^.Name),Change^.OldStatus,false,false);
Stack[StackPointer]:=Change^.Next;
Dispose(Change);
end;
dec(StackPointer);
end;
var
Node: TCodeTreeNode;
NextNode: TCodeTreeNode;
NameStart: integer;
NewStatus: TDefineStatus;
Identifier: PChar;
OldStatus: TDefineStatus;
HasValue: boolean;
ValueStart: integer;
ExprNode: TCodeTreeNode;
IsIfBlock: Boolean;
BlockIsAlwaysReached: Boolean;
BlockIsNeverReached: Boolean;
BlockIsReachable: Boolean;
begin
InitDefines;
InitStack;
try
Node:=Tree.Root;
while Node<>nil do begin
NextNode:=Node.Next;
{$IFDEF VerboseDisableUnreachableIFDEFs}
DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks Node=',CDNodeDescAsString(Node.Desc),'=',GetDirective(Node)]);
{$ENDIF}
case Node.Desc of
cdnIf, cdnElse:
begin
if Node.Desc=cdnIf then begin
IsIfBlock:=true;
end else begin
IsIfBlock:=false;
// close prior block
Pop;
end;
// start new block
Push;
if IsIfBlock then begin
ExprNode:=Node;
end else begin
if Node.PriorBrother.Desc=cdnIf then begin
ExprNode:=Node.PriorBrother;
end else begin
ExprNode:=nil;
end;
end;
{$IFDEF VerboseDisableUnreachableIFDEFs}
if (ExprNode<>nil) then
DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks Expr=',GetIfExpressionString(ExprNode),' Simple=',IsIfExpressionSimple(ExprNode,NameStart)])
else
DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks Expr=nil']);
{$ENDIF}
if (ExprNode<>nil) and IsIfExpressionSimple(ExprNode,NameStart) then
begin
// a simple expression
Identifier:=@Src[NameStart];
if (Node.SubDesc=cdnsIfndef)=IsIfBlock then
NewStatus:=dsNotDefined
else
NewStatus:=dsDefined;
OldStatus:=GetStatus(Identifier);
BlockIsReachable:=(OldStatus=dsUnknown) or (OldStatus=NewStatus);
BlockIsAlwaysReached:=OldStatus=NewStatus;
BlockIsNeverReached:=(OldStatus<>dsUnknown) and (OldStatus<>NewStatus);
{$IFDEF VerboseDisableUnreachableIFDEFs}
DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks Identifier=',GetIdentifier(Identifier),' Reachable=',BlockIsReachable,' Always=',BlockIsAlwaysReached,' Never=',BlockIsNeverReached,' NewStatus=',DefineStatusNames[NewStatus]]);
{$ENDIF}
if BlockIsReachable then
SetStatus(Identifier,NewStatus,true,false);
if BlockIsAlwaysReached or BlockIsNeverReached then begin
// this node can be removed
if BlockIsNeverReached or (Node.FirstChild=nil) then begin
NextNode:=Node.NextBrother;
if (NextNode<>nil) and (NextNode.Desc=cdnEnd) then begin
// if the next node is an end node it will be disabled too
NextNode:=NextNode.NextSkipChilds;
end;
end;
// we can Pop here, because
// this the last block
// or this is the first block, then the next block will
// become the new first block
Pop;
if BlockIsAlwaysReached then
DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks BlockIsAlwaysReached ',GetDirective(Node)]);
if BlockIsNeverReached then
DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks BlockIsNeverReached ',GetDirective(Node)]);
DisableIfNode(Node,BlockIsNeverReached,Changed);
end;
end else begin
// a complex expression (If, ElseIf, Else)
// assume: it is reachable
end;
end;
cdnElseIf:
begin
// if there is an ElseIf block, then there must be an IF block in front
// And the IF block in front must be reachable,
// otherwise it would be disabled
Pop;
// If+ElseIf gives a complex expression
// assume: it is reachable
Push;
end;
cdnEnd:
begin
Pop;
end;
cdnDefine:
if ((Node.SubDesc=cdnsDefine) or (Node.SubDesc=cdnsUndef)
or (Node.SubDesc=cdnsSetC))
and GetDefineNameAndValue(Node,NameStart,HasValue,ValueStart) then begin
if Node.SubDesc=cdnsDefine then
NewStatus:=dsDefined
else
NewStatus:=dsNotDefined;
if GetStatus(@Src[NameStart])=NewStatus then begin
// this define is not needed
NextNode:=NextNode.NextSkipChilds;
DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks DEFINE is already, always set to this value']);
DisableDefineNode(Node,Changed);
end else begin
// set status on all levels
SetStatus(@Src[NameStart],NewStatus,true,true);
end;
end;
end;
Node:=NextNode;
end;
finally
FreeStack;
FreeDefines;
end;
{$IFDEF VerboseDisableUnreachableIFDEFs}
DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks END']);
{$ENDIF}
end;
procedure TCompilerDirectivesTree.DisableNode(Node: TCodeTreeNode;
var Changed: boolean; WithContent: boolean);
begin
if Node=nil then exit;
case Node.Desc of
cdnDefine, cdnInclude: DisableDefineNode(Node,Changed);
cdnIf, cdnElseIf, cdnElse: DisableIfNode(Node,WithContent,Changed);
end;
end;
procedure TCompilerDirectivesTree.DisableDefineNode(Node: TCodeTreeNode;
var Changed: boolean);
var
FromPos: LongInt;
ToPos: LongInt;
NewSrc: String;
begin
if not DisableUnusedDefines then exit;
//DebugLn(['TCompilerDirectivesTree.DisableDefineNode ',GetDirective(Node)]);
if RemoveDisabledDirectives then begin
// remove directive (including space+empty lines in front and spaces behind)
FromPos:=Node.StartPos;
while (FromPos>1) and (IsSpaceChar[Src[FromPos-1]]) do dec(FromPos);
ToPos:=FindCommentEnd(Src,Node.StartPos,NestedComments);
ToPos:=FindLineEndOrCodeAfterPosition(Src,ToPos,SrcLen+1,NestedComments);
NewSrc:='';
if (FromPos=1) and (ToPos<SrcLen) and (Src[ToPos] in [#10,#13]) then begin
inc(ToPos);
if (ToPos<=SrcLen) and (Src[ToPos] in [#10,#13])
and (Src[ToPos]<>Src[ToPos-1]) then
inc(ToPos);
end;
Replace(FromPos,ToPos,NewSrc);
end else begin
// disable directive -> {off $Define MacroName}
Replace(Node.StartPos+1,Node.StartPos+1,'off ');
end;
Changed:=true;
InternalRemoveNode(Node);
end;
procedure TCompilerDirectivesTree.DisableIfNode(Node: TCodeTreeNode;
WithContent: boolean; var Changed: boolean);
procedure RaiseImpossible;
begin
RaiseException(20170422131846,'TCompilerDirectivesTree.DisableIfNode impossible');
end;
function GetExpr(ExprNode: TCodeTreeNode; out Negated: boolean): string;
var
ExprStart: integer;
ExprEnd: integer;
begin
if not GetIfExpression(ExprNode,ExprStart,ExprEnd) then
RaiseImpossible;
Result:=copy(Src,ExprStart,ExprEnd-ExprStart);
Negated:=ExprNode.SubDesc=cdnsIfNdef;
if (ExprNode.SubDesc=cdnsIfdef) or (ExprNode.SubDesc=cdnsIfNdef) then
Result:='defined('+Result+')';
end;
procedure CommentCode(FromPos, ToPos: integer);
var
p: LongInt;
NewSrc: String;
begin
p:=FromPos;
repeat
// find code
MoveCursorToPos(p);
ReadNextAtom;
if AtomStart>=ToPos then break;
// there is code to comment
// = > start comment
Replace(AtomStart,AtomStart,'(* ');
p:=AtomStart;
while (p<FromPos) do begin
if (Src[p]='(') and (Src[p+1]='*') then
break;
inc(p);
end;
// end comment
NewSrc:='*)'+LineEnding;
Replace(p,p,NewSrc);
inc(p,length(NewSrc));
until false;
end;
procedure DisableContent;
var
FromPos: LongInt;
ToPos: LongInt;
ChildNode: TCodeTreeNode;
FirstChild: TCodeTreeNode;
LastChild: TCodeTreeNode;
begin
if not WithContent then begin
// the content (child nodes) will stay, but the Node will be freed
// -> move child nodes in front of Node (keep source positions)
FirstChild:=Node.FirstChild;
LastChild:=Node.LastChild;
if FirstChild<>nil then begin
ChildNode:=FirstChild;
while ChildNode<>nil do begin
ChildNode.Parent:=Node.Parent;
ChildNode:=ChildNode.NextBrother;
end;
FirstChild.PriorBrother:=Node.PriorBrother;
LastChild.NextBrother:=Node;
if FirstChild.PriorBrother=nil then begin
if Node.Parent<>nil then
Node.Parent.FirstChild:=FirstChild;
end else begin
FirstChild.PriorBrother.NextBrother:=FirstChild;
end;
Node.PriorBrother:=LastChild;
Node.FirstChild:=nil;
Node.LastChild:=nil;
end;
end else begin
// free nodes and delete code
while Node.FirstChild<>nil do
InternalRemoveNode(Node.FirstChild);
FromPos:=FindCommentEnd(Src,Node.StartPos,NestedComments);
ToPos:=Node.NextBrother.StartPos;
if RemoveDisabledDirectives then begin
// delete content
Replace(FromPos,ToPos,'');
end else begin
// comment content
CommentCode(FromPos,ToPos);
end;
end;
end;
var
FromPos: LongInt;
ToPos: LongInt;
Expr: String;
ElseNode: TCodeTreeNode;
ElseName: String;
Expr2: String;
NewSrc: String;
PrevNode: TCodeTreeNode;
NewDesc: TCompilerDirectiveNodeDesc;
NewSubDesc: TCompilerDirectiveNodeDesc;
Simplified: Boolean;
ExprNegated: boolean;
Expr2Negated: boolean;
p: LongInt;
begin
if (Node.NextBrother=nil) then
RaiseImpossible;
if (Node.Desc<>cdnIf) and (Node.Desc<>cdnElseIf) and (Node.Desc<>cdnElse) then
RaiseImpossible;
DisableContent;
Changed:=true;
// fix all following elseif and else nodes
Expr:=GetExpr(Node,ExprNegated);
ElseNode:=Node.NextBrother;
while ElseNode<>nil do begin
if (ElseNode.Desc=cdnElse) or (ElseNode.Desc=cdnElseIf) then begin
PrevNode:=ElseNode.PriorBrother;
if (PrevNode.Desc=cdnIf) then begin
NewDesc:=cdnIf;
if ElseNode.SubDesc=cdnsIfC then
NewSubDesc:=cdnsIfC
else
NewSubDesc:=cdnsIf; // IFDEF, IF -> IF
end else begin
NewDesc:=cdnElseIf;
if (ElseNode.SubDesc=cdnsElseIf) or (ElseNode.SubDesc=cdnsElse) then
NewSubDesc:=cdnsElIfC
else
NewSubDesc:=cdnsElseIf; // Else, ElseIf -> ElseIF
end;
ElseName:=CDNodeSubDescAsString(NewSubDesc);
// convert {$Else} to {$ElseIf not (Expr)}
// convert {$ElseIf Expr2} to {$ElseIf (Expr2) and not (Expr)}
NewSrc:='('+Expr+')';
if not ExprNegated then
NewSrc:='not '+NewSrc;
if ElseNode.Desc=cdnElse then
NewSrc:='{$'+ElseName+' '+NewSrc+'}'
else begin
Expr2:=GetExpr(ElseNode,Expr2Negated);
NewSrc:='{$'+ElseName+' ('+Expr2+') and '+NewSrc+'}';
end;
Replace(ElseNode.StartPos,
FindCommentEnd(Src,ElseNode.StartPos,NestedComments),NewSrc);
ElseNode.Desc:=NewDesc;
ElseNode.SubDesc:=NewSubDesc;
Simplified:=false;
CheckAndImproveExpr_Brackets(ElseNode,Simplified);
CheckAndImproveExpr_IfDefinedMacro(ElseNode,Simplified);
end else begin
break;
end;
ElseNode:=ElseNode.NextBrother;
end;
FromPos:=Node.StartPos;
if RemoveDisabledDirectives then begin
if (Node.NextBrother.Desc=cdnEnd) and (Node.Desc=cdnIf) then begin
// remove the whole IF..END block
ToPos:=FindCommentEnd(Src,Node.NextBrother.StartPos,NestedComments);
ToPos:=FindLineEndOrCodeAfterPosition(Src,ToPos,SrcLen+1,NestedComments);
end else begin
// remove a sub block
ToPos:=Node.NextBrother.StartPos;
end;
if WithContent then begin
// remove node source with content
if (FromPos>1) and (Src[FromPos-1] in [#10,#13])
and (ToPos<=SrcLen) and (Src[ToPos] in [#10,#13]) then begin
// the directive has a complete line
// remove the line end too
inc(ToPos);
if (ToPos<=SrcLen) and (Src[ToPos] in [#10,#13]) and (Src[ToPos]<>Src[ToPos-1])
then inc(ToPos);
if (ToPos<=SrcLen) and (Src[ToPos] in [#10,#13]) then begin
// there is an empty line behind the directive
// check if there is an empty line in front of the directive
p:=FromPos;
if (p>1) and (Src[p-1] in [#10,#13]) then begin
dec(p);
if (p>1) and (Src[p-1] in [#10,#13]) and (Src[p]<>Src[p-1]) then
dec(p);
if (p>1) and (Src[p-1] in [#10,#13]) then begin
// there is an empty line in front of the directive too
// => remove one empty line
FromPos:=p;
end;
end;
end;
end;
Replace(FromPos,ToPos,'');
end else begin
// remove node source keeping content (child node source)
Replace(FromPos,FindCommentEnd(Src,FromPos,NestedComments),'');
if Node.NextBrother.Desc=cdnEnd then begin
ToPos:=FindCommentEnd(Src,Node.NextBrother.StartPos,NestedComments);
ToPos:=FindLineEndOrCodeAfterPosition(Src,ToPos,SrcLen+1,NestedComments);
Replace(Node.NextBrother.StartPos,ToPos,'');
end;
end;
end else begin
// disable directive -> {$off IfDef MacroName}
Replace(FromPos+1,FromPos+1,'off ');
if Node.NextBrother.Desc=cdnEnd then
Replace(Node.NextBrother.StartPos+1,Node.NextBrother.StartPos+1,'off ');
end;
if Node.NextBrother.Desc=cdnEnd then
InternalRemoveNode(Node.NextBrother);
InternalRemoveNode(Node);
end;
procedure TCompilerDirectivesTree.InternalRemoveNode(Node: TCodeTreeNode);
var
AVLNode: TAVLTreeNode;
MacroNode: TCompilerMacroStats;
begin
// clear references
if Macros<>nil then begin
AVLNode:=Macros.FindLowest;
while AVLNode<>nil do begin
MacroNode:=TCompilerMacroStats(AVLNode.Data);
if MacroNode.LastDefineNode=Node then
MacroNode.LastDefineNode:=nil;
if MacroNode.LastReadNode=Node then
MacroNode.LastReadNode:=nil;
AVLNode:=Macros.FindSuccessor(AVLNode);
end;
end;
// free node
Tree.DeleteNode(Node);
end;
procedure TCompilerDirectivesTree.RaiseException(id: int64;
const ErrorMsg: string);
begin
fLastErrorMsg:=ErrorMsg;
fLastErrorPos:=AtomStart;
fLastErrorId:=id;
if Code<>nil then
Code.AbsoluteToLineCol(AtomStart,fLastErrorXY.Y,fLastErrorXY.X)
else
fLastErrorXY:=Point(0,0);
RaiseLastError;
end;
procedure TCompilerDirectivesTree.RaiseLastError;
begin
raise ECDirectiveParserException.Create(Self, fLastErrorId,
SrcPosToStr(fLastErrorPos)+' Error: '+ErrorMsg);
end;
procedure TCompilerDirectivesTree.RemoveEmptyNodes(var Changed: boolean);
var
Node: TCodeTreeNode;
NextNode: TCodeTreeNode;
procedure CheckNode;
begin
//DebugLn(['CheckNode ',Node.Desc=cdnIf,' ',(Node.NextBrother<>nil),' ',(Node.FirstChild=nil),' ',GetDirective(Node)]);
case Node.Desc of
cdnIf,cdnElseIf,cdnElse:
if (Node.NextBrother<>nil) and (Node.FirstChild=nil) then begin
case Node.NextBrother.Desc of
cdnEnd,cdnElseIf,cdnElse:
begin
//DebugLn(['CheckNode Checking if empty ...']);
MoveCursorToPos(Node.StartPos);
// skip directive
ReadNextAtom;
// read the following atom (token or directive)
ReadNextAtom;
if AtomStart=Node.NextBrother.StartPos then begin
// node is empty
DebugLn(['TCompilerDirectivesTree.RemoveEmptyNodes node only contains spaces and comments ',GetDirective(Node)]);
DisableIfNode(Node,true,Changed);
end;
end;
end;
end;
end;
end;
begin
//DebugLn(['TCompilerDirectivesTree.RemoveEmptyNodes ']);
// check nodes from end to start
Node:=Tree.Root;
while (Node.NextBrother<>nil) do Node:=Node.NextBrother;
while (Node.LastChild<>nil) do Node:=Node.LastChild;
while Node<>nil do begin
NextNode:=Node.Prior;
CheckNode;
Node:=NextNode;
end;
end;
function TCompilerDirectivesTree.InsertDefine(Position: integer;
const NewSrc: string; SubDesc: TCompilerDirectiveNodeDesc): TCodeTreeNode;
var
ParentNode: TCodeTreeNode;
NextBrotherNode: TCodeTreeNode;
begin
Replace(Position,Position,NewSrc);
ParentNode:=FindNodeAtPos(Position);
if ParentNode=nil then
ParentNode:=Tree.Root;
while (ParentNode<>Tree.Root) and (ParentNode.EndPos=Position) do
ParentNode:=ParentNode.Parent;
Result:=TCodeTreeNode.Create;
Result.Desc:=cdnDefine;
Result.SubDesc:=SubDesc;
Result.StartPos:=FindNextCompilerDirective(Src,Position,NestedComments);
Result.EndPos:=FindCommentEnd(Src,Result.StartPos,NestedComments);
NextBrotherNode:=ParentNode.FirstChild;
while (NextBrotherNode<>nil) and (NextBrotherNode.StartPos<=Position) do
NextBrotherNode:=NextBrotherNode.NextBrother;
if NextBrotherNode<>nil then begin
Tree.AddNodeInFrontOf(NextBrotherNode,Result);
end else begin
Tree.AddNodeAsLastChild(ParentNode,Result);
if ParentNode.EndPos<Result.EndPos then
ParentNode.EndPos:=Result.EndPos;
end;
end;
constructor TCompilerDirectivesTree.Create;
begin
Tree:=TCodeTree.Create;
SimplifyExpressions:=true;
DisableUnusedDefines:=true;
RemoveDisabledDirectives:=true;
UndefH2PasFunctions:=true;
end;
destructor TCompilerDirectivesTree.Destroy;
begin
ClearMacros;
FreeAndNil(Tree);
FDefaultDirectiveFuncList.Free;
inherited Destroy;
end;
procedure TCompilerDirectivesTree.Clear;
begin
Tree.Clear;
if Macros<>nil then begin
Macros.FreeAndClear;
FreeAndNil(Macros);
end;
end;
procedure TCompilerDirectivesTree.Parse;
begin
Parse(Code,NestedComments);
end;
{$IFOPT R+}{$DEFINE RangeChecking}{$ENDIF}
{$R-}
procedure TCompilerDirectivesTree.Parse(aCode: TCodeBuffer;
aNestedComments: boolean);
procedure RaiseDanglingIFDEF;
begin
RaiseException(20170422131848,'missing EndIf');
end;
var
DirectiveName: PChar;
Node: TCodeTreeNode;
begin
if (Code=aCode) and (NestedComments=aNestedComments) and (not UpdateNeeded)
then begin
if FLastErrorMsg<>'' then
RaiseLastError;
exit;
end;
FLastErrorMsg:='';
Code:=aCode;
NestedComments:=aNestedComments;
InitParser;
repeat
ReadRawNextPascalAtom(Src,SrcPos,AtomStart,NestedComments);
//DebugLn(['TCompilerDirectivesTree.Parse ',NestedComments,' ',copy(Src,AtomStart,SrcPos-AtomStart)]);
if SrcPos<=SrcLen then begin
if (Src[AtomStart]='{') and (Src[AtomStart+1]='$') then begin
// compiler directive
DirectiveName:=@Src[AtomStart+2];
//DebugLn(['ParseCompilerDirectives ',GetIdentifier(DirectiveName)]);
FDefaultDirectiveFuncList.DoItCaseInsensitive(DirectiveName);
end;
end else begin
break;
end;
until false;
// close nodes
Node:=CurNode;
while Node<>nil do begin
Node.EndPos:=AtomStart;
Node:=Node.Parent;
end;
if CurNode<>Tree.Root then
RaiseDanglingIFDEF;
end;
{$IFDEF RangeChecking}{$R+}{$UNDEF RangeChecking}{$ENDIF}
function TCompilerDirectivesTree.UpdateNeeded: boolean;
begin
Result:=true;
if (Code=nil) or (Tree=nil) or (Tree.Root=nil) then exit;
if Code.ChangeStep<>ParseChangeStep then exit;
Result:=false;
end;
procedure TCompilerDirectivesTree.ReduceCompilerDirectives(
Undefines, Defines: TStrings; var Changed: boolean);
(* Check and improve the following cases
1. {$DEFINE Name} and Name is never used afterwards -> disable
2. {$DEFINE Name}
... Name is not used here ...
{$DEFINE Name}
-> disable first
3. {$IFDEF Name}... only comments and spaces ...{$ENDIF}
-> disable the whole block
4. {$IFNDEF Name}
... only comments and spaces ...
{$DEFINE Name}
... only comments and spaces ...
{$ENDIF}
-> disable the IFNDEF and the ENDIF and keep the DEFINE
*)
function GetMacroNode(p: PChar): TCompilerMacroStats;
var
AVLNode: TAVLTreeNode;
begin
AVLNode:=Macros.FindKey(p,@ComparePCharWithCompilerMacroStats);
if AVLNode<>nil then
Result:=TCompilerMacroStats(AVLNode.Data)
else
Result:=nil;
end;
procedure CheckMacroInExpression(Node: TCodeTreeNode; NameStart: integer;
Complex: boolean; var {%H-}Changed: boolean);
var
MacroNode: TCompilerMacroStats;
begin
MacroNode:=GetMacroNode(@Src[NameStart]);
if MacroNode=nil then begin
MacroNode:=TCompilerMacroStats.Create;
MacroNode.Name:=GetIdentifier(@Src[NameStart]);
Macros.Add(MacroNode);
end;
MacroNode.LastReadNode:=Node;
if not Complex then begin
end;
end;
procedure CheckDefine(Node: TCodeTreeNode; var Changed: boolean);
var
MacroNode: TCompilerMacroStats;
NameStart: integer;
HasValue: boolean;
ValueStart: integer;
begin
if (Node.SubDesc<>cdnsDefine) and (Node.SubDesc<>cdnsUndef)
and (Node.SubDesc<>cdnsSetC) then exit;
if not GetDefineNameAndValue(Node,NameStart,HasValue,ValueStart) then exit;
MacroNode:=GetMacroNode(@Src[NameStart]);
if MacroNode=nil then begin
MacroNode:=TCompilerMacroStats.Create;
MacroNode.Name:=GetIdentifier(@Src[NameStart]);
Macros.Add(MacroNode);
end;
if (MacroNode.LastReadNode=nil) and (MacroNode.LastDefineNode<>nil)
and (MacroNode.LastDefineNode.Parent=Node.Parent)
and ((MacroNode.LastDefineNode.SubDesc=cdnsUndef)=(Node.SubDesc=cdnsUndef)) then begin
// last define was never used -> disable it
DebugLn(['TCompilerDirectivesTree.ReduceCompilerDirectives this define was already set to this value']);
DisableDefineNode(MacroNode.LastDefineNode,Changed);
end;
MacroNode.LastReadNode:=nil;
MacroNode.LastDefineNode:=Node;
end;
var
Node: TCodeTreeNode;
ExprStart: integer;
ExprEnd: integer;
Complex: Boolean;
AtomCount: Integer;
NextNode: TCodeTreeNode;
begin
try
ResetMacros;
Node:=Tree.Root;
while Node<>nil do begin
NextNode:=Node.Next;
case Node.Desc of
cdnIf,cdnElseIf:
if GetIfExpression(Node,ExprStart,ExprEnd) then begin
// improve expression
CheckAndImproveExpr_Brackets(Node,Changed);
CheckAndImproveExpr_IfDefinedMacro(Node,Changed);
//DebugLn(['TCompilerDirectivesTree.ReduceCompilerDirectives Expr=',copy(Src,ExprStart,ExprEnd-ExprStart)]);
// check if it is a complex expression or just one macro
AtomCount:=0;
if (Node.SubDesc=cdnsIf) or (Node.SubDesc=cdnsIfC)
or (Node.SubDesc=cdnsElseIf) then begin
MoveCursorToPos(ExprStart);
repeat
ReadNextAtom;
inc(AtomCount);
until AtomStart>=ExprEnd;
end;
Complex:=AtomCount>1;
// mark all macros as read
MoveCursorToPos(ExprStart);
repeat
ReadNextAtom;
if AtomIsIdentifier then begin
CheckMacroInExpression(Node,AtomStart,Complex,Changed);
end;
until AtomStart>=ExprEnd;
end;
cdnDefine:
CheckDefine(Node,Changed);
end;
Node:=NextNode;
end;
DisableAllUnusedDefines(Changed);
MoveIfNotThenDefsUp(Changed);
DisableUnreachableBlocks(Undefines,Defines,Changed);
RemoveEmptyNodes(Changed);
finally
ClearMacros;
end;
end;
procedure TCompilerDirectivesTree.GatherH2PasFunctions(out
ListOfH2PasFunctions: TFPList; FindDefNodes: boolean);
var
InInterface: boolean;
procedure ReadFunction;
var
HeaderStart: LongInt;
HeaderEnd: LongInt;
FuncName: String;
IsForward: Boolean;
BlockLevel: Integer;
CurH2PasFunc: TH2PasFunction;
BeginStart: Integer;
BeginEnd: Integer;
IsExternal: Boolean;
begin
HeaderStart:=AtomStart;
// read name
ReadNextAtom;
if not AtomIsIdentifier then exit;
FuncName:=GetAtom;
// read parameter list
ReadNextAtom;
if AtomIs('(') then begin
if not ReadTilBracketClose(')') then exit;
ReadNextAtom;
end;
// read colon
if not AtomIs(':') then exit;
// read result type
ReadNextAtom;
if not AtomIsIdentifier then exit;
// read semicolon
ReadNextAtom;
if not AtomIs(';') then exit;
HeaderEnd:=SrcPos;
// read function modifiers
IsForward:=false;
IsExternal:=false;
repeat
ReadNextAtom;
if (AtomStart<=SrcLen)
and IsKeyWordProcedureSpecifier.DoItCaseInsensitive(@Src[AtomStart])
then begin
if UpAtomIs('EXTERNAL') then
IsExternal:=true;
if UpAtomIs('FORWARD') then
IsForward:=true;
repeat
ReadNextAtom;
until (AtomStart>SrcLen) or AtomIs(';');
HeaderEnd:=SrcPos;
end else
break;
until false;
// read begin..end block
BeginStart:=-1;
BeginEnd:=-1;
if (not IsForward) and (not InInterface) and (not IsExternal)
and UpAtomIs('BEGIN') then begin
BeginStart:=AtomStart;
BlockLevel:=1;
repeat
ReadNextAtom;
if (AtomStart>SrcLen) then break;
if UpAtomIs('END') then begin
dec(BlockLevel);
if BlockLevel=0 then begin
BeginEnd:=SrcPos;
ReadNextAtom;
if AtomIs(';') then
BeginEnd:=SrcPos;
break;
end;
end else if UpAtomIs('BEGIN') or UpAtomIs('ASM') then
inc(BlockLevel);
until false;
end else begin
// undo forward read to make sure that current atom is the last of the function
MoveCursorToPos(HeaderEnd);
end;
// found a function
//DebugLn(['ReadFunction ',copy(Src,HeaderStart,FuncEnd-HeaderStart)]);
CurH2PasFunc:=TH2PasFunction.Create;
CurH2PasFunc.Name:=FuncName;
CurH2PasFunc.HeaderStart:=HeaderStart;
CurH2PasFunc.HeaderEnd:=HeaderEnd;
CurH2PasFunc.BeginStart:=BeginStart;
CurH2PasFunc.BeginEnd:=BeginEnd;
CurH2PasFunc.IsForward:=IsForward;
CurH2PasFunc.InInterface:=InInterface;
CurH2PasFunc.IsExternal:=IsExternal;
if ListOfH2PasFunctions=nil then ListOfH2PasFunctions:=TFPList.Create;
ListOfH2PasFunctions.Add(CurH2PasFunc);
end;
procedure DoFindDefNodes;
var
i: Integer;
CurH2PasFunc: TH2PasFunction;
TreeOfForwardFuncs: TAVLTree;
TreeOfBodyFuncs: TAVLTree;
AVLNode: TAVLTreeNode;
BodyAVLNode: TAVLTreeNode;
BodyFunc: TH2PasFunction;
begin
if ListOfH2PasFunctions=nil then exit;
// create a tree of the function definitions
// and a tree of the function bodies
TreeOfForwardFuncs:=TAVLTree.Create(@CompareH2PasFuncByNameAndPos);
TreeOfBodyFuncs:=TAVLTree.Create(@CompareH2PasFuncByNameAndPos);
for i:=0 to ListOfH2PasFunctions.Count-1 do begin
CurH2PasFunc:=TH2PasFunction(ListOfH2PasFunctions[i]);
if CurH2PasFunc.NeedsBody then
TreeOfForwardFuncs.Add(CurH2PasFunc)
else if (CurH2PasFunc.BeginStart>0) then
TreeOfBodyFuncs.Add(CurH2PasFunc);
end;
// search for every definition the corresponding body
AVLNode:=TreeOfForwardFuncs.FindLowest;
while AVLNode<>nil do begin
CurH2PasFunc:=TH2PasFunction(AVLNode.Data);
if CurH2PasFunc.DefNode=nil then begin
BodyAVLNode:=TreeOfBodyFuncs.FindLeftMostKey(Pointer(CurH2PasFunc.Name),
@ComparePCharWithH2PasFuncName);
if BodyAVLNode<>nil then begin
// there is at least one body with this name
repeat
BodyFunc:=TH2PasFunction(BodyAVLNode.Data);
if BodyFunc.DefNode=nil then begin
// this body node with the same name has not yet a definition node
// => found the corresponding node
BodyFunc.DefNode:=CurH2PasFunc;
CurH2PasFunc.DefNode:=BodyFunc;
break;
end else begin
// this body node has already a definition node
// search next body node with same name
BodyAVLNode:=TreeOfBodyFuncs.FindSuccessor(BodyAVLNode);
if (BodyAVLNode=nil)
or (ComparePCharWithH2PasFuncName(
Pointer(CurH2PasFunc.Name),BodyAVLNode.Data)<>0)
then
break;
end;
until false;
end;
end;
AVLNode:=TreeOfBodyFuncs.FindSuccessor(AVLNode);
end;
// clean up
TreeOfForwardFuncs.Free;
TreeOfBodyFuncs.Free;
end;
begin
ListOfH2PasFunctions:=nil;
InInterface:=false;
MoveCursorToPos(1);
repeat
ReadNextAtom;
if SrcPos>SrcLen then break;
if UpAtomIs('FUNCTION') then begin
ReadFunction;
end else if UpAtomIs('INTERFACE') then begin
InInterface:=true;
end else if UpAtomIs('IMPLEMENTATION') then begin
InInterface:=false;
end;
until false;
if FindDefNodes then
DoFindDefNodes;
end;
procedure TCompilerDirectivesTree.FixMissingH2PasDirectives(var Changed: boolean);
{ Adds the directives around the function bodies, that h2pas forgets to add.
}
type
TBodyBlock = record
Definition: TCodeTreeNode;
FirstBodyFunc: TH2PasFunction;
LastBodyFunc: TH2PasFunction;
end;
var
CurBodyBlock: TBodyBlock;
MacroNames: TStrings; // the Objects are the TCodeTreeNode
ListOfH2PasFunctions: TFPList;
LocalChange: boolean;
function IsSameDirective(OldNode: TCodeTreeNode; Position: integer;
out NewNode: TCodeTreeNode): boolean;
begin
NewNode:=FindNodeAtPos(Position);
//if OldNode<>nil then DebugLn(['IsSameDirective OldNode=',OldNode.StartPos,' "',copy(Src,OldNode.StartPos,OldNode.EndPos-OldNode.StartPos),'"']);
//if NewNode<>nil then DebugLn(['IsSameDirective NewNode=',NewNode.StartPos,' "',copy(Src,NewNode.StartPos,NewNode.EndPos-NewNode.StartPos),'"']);
Result:=(NewNode<>nil) and (NewNode=OldNode);
end;
function HasCodeBetween(FromPos, ToPos: integer): boolean;
begin
if FromPos<1 then FromPos:=1;
if FromPos>ToPos then exit(false);
MoveCursorToPos(FromPos);
ReadNextAtom;
Result:=AtomStart<ToPos;
end;
function GetMacroNameForNode(Node: TCodeTreeNode; out IsNew: boolean): string;
var
i: Integer;
begin
if MacroNames=nil then
MacroNames:=TStringList.Create;
for i:=0 to MacroNames.Count-1 do
if MacroNames.Objects[i]=Node then begin
Result:=MacroNames[i];
IsNew:=false;
exit;
end;
IsNew:=true;
Result:=H2Pas_Function_Prefix+IntToStr(MacroNames.Count+1);
MacroNames.AddObject(Result,Node);
end;
procedure LocalReplace(FromPos, ToPos: integer; const NewSrc: string);
var
DiffPos: Integer;
i: Integer;
Func: TH2PasFunction;
begin
LocalChange:=true;
Replace(FromPos,ToPos,NewSrc);
// update positions
DiffPos:=length(NewSrc)-(ToPos-FromPos);
if DiffPos<>0 then begin
for i:=0 to ListOfH2PasFunctions.Count-1 do begin
Func:=TH2PasFunction(ListOfH2PasFunctions[i]);
Func.AdjustPositionsAfterInsert(FromPos,ToPos,DiffPos);
end;
end;
end;
procedure StartBodyBlock(BodyFunc: TH2PasFunction; DefNode: TCodeTreeNode);
begin
CurBodyBlock.Definition:=DefNode;
CurBodyBlock.FirstBodyFunc:=BodyFunc;
CurBodyBlock.LastBodyFunc:=BodyFunc;
end;
procedure EndBodyBlock;
var
MacroName: String;
InsertPos: LongInt;
IsNewMacro: boolean;
begin
if CurBodyBlock.Definition=nil then exit;
if CurBodyBlock.Definition<>Tree.Root then begin
DebugLn(['TCompilerDirectivesTree.FixMissingH2PasDirectives add missing directives']);
// create unique macro name
MacroName:=GetMacroNameForNode(CurBodyBlock.Definition,IsNewMacro);
if IsNewMacro then begin
// insert $DEFINE
InsertPos:=FindCommentEnd(Src,CurBodyBlock.Definition.StartPos,NestedComments);
LocalReplace(InsertPos,InsertPos,LineEnding+'{$DEFINE '+MacroName+'}');
end;
// insert $IFDEF
InsertPos:=FindLineEndOrCodeInFrontOfPosition(Src,
CurBodyBlock.FirstBodyFunc.HeaderStart,1,NestedComments,true);
LocalReplace(InsertPos,InsertPos,LineEnding+'{$IFDEF '+MacroName+'}');
// insert $ENDIF
InsertPos:=FindLineEndOrCodeAfterPosition(Src,
CurBodyBlock.LastBodyFunc.BeginEnd,1,NestedComments,true);
LocalReplace(InsertPos,InsertPos,LineEnding+'{$ENDIF '+MacroName+'}');
end;
FillChar(CurBodyBlock,SizeOf(TBodyBlock),0);
end;
var
i: Integer;
BodyFunc: TH2PasFunction;
LastDefNode: TCodeTreeNode;
BodyNode: TCodeTreeNode;
begin
ListOfH2PasFunctions:=nil;
MacroNames:=nil;
LocalChange:=false;
try
GatherH2PasFunctions(ListOfH2PasFunctions,true);
DebugLn(['TCompilerDirectivesTree.FixMissingH2PasDirectives ',ListOfH2PasFunctions=nil]);
if ListOfH2PasFunctions=nil then exit;
FillChar(CurBodyBlock,SizeOf(TBodyBlock),0);
LastDefNode:=nil;
for i:=0 to ListOfH2PasFunctions.Count-1 do begin
BodyFunc:=TH2PasFunction(ListOfH2PasFunctions[i]);
//DebugLn(['TCompilerDirectivesTree.FixMissingH2PasDirectives DefNode=',(BodyFunc.DefNode<>nil),' Body="',copy(Src,BodyFunc.HeaderStart,BodyFunc.HeaderEnd-BodyFunc.HeaderStart),'"']);
if (BodyFunc.BeginStart<1) or (BodyFunc.DefNode=nil) then
continue;
BodyNode:=FindNodeAtPos(BodyFunc.HeaderStart);
if BodyNode<>Tree.Root then begin
// this body has already a directive block
continue;
end;
// this function is a body and has a definition
if (CurBodyBlock.LastBodyFunc<>nil)
and HasCodeBetween(CurBodyBlock.LastBodyFunc.BeginEnd,BodyFunc.HeaderStart)
then begin
// there is code between last function body and current function body
// end last block
EndBodyBlock;
end;
if not IsSameDirective(LastDefNode,
BodyFunc.DefNode.HeaderStart,LastDefNode)
then begin
// another directive block => end last block
EndBodyBlock;
end;
if (CurBodyBlock.Definition=nil) then begin
// a new block
StartBodyBlock(BodyFunc, LastDefNode);
end else begin
// continue current block
CurBodyBlock.LastBodyFunc:=BodyFunc;
end;
end;
// end last block
EndBodyBlock;
finally
if ListOfH2PasFunctions<>nil then
for i:=0 to ListOfH2PasFunctions.Count-1 do
TObject(ListOfH2PasFunctions[i]).Free;
ListOfH2PasFunctions.Free;
MacroNames.Free;
if LocalChange then begin
Changed:=true;
Parse(Code,NestedComments);
end;
end;
end;
function TCompilerDirectivesTree.NodeStartToCodePos(Node: TCodeTreeNode; out
CodePos: TCodeXYPosition): boolean;
begin
CodePos.Code:=nil;
CodePos.Y:=0;
CodePos.X:=0;
if (Node=nil) or (Code=nil) then exit(false);
CodePos.Code:=Code;
Code.AbsoluteToLineCol(Node.StartPos,CodePos.Y,CodePos.X);
Result:=true;
end;
function TCompilerDirectivesTree.SrcPosToStr(p: integer;
WithFilename: boolean): string;
var
Line: integer;
Column: integer;
begin
if Code=nil then
exit('P='+IntToStr(p));
if WithFilename then
Result:=Code.Filename
else
Result:='';
Code.AbsoluteToLineCol(p,Line,Column);
Result+='('+IntToStr(Line)+','+IntToStr(Column)+')';
end;
function TCompilerDirectivesTree.FindResourceDirective(const Filename: string;
StartPos: integer): TCodeTreeNode;
begin
if Tree=nil then exit(nil);
Result:=Tree.Root;
while Result<>nil do begin
if (Result.StartPos>=StartPos)
and IsResourceDirective(Result,Filename) then exit;
Result:=Result.Next;
end;
end;
function TCompilerDirectivesTree.IsResourceDirective(Node: TCodeTreeNode;
const Filename: string): boolean;
// search for {$R filename}
// if filename='' then search for any {$R } directive
// Beware: do not find {$R+}
var
p: LongInt;
begin
Result:=false;
if (Node=nil) or (Node.Desc<>cdnDefine) or (Node.SubDesc<>cdnsOther) then exit;
p:=Node.StartPos;
if (Node.EndPos-p>=5) and (Src[p]='{') and (Src[p+1]='$') and (Src[p+2]='R')
and IsSpaceChar[Src[p+3]] then
begin
if (Filename='') then exit(true);
inc(p,4);
while (p<Node.EndPos) and IsSpaceChar[Src[p]] do inc(p);
if CompareText(Filename,copy(Src,p,Node.EndPos-p-1))=0 then // do not use CompareFilenamesIgnoreCase
exit(true);
end;
end;
function TCompilerDirectivesTree.FindIncludeDirective(const Filename: string;
StartPos: integer): TCodeTreeNode;
begin
if Tree=nil then exit(nil);
Result:=Tree.Root;
while Result<>nil do begin
if (Result.StartPos>=StartPos)
and IsIncludeDirective(Result,Filename) then exit;
Result:=Result.Next;
end;
end;
function TCompilerDirectivesTree.IsIncludeDirective(Node: TCodeTreeNode;
const Filename: string): boolean;
// search for {$I filename}
// if filename='' then search for any {$I } directive
// Beware: do not find {$I+}
var
p: LongInt;
FilenameStartPos: integer;
FilenameEndPos: integer;
CommentStart: integer;
CommentEnd: integer;
begin
Result:=false;
//debugln(['TCompilerDirectivesTree.IsIncludeDirective ',CDNodeDescAsString(Node.Desc)]);
if (Node=nil) or (Node.Desc<>cdnInclude) then exit;
p:=Node.StartPos;
if (Node.EndPos-p>=5) and (Src[p]='{') and (Src[p+1]='$') and (Src[p+2]='I')
then begin
if (Filename='') then exit(true);
if FindNextIncludeDirective(Src,p,NestedComments,
FilenameStartPos,FilenameEndPos,CommentStart,CommentEnd)=p then
begin
// do not use CompareFilenamesIgnoreCase
if CompareText(Filename,
copy(Src,FilenameStartPos,FilenameEndPos-FilenameStartPos))=0
then
exit(true);
end;
end;
end;
function TCompilerDirectivesTree.GetDirectiveName(Node: TCodeTreeNode): string;
begin
Result:=GetIdentifier(@Src[Node.StartPos+2]);
end;
function TCompilerDirectivesTree.GetDirective(Node: TCodeTreeNode): string;
begin
Result:=copy(Src,Node.StartPos,
FindCommentEnd(Src,Node.StartPos,NestedComments)-Node.StartPos);
end;
function TCompilerDirectivesTree.GetIfExpression(Node: TCodeTreeNode;
out ExprStart, ExprEnd: integer): boolean;
var
p: LongInt;
begin
Result:=false;
ExprStart:=-1;
ExprEnd:=-1;
p:=Node.StartPos+2;
if p>SrcLen then exit;
while (p<=SrcLen) and IsIdentChar[Src[p]] do inc(p);
if (p>SrcLen) or (not IsSpaceChar[Src[p]]) then exit;
inc(p);
ExprStart:=p;
while (p<=SrcLen) and (Src[p]<>'}') do inc(p);
ExprEnd:=p;
Result:=true;
end;
function TCompilerDirectivesTree.GetIfExpressionString(Node: TCodeTreeNode
): string;
var
ExprStart: integer;
ExprEnd: integer;
begin
if not GetIfExpression(Node,ExprStart,ExprEnd) then
Result:=''
else
Result:=copy(Src,ExprStart,ExprEnd-ExprStart);
end;
function TCompilerDirectivesTree.IsIfExpressionSimple(Node: TCodeTreeNode; out
NameStart: integer): boolean;
var
p: LongInt;
begin
Result:=false;
NameStart:=-1;
// skip {$
p:=Node.StartPos+2;
if p>SrcLen then exit;
// skip directive name
while (p<=SrcLen) and IsIdentChar[Src[p]] do inc(p);
// skip space
if (p>SrcLen) or (not IsSpaceChar[Src[p]]) then exit;
while (p<=SrcLen) and IsSpaceChar[Src[p]] do inc(p);
if (p>SrcLen) or (not IsIdentStartChar[Src[p]]) then exit;
// the expression starts with word
NameStart:=p;
if (Node.SubDesc=cdnsIfdef) or (Node.SubDesc=cdnsIfndef) then begin
// IFDEF and IFNDEF only test the first word
exit(true);
end;
// skip first word
while (p<=SrcLen) and (IsIdentChar[Src[p]]) do inc(p);
// skip space
while (p<=SrcLen) and IsSpaceChar[Src[p]] do inc(p);
if (p>SrcLen) or (Src[p]='}') then begin
// the expression only contains one word
exit(true);
end;
Result:=false;
end;
function TCompilerDirectivesTree.FindNameInIfExpression(Node: TCodeTreeNode;
Identifier: PChar): integer;
var
p: LongInt;
begin
Result:=-1;
// skip {$
p:=Node.StartPos+2;
if p>SrcLen then exit;
// skip directive name
while (p<=SrcLen) and IsIdentChar[Src[p]] do inc(p);
// read expression
while (p<=SrcLen) do begin
if Src[p]='}' then exit;
if IsIdentStartChar[Src[p]] then begin
if CompareIdentifierPtrs(@Src[p],Identifier)=0 then
exit(p);
if (Node.SubDesc=cdnsIfdef) or (Node.SubDesc=cdnsIfndef) then begin
// IFDEF and IFNDEF have only one word
exit;
end;
while (p<=SrcLen) and (IsIdentChar[Src[p]]) do inc(p);
end else begin
inc(p);
end;
end;
end;
function TCompilerDirectivesTree.GetDefineNameAndValue(
DefineNode: TCodeTreeNode; out NameStart: integer; out HasValue: boolean; out
ValueStart: integer): boolean;
var
p: LongInt;
begin
Result:=false;
NameStart:=-1;
HasValue:=false;
ValueStart:=-1;
p:=DefineNode.StartPos+2;
if p>SrcLen then exit;
// skip keyword
while (p<=SrcLen) and (IsIdentChar[Src[p]]) do inc(p);
while (p<=SrcLen) and (IsSpaceChar[Src[p]]) do inc(p);
// check name
if p>SrcLen then exit;
NameStart:=p;
if not IsIdentStartChar[Src[p]] then exit;
Result:=true;
// skip name
while (p<=SrcLen) and (IsIdentChar[Src[p]]) do inc(p);
while (p<=SrcLen) and (IsSpaceChar[Src[p]]) do inc(p);
if p>SrcLen then exit;
if (Src[p]=':') and (p<SrcLen) and (Src[p+1]='=') then begin
// has value
HasValue:=true;
inc(p,2);
while (p<=SrcLen) and (IsSpaceChar[Src[p]]) do inc(p);
ValueStart:=p;
end;
end;
function TCompilerDirectivesTree.DefineUsesName(DefineNode: TCodeTreeNode;
Identifier: PChar): boolean;
var
p: LongInt;
begin
Result:=false;
p:=DefineNode.StartPos+2;
if p>SrcLen then exit;
// skip keyword
while (p<=SrcLen) and (IsIdentChar[Src[p]]) do inc(p);
while (p<=SrcLen) and (IsSpaceChar[Src[p]]) do inc(p);
// check name
if p>SrcLen then exit;
Result:=CompareIdentifierPtrs(@Src[p],Identifier)=0;
end;
function TCompilerDirectivesTree.NodeIsEmpty(Node: TCodeTreeNode;
IgnoreComments: boolean): boolean;
var
DirectiveEndPos: LongInt;
begin
if (Node=nil) then exit(true);
if Node.FirstChild<>nil then exit(false);
case Node.Desc of
cdnNone: exit(true);
cdnRoot: exit(false); // root is never empty, can not be deleted
cdnDefine: exit(true);
cdnIf,
cdnElseIf,
cdnElse:
begin
if Node.NextBrother=nil then exit(false); // maybe continued in another file
MoveCursorToPos(Node.StartPos);
// skip directive
ReadNextAtom;
DirectiveEndPos:=SrcPos;
// read the following atom (token or directive)
ReadNextAtom;
if AtomStart=Node.NextBrother.StartPos then begin
if IgnoreComments then
exit(true)
else if FindNextNonSpace(Src,DirectiveEndPos)<AtomStart then
exit(false)
else
exit(true);
end;
end;
cdnEnd: exit(false);
else exit(false);
end;
end;
function TCompilerDirectivesTree.FindNodeAtPos(p: integer): TCodeTreeNode;
begin
Result:=Tree.Root;
while Result<>nil do begin
if Result.StartPos>p then
exit(Result.Parent);
if (Result.EndPos>p)
or ((Result.EndPos=p) and (Result.NextBrother<>nil)
and (Result.NextBrother.StartPos>p))
then begin
// p is in range of Result => check children
if (Result.FirstChild=nil)
or (Result.FirstChild.StartPos>p) then
exit;
Result:=Result.FirstChild;
end else begin
// p is behind => next
if Result.NextBrother<>nil then
Result:=Result.NextBrother
else
exit(Result.Parent);
end;
end;
end;
procedure TCompilerDirectivesTree.MoveCursorToPos(p: integer);
begin
SrcPos:=p;
AtomStart:=p;
end;
procedure TCompilerDirectivesTree.ReadNextAtom;
begin
//DebugLn(['TCompilerDirectivesTree.ReadNextAtom START ',AtomStart,'-',SrcPos,' ',Src[SrcPos]]);
ReadRawNextPascalAtom(Src,SrcPos,AtomStart,NestedComments);
//DebugLn(['TCompilerDirectivesTree.ReadNextAtom END ',AtomStart,'-',SrcPos,' ',copy(Src,AtomStart,SrcPos-AtomStart)]);
end;
function TCompilerDirectivesTree.ReadTilBracketClose(CloseBracket: char
): boolean;
begin
Result:=false;
repeat
ReadNextAtom;
if AtomStart>SrcLen then exit;
if SrcPos-AtomStart=1 then begin
if Src[AtomStart]=CloseBracket then
exit(true)
else if Src[AtomStart]='(' then
ReadTilBracketClose(')')
else if Src[AtomStart]='[' then
ReadTilBracketClose(']');
end;
until false;
end;
function TCompilerDirectivesTree.AtomIs(const s: shortstring): boolean;
var
len: Integer;
i: Integer;
begin
len:=length(s);
if (len<>SrcPos-AtomStart) then exit(false);
if SrcPos>SrcLen then exit(false);
for i:=1 to len do
if Src[AtomStart+i-1]<>s[i] then exit(false);
Result:=true;
end;
function TCompilerDirectivesTree.UpAtomIs(const s: shortstring): boolean;
var
len: Integer;
i: Integer;
begin
len:=length(s);
if (len<>SrcPos-AtomStart) then exit(false);
if SrcPos>SrcLen then exit(false);
for i:=1 to len do
if UpChars[Src[AtomStart+i-1]]<>s[i] then exit(false);
Result:=true;
end;
function TCompilerDirectivesTree.AtomIsIdentifier: boolean;
var
p: Integer;
begin
if (AtomStart>=SrcPos) then exit(false);
if (SrcPos>SrcLen) or (SrcPos-AtomStart>255) then exit(false);
if not IsIdentStartChar[Src[AtomStart]] then exit(false);
p:=AtomStart+1;
while (p<SrcPos) do begin
if not IsIdentChar[Src[p]] then exit(false);
inc(p);
end;
Result:=true;
end;
function TCompilerDirectivesTree.GetAtom: string;
begin
Result:=copy(Src,AtomStart,SrcPos-AtomStart);
end;
procedure TCompilerDirectivesTree.Replace(FromPos, ToPos: integer;
const NewSrc: string);
var
Node: TCodeTreeNode;
DiffPos: Integer;
begin
//DebugLn(['TCompilerDirectivesTree.Replace ',FromPos,'-',ToPos,' Old="',copy(Src,FromPos,ToPos-FromPos),'" New="',NewSrc,'"']);
IncreaseChangeStep;
Code.Replace(FromPos,ToPos-FromPos,NewSrc);
Src:=Code.Source;
SrcLen:=length(Src);
// update positions
DiffPos:=length(NewSrc)-(ToPos-FromPos);
if DiffPos<>0 then begin
Node:=Tree.Root;
while Node<>nil do begin
AdjustPositionAfterInsert(Node.StartPos,true,FromPos,ToPos,DiffPos);
AdjustPositionAfterInsert(Node.EndPos,false,FromPos,ToPos,DiffPos);
Node:=Node.Next;
end;
end;
end;
procedure TCompilerDirectivesTree.IncreaseChangeStep;
begin
if FChangeStep<>$7fffffff then
inc(FChangeStep)
else
FChangeStep:=-$7fffffff;
end;
procedure TCompilerDirectivesTree.ResetMacros;
begin
if Macros<>nil then
Macros.FreeAndClear
else
Macros:=TAVLTree.Create(@CompareCompilerMacroStats);
end;
procedure TCompilerDirectivesTree.ClearMacros;
begin
if Macros<>nil then begin
Macros.FreeAndClear;
FreeAndNil(Macros);
end;
end;
procedure TCompilerDirectivesTree.WriteDebugReport;
var
Node: TCodeTreeNode;
begin
DebugLn(['TCompilerDirectivesTree.WriteDebugReport ']);
if Tree<>nil then begin
Node:=Tree.Root;
while Node<>nil do begin
DebugLn([GetIndentStr(Node.GetLevel*2)+CDNodeDescAsString(Node.Desc),' ',GetDirective(Node)]);
Node:=Node.Next;
end;
end;
end;
{ TH2PasFunction }
function TH2PasFunction.NeedsBody: boolean;
begin
Result:=(IsForward or InInterface) and (not IsExternal) and (BeginStart<0);
end;
procedure TH2PasFunction.AdjustPositionsAfterInsert(FromPos, ToPos,
DiffPos: integer);
begin
AdjustPositionAfterInsert(HeaderStart,true,FromPos,ToPos,DiffPos);
AdjustPositionAfterInsert(HeaderEnd,false,FromPos,ToPos,DiffPos);
AdjustPositionAfterInsert(BeginStart,true,FromPos,ToPos,DiffPos);
AdjustPositionAfterInsert(BeginEnd,false,FromPos,ToPos,DiffPos);
end;
{ ECDirectiveParserException }
constructor ECDirectiveParserException.Create(ASender: TCompilerDirectivesTree;
TheId: int64; const AMessage: string);
begin
Id:=TheId;
inherited Create(AMessage);
Sender:=ASender;
end;
end.