1 {
2 ***************************************************************************
3 * *
4 * This source is free software; you can redistribute it and/or modify *
5 * it under the terms of the GNU General Public License as published by *
6 * the Free Software Foundation; either version 2 of the License, or *
7 * (at your option) any later version. *
8 * *
9 * This code is distributed in the hope that it will be useful, but *
10 * WITHOUT ANY WARRANTY; without even the implied warranty of *
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
12 * General Public License for more details. *
13 * *
14 * A copy of the GNU General Public License is available on the World *
15 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
16 * obtain it by writing to the Free Software Foundation, *
17 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
18 * *
19 ***************************************************************************
20
21 Author: Mattias Gaertner
22
23 Abstract:
24 Functions to parse and edit compiler directives.
25 }
26 unit DirectivesTree;
27
28 {$ifdef FPC}{$mode objfpc}{$endif}{$H+}
29
30 { $DEFINE VerboseDisableUnreachableIFDEFs}
31
32 interface
33
34 {$I codetools.inc}
35
36 uses
37 {$IFDEF MEM_CHECK}
38 MemCheck,
39 {$ENDIF}
40 Classes, SysUtils, Laz_AVL_Tree,
41 // Codetools
42 FileProcs, BasicCodeTools, KeywordFuncLists, CodeCache, ExprEval, CodeTree;
43
44 type
45 TCompilerDirectiveNodeDesc = word;
46
47 const
48 // descriptors
49 cdnBase = 1000;
50 cdnNone = 0+cdnBase;
51
52 cdnRoot = 1+cdnBase;
53
54 cdnDefine = 11+cdnBase;
55 cdnInclude = 12+cdnBase;
56
57 cdnIf = 21+cdnBase;
58 cdnElseIf = 22+cdnBase;
59 cdnElse = 23+cdnBase;
60 cdnEnd = 24+cdnBase;
61
62 // sub descriptors
63 cdnsBase = 10000;
64 cdnsNone = 0+cdnsBase;
65
66 cdnsIfdef = 1+cdnsBase;
67 cdnsIfC = 2+cdnsBase;
68 cdnsIfndef = 3+cdnsBase;
69 cdnsIf = 4+cdnsBase;
70 cdnsIfOpt = 5+cdnsBase;
71 cdnsEndif = 11+cdnsBase;
72 cdnsEndC = 12+cdnsBase;
73 cdnsIfEnd = 13+cdnsBase;
74 cdnsElse = 21+cdnsBase;
75 cdnsElseC = 22+cdnsBase;
76 cdnsElseIf = 23+cdnsBase;
77 cdnsElIfC = 24+cdnsBase;
78 cdnsDefine = 31+cdnsBase;
79 cdnsUndef = 32+cdnsBase;
80 cdnsSetC = 33+cdnsBase;
81 cdnsInclude = 41+cdnsBase;
82 cdnsIncludePath = 42+cdnsBase;
83 cdnsShortSwitch = 51+cdnsBase;
84 cdnsLongSwitch = 52+cdnsBase;
85 cdnsMode = 53+cdnsBase;
86 cdnsThreading = 54+cdnsBase;
87 cdnsOther = 55+cdnsBase;
88
89 const
90 H2Pas_Function_Prefix = 'H2PAS_FUNCTION_';
91
92 type
93 TCompilerDirectivesTree = class;
94
95 { ECDirectiveParserException }
96
97 ECDirectiveParserException = class(Exception)
98 public
99 Sender: TCompilerDirectivesTree;
100 Id: int64;
101 constructor Create(ASender: TCompilerDirectivesTree; TheId: int64; const AMessage: string);
102 end;
103
104 TCompilerMacroStatus = (
105 cmsUnknown, // never seen
106 cmsDefined, // set to a specific value e.g. by $Define or by $IfDef
107 cmsUndefined, // undefined e.g. by $Undef
108 cmsComplex // value depends on complex expressions. e.g. {$if A or B}.
109 );
110
111 TCompilerMacroStats = class
112 public
113 Name: string;
114 Value: string;
115 Status: TCompilerMacroStatus;
116 LastDefineNode: TCodeTreeNode;// define or undef node
117 LastReadNode: TCodeTreeNode;// if node
118 end;
119
120 { TH2PasFunction }
121
122 TH2PasFunction = class
123 public
124 Name: string;
125 HeaderStart: integer;
126 HeaderEnd: integer;
127 BeginStart: integer;
128 BeginEnd: integer;
129 IsForward: boolean;
130 IsExternal: boolean;
131 InInterface: boolean;
132 DefNode: TH2PasFunction;// the corresponding node
133 function NeedsBody: boolean;
134 procedure AdjustPositionsAfterInsert(FromPos, ToPos, DiffPos: integer);
135 end;
136
137 { TCompilerDirectivesTree }
138
139 TCompilerDirectivesTree = class
140 private
141 FChangeStep: integer;
142 FDefaultDirectiveFuncList: TKeyWordFunctionList;
143 FDisableUnusedDefines: boolean;
144 FNestedComments: boolean;
145 FParseChangeStep: integer;
146 FRemoveDisabledDirectives: boolean;
147 FSimplifyExpressions: boolean;
148 FUndefH2PasFunctions: boolean;
149 FLastErrorMsg: string;
150 fLastErrorPos: integer;
151 fLastErrorXY: TPoint;
152 fLastErrorId: int64;
IfdefDirectivenull153 function IfdefDirective: boolean;
IfCDirectivenull154 function IfCDirective: boolean;
IfndefDirectivenull155 function IfndefDirective: boolean;
IfDirectivenull156 function IfDirective: boolean;
IfOptDirectivenull157 function IfOptDirective: boolean;
EndifDirectivenull158 function EndifDirective: boolean;
EndCDirectivenull159 function EndCDirective: boolean;
IfEndDirectivenull160 function IfEndDirective: boolean;
ElseDirectivenull161 function ElseDirective: boolean;
ElseCDirectivenull162 function ElseCDirective: boolean;
ElseIfDirectivenull163 function ElseIfDirective: boolean;
ElIfCDirectivenull164 function ElIfCDirective: boolean;
DefineDirectivenull165 function DefineDirective: boolean;
166 procedure SetNestedComments(AValue: boolean);
UndefDirectivenull167 function UndefDirective: boolean;
SetCDirectivenull168 function SetCDirective: boolean;
IncludeDirectivenull169 function IncludeDirective: boolean;
IncludePathDirectivenull170 function IncludePathDirective: boolean;
ShortSwitchDirectivenull171 function ShortSwitchDirective: boolean;
ReadNextSwitchDirectivenull172 function ReadNextSwitchDirective: boolean;
LongSwitchDirectivenull173 function LongSwitchDirective: boolean;
ModeDirectivenull174 function ModeDirective: boolean;
ThreadingDirectivenull175 function ThreadingDirective: boolean;
OtherDirectivenull176 function OtherDirective: boolean;
177 procedure InitKeyWordList;
178
179 procedure InitParser;
180 procedure CreateChildNode(Desc: TCompilerDirectiveNodeDesc;
181 SubDesc: TCompilerDirectiveNodeDesc = cdnNone);
182 procedure EndChildNode;
183 procedure EndIFNode(const ErrorMsg: string);
184
185 procedure InternalRemoveNode(Node: TCodeTreeNode);
186 procedure RaiseException(id: int64; const ErrorMsg: string);
187 procedure RaiseLastError;
188 public
189 Code: TCodeBuffer;
190 Src: string;
191 SrcLen: integer;
192 Tree: TCodeTree;
193 CurNode: TCodeTreeNode;
194 SrcPos: Integer;
195 AtomStart: integer;
196 Macros: TAVLTree;// tree of TCompilerMacroStats
197
198 constructor Create;
199 destructor Destroy; override;
200 procedure Clear;
201
202 // parsing
203 procedure Parse;
204 procedure Parse(aCode: TCodeBuffer; aNestedComments: boolean);
205 property NestedComments: boolean read FNestedComments write SetNestedComments;
206 property ParseChangeStep: integer read FParseChangeStep;
UpdateNeedednull207 function UpdateNeeded: boolean;
208 procedure MoveCursorToPos(p: integer);
209 procedure ReadNextAtom;
ReadTilBracketClosenull210 function ReadTilBracketClose(CloseBracket: char): boolean;
AtomIsnull211 function AtomIs(const s: shortstring): boolean;
UpAtomIsnull212 function UpAtomIs(const s: shortstring): boolean;
AtomIsIdentifiernull213 function AtomIsIdentifier: boolean;
GetAtomnull214 function GetAtom: string;
215
216 // errors
217 property ErrorMsg: string read FLastErrorMsg;
218 property ErrorPos: integer read fLastErrorPos;
219 property ErrorLine: integer read fLastErrorXY.Y;
220 property ErrorColumn: integer read fLastErrorXY.X;
221 property ErrorId: int64 read fLastErrorId;
SrcPosToStrnull222 function SrcPosToStr(p: integer; WithFilename: boolean = false): string;
223
224 // search
FindResourceDirectivenull225 function FindResourceDirective(const Filename: string = '';
226 StartPos: integer = 1): TCodeTreeNode;
IsResourceDirectivenull227 function IsResourceDirective(Node: TCodeTreeNode;
228 const Filename: string = ''): boolean;
229
FindIncludeDirectivenull230 function FindIncludeDirective(const Filename: string = '';
231 StartPos: integer = 1): TCodeTreeNode;
IsIncludeDirectivenull232 function IsIncludeDirective(Node: TCodeTreeNode;
233 const Filename: string = ''): boolean;
234
235 // explore
GetDirectiveNamenull236 function GetDirectiveName(Node: TCodeTreeNode): string;
GetDirectivenull237 function GetDirective(Node: TCodeTreeNode): string;
GetIfExpressionnull238 function GetIfExpression(Node: TCodeTreeNode;
239 out ExprStart, ExprEnd: integer): boolean;
GetIfExpressionStringnull240 function GetIfExpressionString(Node: TCodeTreeNode): string;
IsIfExpressionSimplenull241 function IsIfExpressionSimple(Node: TCodeTreeNode; out NameStart: integer
242 ): boolean;
FindNameInIfExpressionnull243 function FindNameInIfExpression(Node: TCodeTreeNode; Identifier: PChar
244 ): integer;
GetDefineNameAndValuenull245 function GetDefineNameAndValue(DefineNode: TCodeTreeNode;
246 out NameStart: integer; out HasValue: boolean; out ValueStart: integer
247 ): boolean;
DefineUsesNamenull248 function DefineUsesName(DefineNode: TCodeTreeNode;
249 Identifier: PChar): boolean;
NodeIsEmptynull250 function NodeIsEmpty(Node: TCodeTreeNode; IgnoreComments: boolean = true): boolean;
FindNodeAtPosnull251 function FindNodeAtPos(p: integer): TCodeTreeNode;
NodeStartToCodePosnull252 function NodeStartToCodePos(Node: TCodeTreeNode;
253 out CodePos: TCodeXYPosition): boolean;
254
255 // refactoring
256 procedure ReduceCompilerDirectives(Undefines, Defines: TStrings;
257 var Changed: boolean);
258 procedure GatherH2PasFunctions(out ListOfH2PasFunctions: TFPList;
259 FindDefNodes: boolean);
260 procedure FixMissingH2PasDirectives(var Changed: boolean);
261
262 procedure CheckAndImproveExpr_Brackets(Node: TCodeTreeNode;
263 var Changed: boolean);
264 procedure CheckAndImproveExpr_IfDefinedMacro(Node: TCodeTreeNode;
265 var Changed: boolean);
266 procedure DisableAllUnusedDefines(var Changed: boolean);
267 procedure MoveIfNotThenDefsUp(var Changed: boolean);
268 procedure DisableUnreachableBlocks(Undefines, Defines: TStrings;
269 var Changed: boolean);
270 procedure DisableNode(Node: TCodeTreeNode; var Changed: boolean;
271 WithContent: boolean);
272 procedure DisableDefineNode(Node: TCodeTreeNode; var Changed: boolean);
273 procedure DisableIfNode(Node: TCodeTreeNode; WithContent: boolean;
274 var Changed: boolean);
InsertDefinenull275 function InsertDefine(Position: integer; const NewSrc: string;
276 SubDesc: TCompilerDirectiveNodeDesc): TCodeTreeNode;
277 procedure RemoveEmptyNodes(var Changed: boolean);
278
279
280 procedure Replace(FromPos, ToPos: integer; const NewSrc: string);
281
282 procedure IncreaseChangeStep;
283 procedure ResetMacros;
284 procedure ClearMacros;
285 procedure WriteDebugReport;
286 public
287 property SimplifyExpressions: boolean read FSimplifyExpressions
288 write FSimplifyExpressions;
289 property DisableUnusedDefines: boolean read FDisableUnusedDefines
290 write FDisableUnusedDefines;
291 property RemoveDisabledDirectives: boolean read FRemoveDisabledDirectives
292 write FRemoveDisabledDirectives;
293 property UndefH2PasFunctions: boolean read FUndefH2PasFunctions
294 write FUndefH2PasFunctions;
295 property ChangeStep: integer read FChangeStep;
296 end;
297
CompareCompilerMacroStatsnull298 function CompareCompilerMacroStats(Data1, Data2: Pointer): integer;
ComparePCharWithCompilerMacroStatsnull299 function ComparePCharWithCompilerMacroStats(Name, MacroStats: Pointer): integer;
CompareH2PasFuncByNameAndPosnull300 function CompareH2PasFuncByNameAndPos(Data1, Data2: Pointer): integer;
ComparePCharWithH2PasFuncNamenull301 function ComparePCharWithH2PasFuncName(Name, H2PasFunc: Pointer): integer;
302
CDNodeDescAsStringnull303 function CDNodeDescAsString(Desc: TCompilerDirectiveNodeDesc): string;
CDNodeSubDescAsStringnull304 function CDNodeSubDescAsString(Desc: TCompilerDirectiveNodeDesc): string;
305
306 implementation
307
308 type
309 TDefineStatus = (
310 dsUnknown,
311 dsDefined,
312 dsNotDefined
313 );
314
315 TDefineValue = class
316 Name: string;
317 Status: TDefineStatus;
318 Value: string;
319 end;
320
321 {$IFDEF VerboseDisableUnreachableIFDEFs}
322 const
323 DefineStatusNames: array[TDefineStatus] of string = (
324 'dsUnknown','dsDefined','dsNotDefined'
325 );
326 {$ENDIF}
327
CompareDefineValuesnull328 function CompareDefineValues(Data1, Data2: Pointer): integer;
329 begin
330 Result:=CompareIdentifierPtrs(Pointer(TDefineValue(Data1).Name),
331 Pointer(TDefineValue(Data2).Name));
332 end;
333
ComparePCharWithDefineValuenull334 function ComparePCharWithDefineValue(Name, DefValue: Pointer): integer;
335 begin
336 Result:=CompareIdentifierPtrs(Name,
337 Pointer(TDefineValue(DefValue).Name));
338 end;
339
CompareCompilerMacroStatsnull340 function CompareCompilerMacroStats(Data1, Data2: Pointer): integer;
341 begin
342 Result:=CompareIdentifierPtrs(Pointer(TCompilerMacroStats(Data1).Name),
343 Pointer(TCompilerMacroStats(Data2).Name));
344 end;
345
ComparePCharWithCompilerMacroStatsnull346 function ComparePCharWithCompilerMacroStats(Name, MacroStats: Pointer): integer;
347 begin
348 Result:=CompareIdentifierPtrs(Name,
349 Pointer(TCompilerMacroStats(MacroStats).Name));
350 end;
351
CompareH2PasFuncByNameAndPosnull352 function CompareH2PasFuncByNameAndPos(Data1, Data2: Pointer): integer;
353 var
354 F1: TH2PasFunction;
F2null355 F2: TH2PasFunction;
356 begin
ata1null357 F1:=TH2PasFunction(Data1);
ata2null358 F2:=TH2PasFunction(Data2);
359 Result:=CompareIdentifierPtrs(Pointer(F1.Name),Pointer(F2.Name));
360 if Result<>0 then exit;
361 if F1.HeaderStart>F2.HeaderStart then
362 exit(1)
363 else if F1.HeaderStart<F2.HeaderStart then
364 exit(-1)
365 else
366 exit(0);
367 end;
368
ComparePCharWithH2PasFuncNamenull369 function ComparePCharWithH2PasFuncName(Name, H2PasFunc: Pointer): integer;
370 begin
2PasFuncnull371 Result:=CompareIdentifierPtrs(Name,Pointer(TH2PasFunction(H2PasFunc).Name));
372 end;
373
CDNodeDescAsStringnull374 function CDNodeDescAsString(Desc: TCompilerDirectiveNodeDesc): string;
375 begin
376 case Desc of
377 cdnNone : Result:='None';
378
379 cdnRoot : Result:='Root';
380
381 cdnDefine : Result:='Define';
382
383 cdnIf : Result:='If';
384 cdnElseIf : Result:='ElseIf';
385 cdnElse : Result:='Else';
386 cdnEnd : Result:='End';
387 else Result:='?';
388 end;
389 end;
390
CDNodeSubDescAsStringnull391 function CDNodeSubDescAsString(Desc: TCompilerDirectiveNodeDesc): string;
392 begin
393 case Desc of
394 cdnsIfdef : Result:='IfDef';
395 cdnsIfC : Result:='IfC';
396 cdnsIfndef : Result:='IfNDef';
397 cdnsIf : Result:='If';
398 cdnsIfOpt : Result:='IfOpt';
399 cdnsEndif : Result:='EndIf';
400 cdnsEndC : Result:='EndC';
401 cdnsIfEnd : Result:='IfEnd';
402 cdnsElse : Result:='Else';
403 cdnsElseC : Result:='ElseC';
404 cdnsElseIf : Result:='ElseIf';
405 cdnsElIfC : Result:='ElIfC';
406 cdnsDefine : Result:='Define';
407 cdnsUndef : Result:='UnDef';
408 cdnsSetC : Result:='SetC';
409 cdnsInclude : Result:='Include';
410 cdnsIncludePath : Result:='IncludePath';
411 cdnsShortSwitch : Result:='ShortSwitch';
412 cdnsLongSwitch : Result:='LongSwitch';
413 cdnsMode : Result:='Mode';
414 cdnsThreading : Result:='Threading';
415 cdnsOther : Result:='Other';
416 else Result:='?';
417 end;
418 end;
419
420
421 { TCompilerDirectivesTree }
422
IfdefDirectivenull423 function TCompilerDirectivesTree.IfdefDirective: boolean;
424 // example: {$IFDEF macroname}
425 begin
426 Result:=true;
427 CreateChildNode(cdnIf,cdnsIfdef);
428 end;
429
TCompilerDirectivesTree.IfCDirectivenull430 function TCompilerDirectivesTree.IfCDirective: boolean;
431 // example: {$IFC expression}
432 begin
433 Result:=true;
434 CreateChildNode(cdnIf,cdnsIfC);
435 end;
436
IfndefDirectivenull437 function TCompilerDirectivesTree.IfndefDirective: boolean;
438 // example: {$IFNDEF macroname}
439 begin
440 Result:=true;
441 CreateChildNode(cdnIf,cdnsIfndef);
442 end;
443
TCompilerDirectivesTree.IfDirectivenull444 function TCompilerDirectivesTree.IfDirective: boolean;
445 // example: {$IF expression}
446 begin
447 Result:=true;
448 CreateChildNode(cdnIf,cdnsIf);
449 end;
450
TCompilerDirectivesTree.IfOptDirectivenull451 function TCompilerDirectivesTree.IfOptDirective: boolean;
452 // {$ifopt o+} or {$ifopt o-}
453 begin
454 Result:=true;
455 CreateChildNode(cdnIf,cdnsIfOpt);
456 end;
457
TCompilerDirectivesTree.EndifDirectivenull458 function TCompilerDirectivesTree.EndifDirective: boolean;
459 // example: {$ENDIF comment}
460 begin
461 Result:=true;
462 EndIFNode('EndIf without IfDef');
463 CreateChildNode(cdnEnd,cdnsEndif);
464 AtomStart:=SrcPos;
465 EndChildNode;
466 end;
467
EndCDirectivenull468 function TCompilerDirectivesTree.EndCDirective: boolean;
469 // example: {$ENDC comment}
470 begin
471 Result:=true;
472 EndIFNode('EndC without IfC');
473 CreateChildNode(cdnEnd,cdnsEndC);
474 AtomStart:=SrcPos;
475 EndChildNode;
476 end;
477
TCompilerDirectivesTree.IfEndDirectivenull478 function TCompilerDirectivesTree.IfEndDirective: boolean;
479 // {$IfEnd comment}
480 begin
481 Result:=true;
482 EndIFNode('IfEnd without IfDef');
483 CreateChildNode(cdnEnd,cdnsIfEnd);
484 AtomStart:=SrcPos;
485 EndChildNode;
486 end;
487
TCompilerDirectivesTree.ElseDirectivenull488 function TCompilerDirectivesTree.ElseDirective: boolean;
489 // {$Else comment}
490 begin
491 Result:=true;
492 EndIFNode('Else without IfDef');
493 CreateChildNode(cdnElse,cdnsElse);
494 end;
495
ElseCDirectivenull496 function TCompilerDirectivesTree.ElseCDirective: boolean;
497 // {$elsec comment}
498 begin
499 Result:=true;
500 EndIFNode('ElseC without IfC');
501 CreateChildNode(cdnElse,cdnsElseC);
502 end;
503
TCompilerDirectivesTree.ElseIfDirectivenull504 function TCompilerDirectivesTree.ElseIfDirective: boolean;
505 // {$elseif expression}
506 begin
507 Result:=true;
508 EndIFNode('ElseIf without IfDef');
509 CreateChildNode(cdnElseIf,cdnsElseIf);
510 end;
511
ElIfCDirectivenull512 function TCompilerDirectivesTree.ElIfCDirective: boolean;
513 // {$elifc expression}
514 begin
515 Result:=true;
516 EndIFNode('ElIfC without IfC');
517 CreateChildNode(cdnElseIf,cdnsElIfC);
518 end;
519
TCompilerDirectivesTree.DefineDirectivenull520 function TCompilerDirectivesTree.DefineDirective: boolean;
521 // {$define name} or {$define name:=value}
522 begin
523 Result:=true;
524 CreateChildNode(cdnDefine,cdnsDefine);
525 AtomStart:=SrcPos;
526 EndChildNode;
527 end;
528
529 procedure TCompilerDirectivesTree.SetNestedComments(AValue: boolean);
530 begin
531 if FNestedComments=AValue then Exit;
532 FNestedComments:=AValue;
533 FParseChangeStep:=CTInvalidChangeStamp;
534 IncreaseChangeStep;
535 end;
536
UndefDirectivenull537 function TCompilerDirectivesTree.UndefDirective: boolean;
538 // {$undefine macroname}
539 begin
540 Result:=true;
541 CreateChildNode(cdnDefine,cdnsUndef);
542 AtomStart:=SrcPos;
543 EndChildNode;
544 end;
545
SetCDirectivenull546 function TCompilerDirectivesTree.SetCDirective: boolean;
547 // {$setc macroname} or {$setc macroname:=value}
548 begin
549 Result:=true;
550 CreateChildNode(cdnDefine,cdnsSetC);
551 AtomStart:=SrcPos;
552 EndChildNode;
553 end;
554
TCompilerDirectivesTree.IncludeDirectivenull555 function TCompilerDirectivesTree.IncludeDirective: boolean;
556 begin
557 Result:=true;
558 CreateChildNode(cdnInclude,cdnsInclude);
559 AtomStart:=SrcPos;
560 EndChildNode;
561 end;
562
IncludePathDirectivenull563 function TCompilerDirectivesTree.IncludePathDirective: boolean;
564 // {$includepath path_addition}
565 begin
566 Result:=true;
567 end;
568
TCompilerDirectivesTree.ShortSwitchDirectivenull569 function TCompilerDirectivesTree.ShortSwitchDirective: boolean;
570 // example: {$H+} or {$H+, R- comment}
571 begin
572 Result:=true;
573 if Src[AtomStart+3] in ['+','-'] then
574 CreateChildNode(cdnDefine,cdnsShortSwitch)
575 else begin
576 if (Src[AtomStart+2] in ['I','i']) then
577 CreateChildNode(cdnInclude,cdnsInclude)
578 else
579 CreateChildNode(cdnDefine,cdnsOther);
580 end;
581 AtomStart:=SrcPos;
582 EndChildNode;
583 end;
584
ReadNextSwitchDirectivenull585 function TCompilerDirectivesTree.ReadNextSwitchDirective: boolean;
586 begin
587 Result:=true;
588 end;
589
LongSwitchDirectivenull590 function TCompilerDirectivesTree.LongSwitchDirective: boolean;
591 // example: {$ASSERTIONS ON comment}
592 begin
593 Result:=true;
594 CreateChildNode(cdnDefine,cdnsLongSwitch);
595 AtomStart:=SrcPos;
596 EndChildNode;
597 end;
598
ModeDirectivenull599 function TCompilerDirectivesTree.ModeDirective: boolean;
600 // example: {$MODE ObjFPC comment}
601 begin
602 Result:=true;
603 CreateChildNode(cdnDefine,cdnsMode);
604 AtomStart:=SrcPos;
605 EndChildNode;
606 end;
607
TCompilerDirectivesTree.ThreadingDirectivenull608 function TCompilerDirectivesTree.ThreadingDirective: boolean;
609 // example: {$threading on}
610 begin
611 Result:=true;
612 CreateChildNode(cdnDefine,cdnsThreading);
613 AtomStart:=SrcPos;
614 EndChildNode;
615 end;
616
OtherDirectivenull617 function TCompilerDirectivesTree.OtherDirective: boolean;
618 begin
619 Result:=true;
620 CreateChildNode(cdnDefine,cdnsOther);
621 AtomStart:=SrcPos;
622 EndChildNode;
623 end;
624
625 procedure TCompilerDirectivesTree.InitKeyWordList;
626 var
627 c: Char;
628 begin
629 if FDefaultDirectiveFuncList=nil then begin
630 FDefaultDirectiveFuncList:=TKeyWordFunctionList.Create('TCompilerDirectivesTree.DefaultDirectiveFuncList');
631 with FDefaultDirectiveFuncList do begin
632 for c:='A' to 'Z' do begin
633 if CompilerSwitchesNames[c]<>'' then begin
634 Add(c,{$ifdef FPC}@{$endif}ShortSwitchDirective);
635 Add(CompilerSwitchesNames[c],{$ifdef FPC}@{$endif}LongSwitchDirective);
636 end;
637 end;
638 Add('IFDEF',{$ifdef FPC}@{$endif}IfdefDirective);
639 Add('IFC',{$ifdef FPC}@{$endif}IfCDirective);
640 Add('IFNDEF',{$ifdef FPC}@{$endif}IfndefDirective);
641 Add('IF',{$ifdef FPC}@{$endif}IfDirective);
642 Add('IFOPT',{$ifdef FPC}@{$endif}IfOptDirective);
643 Add('ENDIF',{$ifdef FPC}@{$endif}EndIfDirective);
644 Add('ENDC',{$ifdef FPC}@{$endif}EndCDirective);
645 Add('ELSE',{$ifdef FPC}@{$endif}ElseDirective);
646 Add('ELSEC',{$ifdef FPC}@{$endif}ElseCDirective);
647 Add('ELSEIF',{$ifdef FPC}@{$endif}ElseIfDirective);
648 Add('ELIFC',{$ifdef FPC}@{$endif}ElIfCDirective);
649 Add('IFEND',{$ifdef FPC}@{$endif}IfEndDirective);
650 Add('DEFINE',{$ifdef FPC}@{$endif}DefineDirective);
651 Add('UNDEF',{$ifdef FPC}@{$endif}UndefDirective);
652 Add('SETC',{$ifdef FPC}@{$endif}SetCDirective);
653 Add('INCLUDE',{$ifdef FPC}@{$endif}IncludeDirective);
654 Add('INCLUDEPATH',{$ifdef FPC}@{$endif}IncludePathDirective);
655 Add('MODE',{$ifdef FPC}@{$endif}ModeDirective);
656 Add('THREADING',{$ifdef FPC}@{$endif}ThreadingDirective);
657 DefaultKeyWordFunction:={$ifdef FPC}@{$endif}OtherDirective;
658 end;
659 end;
660 end;
661
662 procedure TCompilerDirectivesTree.InitParser;
663 begin
664 FParseChangeStep:=Code.ChangeStep;
665 IncreaseChangeStep;
666 InitKeyWordList;
667 Src:=Code.Source;
668 SrcLen:=length(Src);
669 if Tree=nil then
670 Tree:=TCodeTree.Create
671 else
672 Tree.Clear;
673 SrcPos:=1;
674 AtomStart:=1;
675 CurNode:=nil;
676 CreateChildNode(cdnRoot);
677 end;
678
679 procedure TCompilerDirectivesTree.CreateChildNode(
680 Desc: TCompilerDirectiveNodeDesc;
681 SubDesc: TCompilerDirectiveNodeDesc);
682 var NewNode: TCodeTreeNode;
683 begin
684 NewNode:=TCodeTreeNode.Create;
685 Tree.AddNodeAsLastChild(CurNode,NewNode);
686 NewNode.Desc:=Desc;
687 NewNode.SubDesc:=SubDesc;
688 CurNode:=NewNode;
689 CurNode.StartPos:=AtomStart;
690 //DebugLn([GetIndentStr(CurNode.GetLevel*2),'TCompilerDirectivesTree.CreateChildNode ']);
691 end;
692
693 procedure TCompilerDirectivesTree.EndChildNode;
694 begin
695 //DebugLn([GetIndentStr(CurNode.GetLevel*2),'TCompilerDirectivesTree.EndChildNode ']);
696 CurNode.EndPos:=AtomStart;
697 CurNode:=CurNode.Parent;
698 end;
699
700 procedure TCompilerDirectivesTree.EndIFNode(const ErrorMsg: string);
701 begin
702 if (CurNode.Desc<>cdnIf) and (CurNode.Desc<>cdnElse)
703 and (CurNode.Desc<>cdnElseIf) then
704 RaiseException(20170422131836,ErrorMsg);
705 EndChildNode;
706 end;
707
708 procedure TCompilerDirectivesTree.CheckAndImproveExpr_Brackets(
709 Node: TCodeTreeNode; var Changed: boolean);
710 // improve (MacroName) to MacroName
711 var
712 ExprStart: integer;
713 ExprEnd: integer;
714 NameStart: LongInt;
715 FromPos: LongInt;
716 ToPos: LongInt;
717 begin
718 if not SimplifyExpressions then exit;
719 if (Node.SubDesc<>cdnsIf) and (Node.SubDesc<>cdnElseIf) then exit;
720 if not GetIfExpression(Node,ExprStart,ExprEnd) then exit;
721
722 // improve (MacroName) to MacroName
723 MoveCursorToPos(ExprStart);
724 repeat
725 ReadNextAtom;
726 if UpAtomIs('DEFINED') then begin
definednull727 // the function defined(): skip keyword and bracket
728 ReadNextAtom;
729 ReadNextAtom;
730 end;
731 if AtomIs('(') then begin
732 FromPos:=AtomStart;
733 ReadNextAtom;
734 if AtomIsIdentifier then begin
735 NameStart:=AtomStart;
736 ReadNextAtom;
737 if AtomIs(')') then begin
738 ToPos:=SrcPos;
739 DebugLn(['TCompilerDirectivesTree.CheckAndImproveExpr_Brackets removing unneeded brackets']);
740 Changed:=true;
741 Replace(FromPos,ToPos,GetIdentifier(@Src[NameStart]));
742 MoveCursorToPos(FromPos);
743 end;
744 end;
745 end;
746 until SrcPos>=ExprEnd;
747 end;
748
749 procedure TCompilerDirectivesTree.CheckAndImproveExpr_IfDefinedMacro(
750 Node: TCodeTreeNode; var Changed: boolean);
751 // check if {$IF defined(MacroName)}
752 // or {$IF !defined(MacroName)}
753 // or {$IF not defined(MacroName)}
754 // or {$IF not (defined(MacroName))}
755 var
756 ExprStart: integer;
757 ExprEnd: integer;
758 MacroNameStart: LongInt;
759 Negated: Boolean;
760 NewDirective: String;
761 BracketLvl: Integer;
762 begin
763 if not SimplifyExpressions then exit;
764 if (Node.SubDesc<>cdnsIf) then exit;
765 if not GetIfExpression(Node,ExprStart,ExprEnd) then exit;
766 Negated:=false;
767 MoveCursorToPos(ExprStart);
768 ReadNextAtom;
769 if UpAtomIs('NOT') or AtomIs('!') then begin
770 Negated:=true;
771 ReadNextAtom;
772 end;
773 BracketLvl:=0;
774 while AtomIs('(') do begin
775 inc(BracketLvl);
776 ReadNextAtom;
777 end;
778 if not UpAtomIs('DEFINED') then exit;
779 ReadNextAtom;
780 if not AtomIs('(') then exit;
781 inc(BracketLvl);
782 ReadNextAtom;
783 if not AtomIsIdentifier then exit;
784 MacroNameStart:=AtomStart;
785 ReadNextAtom;
786 while AtomIs(')') do begin
787 dec(BracketLvl);
788 ReadNextAtom;
789 end;
790 if BracketLvl>0 then exit;
791 if SrcPos<=ExprEnd then exit;
792
793 if Negated then
794 NewDirective:='IFNDEF'
795 else
796 NewDirective:='IFDEF';
797 NewDirective:='{$'+NewDirective+' '+GetIdentifier(@Src[MacroNameStart])+'}';
798
799 DebugLn(['TCompilerDirectivesTree.CheckAndImproveExpr_IfDefinedMacro simplifying expression']);
800 Replace(Node.StartPos,FindCommentEnd(Src,Node.StartPos,NestedComments),NewDirective);
801 if Negated then
802 Node.SubDesc:=cdnsIfNdef
803 else
804 Node.SubDesc:=cdnsIfdef;
805
806 Changed:=true;
807 end;
808
809 procedure TCompilerDirectivesTree.DisableAllUnusedDefines(var Changed: boolean);
810 var
811 AVLNode: TAVLTreeNode;
812 MacroNode: TCompilerMacroStats;
813 NextAVLNode: TAVLTreeNode;
814 begin
815 if Macros=nil then exit;
816 if not DisableUnusedDefines then exit;
817 AVLNode:=Macros.FindLowest;
818 while AVLNode<>nil do begin
819 NextAVLNode:=Macros.FindSuccessor(AVLNode);
820 MacroNode:=TCompilerMacroStats(AVLNode.Data);
821 if (MacroNode.LastDefineNode<>nil)
822 and (MacroNode.LastReadNode=nil) then begin
823 // this Define/Undef is not used
824 DebugLn(['TCompilerDirectivesTree.DisableAllUnusedDefines']);
825 DisableDefineNode(MacroNode.LastDefineNode,Changed);
826 end;
827 AVLNode:=NextAVLNode;
828 end;
829 end;
830
831 procedure TCompilerDirectivesTree.MoveIfNotThenDefsUp(var Changed: boolean);
832 (* 1. Search for
833 {$IFNDEF Name}
834 {$DEFINE Name}
835 .. name is not used here ..
836 {$ENDIF}
837
838 And move the define behind the IF block
839
840 2. And check for
841 {$IFDEF Name}
842 .. name is not set here ..
843 {$DEFINE Name}
844 {$ENDIF}
845
846 And remove the define
847 *)
848
IdentifierIsReadAfterNodenull849 function IdentifierIsReadAfterNode(Identifier: PChar;
850 StartNode: TCodeTreeNode): boolean;
851 var
852 Node: TCodeTreeNode;
853 ParentNode: TCodeTreeNode;
854 begin
855 Node:=StartNode;
856 while Node<>nil do begin
857 case Node.Desc of
858 cdnIf,cdnElseIf:
859 if FindNameInIfExpression(Node,Identifier)>0 then begin
860 exit(true);
861 end;
862 cdnDefine:
863 if DefineUsesName(Node,Identifier) then begin
864 ParentNode:=StartNode;
865 while (ParentNode<>nil) do begin
866 if ParentNode=Node.Parent then exit(false);
867 ParentNode:=ParentNode.Parent;
868 end;
869 end;
870 end;
871 Node:=Node.Next;
872 end;
873 Result:=false;
874 end;
875
876 var
877 Node: TCodeTreeNode;
878 NextNode: TCodeTreeNode;
879 SubNode: TCodeTreeNode;
880 NameStart: integer;
881 LastDefineNode: TCodeTreeNode;
882 LastIFNode: TCodeTreeNode;
883 NextSubNode: TCodeTreeNode;
884 EndNode: TCodeTreeNode;
885 InsertPos: LongInt;
886 NewSrc: String;
887 LastChildDefineNode: TCodeTreeNode;
888 begin
889 Node:=Tree.Root;
890 while Node<>nil do begin
891 NextNode:=Node.Next;
892 if ((Node.Desc=cdnIf) or (Node.Desc=cdnElseIf))
893 and IsIfExpressionSimple(Node,NameStart) then begin
894 // an IF with a single test
895 LastIFNode:=nil;
896 LastDefineNode:=nil;
897 LastChildDefineNode:=nil;
898 SubNode:=Node.FirstChild;
899 while (SubNode<>nil) and (SubNode.HasAsParent(Node)) do begin
900 NextSubNode:=SubNode.Next;
901 case SubNode.Desc of
902
903 cdnIf, cdnElseIf:
904 if FindNameInIfExpression(SubNode,@Src[NameStart])>0 then begin
905 // this sub IF block uses the macro
906 LastIFNode:=SubNode;
907 end;
908
909 cdnDefine:
910 if ((SubNode.SubDesc=cdnsDefine) or (SubNode.SubDesc=cdnsUndef))
911 and DefineUsesName(SubNode,@Src[NameStart]) then begin
912 // this sub Define/Undef sets the macro
913 if (LastIFNode=nil) and (LastDefineNode=nil) then begin
914 (* This is
915 {$IF(N)DEF Name}
916 ... Name not used ...
917 {$DEFINE|UNDEF Name}
918 *)
919 if (Node.SubDesc=cdnsIfndef) = (SubNode.SubDesc=cdnsUndef) then
920 begin
921 { this is
922 IFNDEF then UNDEF
923 or IFDEF then DEFINE
924 -> remove define
925 }
926 NextSubNode:=SubNode.NextSkipChilds;
927 DebugLn(['TCompilerDirectivesTree.MoveIfNotThenDefsUp IFDEF + DEFINE => the define is not needed']);
928 if NextNode=SubNode then
929 NextNode:=NextNode.NextSkipChilds;
930 DisableDefineNode(SubNode,Changed);
931 SubNode:=nil;
932 end;
933 end;
934 if SubNode<>nil then begin
935 LastDefineNode:=SubNode;
936 LastIFNode:=nil;
937 if SubNode.Parent=Node then begin
938 // this define is valid for end of the IF block
939 LastChildDefineNode:=SubNode;
940 end else if (LastChildDefineNode<>nil)
941 and (LastChildDefineNode.SubDesc<>SubNode.SubDesc) then begin
942 // this sub define can cancel the higher level define
943 LastChildDefineNode:=nil;
944 end;
945 end;
946 end;
947 end;
948 SubNode:=NextSubNode;
949 end;
950
951 if (LastChildDefineNode<>nil) then begin
952 (* this is
953 {$IFNDEF Name}
954 ...
955 {$DEFINE Name}
956 ... Name only read ...
957 {$ENDIF}
958
959 or IFDEF and UNDEF
960 -> move define behind IF block
961 *)
962 EndNode:=Node;
963 while (EndNode<>nil) and (EndNode.Desc<>cdnEnd) do
964 EndNode:=EndNode.NextBrother;
965 if (EndNode<>nil)
966 and IdentifierIsReadAfterNode(@Src[NameStart],EndNode) then begin
967 InsertPos:=FindLineEndOrCodeAfterPosition(Src,EndNode.EndPos,SrcLen,
968 NestedComments);
969 NewSrc:=LineEnding+GetDirective(LastDefineNode);
970 DebugLn(['TCompilerDirectivesTree.MoveIfNotThenDefsUp IFNDEF + DEFINE => add define after block']);
971 InsertDefine(InsertPos,NewSrc,LastDefineNode.SubDesc);
972 if (LastDefineNode=LastChildDefineNode)
973 and (LastIFNode=nil) then begin
974 // the name was not read after it was set -> disable the define
975 // in the block
976 DebugLn(['TCompilerDirectivesTree.MoveIfNotThenDefsUp old DEFINE is not needed anymore']);
977 if NextNode=LastDefineNode then
978 NextNode:=NextNode.NextSkipChilds;
979 DisableDefineNode(LastDefineNode,Changed);
980 end;
981 end;
982 end;
983 end;
984 Node:=NextNode;
985 end;
986 end;
987
988 procedure TCompilerDirectivesTree.DisableUnreachableBlocks(Undefines,
989 Defines: TStrings; var Changed: boolean);
990 type
991 PDefineChange = ^TDefineChange;
992 TDefineChange = record
993 Name: string;
994 OldStatus: TDefineStatus;
995 Next: PDefineChange;
996 end;
997
998 var
999 CurDefines: TAVLTree;
1000 Stack: array of PDefineChange;// stack of lists of PDefineChange
1001 StackPointer: integer;
1002
1003 procedure InitStack;
1004 begin
1005 SetLength(Stack,1);
1006 StackPointer:=0;
1007 Stack[0]:=nil;
1008 end;
1009
1010 procedure FreeStack;
1011 var
1012 i: Integer;
1013 Item: PDefineChange;
1014 DeleteItem: PDefineChange;
1015 begin
1016 for i:=0 to StackPointer do begin
1017 Item:=Stack[i];
1018 while Item<>nil do begin
1019 DeleteItem:=Item;
1020 Item:=DeleteItem^.Next;
1021 Dispose(DeleteItem);
1022 end;
1023 end;
1024 Setlength(Stack,0);
1025 end;
1026
1027 procedure AddStackChange(const MacroName: string; OldStatus: TDefineStatus);
1028 var
1029 Change: PDefineChange;
1030 begin
1031 {$IFDEF VerboseDisableUnreachableIFDEFs}
1032 DebugLn(['AddStackChange ',MacroName,' ',DefineStatusNames[OldStatus]]);
1033 {$ENDIF}
1034 // check if MacroName was already changed
1035 Change:=Stack[StackPointer];
1036 while (Change<>nil) do begin
1037 if (CompareIdentifierPtrs(Pointer(MacroName),Pointer(Change^.Name))=0)
1038 then begin
1039 // old status is already saved
1040 exit;
1041 end;
1042 Change:=Change^.Next;
1043 end;
1044
1045 {$IFDEF VerboseDisableUnreachableIFDEFs}
1046 DebugLn(['AddStackChange ADD ',MacroName,' ',DefineStatusNames[OldStatus]]);
1047 {$ENDIF}
1048 New(Change);
1049 FillChar(Change^,SizeOf(TDefineChange),0);
1050 Change^.Name:=MacroName;
1051 Change^.OldStatus:=OldStatus;
1052 Change^.Next:=Stack[StackPointer];
1053 Stack[StackPointer]:=Change;
1054 end;
1055
GetStatusnull1056 function GetStatus(Identifier: PChar): TDefineStatus;
1057 var
1058 AVLNode: TAVLTreeNode;
1059 begin
1060 AVLNode:=CurDefines.FindKey(Identifier,@ComparePCharWithDefineValue);
1061 if AVLNode<>nil then
1062 Result:=TDefineValue(AVLNode.Data).Status
1063 else
1064 Result:=dsUnknown;
1065 end;
1066
1067 procedure SetStatus(Identifier: PChar; NewStatus: TDefineStatus;
1068 SaveOnStack, SetGlobal: boolean);
1069 var
1070 AVLNode: TAVLTreeNode;
1071 DefValue: TDefineValue;
1072 i: Integer;
1073 Change: PDefineChange;
1074 begin
1075 {$IFDEF VerboseDisableUnreachableIFDEFs}
1076 DebugLn(['SetStatus ',GetIdentifier(Identifier),' Old=',DefineStatusNames[GetStatus(Identifier)],' New=',DefineStatusNames[NewStatus],' SaveOnStack=',SaveOnStack,' SetGlobal=',SetGlobal]);
1077 {$ENDIF}
1078 AVLNode:=CurDefines.FindKey(Identifier,@ComparePCharWithDefineValue);
1079 if AVLNode=nil then begin
1080 if NewStatus<>dsUnknown then begin
1081 DefValue:=TDefineValue.Create;
1082 DefValue.Name:=GetIdentifier(Identifier);
1083 DefValue.Status:=NewStatus;
1084 CurDefines.Add(DefValue);
1085 if SaveOnStack then
1086 AddStackChange(DefValue.Name,dsUnknown);
1087 end else begin
1088 // no change
1089 end;
1090 end else begin
1091 DefValue:=TDefineValue(AVLNode.Data);
1092 if NewStatus<>dsUnknown then begin
1093 if NewStatus<>DefValue.Status then begin
1094 if SaveOnStack then
1095 AddStackChange(DefValue.Name,DefValue.Status);
1096 DefValue.Status:=NewStatus;
1097 end;
1098 end else begin
1099 if SaveOnStack then
1100 AddStackChange(DefValue.Name,DefValue.Status);
1101 CurDefines.Delete(AVLNode);
1102 DefValue.Free;
1103 end;
1104 end;
1105 if SetGlobal then begin
1106 for i:=StackPointer downto 0 do begin
1107 Change:=Stack[i];
1108 while Change<>nil do begin
1109 if CompareIdentifiers(PChar(Change^.Name),Identifier)=0 then begin
1110 if (Change^.OldStatus=dsUnknown)
1111 or (Change^.OldStatus=NewStatus) then begin
1112 // ok
1113 end else begin
1114 Change^.OldStatus:=dsUnknown;
1115 end;
1116 end;
1117 Change:=Change^.Next;
1118 end;
1119 end;
1120 end;
1121 {$IFDEF VerboseDisableUnreachableIFDEFs}
1122 DebugLn(['SetStatus ',GetIdentifier(Identifier),' Cur=',DefineStatusNames[GetStatus(Identifier)],' Should=',DefineStatusNames[NewStatus]]);
1123 {$ENDIF}
1124 end;
1125
1126 procedure InitDefines;
1127 var
1128 i: Integer;
1129 CurName: string;
1130 Node: TCodeTreeNode;
1131 ExprStart: integer;
1132 ExprEnd: integer;
1133 begin
1134 CurDefines:=TAVLTree.Create(@CompareDefineValues);
1135 {$IFDEF VerboseDisableUnreachableIFDEFs}
1136 DebugLn(['InitDefines ',Defines<>nil,' ',Undefines<>nil]);
1137 {$ENDIF}
1138 if Undefines<>nil then begin
1139 for i:=0 to Undefines.Count-1 do
1140 if Undefines[i]<>'' then
1141 SetStatus(PChar(Undefines[i]),dsNotDefined,false,false);
1142 end;
1143 if Defines<>nil then begin
1144 for i:=0 to Defines.Count-1 do begin
1145 CurName:=Defines[i];
1146 if System.Pos('=',CurName)>0 then
1147 CurName:=Defines.Names[i];
1148 if CurName='' then continue;
1149 SetStatus(PChar(CurName),dsDefined,false,false);
1150 end;
1151 end;
1152 if UndefH2PasFunctions then begin
1153 Node:=Tree.Root;
1154 while Node<>nil do begin
1155 if ((Node.Desc=cdnIf) or (Node.Desc=cdnElseIf)) then begin
1156 if GetIfExpression(Node,ExprStart,ExprEnd) then begin
1157 MoveCursorToPos(ExprStart);
1158 repeat
1159 ReadNextAtom;
1160 if AtomStart>=ExprEnd then break;
1161 if ComparePrefixIdent(H2Pas_Function_Prefix,@Src[AtomStart]) then
1162 SetStatus(@Src[AtomStart],dsNotDefined,false,false);
1163 until false;
1164 end;
1165 end;
1166 Node:=Node.Next;
1167 end;
1168 end;
1169 end;
1170
1171 procedure FreeDefines;
1172 begin
1173 if CurDefines=nil then exit;
1174 CurDefines.FreeAndClear;
1175 FreeAndNil(CurDefines);
1176 end;
1177
1178 procedure Push;
1179 begin
1180 inc(StackPointer);
1181 if StackPointer=length(Stack) then
1182 SetLength(Stack,length(Stack)*2+10);
1183 Stack[StackPointer]:=nil;
1184 end;
1185
1186 procedure Pop;
1187 var
1188 Change: PDefineChange;
1189 begin
1190 if StackPointer=0 then
1191 RaiseException(20170422131842,'TCompilerDirectivesTree.DisableUnreachableBlocks.Pop without Push');
1192 // undo all changes
1193 while Stack[StackPointer]<>nil do begin
1194 Change:=Stack[StackPointer];
1195 SetStatus(PChar(Change^.Name),Change^.OldStatus,false,false);
1196 Stack[StackPointer]:=Change^.Next;
1197 Dispose(Change);
1198 end;
1199 dec(StackPointer);
1200 end;
1201
1202 var
1203 Node: TCodeTreeNode;
1204 NextNode: TCodeTreeNode;
1205 NameStart: integer;
1206 NewStatus: TDefineStatus;
1207 Identifier: PChar;
1208 OldStatus: TDefineStatus;
1209 HasValue: boolean;
1210 ValueStart: integer;
1211 ExprNode: TCodeTreeNode;
1212 IsIfBlock: Boolean;
1213 BlockIsAlwaysReached: Boolean;
1214 BlockIsNeverReached: Boolean;
1215 BlockIsReachable: Boolean;
1216 begin
1217 InitDefines;
1218 InitStack;
1219 try
1220 Node:=Tree.Root;
1221 while Node<>nil do begin
1222 NextNode:=Node.Next;
1223 {$IFDEF VerboseDisableUnreachableIFDEFs}
1224 DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks Node=',CDNodeDescAsString(Node.Desc),'=',GetDirective(Node)]);
1225 {$ENDIF}
1226 case Node.Desc of
1227 cdnIf, cdnElse:
1228 begin
1229 if Node.Desc=cdnIf then begin
1230 IsIfBlock:=true;
1231 end else begin
1232 IsIfBlock:=false;
1233 // close prior block
1234 Pop;
1235 end;
1236 // start new block
1237 Push;
1238
1239 if IsIfBlock then begin
1240 ExprNode:=Node;
1241 end else begin
1242 if Node.PriorBrother.Desc=cdnIf then begin
1243 ExprNode:=Node.PriorBrother;
1244 end else begin
1245 ExprNode:=nil;
1246 end;
1247 end;
1248 {$IFDEF VerboseDisableUnreachableIFDEFs}
1249 if (ExprNode<>nil) then
1250 DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks Expr=',GetIfExpressionString(ExprNode),' Simple=',IsIfExpressionSimple(ExprNode,NameStart)])
1251 else
1252 DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks Expr=nil']);
1253 {$ENDIF}
1254
1255 if (ExprNode<>nil) and IsIfExpressionSimple(ExprNode,NameStart) then
1256 begin
1257 // a simple expression
1258 Identifier:=@Src[NameStart];
1259 if (Node.SubDesc=cdnsIfndef)=IsIfBlock then
1260 NewStatus:=dsNotDefined
1261 else
1262 NewStatus:=dsDefined;
1263 OldStatus:=GetStatus(Identifier);
1264 BlockIsReachable:=(OldStatus=dsUnknown) or (OldStatus=NewStatus);
1265 BlockIsAlwaysReached:=OldStatus=NewStatus;
1266 BlockIsNeverReached:=(OldStatus<>dsUnknown) and (OldStatus<>NewStatus);
1267 {$IFDEF VerboseDisableUnreachableIFDEFs}
1268 DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks Identifier=',GetIdentifier(Identifier),' Reachable=',BlockIsReachable,' Always=',BlockIsAlwaysReached,' Never=',BlockIsNeverReached,' NewStatus=',DefineStatusNames[NewStatus]]);
1269 {$ENDIF}
1270 if BlockIsReachable then
1271 SetStatus(Identifier,NewStatus,true,false);
1272 if BlockIsAlwaysReached or BlockIsNeverReached then begin
1273 // this node can be removed
1274 if BlockIsNeverReached or (Node.FirstChild=nil) then begin
1275 NextNode:=Node.NextBrother;
1276 if (NextNode<>nil) and (NextNode.Desc=cdnEnd) then begin
1277 // if the next node is an end node it will be disabled too
1278 NextNode:=NextNode.NextSkipChilds;
1279 end;
1280 end;
1281 // we can Pop here, because
1282 // this the last block
1283 // or this is the first block, then the next block will
1284 // become the new first block
1285 Pop;
1286 if BlockIsAlwaysReached then
1287 DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks BlockIsAlwaysReached ',GetDirective(Node)]);
1288 if BlockIsNeverReached then
1289 DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks BlockIsNeverReached ',GetDirective(Node)]);
1290 DisableIfNode(Node,BlockIsNeverReached,Changed);
1291 end;
1292 end else begin
1293 // a complex expression (If, ElseIf, Else)
1294 // assume: it is reachable
1295 end;
1296 end;
1297
1298 cdnElseIf:
1299 begin
1300 // if there is an ElseIf block, then there must be an IF block in front
1301 // And the IF block in front must be reachable,
1302 // otherwise it would be disabled
1303 Pop;
1304 // If+ElseIf gives a complex expression
1305 // assume: it is reachable
1306 Push;
1307 end;
1308
1309 cdnEnd:
1310 begin
1311 Pop;
1312 end;
1313
1314 cdnDefine:
1315 if ((Node.SubDesc=cdnsDefine) or (Node.SubDesc=cdnsUndef)
1316 or (Node.SubDesc=cdnsSetC))
1317 and GetDefineNameAndValue(Node,NameStart,HasValue,ValueStart) then begin
1318 if Node.SubDesc=cdnsDefine then
1319 NewStatus:=dsDefined
1320 else
1321 NewStatus:=dsNotDefined;
1322 if GetStatus(@Src[NameStart])=NewStatus then begin
1323 // this define is not needed
1324 NextNode:=NextNode.NextSkipChilds;
1325 DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks DEFINE is already, always set to this value']);
1326 DisableDefineNode(Node,Changed);
1327 end else begin
1328 // set status on all levels
1329 SetStatus(@Src[NameStart],NewStatus,true,true);
1330 end;
1331 end;
1332 end;
1333 Node:=NextNode;
1334 end;
1335 finally
1336 FreeStack;
1337 FreeDefines;
1338 end;
1339 {$IFDEF VerboseDisableUnreachableIFDEFs}
1340 DebugLn(['TCompilerDirectivesTree.DisableUnreachableBlocks END']);
1341 {$ENDIF}
1342 end;
1343
1344 procedure TCompilerDirectivesTree.DisableNode(Node: TCodeTreeNode;
1345 var Changed: boolean; WithContent: boolean);
1346 begin
1347 if Node=nil then exit;
1348 case Node.Desc of
1349 cdnDefine, cdnInclude: DisableDefineNode(Node,Changed);
1350 cdnIf, cdnElseIf, cdnElse: DisableIfNode(Node,WithContent,Changed);
1351 end;
1352 end;
1353
1354 procedure TCompilerDirectivesTree.DisableDefineNode(Node: TCodeTreeNode;
1355 var Changed: boolean);
1356 var
1357 FromPos: LongInt;
1358 ToPos: LongInt;
1359 NewSrc: String;
1360 begin
1361 if not DisableUnusedDefines then exit;
1362 //DebugLn(['TCompilerDirectivesTree.DisableDefineNode ',GetDirective(Node)]);
1363 if RemoveDisabledDirectives then begin
1364 // remove directive (including space+empty lines in front and spaces behind)
1365 FromPos:=Node.StartPos;
1366 while (FromPos>1) and (IsSpaceChar[Src[FromPos-1]]) do dec(FromPos);
1367 ToPos:=FindCommentEnd(Src,Node.StartPos,NestedComments);
1368 ToPos:=FindLineEndOrCodeAfterPosition(Src,ToPos,SrcLen+1,NestedComments);
1369 NewSrc:='';
1370 if (FromPos=1) and (ToPos<SrcLen) and (Src[ToPos] in [#10,#13]) then begin
1371 inc(ToPos);
1372 if (ToPos<=SrcLen) and (Src[ToPos] in [#10,#13])
1373 and (Src[ToPos]<>Src[ToPos-1]) then
1374 inc(ToPos);
1375 end;
1376 Replace(FromPos,ToPos,NewSrc);
1377 end else begin
1378 // disable directive -> {off $Define MacroName}
1379 Replace(Node.StartPos+1,Node.StartPos+1,'off ');
1380 end;
1381 Changed:=true;
1382 InternalRemoveNode(Node);
1383 end;
1384
1385 procedure TCompilerDirectivesTree.DisableIfNode(Node: TCodeTreeNode;
1386 WithContent: boolean; var Changed: boolean);
1387
1388 procedure RaiseImpossible;
1389 begin
1390 RaiseException(20170422131846,'TCompilerDirectivesTree.DisableIfNode impossible');
1391 end;
1392
GetExprnull1393 function GetExpr(ExprNode: TCodeTreeNode; out Negated: boolean): string;
1394 var
1395 ExprStart: integer;
1396 ExprEnd: integer;
1397 begin
1398 if not GetIfExpression(ExprNode,ExprStart,ExprEnd) then
1399 RaiseImpossible;
1400 Result:=copy(Src,ExprStart,ExprEnd-ExprStart);
1401 Negated:=ExprNode.SubDesc=cdnsIfNdef;
1402 if (ExprNode.SubDesc=cdnsIfdef) or (ExprNode.SubDesc=cdnsIfNdef) then
1403 Result:='defined('+Result+')';
1404 end;
1405
1406 procedure CommentCode(FromPos, ToPos: integer);
1407 var
1408 p: LongInt;
1409 NewSrc: String;
1410 begin
1411 p:=FromPos;
1412 repeat
1413 // find code
1414 MoveCursorToPos(p);
1415 ReadNextAtom;
1416 if AtomStart>=ToPos then break;
1417 // there is code to comment
1418 // = > start comment
1419 Replace(AtomStart,AtomStart,'(* ');
1420 p:=AtomStart;
1421 while (p<FromPos) do begin
1422 if (Src[p]='(') and (Src[p+1]='*') then
1423 break;
1424 inc(p);
1425 end;
1426 // end comment
1427 NewSrc:='*)'+LineEnding;
1428 Replace(p,p,NewSrc);
1429 inc(p,length(NewSrc));
1430 until false;
1431 end;
1432
1433 procedure DisableContent;
1434 var
1435 FromPos: LongInt;
1436 ToPos: LongInt;
1437 ChildNode: TCodeTreeNode;
1438 FirstChild: TCodeTreeNode;
1439 LastChild: TCodeTreeNode;
1440 begin
1441 if not WithContent then begin
1442 // the content (child nodes) will stay, but the Node will be freed
1443 // -> move child nodes in front of Node (keep source positions)
1444 FirstChild:=Node.FirstChild;
1445 LastChild:=Node.LastChild;
1446 if FirstChild<>nil then begin
1447 ChildNode:=FirstChild;
1448 while ChildNode<>nil do begin
1449 ChildNode.Parent:=Node.Parent;
1450 ChildNode:=ChildNode.NextBrother;
1451 end;
1452 FirstChild.PriorBrother:=Node.PriorBrother;
1453 LastChild.NextBrother:=Node;
1454 if FirstChild.PriorBrother=nil then begin
1455 if Node.Parent<>nil then
1456 Node.Parent.FirstChild:=FirstChild;
1457 end else begin
1458 FirstChild.PriorBrother.NextBrother:=FirstChild;
1459 end;
1460 Node.PriorBrother:=LastChild;
1461 Node.FirstChild:=nil;
1462 Node.LastChild:=nil;
1463 end;
1464 end else begin
1465 // free nodes and delete code
1466 while Node.FirstChild<>nil do
1467 InternalRemoveNode(Node.FirstChild);
1468 FromPos:=FindCommentEnd(Src,Node.StartPos,NestedComments);
1469 ToPos:=Node.NextBrother.StartPos;
1470 if RemoveDisabledDirectives then begin
1471 // delete content
1472 Replace(FromPos,ToPos,'');
1473 end else begin
1474 // comment content
1475 CommentCode(FromPos,ToPos);
1476 end;
1477 end;
1478 end;
1479
1480 var
1481 FromPos: LongInt;
1482 ToPos: LongInt;
1483 Expr: String;
1484 ElseNode: TCodeTreeNode;
1485 ElseName: String;
1486 Expr2: String;
1487 NewSrc: String;
1488 PrevNode: TCodeTreeNode;
1489 NewDesc: TCompilerDirectiveNodeDesc;
1490 NewSubDesc: TCompilerDirectiveNodeDesc;
1491 Simplified: Boolean;
1492 ExprNegated: boolean;
1493 Expr2Negated: boolean;
1494 p: LongInt;
1495 begin
1496 if (Node.NextBrother=nil) then
1497 RaiseImpossible;
1498 if (Node.Desc<>cdnIf) and (Node.Desc<>cdnElseIf) and (Node.Desc<>cdnElse) then
1499 RaiseImpossible;
1500
1501 DisableContent;
1502
1503 Changed:=true;
1504
1505 // fix all following elseif and else nodes
1506 Expr:=GetExpr(Node,ExprNegated);
1507 ElseNode:=Node.NextBrother;
1508 while ElseNode<>nil do begin
1509 if (ElseNode.Desc=cdnElse) or (ElseNode.Desc=cdnElseIf) then begin
1510 PrevNode:=ElseNode.PriorBrother;
1511 if (PrevNode.Desc=cdnIf) then begin
1512 NewDesc:=cdnIf;
1513 if ElseNode.SubDesc=cdnsIfC then
1514 NewSubDesc:=cdnsIfC
1515 else
1516 NewSubDesc:=cdnsIf; // IFDEF, IF -> IF
1517 end else begin
1518 NewDesc:=cdnElseIf;
1519 if (ElseNode.SubDesc=cdnsElseIf) or (ElseNode.SubDesc=cdnsElse) then
1520 NewSubDesc:=cdnsElIfC
1521 else
1522 NewSubDesc:=cdnsElseIf; // Else, ElseIf -> ElseIF
1523 end;
1524 ElseName:=CDNodeSubDescAsString(NewSubDesc);
1525 // convert {$Else} to {$ElseIf not (Expr)}
1526 // convert {$ElseIf Expr2} to {$ElseIf (Expr2) and not (Expr)}
1527 NewSrc:='('+Expr+')';
1528 if not ExprNegated then
1529 NewSrc:='not '+NewSrc;
1530 if ElseNode.Desc=cdnElse then
1531 NewSrc:='{$'+ElseName+' '+NewSrc+'}'
1532 else begin
1533 Expr2:=GetExpr(ElseNode,Expr2Negated);
1534 NewSrc:='{$'+ElseName+' ('+Expr2+') and '+NewSrc+'}';
1535 end;
1536 Replace(ElseNode.StartPos,
1537 FindCommentEnd(Src,ElseNode.StartPos,NestedComments),NewSrc);
1538 ElseNode.Desc:=NewDesc;
1539 ElseNode.SubDesc:=NewSubDesc;
1540 Simplified:=false;
1541 CheckAndImproveExpr_Brackets(ElseNode,Simplified);
1542 CheckAndImproveExpr_IfDefinedMacro(ElseNode,Simplified);
1543 end else begin
1544 break;
1545 end;
1546 ElseNode:=ElseNode.NextBrother;
1547 end;
1548
1549 FromPos:=Node.StartPos;
1550 if RemoveDisabledDirectives then begin
1551 if (Node.NextBrother.Desc=cdnEnd) and (Node.Desc=cdnIf) then begin
1552 // remove the whole IF..END block
1553 ToPos:=FindCommentEnd(Src,Node.NextBrother.StartPos,NestedComments);
1554 ToPos:=FindLineEndOrCodeAfterPosition(Src,ToPos,SrcLen+1,NestedComments);
1555 end else begin
1556 // remove a sub block
1557 ToPos:=Node.NextBrother.StartPos;
1558 end;
1559 if WithContent then begin
1560 // remove node source with content
1561 if (FromPos>1) and (Src[FromPos-1] in [#10,#13])
1562 and (ToPos<=SrcLen) and (Src[ToPos] in [#10,#13]) then begin
1563 // the directive has a complete line
1564 // remove the line end too
1565 inc(ToPos);
1566 if (ToPos<=SrcLen) and (Src[ToPos] in [#10,#13]) and (Src[ToPos]<>Src[ToPos-1])
1567 then inc(ToPos);
1568 if (ToPos<=SrcLen) and (Src[ToPos] in [#10,#13]) then begin
1569 // there is an empty line behind the directive
1570 // check if there is an empty line in front of the directive
1571 p:=FromPos;
1572 if (p>1) and (Src[p-1] in [#10,#13]) then begin
1573 dec(p);
1574 if (p>1) and (Src[p-1] in [#10,#13]) and (Src[p]<>Src[p-1]) then
1575 dec(p);
1576 if (p>1) and (Src[p-1] in [#10,#13]) then begin
1577 // there is an empty line in front of the directive too
1578 // => remove one empty line
1579 FromPos:=p;
1580 end;
1581 end;
1582 end;
1583 end;
1584 Replace(FromPos,ToPos,'');
1585 end else begin
1586 // remove node source keeping content (child node source)
1587 Replace(FromPos,FindCommentEnd(Src,FromPos,NestedComments),'');
1588 if Node.NextBrother.Desc=cdnEnd then begin
1589 ToPos:=FindCommentEnd(Src,Node.NextBrother.StartPos,NestedComments);
1590 ToPos:=FindLineEndOrCodeAfterPosition(Src,ToPos,SrcLen+1,NestedComments);
1591 Replace(Node.NextBrother.StartPos,ToPos,'');
1592 end;
1593 end;
1594 end else begin
1595 // disable directive -> {$off IfDef MacroName}
1596 Replace(FromPos+1,FromPos+1,'off ');
1597 if Node.NextBrother.Desc=cdnEnd then
1598 Replace(Node.NextBrother.StartPos+1,Node.NextBrother.StartPos+1,'off ');
1599 end;
1600
1601 if Node.NextBrother.Desc=cdnEnd then
1602 InternalRemoveNode(Node.NextBrother);
1603 InternalRemoveNode(Node);
1604 end;
1605
1606 procedure TCompilerDirectivesTree.InternalRemoveNode(Node: TCodeTreeNode);
1607 var
1608 AVLNode: TAVLTreeNode;
1609 MacroNode: TCompilerMacroStats;
1610 begin
1611 // clear references
1612 if Macros<>nil then begin
1613 AVLNode:=Macros.FindLowest;
1614 while AVLNode<>nil do begin
1615 MacroNode:=TCompilerMacroStats(AVLNode.Data);
1616 if MacroNode.LastDefineNode=Node then
1617 MacroNode.LastDefineNode:=nil;
1618 if MacroNode.LastReadNode=Node then
1619 MacroNode.LastReadNode:=nil;
1620 AVLNode:=Macros.FindSuccessor(AVLNode);
1621 end;
1622 end;
1623
1624 // free node
1625 Tree.DeleteNode(Node);
1626 end;
1627
1628 procedure TCompilerDirectivesTree.RaiseException(id: int64;
1629 const ErrorMsg: string);
1630 begin
1631 fLastErrorMsg:=ErrorMsg;
1632 fLastErrorPos:=AtomStart;
1633 fLastErrorId:=id;
1634 if Code<>nil then
1635 Code.AbsoluteToLineCol(AtomStart,fLastErrorXY.Y,fLastErrorXY.X)
1636 else
1637 fLastErrorXY:=Point(0,0);
1638 RaiseLastError;
1639 end;
1640
1641 procedure TCompilerDirectivesTree.RaiseLastError;
1642 begin
1643 raise ECDirectiveParserException.Create(Self, fLastErrorId,
1644 SrcPosToStr(fLastErrorPos)+' Error: '+ErrorMsg);
1645 end;
1646
1647 procedure TCompilerDirectivesTree.RemoveEmptyNodes(var Changed: boolean);
1648 var
1649 Node: TCodeTreeNode;
1650 NextNode: TCodeTreeNode;
1651
1652 procedure CheckNode;
1653 begin
1654 //DebugLn(['CheckNode ',Node.Desc=cdnIf,' ',(Node.NextBrother<>nil),' ',(Node.FirstChild=nil),' ',GetDirective(Node)]);
1655 case Node.Desc of
1656 cdnIf,cdnElseIf,cdnElse:
1657 if (Node.NextBrother<>nil) and (Node.FirstChild=nil) then begin
1658 case Node.NextBrother.Desc of
1659 cdnEnd,cdnElseIf,cdnElse:
1660 begin
1661 //DebugLn(['CheckNode Checking if empty ...']);
1662 MoveCursorToPos(Node.StartPos);
1663 // skip directive
1664 ReadNextAtom;
1665 // read the following atom (token or directive)
1666 ReadNextAtom;
1667 if AtomStart=Node.NextBrother.StartPos then begin
1668 // node is empty
1669 DebugLn(['TCompilerDirectivesTree.RemoveEmptyNodes node only contains spaces and comments ',GetDirective(Node)]);
1670 DisableIfNode(Node,true,Changed);
1671 end;
1672 end;
1673 end;
1674 end;
1675 end;
1676 end;
1677
1678 begin
1679 //DebugLn(['TCompilerDirectivesTree.RemoveEmptyNodes ']);
1680 // check nodes from end to start
1681 Node:=Tree.Root;
1682 while (Node.NextBrother<>nil) do Node:=Node.NextBrother;
1683 while (Node.LastChild<>nil) do Node:=Node.LastChild;
1684 while Node<>nil do begin
1685 NextNode:=Node.Prior;
1686 CheckNode;
1687 Node:=NextNode;
1688 end;
1689 end;
1690
InsertDefinenull1691 function TCompilerDirectivesTree.InsertDefine(Position: integer;
1692 const NewSrc: string; SubDesc: TCompilerDirectiveNodeDesc): TCodeTreeNode;
1693 var
1694 ParentNode: TCodeTreeNode;
1695 NextBrotherNode: TCodeTreeNode;
1696 begin
1697 Replace(Position,Position,NewSrc);
1698 ParentNode:=FindNodeAtPos(Position);
1699 if ParentNode=nil then
1700 ParentNode:=Tree.Root;
1701 while (ParentNode<>Tree.Root) and (ParentNode.EndPos=Position) do
1702 ParentNode:=ParentNode.Parent;
1703 Result:=TCodeTreeNode.Create;
1704 Result.Desc:=cdnDefine;
1705 Result.SubDesc:=SubDesc;
1706 Result.StartPos:=FindNextCompilerDirective(Src,Position,NestedComments);
1707 Result.EndPos:=FindCommentEnd(Src,Result.StartPos,NestedComments);
1708 NextBrotherNode:=ParentNode.FirstChild;
1709 while (NextBrotherNode<>nil) and (NextBrotherNode.StartPos<=Position) do
1710 NextBrotherNode:=NextBrotherNode.NextBrother;
1711 if NextBrotherNode<>nil then begin
1712 Tree.AddNodeInFrontOf(NextBrotherNode,Result);
1713 end else begin
1714 Tree.AddNodeAsLastChild(ParentNode,Result);
1715 if ParentNode.EndPos<Result.EndPos then
1716 ParentNode.EndPos:=Result.EndPos;
1717 end;
1718 end;
1719
1720 constructor TCompilerDirectivesTree.Create;
1721 begin
1722 Tree:=TCodeTree.Create;
1723 SimplifyExpressions:=true;
1724 DisableUnusedDefines:=true;
1725 RemoveDisabledDirectives:=true;
1726 UndefH2PasFunctions:=true;
1727 end;
1728
1729 destructor TCompilerDirectivesTree.Destroy;
1730 begin
1731 ClearMacros;
1732 FreeAndNil(Tree);
1733 FDefaultDirectiveFuncList.Free;
1734 inherited Destroy;
1735 end;
1736
1737 procedure TCompilerDirectivesTree.Clear;
1738 begin
1739 Tree.Clear;
1740 if Macros<>nil then begin
1741 Macros.FreeAndClear;
1742 FreeAndNil(Macros);
1743 end;
1744 end;
1745
1746 procedure TCompilerDirectivesTree.Parse;
1747 begin
1748 Parse(Code,NestedComments);
1749 end;
1750
1751 {$IFOPT R+}{$DEFINE RangeChecking}{$ENDIF}
1752 {$R-}
1753 procedure TCompilerDirectivesTree.Parse(aCode: TCodeBuffer;
1754 aNestedComments: boolean);
1755
1756 procedure RaiseDanglingIFDEF;
1757 begin
1758 RaiseException(20170422131848,'missing EndIf');
1759 end;
1760
1761 var
1762 DirectiveName: PChar;
1763 Node: TCodeTreeNode;
1764 begin
1765 if (Code=aCode) and (NestedComments=aNestedComments) and (not UpdateNeeded)
1766 then begin
1767 if FLastErrorMsg<>'' then
1768 RaiseLastError;
1769 exit;
1770 end;
1771
1772 FLastErrorMsg:='';
1773 Code:=aCode;
1774 NestedComments:=aNestedComments;
1775 InitParser;
1776
1777 repeat
1778 ReadRawNextPascalAtom(Src,SrcPos,AtomStart,NestedComments);
1779 //DebugLn(['TCompilerDirectivesTree.Parse ',NestedComments,' ',copy(Src,AtomStart,SrcPos-AtomStart)]);
1780 if SrcPos<=SrcLen then begin
1781 if (Src[AtomStart]='{') and (Src[AtomStart+1]='$') then begin
1782 // compiler directive
1783 DirectiveName:=@Src[AtomStart+2];
1784 //DebugLn(['ParseCompilerDirectives ',GetIdentifier(DirectiveName)]);
1785 FDefaultDirectiveFuncList.DoItCaseInsensitive(DirectiveName);
1786 end;
1787 end else begin
1788 break;
1789 end;
1790 until false;
1791 // close nodes
1792 Node:=CurNode;
1793 while Node<>nil do begin
1794 Node.EndPos:=AtomStart;
1795 Node:=Node.Parent;
1796 end;
1797 if CurNode<>Tree.Root then
1798 RaiseDanglingIFDEF;
1799
1800 end;
1801 {$IFDEF RangeChecking}{$R+}{$UNDEF RangeChecking}{$ENDIF}
1802
UpdateNeedednull1803 function TCompilerDirectivesTree.UpdateNeeded: boolean;
1804 begin
1805 Result:=true;
1806 if (Code=nil) or (Tree=nil) or (Tree.Root=nil) then exit;
1807 if Code.ChangeStep<>ParseChangeStep then exit;
1808 Result:=false;
1809 end;
1810
1811 procedure TCompilerDirectivesTree.ReduceCompilerDirectives(
1812 Undefines, Defines: TStrings; var Changed: boolean);
1813 (* Check and improve the following cases
1814 1. {$DEFINE Name} and Name is never used afterwards -> disable
1815
1816 2. {$DEFINE Name}
1817 ... Name is not used here ...
1818 {$DEFINE Name}
1819 -> disable first
1820
1821 3. {$IFDEF Name}... only comments and spaces ...{$ENDIF}
1822 -> disable the whole block
1823
1824 4. {$IFNDEF Name}
1825 ... only comments and spaces ...
1826 {$DEFINE Name}
1827 ... only comments and spaces ...
1828 {$ENDIF}
1829 -> disable the IFNDEF and the ENDIF and keep the DEFINE
1830 *)
1831
GetMacroNodenull1832 function GetMacroNode(p: PChar): TCompilerMacroStats;
1833 var
1834 AVLNode: TAVLTreeNode;
1835 begin
1836 AVLNode:=Macros.FindKey(p,@ComparePCharWithCompilerMacroStats);
1837 if AVLNode<>nil then
1838 Result:=TCompilerMacroStats(AVLNode.Data)
1839 else
1840 Result:=nil;
1841 end;
1842
1843 procedure CheckMacroInExpression(Node: TCodeTreeNode; NameStart: integer;
1844 Complex: boolean; var {%H-}Changed: boolean);
1845 var
1846 MacroNode: TCompilerMacroStats;
1847 begin
1848 MacroNode:=GetMacroNode(@Src[NameStart]);
1849 if MacroNode=nil then begin
1850 MacroNode:=TCompilerMacroStats.Create;
1851 MacroNode.Name:=GetIdentifier(@Src[NameStart]);
1852 Macros.Add(MacroNode);
1853 end;
1854 MacroNode.LastReadNode:=Node;
1855
1856 if not Complex then begin
1857
1858 end;
1859 end;
1860
1861 procedure CheckDefine(Node: TCodeTreeNode; var Changed: boolean);
1862 var
1863 MacroNode: TCompilerMacroStats;
1864 NameStart: integer;
1865 HasValue: boolean;
1866 ValueStart: integer;
1867 begin
1868 if (Node.SubDesc<>cdnsDefine) and (Node.SubDesc<>cdnsUndef)
1869 and (Node.SubDesc<>cdnsSetC) then exit;
1870 if not GetDefineNameAndValue(Node,NameStart,HasValue,ValueStart) then exit;
1871 MacroNode:=GetMacroNode(@Src[NameStart]);
1872 if MacroNode=nil then begin
1873 MacroNode:=TCompilerMacroStats.Create;
1874 MacroNode.Name:=GetIdentifier(@Src[NameStart]);
1875 Macros.Add(MacroNode);
1876 end;
1877 if (MacroNode.LastReadNode=nil) and (MacroNode.LastDefineNode<>nil)
1878 and (MacroNode.LastDefineNode.Parent=Node.Parent)
1879 and ((MacroNode.LastDefineNode.SubDesc=cdnsUndef)=(Node.SubDesc=cdnsUndef)) then begin
1880 // last define was never used -> disable it
1881 DebugLn(['TCompilerDirectivesTree.ReduceCompilerDirectives this define was already set to this value']);
1882 DisableDefineNode(MacroNode.LastDefineNode,Changed);
1883 end;
1884
1885 MacroNode.LastReadNode:=nil;
1886 MacroNode.LastDefineNode:=Node;
1887 end;
1888
1889 var
1890 Node: TCodeTreeNode;
1891 ExprStart: integer;
1892 ExprEnd: integer;
1893 Complex: Boolean;
1894 AtomCount: Integer;
1895 NextNode: TCodeTreeNode;
1896 begin
1897 try
1898 ResetMacros;
1899 Node:=Tree.Root;
1900 while Node<>nil do begin
1901 NextNode:=Node.Next;
1902
1903 case Node.Desc of
1904 cdnIf,cdnElseIf:
1905 if GetIfExpression(Node,ExprStart,ExprEnd) then begin
1906 // improve expression
1907 CheckAndImproveExpr_Brackets(Node,Changed);
1908 CheckAndImproveExpr_IfDefinedMacro(Node,Changed);
1909
1910 //DebugLn(['TCompilerDirectivesTree.ReduceCompilerDirectives Expr=',copy(Src,ExprStart,ExprEnd-ExprStart)]);
1911 // check if it is a complex expression or just one macro
1912 AtomCount:=0;
1913 if (Node.SubDesc=cdnsIf) or (Node.SubDesc=cdnsIfC)
1914 or (Node.SubDesc=cdnsElseIf) then begin
1915 MoveCursorToPos(ExprStart);
1916 repeat
1917 ReadNextAtom;
1918 inc(AtomCount);
1919 until AtomStart>=ExprEnd;
1920 end;
1921 Complex:=AtomCount>1;
1922
1923 // mark all macros as read
1924 MoveCursorToPos(ExprStart);
1925 repeat
1926 ReadNextAtom;
1927 if AtomIsIdentifier then begin
1928 CheckMacroInExpression(Node,AtomStart,Complex,Changed);
1929 end;
1930 until AtomStart>=ExprEnd;
1931 end;
1932
1933 cdnDefine:
1934 CheckDefine(Node,Changed);
1935
1936 end;
1937
1938 Node:=NextNode;
1939 end;
1940
1941 DisableAllUnusedDefines(Changed);
1942
1943 MoveIfNotThenDefsUp(Changed);
1944
1945 DisableUnreachableBlocks(Undefines,Defines,Changed);
1946
1947 RemoveEmptyNodes(Changed);
1948 finally
1949 ClearMacros;
1950 end;
1951 end;
1952
1953 procedure TCompilerDirectivesTree.GatherH2PasFunctions(out
1954 ListOfH2PasFunctions: TFPList; FindDefNodes: boolean);
1955 var
1956 InInterface: boolean;
1957
1958 procedure ReadFunction;
1959 var
1960 HeaderStart: LongInt;
1961 HeaderEnd: LongInt;
1962 FuncName: String;
1963 IsForward: Boolean;
1964 BlockLevel: Integer;
1965 CurH2PasFunc: TH2PasFunction;
BeginStartnull1966 BeginStart: Integer;
1967 BeginEnd: Integer;
1968 IsExternal: Boolean;
1969 begin
1970 HeaderStart:=AtomStart;
1971 // read name
1972 ReadNextAtom;
1973 if not AtomIsIdentifier then exit;
1974 FuncName:=GetAtom;
1975 // read parameter list
1976 ReadNextAtom;
1977 if AtomIs('(') then begin
1978 if not ReadTilBracketClose(')') then exit;
1979 ReadNextAtom;
1980 end;
1981 // read colon
1982 if not AtomIs(':') then exit;
1983 // read result type
1984 ReadNextAtom;
1985 if not AtomIsIdentifier then exit;
1986 // read semicolon
1987 ReadNextAtom;
1988 if not AtomIs(';') then exit;
1989 HeaderEnd:=SrcPos;
modifiersnull1990 // read function modifiers
1991 IsForward:=false;
1992 IsExternal:=false;
1993 repeat
1994 ReadNextAtom;
1995 if (AtomStart<=SrcLen)
1996 and IsKeyWordProcedureSpecifier.DoItCaseInsensitive(@Src[AtomStart])
1997 then begin
1998 if UpAtomIs('EXTERNAL') then
1999 IsExternal:=true;
2000 if UpAtomIs('FORWARD') then
2001 IsForward:=true;
2002 repeat
2003 ReadNextAtom;
2004 until (AtomStart>SrcLen) or AtomIs(';');
2005 HeaderEnd:=SrcPos;
2006 end else
2007 break;
2008 until false;
2009
2010 // read begin..end block
2011 BeginStart:=-1;
2012 BeginEnd:=-1;
2013 if (not IsForward) and (not InInterface) and (not IsExternal)
2014 and UpAtomIs('BEGIN') then begin
2015 BeginStart:=AtomStart;
2016 BlockLevel:=1;
2017 repeat
2018 ReadNextAtom;
2019 if (AtomStart>SrcLen) then break;
2020 if UpAtomIs('END') then begin
2021 dec(BlockLevel);
2022 if BlockLevel=0 then begin
2023 BeginEnd:=SrcPos;
2024 ReadNextAtom;
2025 if AtomIs(';') then
2026 BeginEnd:=SrcPos;
2027 break;
2028 end;
2029 end else if UpAtomIs('BEGIN') or UpAtomIs('ASM') then
2030 inc(BlockLevel);
2031 until false;
2032 end else begin
2033 // undo forward read to make sure that current atom is the last of the function
MoveCursorToPosnull2034 MoveCursorToPos(HeaderEnd);
2035 end;
2036
2037 // found a function
2038 //DebugLn(['ReadFunction ',copy(Src,HeaderStart,FuncEnd-HeaderStart)]);
2039 CurH2PasFunc:=TH2PasFunction.Create;
2040 CurH2PasFunc.Name:=FuncName;
2041 CurH2PasFunc.HeaderStart:=HeaderStart;
2042 CurH2PasFunc.HeaderEnd:=HeaderEnd;
2043 CurH2PasFunc.BeginStart:=BeginStart;
2044 CurH2PasFunc.BeginEnd:=BeginEnd;
2045 CurH2PasFunc.IsForward:=IsForward;
2046 CurH2PasFunc.InInterface:=InInterface;
2047 CurH2PasFunc.IsExternal:=IsExternal;
2048 if ListOfH2PasFunctions=nil then ListOfH2PasFunctions:=TFPList.Create;
2049 ListOfH2PasFunctions.Add(CurH2PasFunc);
2050 end;
2051
2052 procedure DoFindDefNodes;
2053 var
2054 i: Integer;
2055 CurH2PasFunc: TH2PasFunction;
TreeOfForwardFuncsnull2056 TreeOfForwardFuncs: TAVLTree;
2057 TreeOfBodyFuncs: TAVLTree;
2058 AVLNode: TAVLTreeNode;
2059 BodyAVLNode: TAVLTreeNode;
2060 BodyFunc: TH2PasFunction;
beginnull2061 begin
2062 if ListOfH2PasFunctions=nil then exit;
2063
2064 // create a tree of the function definitions
2065 // and a tree of the function bodies
2066 TreeOfForwardFuncs:=TAVLTree.Create(@CompareH2PasFuncByNameAndPos);
2067 TreeOfBodyFuncs:=TAVLTree.Create(@CompareH2PasFuncByNameAndPos);
2068 for i:=0 to ListOfH2PasFunctions.Count-1 do begin
2069 CurH2PasFunc:=TH2PasFunction(ListOfH2PasFunctions[i]);
2070 if CurH2PasFunc.NeedsBody then
2071 TreeOfForwardFuncs.Add(CurH2PasFunc)
2072 else if (CurH2PasFunc.BeginStart>0) then
2073 TreeOfBodyFuncs.Add(CurH2PasFunc);
2074 end;
2075
2076 // search for every definition the corresponding body
2077 AVLNode:=TreeOfForwardFuncs.FindLowest;
2078 while AVLNode<>nil do begin
2079 CurH2PasFunc:=TH2PasFunction(AVLNode.Data);
2080 if CurH2PasFunc.DefNode=nil then begin
2081 BodyAVLNode:=TreeOfBodyFuncs.FindLeftMostKey(Pointer(CurH2PasFunc.Name),
2082 @ComparePCharWithH2PasFuncName);
2083 if BodyAVLNode<>nil then begin
2084 // there is at least one body with this name
2085 repeat
2086 BodyFunc:=TH2PasFunction(BodyAVLNode.Data);
2087 if BodyFunc.DefNode=nil then begin
2088 // this body node with the same name has not yet a definition node
2089 // => found the corresponding node
2090 BodyFunc.DefNode:=CurH2PasFunc;
2091 CurH2PasFunc.DefNode:=BodyFunc;
2092 break;
2093 end else begin
2094 // this body node has already a definition node
2095 // search next body node with same name
2096 BodyAVLNode:=TreeOfBodyFuncs.FindSuccessor(BodyAVLNode);
2097 if (BodyAVLNode=nil)
2098 or (ComparePCharWithH2PasFuncName(
2099 Pointer(CurH2PasFunc.Name),BodyAVLNode.Data)<>0)
2100 then
2101 break;
2102 end;
2103 until false;
2104 end;
2105 end;
2106 AVLNode:=TreeOfBodyFuncs.FindSuccessor(AVLNode);
2107 end;
2108
2109 // clean up
2110 TreeOfForwardFuncs.Free;
2111 TreeOfBodyFuncs.Free;
2112 end;
2113
2114 begin
2115 ListOfH2PasFunctions:=nil;
2116
2117 InInterface:=false;
2118 MoveCursorToPos(1);
2119 repeat
2120 ReadNextAtom;
2121 if SrcPos>SrcLen then break;
2122 if UpAtomIs('FUNCTION') then begin
2123 ReadFunction;
endnull2124 end else if UpAtomIs('INTERFACE') then begin
2125 InInterface:=true;
2126 end else if UpAtomIs('IMPLEMENTATION') then begin
2127 InInterface:=false;
2128 end;
2129 until false;
2130
2131 if FindDefNodes then
2132 DoFindDefNodes;
2133 end;
2134
2135 procedure TCompilerDirectivesTree.FixMissingH2PasDirectives(var Changed: boolean);
2136 { Adds the directives around the function bodies, that h2pas forgets to add.
2137
2138 }
2139 type
2140 TBodyBlock = record
2141 Definition: TCodeTreeNode;
2142 FirstBodyFunc: TH2PasFunction;
LastBodyFuncnull2143 LastBodyFunc: TH2PasFunction;
2144 end;
2145
2146 var
2147 CurBodyBlock: TBodyBlock;
2148 MacroNames: TStrings; // the Objects are the TCodeTreeNode
2149 ListOfH2PasFunctions: TFPList;
2150 LocalChange: boolean;
2151
IsSameDirectivenull2152 function IsSameDirective(OldNode: TCodeTreeNode; Position: integer;
2153 out NewNode: TCodeTreeNode): boolean;
2154 begin
2155 NewNode:=FindNodeAtPos(Position);
2156 //if OldNode<>nil then DebugLn(['IsSameDirective OldNode=',OldNode.StartPos,' "',copy(Src,OldNode.StartPos,OldNode.EndPos-OldNode.StartPos),'"']);
2157 //if NewNode<>nil then DebugLn(['IsSameDirective NewNode=',NewNode.StartPos,' "',copy(Src,NewNode.StartPos,NewNode.EndPos-NewNode.StartPos),'"']);
2158 Result:=(NewNode<>nil) and (NewNode=OldNode);
2159 end;
2160
HasCodeBetweennull2161 function HasCodeBetween(FromPos, ToPos: integer): boolean;
2162 begin
2163 if FromPos<1 then FromPos:=1;
2164 if FromPos>ToPos then exit(false);
2165 MoveCursorToPos(FromPos);
2166 ReadNextAtom;
2167 Result:=AtomStart<ToPos;
2168 end;
2169
GetMacroNameForNodenull2170 function GetMacroNameForNode(Node: TCodeTreeNode; out IsNew: boolean): string;
2171 var
2172 i: Integer;
2173 begin
2174 if MacroNames=nil then
2175 MacroNames:=TStringList.Create;
2176 for i:=0 to MacroNames.Count-1 do
2177 if MacroNames.Objects[i]=Node then begin
2178 Result:=MacroNames[i];
2179 IsNew:=false;
2180 exit;
2181 end;
2182 IsNew:=true;
2183 Result:=H2Pas_Function_Prefix+IntToStr(MacroNames.Count+1);
2184 MacroNames.AddObject(Result,Node);
2185 end;
2186
2187 procedure LocalReplace(FromPos, ToPos: integer; const NewSrc: string);
2188 var
2189 DiffPos: Integer;
2190 i: Integer;
2191 Func: TH2PasFunction;
beginnull2192 begin
2193 LocalChange:=true;
2194 Replace(FromPos,ToPos,NewSrc);
2195 // update positions
2196 DiffPos:=length(NewSrc)-(ToPos-FromPos);
2197 if DiffPos<>0 then begin
2198 for i:=0 to ListOfH2PasFunctions.Count-1 do begin
2199 Func:=TH2PasFunction(ListOfH2PasFunctions[i]);
2200 Func.AdjustPositionsAfterInsert(FromPos,ToPos,DiffPos);
2201 end;
2202 end;
2203 end;
2204
2205 procedure StartBodyBlock(BodyFunc: TH2PasFunction; DefNode: TCodeTreeNode);
2206 begin
2207 CurBodyBlock.Definition:=DefNode;
2208 CurBodyBlock.FirstBodyFunc:=BodyFunc;
2209 CurBodyBlock.LastBodyFunc:=BodyFunc;
2210 end;
2211
2212 procedure EndBodyBlock;
2213 var
2214 MacroName: String;
2215 InsertPos: LongInt;
2216 IsNewMacro: boolean;
2217 begin
2218 if CurBodyBlock.Definition=nil then exit;
2219 if CurBodyBlock.Definition<>Tree.Root then begin
2220 DebugLn(['TCompilerDirectivesTree.FixMissingH2PasDirectives add missing directives']);
2221 // create unique macro name
2222 MacroName:=GetMacroNameForNode(CurBodyBlock.Definition,IsNewMacro);
2223 if IsNewMacro then begin
2224 // insert $DEFINE
2225 InsertPos:=FindCommentEnd(Src,CurBodyBlock.Definition.StartPos,NestedComments);
2226 LocalReplace(InsertPos,InsertPos,LineEnding+'{$DEFINE '+MacroName+'}');
2227 end;
2228 // insert $IFDEF
2229 InsertPos:=FindLineEndOrCodeInFrontOfPosition(Src,
2230 CurBodyBlock.FirstBodyFunc.HeaderStart,1,NestedComments,true);
2231 LocalReplace(InsertPos,InsertPos,LineEnding+'{$IFDEF '+MacroName+'}');
2232 // insert $ENDIF
2233 InsertPos:=FindLineEndOrCodeAfterPosition(Src,
2234 CurBodyBlock.LastBodyFunc.BeginEnd,1,NestedComments,true);
2235 LocalReplace(InsertPos,InsertPos,LineEnding+'{$ENDIF '+MacroName+'}');
2236 end;
2237 FillChar(CurBodyBlock,SizeOf(TBodyBlock),0);
2238 end;
2239
2240 var
2241 i: Integer;
2242 BodyFunc: TH2PasFunction;
LastDefNodenull2243 LastDefNode: TCodeTreeNode;
2244 BodyNode: TCodeTreeNode;
2245 begin
2246 ListOfH2PasFunctions:=nil;
2247 MacroNames:=nil;
2248 LocalChange:=false;
2249 try
2250 GatherH2PasFunctions(ListOfH2PasFunctions,true);
2251 DebugLn(['TCompilerDirectivesTree.FixMissingH2PasDirectives ',ListOfH2PasFunctions=nil]);
2252 if ListOfH2PasFunctions=nil then exit;
2253 FillChar(CurBodyBlock,SizeOf(TBodyBlock),0);
2254 LastDefNode:=nil;
2255 for i:=0 to ListOfH2PasFunctions.Count-1 do begin
istOfH2PasFunctionsnull2256 BodyFunc:=TH2PasFunction(ListOfH2PasFunctions[i]);
2257 //DebugLn(['TCompilerDirectivesTree.FixMissingH2PasDirectives DefNode=',(BodyFunc.DefNode<>nil),' Body="',copy(Src,BodyFunc.HeaderStart,BodyFunc.HeaderEnd-BodyFunc.HeaderStart),'"']);
2258 if (BodyFunc.BeginStart<1) or (BodyFunc.DefNode=nil) then
2259 continue;
2260 BodyNode:=FindNodeAtPos(BodyFunc.HeaderStart);
2261 if BodyNode<>Tree.Root then begin
2262 // this body has already a directive block
2263 continue;
2264 end;
isnull2265 // this function is a body and has a definition
2266
2267 if (CurBodyBlock.LastBodyFunc<>nil)
2268 and HasCodeBetween(CurBodyBlock.LastBodyFunc.BeginEnd,BodyFunc.HeaderStart)
2269 then begin
2270 // there is code between last function body and current function body
2271 // end last block
2272 EndBodyBlock;
2273 end;
2274
2275 if not IsSameDirective(LastDefNode,
2276 BodyFunc.DefNode.HeaderStart,LastDefNode)
2277 then begin
2278 // another directive block => end last block
2279 EndBodyBlock;
2280 end;
2281
2282 if (CurBodyBlock.Definition=nil) then begin
2283 // a new block
2284 StartBodyBlock(BodyFunc, LastDefNode);
2285 end else begin
2286 // continue current block
2287 CurBodyBlock.LastBodyFunc:=BodyFunc;
2288 end;
2289 end;
2290 // end last block
2291 EndBodyBlock;
2292
2293 finally
2294 if ListOfH2PasFunctions<>nil then
2295 for i:=0 to ListOfH2PasFunctions.Count-1 do
2296 TObject(ListOfH2PasFunctions[i]).Free;
2297 ListOfH2PasFunctions.Free;
2298 MacroNames.Free;
2299
2300 if LocalChange then begin
2301 Changed:=true;
2302 Parse(Code,NestedComments);
2303 end;
2304 end;
2305 end;
2306
NodeStartToCodePosnull2307 function TCompilerDirectivesTree.NodeStartToCodePos(Node: TCodeTreeNode; out
2308 CodePos: TCodeXYPosition): boolean;
2309 begin
2310 CodePos.Code:=nil;
2311 CodePos.Y:=0;
2312 CodePos.X:=0;
2313 if (Node=nil) or (Code=nil) then exit(false);
2314 CodePos.Code:=Code;
2315 Code.AbsoluteToLineCol(Node.StartPos,CodePos.Y,CodePos.X);
2316 Result:=true;
2317 end;
2318
SrcPosToStrnull2319 function TCompilerDirectivesTree.SrcPosToStr(p: integer;
2320 WithFilename: boolean): string;
2321 var
2322 Line: integer;
2323 Column: integer;
2324 begin
2325 if Code=nil then
2326 exit('P='+IntToStr(p));
2327 if WithFilename then
2328 Result:=Code.Filename
2329 else
2330 Result:='';
2331 Code.AbsoluteToLineCol(p,Line,Column);
2332 Result+='('+IntToStr(Line)+','+IntToStr(Column)+')';
2333 end;
2334
FindResourceDirectivenull2335 function TCompilerDirectivesTree.FindResourceDirective(const Filename: string;
2336 StartPos: integer): TCodeTreeNode;
2337 begin
2338 if Tree=nil then exit(nil);
2339 Result:=Tree.Root;
2340 while Result<>nil do begin
2341 if (Result.StartPos>=StartPos)
2342 and IsResourceDirective(Result,Filename) then exit;
2343 Result:=Result.Next;
2344 end;
2345 end;
2346
IsResourceDirectivenull2347 function TCompilerDirectivesTree.IsResourceDirective(Node: TCodeTreeNode;
2348 const Filename: string): boolean;
2349 // search for {$R filename}
2350 // if filename='' then search for any {$R } directive
2351 // Beware: do not find {$R+}
2352 var
2353 p: LongInt;
2354 begin
2355 Result:=false;
2356 if (Node=nil) or (Node.Desc<>cdnDefine) or (Node.SubDesc<>cdnsOther) then exit;
2357 p:=Node.StartPos;
2358 if (Node.EndPos-p>=5) and (Src[p]='{') and (Src[p+1]='$') and (Src[p+2]='R')
2359 and IsSpaceChar[Src[p+3]] then
2360 begin
2361 if (Filename='') then exit(true);
2362 inc(p,4);
2363 while (p<Node.EndPos) and IsSpaceChar[Src[p]] do inc(p);
2364 if CompareText(Filename,copy(Src,p,Node.EndPos-p-1))=0 then // do not use CompareFilenamesIgnoreCase
2365 exit(true);
2366 end;
2367 end;
2368
FindIncludeDirectivenull2369 function TCompilerDirectivesTree.FindIncludeDirective(const Filename: string;
2370 StartPos: integer): TCodeTreeNode;
2371 begin
2372 if Tree=nil then exit(nil);
2373 Result:=Tree.Root;
2374 while Result<>nil do begin
2375 if (Result.StartPos>=StartPos)
2376 and IsIncludeDirective(Result,Filename) then exit;
2377 Result:=Result.Next;
2378 end;
2379 end;
2380
TCompilerDirectivesTree.IsIncludeDirectivenull2381 function TCompilerDirectivesTree.IsIncludeDirective(Node: TCodeTreeNode;
2382 const Filename: string): boolean;
2383 // search for {$I filename}
2384 // if filename='' then search for any {$I } directive
2385 // Beware: do not find {$I+}
2386 var
2387 p: LongInt;
2388 FilenameStartPos: integer;
2389 FilenameEndPos: integer;
2390 CommentStart: integer;
2391 CommentEnd: integer;
2392 begin
2393 Result:=false;
2394 //debugln(['TCompilerDirectivesTree.IsIncludeDirective ',CDNodeDescAsString(Node.Desc)]);
2395 if (Node=nil) or (Node.Desc<>cdnInclude) then exit;
2396 p:=Node.StartPos;
2397 if (Node.EndPos-p>=5) and (Src[p]='{') and (Src[p+1]='$') and (Src[p+2]='I')
2398 then begin
2399 if (Filename='') then exit(true);
2400 if FindNextIncludeDirective(Src,p,NestedComments,
2401 FilenameStartPos,FilenameEndPos,CommentStart,CommentEnd)=p then
2402 begin
2403 // do not use CompareFilenamesIgnoreCase
2404 if CompareText(Filename,
2405 copy(Src,FilenameStartPos,FilenameEndPos-FilenameStartPos))=0
2406 then
2407 exit(true);
2408 end;
2409 end;
2410 end;
2411
TCompilerDirectivesTree.GetDirectiveNamenull2412 function TCompilerDirectivesTree.GetDirectiveName(Node: TCodeTreeNode): string;
2413 begin
2414 Result:=GetIdentifier(@Src[Node.StartPos+2]);
2415 end;
2416
TCompilerDirectivesTree.GetDirectivenull2417 function TCompilerDirectivesTree.GetDirective(Node: TCodeTreeNode): string;
2418 begin
2419 Result:=copy(Src,Node.StartPos,
2420 FindCommentEnd(Src,Node.StartPos,NestedComments)-Node.StartPos);
2421 end;
2422
GetIfExpressionnull2423 function TCompilerDirectivesTree.GetIfExpression(Node: TCodeTreeNode;
2424 out ExprStart, ExprEnd: integer): boolean;
2425 var
2426 p: LongInt;
2427 begin
2428 Result:=false;
2429 ExprStart:=-1;
2430 ExprEnd:=-1;
2431 p:=Node.StartPos+2;
2432 if p>SrcLen then exit;
2433 while (p<=SrcLen) and IsIdentChar[Src[p]] do inc(p);
2434 if (p>SrcLen) or (not IsSpaceChar[Src[p]]) then exit;
2435 inc(p);
2436 ExprStart:=p;
2437 while (p<=SrcLen) and (Src[p]<>'}') do inc(p);
2438 ExprEnd:=p;
2439 Result:=true;
2440 end;
2441
GetIfExpressionStringnull2442 function TCompilerDirectivesTree.GetIfExpressionString(Node: TCodeTreeNode
2443 ): string;
2444 var
2445 ExprStart: integer;
2446 ExprEnd: integer;
2447 begin
2448 if not GetIfExpression(Node,ExprStart,ExprEnd) then
2449 Result:=''
2450 else
2451 Result:=copy(Src,ExprStart,ExprEnd-ExprStart);
2452 end;
2453
IsIfExpressionSimplenull2454 function TCompilerDirectivesTree.IsIfExpressionSimple(Node: TCodeTreeNode; out
2455 NameStart: integer): boolean;
2456 var
2457 p: LongInt;
2458 begin
2459 Result:=false;
2460 NameStart:=-1;
2461 // skip {$
2462 p:=Node.StartPos+2;
2463 if p>SrcLen then exit;
2464 // skip directive name
2465 while (p<=SrcLen) and IsIdentChar[Src[p]] do inc(p);
2466 // skip space
2467 if (p>SrcLen) or (not IsSpaceChar[Src[p]]) then exit;
2468 while (p<=SrcLen) and IsSpaceChar[Src[p]] do inc(p);
2469 if (p>SrcLen) or (not IsIdentStartChar[Src[p]]) then exit;
2470 // the expression starts with word
2471 NameStart:=p;
2472 if (Node.SubDesc=cdnsIfdef) or (Node.SubDesc=cdnsIfndef) then begin
2473 // IFDEF and IFNDEF only test the first word
2474 exit(true);
2475 end;
2476 // skip first word
2477 while (p<=SrcLen) and (IsIdentChar[Src[p]]) do inc(p);
2478 // skip space
2479 while (p<=SrcLen) and IsSpaceChar[Src[p]] do inc(p);
2480 if (p>SrcLen) or (Src[p]='}') then begin
2481 // the expression only contains one word
2482 exit(true);
2483 end;
2484 Result:=false;
2485 end;
2486
FindNameInIfExpressionnull2487 function TCompilerDirectivesTree.FindNameInIfExpression(Node: TCodeTreeNode;
2488 Identifier: PChar): integer;
2489 var
2490 p: LongInt;
2491 begin
2492 Result:=-1;
2493 // skip {$
2494 p:=Node.StartPos+2;
2495 if p>SrcLen then exit;
2496 // skip directive name
2497 while (p<=SrcLen) and IsIdentChar[Src[p]] do inc(p);
2498 // read expression
2499 while (p<=SrcLen) do begin
2500 if Src[p]='}' then exit;
2501 if IsIdentStartChar[Src[p]] then begin
2502 if CompareIdentifierPtrs(@Src[p],Identifier)=0 then
2503 exit(p);
2504 if (Node.SubDesc=cdnsIfdef) or (Node.SubDesc=cdnsIfndef) then begin
2505 // IFDEF and IFNDEF have only one word
2506 exit;
2507 end;
2508 while (p<=SrcLen) and (IsIdentChar[Src[p]]) do inc(p);
2509 end else begin
2510 inc(p);
2511 end;
2512 end;
2513 end;
2514
GetDefineNameAndValuenull2515 function TCompilerDirectivesTree.GetDefineNameAndValue(
2516 DefineNode: TCodeTreeNode; out NameStart: integer; out HasValue: boolean; out
2517 ValueStart: integer): boolean;
2518 var
2519 p: LongInt;
2520 begin
2521 Result:=false;
2522 NameStart:=-1;
2523 HasValue:=false;
2524 ValueStart:=-1;
2525 p:=DefineNode.StartPos+2;
2526 if p>SrcLen then exit;
2527 // skip keyword
2528 while (p<=SrcLen) and (IsIdentChar[Src[p]]) do inc(p);
2529 while (p<=SrcLen) and (IsSpaceChar[Src[p]]) do inc(p);
2530 // check name
2531 if p>SrcLen then exit;
2532 NameStart:=p;
2533 if not IsIdentStartChar[Src[p]] then exit;
2534 Result:=true;
2535
2536 // skip name
2537 while (p<=SrcLen) and (IsIdentChar[Src[p]]) do inc(p);
2538 while (p<=SrcLen) and (IsSpaceChar[Src[p]]) do inc(p);
2539 if p>SrcLen then exit;
2540 if (Src[p]=':') and (p<SrcLen) and (Src[p+1]='=') then begin
2541 // has value
2542 HasValue:=true;
2543 inc(p,2);
2544 while (p<=SrcLen) and (IsSpaceChar[Src[p]]) do inc(p);
2545 ValueStart:=p;
2546 end;
2547 end;
2548
DefineUsesNamenull2549 function TCompilerDirectivesTree.DefineUsesName(DefineNode: TCodeTreeNode;
2550 Identifier: PChar): boolean;
2551 var
2552 p: LongInt;
2553 begin
2554 Result:=false;
2555 p:=DefineNode.StartPos+2;
2556 if p>SrcLen then exit;
2557 // skip keyword
2558 while (p<=SrcLen) and (IsIdentChar[Src[p]]) do inc(p);
2559 while (p<=SrcLen) and (IsSpaceChar[Src[p]]) do inc(p);
2560 // check name
2561 if p>SrcLen then exit;
2562 Result:=CompareIdentifierPtrs(@Src[p],Identifier)=0;
2563 end;
2564
NodeIsEmptynull2565 function TCompilerDirectivesTree.NodeIsEmpty(Node: TCodeTreeNode;
2566 IgnoreComments: boolean): boolean;
2567 var
2568 DirectiveEndPos: LongInt;
2569 begin
2570 if (Node=nil) then exit(true);
2571 if Node.FirstChild<>nil then exit(false);
2572 case Node.Desc of
2573 cdnNone: exit(true);
2574 cdnRoot: exit(false); // root is never empty, can not be deleted
2575 cdnDefine: exit(true);
2576 cdnIf,
2577 cdnElseIf,
2578 cdnElse:
2579 begin
2580 if Node.NextBrother=nil then exit(false); // maybe continued in another file
2581 MoveCursorToPos(Node.StartPos);
2582 // skip directive
2583 ReadNextAtom;
2584 DirectiveEndPos:=SrcPos;
2585 // read the following atom (token or directive)
2586 ReadNextAtom;
2587 if AtomStart=Node.NextBrother.StartPos then begin
2588 if IgnoreComments then
2589 exit(true)
2590 else if FindNextNonSpace(Src,DirectiveEndPos)<AtomStart then
2591 exit(false)
2592 else
2593 exit(true);
2594 end;
2595 end;
2596 cdnEnd: exit(false);
2597 else exit(false);
2598 end;
2599 end;
2600
FindNodeAtPosnull2601 function TCompilerDirectivesTree.FindNodeAtPos(p: integer): TCodeTreeNode;
2602 begin
2603 Result:=Tree.Root;
2604 while Result<>nil do begin
2605 if Result.StartPos>p then
2606 exit(Result.Parent);
2607 if (Result.EndPos>p)
2608 or ((Result.EndPos=p) and (Result.NextBrother<>nil)
2609 and (Result.NextBrother.StartPos>p))
2610 then begin
2611 // p is in range of Result => check children
2612 if (Result.FirstChild=nil)
2613 or (Result.FirstChild.StartPos>p) then
2614 exit;
2615 Result:=Result.FirstChild;
2616 end else begin
2617 // p is behind => next
2618 if Result.NextBrother<>nil then
2619 Result:=Result.NextBrother
2620 else
2621 exit(Result.Parent);
2622 end;
2623 end;
2624 end;
2625
2626 procedure TCompilerDirectivesTree.MoveCursorToPos(p: integer);
2627 begin
2628 SrcPos:=p;
2629 AtomStart:=p;
2630 end;
2631
2632 procedure TCompilerDirectivesTree.ReadNextAtom;
2633 begin
2634 //DebugLn(['TCompilerDirectivesTree.ReadNextAtom START ',AtomStart,'-',SrcPos,' ',Src[SrcPos]]);
2635 ReadRawNextPascalAtom(Src,SrcPos,AtomStart,NestedComments);
2636 //DebugLn(['TCompilerDirectivesTree.ReadNextAtom END ',AtomStart,'-',SrcPos,' ',copy(Src,AtomStart,SrcPos-AtomStart)]);
2637 end;
2638
ReadTilBracketClosenull2639 function TCompilerDirectivesTree.ReadTilBracketClose(CloseBracket: char
2640 ): boolean;
2641 begin
2642 Result:=false;
2643 repeat
2644 ReadNextAtom;
2645 if AtomStart>SrcLen then exit;
2646 if SrcPos-AtomStart=1 then begin
2647 if Src[AtomStart]=CloseBracket then
2648 exit(true)
2649 else if Src[AtomStart]='(' then
2650 ReadTilBracketClose(')')
2651 else if Src[AtomStart]='[' then
2652 ReadTilBracketClose(']');
2653 end;
2654 until false;
2655 end;
2656
AtomIsnull2657 function TCompilerDirectivesTree.AtomIs(const s: shortstring): boolean;
2658 var
2659 len: Integer;
2660 i: Integer;
2661 begin
2662 len:=length(s);
2663 if (len<>SrcPos-AtomStart) then exit(false);
2664 if SrcPos>SrcLen then exit(false);
2665 for i:=1 to len do
2666 if Src[AtomStart+i-1]<>s[i] then exit(false);
2667 Result:=true;
2668 end;
2669
UpAtomIsnull2670 function TCompilerDirectivesTree.UpAtomIs(const s: shortstring): boolean;
2671 var
2672 len: Integer;
2673 i: Integer;
2674 begin
2675 len:=length(s);
2676 if (len<>SrcPos-AtomStart) then exit(false);
2677 if SrcPos>SrcLen then exit(false);
2678 for i:=1 to len do
2679 if UpChars[Src[AtomStart+i-1]]<>s[i] then exit(false);
2680 Result:=true;
2681 end;
2682
AtomIsIdentifiernull2683 function TCompilerDirectivesTree.AtomIsIdentifier: boolean;
2684 var
2685 p: Integer;
2686 begin
2687 if (AtomStart>=SrcPos) then exit(false);
2688 if (SrcPos>SrcLen) or (SrcPos-AtomStart>255) then exit(false);
2689 if not IsIdentStartChar[Src[AtomStart]] then exit(false);
2690 p:=AtomStart+1;
2691 while (p<SrcPos) do begin
2692 if not IsIdentChar[Src[p]] then exit(false);
2693 inc(p);
2694 end;
2695 Result:=true;
2696 end;
2697
GetAtomnull2698 function TCompilerDirectivesTree.GetAtom: string;
2699 begin
2700 Result:=copy(Src,AtomStart,SrcPos-AtomStart);
2701 end;
2702
2703 procedure TCompilerDirectivesTree.Replace(FromPos, ToPos: integer;
2704 const NewSrc: string);
2705 var
2706 Node: TCodeTreeNode;
2707 DiffPos: Integer;
2708 begin
2709 //DebugLn(['TCompilerDirectivesTree.Replace ',FromPos,'-',ToPos,' Old="',copy(Src,FromPos,ToPos-FromPos),'" New="',NewSrc,'"']);
2710 IncreaseChangeStep;
2711 Code.Replace(FromPos,ToPos-FromPos,NewSrc);
2712 Src:=Code.Source;
2713 SrcLen:=length(Src);
2714 // update positions
2715 DiffPos:=length(NewSrc)-(ToPos-FromPos);
2716 if DiffPos<>0 then begin
2717 Node:=Tree.Root;
2718 while Node<>nil do begin
2719 AdjustPositionAfterInsert(Node.StartPos,true,FromPos,ToPos,DiffPos);
2720 AdjustPositionAfterInsert(Node.EndPos,false,FromPos,ToPos,DiffPos);
2721 Node:=Node.Next;
2722 end;
2723 end;
2724 end;
2725
2726 procedure TCompilerDirectivesTree.IncreaseChangeStep;
2727 begin
2728 if FChangeStep<>$7fffffff then
2729 inc(FChangeStep)
2730 else
2731 FChangeStep:=-$7fffffff;
2732 end;
2733
2734 procedure TCompilerDirectivesTree.ResetMacros;
2735 begin
2736 if Macros<>nil then
2737 Macros.FreeAndClear
2738 else
2739 Macros:=TAVLTree.Create(@CompareCompilerMacroStats);
2740 end;
2741
2742 procedure TCompilerDirectivesTree.ClearMacros;
2743 begin
2744 if Macros<>nil then begin
2745 Macros.FreeAndClear;
2746 FreeAndNil(Macros);
2747 end;
2748 end;
2749
2750 procedure TCompilerDirectivesTree.WriteDebugReport;
2751 var
2752 Node: TCodeTreeNode;
2753 begin
2754 DebugLn(['TCompilerDirectivesTree.WriteDebugReport ']);
2755 if Tree<>nil then begin
2756 Node:=Tree.Root;
2757 while Node<>nil do begin
2758 DebugLn([GetIndentStr(Node.GetLevel*2)+CDNodeDescAsString(Node.Desc),' ',GetDirective(Node)]);
2759 Node:=Node.Next;
2760 end;
2761 end;
2762 end;
2763
2764 { TH2PasFunction }
2765
NeedsBodynull2766 function TH2PasFunction.NeedsBody: boolean;
2767 begin
2768 Result:=(IsForward or InInterface) and (not IsExternal) and (BeginStart<0);
2769 end;
2770
2771 procedure TH2PasFunction.AdjustPositionsAfterInsert(FromPos, ToPos,
2772 DiffPos: integer);
2773 begin
2774 AdjustPositionAfterInsert(HeaderStart,true,FromPos,ToPos,DiffPos);
2775 AdjustPositionAfterInsert(HeaderEnd,false,FromPos,ToPos,DiffPos);
2776 AdjustPositionAfterInsert(BeginStart,true,FromPos,ToPos,DiffPos);
2777 AdjustPositionAfterInsert(BeginEnd,false,FromPos,ToPos,DiffPos);
2778 end;
2779
2780 { ECDirectiveParserException }
2781
2782 constructor ECDirectiveParserException.Create(ASender: TCompilerDirectivesTree;
2783 TheId: int64; const AMessage: string);
2784 begin
2785 Id:=TheId;
2786 inherited Create(AMessage);
2787 Sender:=ASender;
2788 end;
2789
2790 end.
2791
2792