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     Cache objects for TFindDeclarationTool.
25 
26 }
27 unit FindDeclarationCache;
28 
29 {$mode objfpc}{$H+}
30 
31 interface
32 
33 {$I codetools.inc}
34 
35 
36 // for debugging
37 { $DEFINE HardExceptions}
38 
39 uses
40   Classes, SysUtils, Laz_AVL_Tree,
41   // Codetools
42   FileProcs, BasicCodeTools, CodeTree, LinkScanner,
43   PascalParserTool, KeywordFuncLists, CodeToolMemManager;
44 
45 type
46   {
47     1. interface cache: (unit interfaces, not class interfaces)
48       Every FindIdentifierInInterface call is cached
49         - stores: Identifier -> Node+CleanPos
50         - cache must be deleted, everytime the codetree is rebuilt
51            this is enough update, because it does only store internals
52        -> This improves search time for interface requests
53   }
54   PInterfaceIdentCacheEntry = ^TInterfaceIdentCacheEntry;
55   TInterfaceIdentCacheEntry = record
56     Identifier: PChar;
57     Node: TCodeTreeNode; // if node = nil then identifier does not exist in
58                          //                    this interface
59     CleanPos: integer;
60     Overloaded: PInterfaceIdentCacheEntry;
61     NextEntry: PInterfaceIdentCacheEntry; // used by memory manager
62   end;
63 
64   { TInterfaceIdentifierCache }
65 
66   TInterfaceIdentifierCache = class
67   private
68     FComplete: boolean;
69     FItems: TAVLTree; // tree of PInterfaceIdentCacheEntry
70     FTool: TPascalParserTool;
FindAVLNodenull71     function FindAVLNode(Identifier: PChar): TAVLTreeNode;
72     procedure SetComplete(const AValue: boolean);
73   public
FindIdentifiernull74     function FindIdentifier(Identifier: PChar): PInterfaceIdentCacheEntry;
75     procedure Add(Identifier: PChar; Node: TCodeTreeNode; CleanPos: integer);
76     procedure Clear;
77     procedure ClearMissingIdentifiers;
78     constructor Create(ATool: TPascalParserTool);
79     destructor Destroy; override;
80     procedure ConsistencyCheck;
81     property Tool: TPascalParserTool read FTool;
82     property Complete: boolean read FComplete write SetComplete;
83     property Items: TAVLTree read FItems; // Tree of PInterfaceIdentCacheEntry
CalcMemSizenull84     function CalcMemSize: PtrUInt;
85   end;
86 
87   {
88     2. code tree node cache:
89       Some nodes (class, proc, record) contain a node cache. A node cache caches
90       search results of searched identifiers for child nodes.
91 
92       Every entry in the node cache describes the following relationship:
93         Identifier+Range -> Source Position
94       and can be interpreted as:
95       Identifier is a PChar to the beginning of an identifier string.
96       Range is a cleaned source range (CleanStartPos-CleanEndPos).
97       Source position is a tuple of NewTool, NewNode, NewCleanPos.
98       If the current context node is a child of a caching node and it is in the
99       range, then the result is valid. If NewNode=nil then there is no such
100       identifier valid at the context node.
101 
102       Every node that defines local identifiers contains a node cache.
103       These are: class, interface, proc, record, withstatement
104 
105       Because node caches can store information of used units, the cache must be
106       deleted every time a used unit is changed.
107   }
108 const
109   AllNodeCacheDescs =
110     AllClasses+[ctnProcedure, ctnWithVariable];
111 
112 type
113   TNodeCacheEntryFlag = (ncefSearchedInParents, ncefSearchedInAncestors);
114   TNodeCacheEntryFlags = set of TNodeCacheEntryFlag;
115 
116   PCodeTreeNodeCacheEntry = ^TCodeTreeNodeCacheEntry;
117   TCodeTreeNodeCacheEntry = record
118     Identifier: PChar;
119     CleanStartPos: integer;
120     CleanEndPos: integer;
121     NewNode: TCodeTreeNode;
122     NewTool: TPascalParserTool;
123     NewCleanPos: integer;
124     Flags: TNodeCacheEntryFlags;
125     NextEntry: PCodeTreeNodeCacheEntry; // used for mem manager
126   end;
127 
128   { TCodeTreeNodeCache }
129 
130   TCodeTreeNodeCache = class
131   private
132     FItems: TAVLTree; // tree of PCodeTreeNodeCacheEntry
133   public
134     Next: TCodeTreeNodeCache;
135     Owner: TCodeTreeNode;
FindLeftMostAVLNodenull136     function FindLeftMostAVLNode(Identifier: PChar): TAVLTreeNode;
FindRightMostAVLNodenull137     function FindRightMostAVLNode(Identifier: PChar): TAVLTreeNode;
FindAVLNodenull138     function FindAVLNode(Identifier: PChar; CleanPos: integer): TAVLTreeNode;
FindAVLNodeInRangenull139     function FindAVLNodeInRange(Identifier: PChar;
140       CleanStartPos, CleanEndPos: integer): TAVLTreeNode;
FindInRangenull141     function FindInRange(Identifier: PChar;
142       CleanStartPos, CleanEndPos: integer): PCodeTreeNodeCacheEntry;
FindNearestAVLNodenull143     function FindNearestAVLNode(Identifier: PChar;
144       CleanStartPos, CleanEndPos: integer; {%H-}InFront: boolean): TAVLTreeNode;
FindNearestnull145     function FindNearest(Identifier: PChar;
146       CleanStartPos, CleanEndPos: integer;
147       InFront: boolean): PCodeTreeNodeCacheEntry;
Findnull148     function Find(Identifier: PChar): PCodeTreeNodeCacheEntry;
149     procedure Add(Identifier: PChar;
150       SrcTool: TPascalParserTool; CleanStartPos, CleanEndPos: integer;
151       NewNode: TCodeTreeNode; NewTool: TPascalParserTool; NewCleanPos: integer;
152       Flags: TNodeCacheEntryFlags);
153     procedure Clear;
154     procedure BindToOwner(NewOwner: TCodeTreeNode);
155     procedure UnbindFromOwner;
156     constructor Create(AnOwner: TCodeTreeNode);
157     destructor Destroy; override;
158     procedure WriteDebugReport(const Prefix: string);
159     procedure ConsistencyCheck;
CalcMemSizenull160     function CalcMemSize: PtrUInt;
161   end;
162 
163   {
164     3. Base type node cache
165 
166     All nodes, that are aliases, has this type of cache.
167     For example a variable 'i: integer' creates several basetype nodes:
168       1. i variable node points to its type node 'integer'.
169       2. 'integer' node points to type definition node 'integer'.
170       3. 'integer' identifier node points to its base type 'longint'.
171       4. 'longint' identifier node points points to its range.
172 
173       FindBaseTypeOfNode will search this chain, and on success will create
174       TBaseTypeCache(s). The All four nodes will point directly to the range.
175 
176   }
177 
178   { TBaseTypeCache }
179 
180   TBaseTypeCache = class
181   private
182   public
183     BaseNode: TCodeTreeNode; // final base type
184     BaseTool: TPascalParserTool;
185     NextNode: TCodeTreeNode; // next node on path to the BaseNode
186     NextTool: TPascalParserTool;
187     NextCache: TBaseTypeCache; // used for mem manager
188     Owner: TCodeTreeNode;
189     procedure BindToOwner(NewOwner: TCodeTreeNode);
190     procedure UnbindFromOwner;
191     constructor Create(AnOwner: TCodeTreeNode);
192     destructor Destroy; override;
CalcMemSizenull193     function CalcMemSize: PtrUInt;
194   end;
195 
196   {
197     4. CodeTool Cache Dependencies
198 
199     Node- and BaseTypeCache depends on their codetool and the
200     node- and basetypecaches of other codetools (=used codetools). The used
201     codetools dependencies are saved in the TCodeToolDependencies, which is
202     simply an TAVLTree of codetools. This allows one to decide, wether the cache of
203     a codetools must be rebuilt.
204   }
205 
206   //----------------------------------------------------------------------------
207 type
208 
209   { TGlobalIdentifierTree }
210 
211   TGlobalIdentifierTree = class
212   private
213     FItems: TAVLTree; // tree of PChar;
214     FDefaultDataBlockSize: integer;
215     FDataBlockSize: integer;
216     FDataBlock: Pointer;
217     FDataBlockEnd: integer;
218     FFullDataBlocks: TFPList; // full blocks of data
InternalGetMemnull219     function InternalGetMem(Size: integer): Pointer;
220   public
AddCopynull221     function AddCopy(Identifier: PChar): PChar;
Findnull222     function Find(Identifier: PChar): PChar;
223     procedure Clear;
224     constructor Create;
225     destructor Destroy; override;
Countnull226     function Count: integer;
CalcMemSizenull227     function CalcMemSize: PtrUInt;
228   end;
229 
230   //----------------------------------------------------------------------------
231   // Memory Managers
232 
233   // memory system for PInterfaceIdentCacheEntry(s)
234   TInterfaceIdentCacheEntryMemManager = class(TCodeToolMemManager)
235   protected
236     procedure FreeFirstItem; override;
237   public
238     procedure DisposeEntry(Entry: PInterfaceIdentCacheEntry);
NewEntrynull239     function NewEntry: PInterfaceIdentCacheEntry;
240   end;
241 
242   // memory system for PCodeTreeNodeCacheEntry(s)
243   TNodeCacheEntryMemManager = class(TCodeToolMemManager)
244   protected
245     procedure FreeFirstItem; override;
246   public
247     procedure DisposeEntry(Entry: PCodeTreeNodeCacheEntry);
NewEntrynull248     function NewEntry: PCodeTreeNodeCacheEntry;
249   end;
250 
251   // memory system for TCodeTreeNodeCache(s)
252   TNodeCacheMemManager = class(TCodeToolMemManager)
253   protected
254     procedure FreeFirstItem; override;
255   public
256     procedure DisposeNodeCache(NodeCache: TCodeTreeNodeCache);
NewNodeCachenull257     function NewNodeCache(AnOwner: TCodeTreeNode): TCodeTreeNodeCache;
258   end;
259 
260   // memory system for TBaseTypeCache(s)
261   TBaseTypeCacheMemManager = class(TCodeToolMemManager)
262   protected
263     procedure FreeFirstItem; override;
264   public
265     procedure DisposeBaseTypeCache(BaseTypeCache: TBaseTypeCache);
NewBaseTypeCachenull266     function NewBaseTypeCache(AnOwner: TCodeTreeNode): TBaseTypeCache;
267   end;
268 
269   //----------------------------------------------------------------------------
270   // stacks for cycle checking
271 const
272   CodeTreeNodeFixedItemCount = 12;
273 type
274   TCodeTreeNodeStackEntry = record
275     Tool: TPascalParserTool;
276     Node: TCodeTreeNode;
277   end;
278   PCodeTreeNodeStackEntry = ^TCodeTreeNodeStackEntry;
279 
280   TCodeTreeNodeStack = record
281     FixedItems: array[0..CodeTreeNodeFixedItemCount-1] of TCodeTreeNodeStackEntry;
282     DynItems: PCodeTreeNodeStackEntry;
283     StackPtr: integer;
284     Capacity: integer; // size of  DynItems in entries
285   end;
286   PCodeTreeNodeStack = ^TCodeTreeNodeStack;
287 
288   procedure InitializeNodeStack(NodeStack: PCodeTreeNodeStack);
GetNodeStackEntrynull289   function GetNodeStackEntry(NodeStack: PCodeTreeNodeStack;
290     Index: integer): PCodeTreeNodeStackEntry;
291   procedure AddNodeToStack(NodeStack: PCodeTreeNodeStack;
292     NewTool: TPascalParserTool; NewNode: TCodeTreeNode);
NodeExistsInStacknull293   function NodeExistsInStack(NodeStack: PCodeTreeNodeStack;
294     Node: TCodeTreeNode): boolean;
295   procedure FinalizeNodeStack(NodeStack: PCodeTreeNodeStack);
296 
297 const
298   ncefAllSearchRanges = [ncefSearchedInAncestors,ncefSearchedInParents];
299   NodeCacheEntryFlagNames: array[TNodeCacheEntryFlag] of string = (
300       'SearchedInParents', 'SearchedInAncestors'
301     );
302 
303 var
304   GlobalIdentifierTree: TGlobalIdentifierTree;
305   InterfaceIdentCacheEntryMemManager: TInterfaceIdentCacheEntryMemManager;
306   NodeCacheEntryMemManager: TNodeCacheEntryMemManager;
307   NodeCacheMemManager: TNodeCacheMemManager;
308   BaseTypeCacheMemManager: TBaseTypeCacheMemManager;
309 
310 
NodeCacheEntryFlagsAsStringnull311 function NodeCacheEntryFlagsAsString(Flags: TNodeCacheEntryFlags): string;
312 
313 
314 implementation
315 
316 
NodeCacheEntryFlagsAsStringnull317 function NodeCacheEntryFlagsAsString(Flags: TNodeCacheEntryFlags): string;
318 var f: TNodeCacheEntryFlag;
319 begin
320   Result:='';
321   for f:=Low(TNodeCacheEntryFlag) to High(TNodeCacheEntryFlag) do begin
322     if f in Flags then begin
323       if Result<>'' then Result:=rEsult+', ';
324       Result:=Result+NodeCacheEntryFlagNames[f];
325     end;
326   end;
327 end;
328 
329 { TNodeCacheEntryMemManager }
330 
331 procedure TNodeCacheEntryMemManager.DisposeEntry(Entry: PCodeTreeNodeCacheEntry);
332 begin
333   if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio)) then
334   begin
335     // add Entry to Free list
336     Entry^.NextEntry:=PCodeTreeNodeCacheEntry(FFirstFree);
337     PCodeTreeNodeCacheEntry(FFirstFree):=Entry;
338     inc(FFreeCount);
339   end else begin
340     // free list full -> free the Entry
341     Dispose(Entry);
342     {$IFDEF DebugCTMemManager}
343     inc(FFreedCount);
344     {$ENDIF}
345   end;
346   dec(FCount);
347 end;
348 
NewEntrynull349 function TNodeCacheEntryMemManager.NewEntry: PCodeTreeNodeCacheEntry;
350 begin
351   if FFirstFree<>nil then begin
352     // take from free list
353     Result:=PCodeTreeNodeCacheEntry(FFirstFree);
354     PCodeTreeNodeCacheEntry(FFirstFree):=Result^.NextEntry;
355     Result^.NextEntry:=nil;
356     dec(FFreeCount);
357   end else begin
358     // free list empty -> create new Entry
359     New(Result);
360     {$IFDEF DebugCTMemManager}
361     inc(FAllocatedCount);
362     {$ENDIF}
363   end;
364   inc(FCount);
365 end;
366 
367 procedure TNodeCacheEntryMemManager.FreeFirstItem;
368 var Entry: PCodeTreeNodeCacheEntry;
369 begin
370   Entry:=PCodeTreeNodeCacheEntry(FFirstFree);
371   PCodeTreeNodeCacheEntry(FFirstFree):=Entry^.NextEntry;
372   Dispose(Entry);
373 end;
374 
375 
376 { TInterfaceIdentCacheEntryMemManager }
377 
378 procedure TInterfaceIdentCacheEntryMemManager.DisposeEntry(
379   Entry: PInterfaceIdentCacheEntry);
380 begin
381   if Entry^.Overloaded<>nil then begin
382     DisposeEntry(Entry^.Overloaded);
383     Entry^.Overloaded:=nil;
384   end;
385   if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio)) then
386   begin
387     // add Entry to Free list
388     Entry^.NextEntry:=PInterfaceIdentCacheEntry(FFirstFree);
389     PInterfaceIdentCacheEntry(FFirstFree):=Entry;
390     inc(FFreeCount);
391   end else begin
392     // free list full -> free the Entry
393     Dispose(Entry);
394     {$IFDEF DebugCTMemManager}
395     inc(FFreedCount);
396     {$ENDIF}
397   end;
398   dec(FCount);
399 end;
400 
TInterfaceIdentCacheEntryMemManager.NewEntrynull401 function TInterfaceIdentCacheEntryMemManager.NewEntry: PInterfaceIdentCacheEntry;
402 begin
403   if FFirstFree<>nil then begin
404     // take from free list
405     Result:=PInterfaceIdentCacheEntry(FFirstFree);
406     PInterfaceIdentCacheEntry(FFirstFree):=Result^.NextEntry;
407     Result^.NextEntry:=nil;
408     dec(FFreeCount);
409   end else begin
410     // free list empty -> create new Entry
411     New(Result);
412     {$IFDEF DebugCTMemManager}
413     inc(FAllocatedCount);
414     {$ENDIF}
415   end;
416   inc(FCount);
417 end;
418 
419 procedure TInterfaceIdentCacheEntryMemManager.FreeFirstItem;
420 var Entry: PInterfaceIdentCacheEntry;
421 begin
422   Entry:=PInterfaceIdentCacheEntry(FFirstFree);
423   PInterfaceIdentCacheEntry(FFirstFree):=Entry^.NextEntry;
424   Dispose(Entry);
425 end;
426 
427 
428 { TInterfaceIdentifierCache }
429 
CompareTInterfaceIdentCacheEntrynull430 function CompareTInterfaceIdentCacheEntry(Data1, Data2: Pointer): integer;
431 begin
432   Result:=CompareIdentifiers(PInterfaceIdentCacheEntry(Data1)^.Identifier,
433                              PInterfaceIdentCacheEntry(Data2)^.Identifier);
434 end;
435 
436 
437 procedure TInterfaceIdentifierCache.Clear;
438 var
439   Node: TAVLTreeNode;
440   Entry: PInterfaceIdentCacheEntry;
441 begin
442   if FItems<>nil then begin
443     Node:=FItems.FindLowest;
444     while Node<>nil do begin
445       Entry:=PInterfaceIdentCacheEntry(Node.Data);
446       InterfaceIdentCacheEntryMemManager.DisposeEntry(Entry);
447       Node:=FItems.FindSuccessor(Node);
448     end;
449     FItems.Clear;
450   end;
451 end;
452 
453 procedure TInterfaceIdentifierCache.ClearMissingIdentifiers;
454 var
455   Node: TAVLTreeNode;
456   NextNode: TAVLTreeNode;
457   Entry: PInterfaceIdentCacheEntry;
458 begin
459   if FItems=nil then exit;
460   Node:=FItems.FindLowest;
461   while Node<>nil do begin
462     NextNode:=FItems.FindSuccessor(Node);
463     Entry:=PInterfaceIdentCacheEntry(Node.Data);
464     if Entry^.Node=nil then begin
465       FItems.Delete(Node);
466       InterfaceIdentCacheEntryMemManager.DisposeEntry(Entry);
467     end;
468     Node:=NextNode;
469   end;
470 end;
471 
472 constructor TInterfaceIdentifierCache.Create(ATool: TPascalParserTool);
473 begin
474   inherited Create;
475   FTool:=ATool;
476   if ATool=nil then
477     raise Exception.Create('TInterfaceIdentifierCache.Create ATool=nil');
478 end;
479 
480 destructor TInterfaceIdentifierCache.Destroy;
481 begin
482   Clear;
483   FreeAndNil(FItems);
484   inherited Destroy;
485 end;
486 
487 procedure TInterfaceIdentifierCache.ConsistencyCheck;
488 var
489   Node: TAVLTreeNode;
490   Entry: PInterfaceIdentCacheEntry;
491 begin
492   if FItems<>nil then begin
493     FItems.ConsistencyCheck;
494     Node:=FItems.FindLowest;
495     while Node<>nil do begin
496       Entry:=PInterfaceIdentCacheEntry(Node.Data);
497       while Entry<>nil do begin
498         if (Entry^.Identifier=nil) or (Entry^.Identifier^=#0) then
499           RaiseCatchableException('');
500         if (Entry^.Node=nil) and Complete then
501           RaiseCatchableException('');
502         if (Entry^.Overloaded<>nil)
503         and (CompareIdentifiers(Entry^.Identifier,Entry^.Overloaded^.Identifier)<>0)
504         then begin
505           debugln(['TInterfaceIdentifierCache.ConsistencyCheck Entry=',GetIdentifier(Entry^.Identifier),'<>',GetIdentifier(Entry^.Overloaded^.Identifier)]);
506           RaiseCatchableException('');
507         end;
508         Entry:=Entry^.Overloaded;
509       end;
510       Node:=FItems.FindSuccessor(Node);
511     end;
512   end;
513 end;
514 
CalcMemSizenull515 function TInterfaceIdentifierCache.CalcMemSize: PtrUInt;
516 var
517   Node: TAVLTreeNode;
518 begin
519   Result:=PtrUInt(InstanceSize);
520   if FItems<>nil then begin
521     inc(Result,FItems.Count*SizeOf(TAVLTreeNode));
522     Node:=FItems.FindLowest;
523     while Node<>nil do begin
524       inc(Result,SizeOf(TInterfaceIdentCacheEntry));
525       Node:=FItems.FindSuccessor(Node);
526     end;
527   end;
528 end;
529 
TInterfaceIdentifierCache.FindAVLNodenull530 function TInterfaceIdentifierCache.FindAVLNode(Identifier: PChar): TAVLTreeNode;
531 var
532   Entry: PInterfaceIdentCacheEntry;
533   comp: integer;
534 begin
535   if FItems<>nil then begin
536     Result:=FItems.Root;
537     while Result<>nil do begin
538       Entry:=PInterfaceIdentCacheEntry(Result.Data);
539       comp:=CompareIdentifiers(Identifier,Entry^.Identifier);
540       if comp<0 then
541         Result:=Result.Left
542       else if comp>0 then
543         Result:=Result.Right
544       else
545         exit;
546     end;
547   end else begin
548     Result:=nil;
549   end;
550 end;
551 
552 procedure TInterfaceIdentifierCache.SetComplete(const AValue: boolean);
553 begin
554   if FComplete=AValue then exit;
555   FComplete:=AValue;
556   if FComplete then
557     ClearMissingIdentifiers;
558 end;
559 
TInterfaceIdentifierCache.FindIdentifiernull560 function TInterfaceIdentifierCache.FindIdentifier(Identifier: PChar
561   ): PInterfaceIdentCacheEntry;
562 var Node: TAVLTreeNode;
563 begin
564   Node:=FindAVLNode(Identifier);
565   if Node<>nil then
566     Result:=PInterfaceIdentCacheEntry(Node.Data)
567   else
568     Result:=nil;
569 end;
570 
571 procedure TInterfaceIdentifierCache.Add(Identifier: PChar; Node: TCodeTreeNode;
572   CleanPos: integer);
573 var
574   NewEntry: PInterfaceIdentCacheEntry;
575   OldNode: TAVLTreeNode;
576 begin
577   if (Identifier<>nil) and (Identifier^ = '&') then
578     Inc(Identifier);
579   if (GetIdentLen(Identifier)=0) then
580     RaiseCatchableException('TInterfaceIdentifierCache.Add: empty identifier');
581   if FItems=nil then
582     FItems:=TAVLTree.Create(@CompareTInterfaceIdentCacheEntry);
583   OldNode:=FindAVLNode(Identifier);
584   NewEntry:=InterfaceIdentCacheEntryMemManager.NewEntry;
585   NewEntry^.Identifier:=GlobalIdentifierTree.AddCopy(Identifier);
586   NewEntry^.Node:=Node;
587   NewEntry^.CleanPos:=CleanPos;
588   if OldNode<>nil then begin
589     NewEntry^.Overloaded:=PInterfaceIdentCacheEntry(OldNode.Data);
590     OldNode.Data:=NewEntry;
591   end else begin
592     NewEntry^.Overloaded:=nil;
593     FItems.Add(NewEntry);
594   end;
595 end;
596 
597 { TGlobalIdentifierTree }
598 
599 procedure TGlobalIdentifierTree.Clear;
600 var
601   i: Integer;
602 begin
603   if FItems<>nil then
604     FItems.Clear;
605   if FFullDataBlocks<>nil then begin
606     for i:=0 to FFullDataBlocks.Count-1 do
607       FreeMem(FFullDataBlocks[i]);
608     FFullDataBlocks.Clear;
609     ReAllocMem(FDataBlock,0);
610     FDataBlockEnd:=0;
611     FDataBlockSize:=0;
612   end;
613 end;
614 
615 constructor TGlobalIdentifierTree.Create;
616 begin
617   inherited Create;
618   FItems:=TAVLTree.Create(TListSortCompare(@CompareIdentifiers));
619   FFullDataBlocks:=TFPList.Create;
620   FDefaultDataBlockSize:=256*256*2;
621 end;
622 
623 destructor TGlobalIdentifierTree.Destroy;
624 begin
625   Clear;
626   FItems.Free;
627   FFullDataBlocks.Free;
628   inherited Destroy;
629 end;
630 
TGlobalIdentifierTree.Countnull631 function TGlobalIdentifierTree.Count: integer;
632 begin
633   if FItems<>nil then
634     Result:=FItems.Count
635   else
636     Result:=0;
637 end;
638 
CalcMemSizenull639 function TGlobalIdentifierTree.CalcMemSize: PtrUInt;
640 begin
641   Result:=PtrUInt(InstanceSize)
642     +PtrUint(FItems.InstanceSize)
643     +PtrUInt(FItems.Count)*PtrUint(TAVLTreeNode.InstanceSize)
644     +PtrUInt(FFullDataBlocks.InstanceSize)
645     +PtrUInt(FFullDataBlocks.Capacity)*SizeOf(Pointer)
646     +PtrUInt(FFullDataBlocks.Count*FDefaultDataBlockSize)
647     +PtrUInt(FDataBlockSize);
648 end;
649 
TGlobalIdentifierTree.InternalGetMemnull650 function TGlobalIdentifierTree.InternalGetMem(Size: integer): Pointer;
651 begin
652   if (FDataBlock=nil) or (FDataBlockEnd+Size>FDataBlockSize) then begin
653     // store old block
654     FFullDataBlocks.Add(FDataBlock);
655     // create a new
656     FDataBlockSize:=FDefaultDataBlockSize;
657     if FDataBlockSize<Size then
658       FDataBlockSize:=Size;
659     GetMem(FDataBlock,FDataBlockSize);
660     FDataBlockEnd:=0;
661   end;
662   Result:=FDataBlock+FDataBlockEnd;
663   inc(FDataBlockEnd,Size);
664 end;
665 
AddCopynull666 function TGlobalIdentifierTree.AddCopy(Identifier: PChar): PChar;
667 var Len: integer;
668 begin
669   Result:=nil;
670   if (Identifier=nil) or (not IsIdentChar[Identifier[0]]) then exit;
671   Result:=Find(Identifier);
672   if Result<>nil then
673     exit;
674   Len:=0;
675   while IsIdentChar[Identifier[Len]] do inc(Len);
676   Result:=InternalGetMem(Len+1);
677   // GetMem(Result,Len+1);
678   Move(Identifier^,Result^,Len);
679   Result[Len]:=#0;
680   FItems.Add(Result);
681 end;
682 
Findnull683 function TGlobalIdentifierTree.Find(Identifier: PChar): PChar;
684 var
685   comp: integer;
686   Node: TAVLTreeNode;
687 begin
688   if FItems<>nil then begin
689     Node:=FItems.Root;
690     while Node<>nil do begin
691       Result:=PChar(Node.Data);
692       comp:=CompareIdentifiers(Identifier,Result);
693       if comp<0 then
694         Node:=Node.Left
695       else if comp>0 then
696         Node:=Node.Right
697       else
698         exit;
699     end;
700   end;
701   Result:=nil;
702 end;
703 
704 
705 { TCodeTreeNodeCache }
706 
CompareTCodeTreeNodeCacheEntrynull707 function CompareTCodeTreeNodeCacheEntry(Data1, Data2: Pointer): integer;
708 var Entry1, Entry2: PCodeTreeNodeCacheEntry;
709 begin
710   Entry1:=PCodeTreeNodeCacheEntry(Data1);
711   Entry2:=PCodeTreeNodeCacheEntry(Data2);
712   Result:=CompareIdentifiers(Entry1^.Identifier,Entry2^.Identifier);
713   if Result=0 then begin
714     if Entry1^.CleanStartPos>Entry2^.CleanStartPos then
715       Result:=-1
716     else if Entry1^.CleanStartPos<Entry2^.CleanStartPos then
717       Result:=1
718     else
719       Result:=0;
720   end;
721 end;
722 
723 constructor TCodeTreeNodeCache.Create(AnOwner: TCodeTreeNode);
724 begin
725   inherited Create;
726   if AnOwner<>nil then BindToOwner(AnOwner);
727 end;
728 
729 destructor TCodeTreeNodeCache.Destroy;
730 begin
731   Clear;
732   UnbindFromOwner;
733   FItems.Free;
734   inherited Destroy;
735 end;
736 
TCodeTreeNodeCache.FindLeftMostAVLNodenull737 function TCodeTreeNodeCache.FindLeftMostAVLNode(Identifier: PChar): TAVLTreeNode;
738 // find leftmost avl node with Identifier
739 var
740   Entry: PCodeTreeNodeCacheEntry;
741   Node: TAVLTreeNode;
742   comp: integer;
743 begin
744   if FItems<>nil then begin
745     Result:=FItems.Root;
746     while Result<>nil do begin
747       Entry:=PCodeTreeNodeCacheEntry(Result.Data);
748       comp:=CompareIdentifiers(Identifier,Entry^.Identifier);
749       if comp<0 then
750         Result:=Result.Left
751       else if comp>0 then
752         Result:=Result.Right
753       else begin
754         repeat
755           Node:=FItems.FindPrecessor(Result);
756           if Node<>nil then begin
757             Entry:=PCodeTreeNodeCacheEntry(Node.Data);
758             if CompareIdentifiers(Identifier,Entry^.Identifier)=0 then
759               Result:=Node
760             else
761               break;
762           end else
763             break;
764         until false;
765         exit;
766       end;
767     end;
768   end else begin
769     Result:=nil;
770   end;
771 end;
772 
773 procedure TCodeTreeNodeCache.Clear;
774 var
775   Node: TAVLTreeNode;
776   Entry: PCodeTreeNodeCacheEntry;
777 begin
778   if FItems<>nil then begin
779     Node:=FItems.FindLowest;
780     while Node<>nil do begin
781       Entry:=PCodeTreeNodeCacheEntry(Node.Data);
782       NodeCacheEntryMemManager.DisposeEntry(Entry);
783       Node:=FItems.FindSuccessor(Node);
784     end;
785     FItems.Clear;
786   end;
787 end;
788 
789 procedure TCodeTreeNodeCache.Add(Identifier: PChar;
790   SrcTool: TPascalParserTool; CleanStartPos, CleanEndPos: integer;
791   NewNode: TCodeTreeNode; NewTool: TPascalParserTool; NewCleanPos: integer;
792   Flags: TNodeCacheEntryFlags);
793 
794   procedure AddNewEntry;
795   var NewEntry: PCodeTreeNodeCacheEntry;
796   begin
797     NewEntry:=NodeCacheEntryMemManager.NewEntry;
798     NewEntry^.Identifier:=GlobalIdentifierTree.AddCopy(Identifier);
799     NewEntry^.CleanStartPos:=CleanStartPos;
800     NewEntry^.CleanEndPos:=CleanEndPos;
801     NewEntry^.NewNode:=NewNode;
802     NewEntry^.NewTool:=NewTool;
803     NewEntry^.NewCleanPos:=NewCleanPos;
804     NewEntry^.Flags:=Flags;
805     FItems.Add(NewEntry);
806   end;
807 
808 var
809   OldEntry: PCodeTreeNodeCacheEntry;
810   OldNode: TAVLTreeNode;
811   NewSearchRangeFlags: TNodeCacheEntryFlags;
812 
P2Snull813   function P2S(CleanPos: integer): string;
814   begin
815     Result:=SrcTool.CleanPosToStr(CleanPos);
816   end;
817 
ParamsDebugReportnull818   function ParamsDebugReport: string;
819   var
820     s: string;
821   begin
822     s:=' Ident='+GetIdentifier(Identifier);
823     s:=s+' New: Range='+P2S(CleanStartPos)
824              +'-'+P2S(CleanEndPos);
825     if Owner<>nil then begin
826       s:=s+' Owner='+Owner.DescAsString;
827       s:=s+' OwnerPos='+P2S(Owner.StartPos);
828     end;
829     if OldEntry<>nil then begin
830       s:=s+' Old: Range='+P2S(OldEntry^.CleanStartPos)
831                +'-'+P2S(OldEntry^.CleanEndPos);
832       if OldEntry^.NewNode<>nil then begin
833         s:=s+' Node='+OldEntry^.NewNode.DescAsString
834             +' Pos='+OldEntry^.NewTool.CleanPosToStr(OldEntry^.NewNode.StartPos);
835       end else
836         s:=s+' Node=nil';
837       if OldEntry^.NewTool<>nil then begin
838         s:=s+' Tool='+ExtractFilename(OldEntry^.NewTool.MainFilename);
839         if OldEntry^.NewNode<>nil then
840           s:=s+' Src="'
841             +StringToPascalConst(
842             copy(OldEntry^.NewTool.Src,OldEntry^.NewNode.StartPos,50))+'"';
843       end;
844     end;
845     if NewNode<>nil then begin
846       s:=s+' Node='+NewNode.DescAsString
847           +' Pos='+NewTool.CleanPosToStr(NewNode.StartPos);
848     end else
849       s:=s+' Node=nil';
850     if NewTool<>nil then begin
851       s:=s+' Tool='+ExtractFileName(NewTool.MainFilename);
852       if NewNode<>nil then
853         s:=s+' Src="'
854           +StringToPascalConst(copy(NewTool.Src,NewNode.StartPos,50))+'"';
855     end;
856     Result:=s;
857   end;
858 
859   procedure RaiseConflictException(const Msg: string);
860   var
861     s: string;
862   begin
863     s:='[TCodeTreeNodeCache.Add] internal error:'+Msg+ParamsDebugReport;
864     {$IFDEF HardExceptions}
865     DebugLn(s);
866     RaiseCatchableException('TCodeTreeNodeCache.Add A');
867     {$ELSE}
868     raise Exception.Create(s);
869     {$ENDIF}
870   end;
871 
872 begin
873   OldEntry:=nil;
874   // consistency checks
875   if CleanStartPos>=CleanEndPos then
876     RaiseConflictException('CleanStartPos>=CleanEndPos');
877   if (NewNode<>nil) then begin
878     if NewTool=nil then
879       RaiseConflictException('NewNode<>nil and NewTool=nil');
880     if not NewTool.Tree.ContainsNode(NewNode) then
881       RaiseConflictException('NewNode is not a node of NewTool');
882   end;
883 
884   {if CompareIdentifiers(Identifier,'FillRect')=0 then begin
885     DebugLn('[[[[======================================================');
886     DebugLn(['[TCodeTreeNodeCache.Add] Ident=',GetIdentifier(Identifier),
887        ' CleanStartPos=',CleanStartPos,' CleanEndPos=',CleanEndPos,
888        ' Flags=[',NodeCacheEntryFlagsAsString(Flags),']',
889        ' NewNode=',NewNode<>nil
890        ]);
891     DebugLn('======================================================]]]]');
892     CTDumpStack;
893   end;}
894   if FItems=nil then
895     FItems:=TAVLTree.Create(@CompareTCodeTreeNodeCacheEntry);
896   // if identifier already exists, try to combine them
897   OldNode:=FindAVLNodeInRange(Identifier,CleanStartPos,CleanEndPos);
898   if OldNode=nil then begin
899     // identifier was never searched in this range
900     AddNewEntry;
901   end else begin
902     // identifier was already searched in this range
903     OldEntry:=PCodeTreeNodeCacheEntry(OldNode.Data);
904     NewSearchRangeFlags:=(ncefAllSearchRanges * (OldEntry^.Flags+Flags));
905     if ((NewNode=OldEntry^.NewNode)
906     and (NewTool=OldEntry^.NewTool))
907     or ((OldEntry^.NewNode=nil) and (NewSearchRangeFlags<>[])) then
908     begin
909       // same FindContext or better FindContext with overlapping search ranges
910       // -> combine search ranges
911       if OldEntry^.CleanStartPos>CleanStartPos then
912         OldEntry^.CleanStartPos:=CleanStartPos;
913       if OldEntry^.CleanEndPos<CleanEndPos then
914         OldEntry^.CleanEndPos:=CleanEndPos;
915       OldEntry^.Flags:=NewSearchRangeFlags;
916     end else begin
917       // different FindContext with overlapping search ranges
918       RaiseConflictException('conflicting cache nodes');
919     end;
920   end;
921 end;
922 
TCodeTreeNodeCache.Findnull923 function TCodeTreeNodeCache.Find(Identifier: PChar): PCodeTreeNodeCacheEntry;
924 var Node: TAVLTreeNode;
925 begin
926   Node:=FindLeftMostAVLNode(Identifier);
927   if Node<>nil then begin
928     Result:=PCodeTreeNodeCacheEntry(Node.Data);
929   end else begin
930     Result:=nil;
931   end;
932 end;
933 
TCodeTreeNodeCache.FindAVLNodenull934 function TCodeTreeNodeCache.FindAVLNode(Identifier: PChar; CleanPos: integer
935   ): TAVLTreeNode;
936 begin
937   Result:=FindAVLNodeInRange(Identifier,CleanPos,CleanPos);
938 end;
939 
TCodeTreeNodeCache.FindRightMostAVLNodenull940 function TCodeTreeNodeCache.FindRightMostAVLNode(Identifier: PChar
941   ): TAVLTreeNode;
942 // find rightmost avl node with Identifier
943 var
944   Entry: PCodeTreeNodeCacheEntry;
945   Node: TAVLTreeNode;
946   comp: integer;
947 begin
948   if FItems<>nil then begin
949     Result:=FItems.Root;
950     while Result<>nil do begin
951       Entry:=PCodeTreeNodeCacheEntry(Result.Data);
952       comp:=CompareIdentifiers(Identifier,Entry^.Identifier);
953       if comp<0 then
954         Result:=Result.Left
955       else if comp>0 then
956         Result:=Result.Right
957       else begin
958         repeat
959           Node:=FItems.FindSuccessor(Result);
960           if Node<>nil then begin
961             Entry:=PCodeTreeNodeCacheEntry(Node.Data);
962             if CompareIdentifiers(Identifier,Entry^.Identifier)=0 then
963               Result:=Node
964             else
965               break;
966           end else
967             break;
968         until false;
969         exit;
970       end;
971     end;
972   end else begin
973     Result:=nil;
974   end;
975 end;
976 
FindAVLNodeInRangenull977 function TCodeTreeNodeCache.FindAVLNodeInRange(Identifier: PChar;
978   CleanStartPos, CleanEndPos: integer): TAVLTreeNode;
979 var
980   Entry: PCodeTreeNodeCacheEntry;
981 begin
982   Result:=FindNearestAVLNode(Identifier,CleanStartPos,CleanEndPos,true);
983   if Result<>nil then begin
984     Entry:=PCodeTreeNodeCacheEntry(Result.Data);
985     if (CleanStartPos>=Entry^.CleanEndPos)
986     or (CleanEndPos<=Entry^.CleanStartPos) then begin
987       // node is not in range
988       Result:=nil;
989     end;
990   end;
991 end;
992 
TCodeTreeNodeCache.FindNearestAVLNodenull993 function TCodeTreeNodeCache.FindNearestAVLNode(Identifier: PChar;
994   CleanStartPos, CleanEndPos: integer; InFront: boolean): TAVLTreeNode;
995 var
996   Entry: PCodeTreeNodeCacheEntry;
997   comp: integer;
998   DirectionSucc: boolean;
999   NextNode: TAVLTreeNode;
1000 begin
1001   if CleanStartPos>CleanEndPos then begin
1002     raise Exception.Create('[TCodeTreeNodeCache.FindNearestAVLNode]'
1003       +' internal error: CleanStartPos>CleanEndPos');
1004   end;
1005   if (FItems<>nil) and (Identifier<>nil) then begin
1006     Result:=FItems.Root;
1007     while Result<>nil do begin
1008       Entry:=PCodeTreeNodeCacheEntry(Result.Data);
1009       comp:=CompareIdentifiers(Identifier,Entry^.Identifier);
1010       if comp<0 then
1011         Result:=Result.Left
1012       else if comp>0 then
1013         Result:=Result.Right
1014       else begin
1015         // cached result with identifier found
1016         // -> check range
1017         if CleanStartPos>=Entry^.CleanEndPos then begin
1018           NextNode:=FItems.FindSuccessor(Result);
1019           DirectionSucc:=true;
1020         end else if CleanEndPos<=Entry^.CleanStartPos then begin
1021           NextNode:=FItems.FindPrecessor(Result);
1022           DirectionSucc:=false;
1023         end else begin
1024           // cached result in range found
1025           exit;
1026         end;
1027         while (NextNode<>nil) do begin
1028           Entry:=PCodeTreeNodeCacheEntry(NextNode.Data);
1029           if CompareIdentifiers(Identifier,Entry^.Identifier)<>0 then begin
1030             exit;
1031           end;
1032           Result:=NextNode;
1033           if (CleanStartPos<Entry^.CleanEndPos)
1034           and (CleanEndPos>Entry^.CleanStartPos) then begin
1035             // cached result in range found
1036             exit;
1037           end;
1038           if DirectionSucc then
1039             NextNode:=FItems.FindSuccessor(Result)
1040           else
1041             NextNode:=FItems.FindPrecessor(Result);
1042         end;
1043         exit;
1044       end;
1045     end;
1046   end else begin
1047     Result:=nil;
1048   end;
1049 end;
1050 
1051 procedure TCodeTreeNodeCache.ConsistencyCheck;
1052 begin
1053   if (FItems<>nil) then
1054     FItems.ConsistencyCheck;
1055   if Owner<>nil then begin
1056     if Owner.Cache<>Self then
1057       raise Exception.Create('');
1058   end;
1059 end;
1060 
CalcMemSizenull1061 function TCodeTreeNodeCache.CalcMemSize: PtrUInt;
1062 var
1063   Node: TAVLTreeNode;
1064 begin
1065   Result:=PtrUInt(InstanceSize);
1066   if FItems<>nil then begin
1067     inc(Result,SizeOf(TAVLTreeNode)*FItems.Count);
1068     Node:=FItems.FindLowest;
1069     while Node<>nil do begin
1070       inc(Result,SizeOf(TCodeTreeNodeCacheEntry));
1071       Node:=FItems.FindSuccessor(Node);
1072     end;
1073   end;
1074 end;
1075 
1076 procedure TCodeTreeNodeCache.WriteDebugReport(const Prefix: string);
1077 var Node: TAVLTreeNode;
1078   Entry: PCodeTreeNodeCacheEntry;
1079 begin
1080   DebugLn(Prefix+'[TCodeTreeNodeCache.WriteDebugReport] Self='+DbgS(Self));
1081   if FItems<>nil then begin
1082     Node:=FItems.FindLowest;
1083     while Node<>nil do begin
1084       Entry:=PCodeTreeNodeCacheEntry(Node.Data);
1085       write(Prefix,' Ident="',GetIdentifier(Entry^.Identifier),'"');
1086       DbgOut(' Flags=[',NodeCacheEntryFlagsAsString(Entry^.Flags),']');
1087       DbgOut(' Node=',DbgS(Entry^.NewNode<>nil));
1088       DebugLn('');
1089       Node:=FItems.FindSuccessor(Node);
1090     end;
1091   end;
1092   ConsistencyCheck;
1093 end;
1094 
1095 procedure TCodeTreeNodeCache.UnbindFromOwner;
1096 begin
1097   if Owner<>nil then begin
1098     if Owner.Cache<>Self then
1099       raise Exception.Create('[TCodeTreeNodeCache.UnbindFromOwner] '
1100         +' internal error: Owner.Cache<>Self');
1101     Owner.Cache:=nil;
1102     Owner:=nil;
1103   end;
1104 end;
1105 
1106 procedure TCodeTreeNodeCache.BindToOwner(NewOwner: TCodeTreeNode);
1107 begin
1108   if NewOwner<>nil then begin
1109     if NewOwner.Cache<>nil then
1110       raise Exception.Create('[TCodeTreeNodeCache.BindToOwner] internal error:'
1111         +' NewOwner.Cache<>nil');
1112     NewOwner.Cache:=Self;
1113   end;
1114   Owner:=NewOwner;
1115 end;
1116 
TCodeTreeNodeCache.FindNearestnull1117 function TCodeTreeNodeCache.FindNearest(Identifier: PChar; CleanStartPos,
1118   CleanEndPos: integer; InFront: boolean): PCodeTreeNodeCacheEntry;
1119 var Node: TAVLTreeNode;
1120 begin
1121   Node:=FindNearestAVLNode(Identifier,CleanStartPos,CleanEndPos,InFront);
1122   if Node<>nil then
1123     Result:=PCodeTreeNodeCacheEntry(Node.Data)
1124   else
1125     Result:=nil;
1126 end;
1127 
TCodeTreeNodeCache.FindInRangenull1128 function TCodeTreeNodeCache.FindInRange(Identifier: PChar; CleanStartPos,
1129   CleanEndPos: integer): PCodeTreeNodeCacheEntry;
1130 var Node: TAVLTreeNode;
1131 begin
1132   Node:=FindAVLNodeInRange(Identifier,CleanStartPos,CleanEndPos);
1133   if Node<>nil then
1134     Result:=PCodeTreeNodeCacheEntry(Node.Data)
1135   else
1136     Result:=nil;
1137 end;
1138 
1139 { TNodeCacheMemManager }
1140 
1141 procedure TNodeCacheMemManager.DisposeNodeCache(NodeCache: TCodeTreeNodeCache);
1142 begin
1143   NodeCache.UnbindFromOwner;
1144   if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio)) then
1145   begin
1146     // add Entry to Free list
1147     NodeCache.Next:=TCodeTreeNodeCache(FFirstFree);
1148     TCodeTreeNodeCache(FFirstFree):=NodeCache;
1149     inc(FFreeCount);
1150   end else begin
1151     // free list full -> free the NodeCache
1152     NodeCache.Free;
1153     {$IFDEF DebugCTMemManager}
1154     inc(FFreedCount);
1155     {$ENDIF}
1156   end;
1157   dec(FCount);
1158 end;
1159 
1160 procedure TNodeCacheMemManager.FreeFirstItem;
1161 var NodeCache: TCodeTreeNodeCache;
1162 begin
1163   NodeCache:=TCodeTreeNodeCache(FFirstFree);
1164   TCodeTreeNodeCache(FFirstFree):=NodeCache.Next;
1165   NodeCache.Free;
1166 end;
1167 
NewNodeCachenull1168 function TNodeCacheMemManager.NewNodeCache(
1169   AnOwner: TCodeTreeNode): TCodeTreeNodeCache;
1170 begin
1171   if FFirstFree<>nil then begin
1172     // take from free list
1173     Result:=TCodeTreeNodeCache(FFirstFree);
1174     TCodeTreeNodeCache(FFirstFree):=Result.Next;
1175     Result.Clear;
1176     Result.BindToOwner(AnOwner);
1177     dec(FFreeCount);
1178   end else begin
1179     // free list empty -> create new NodeCache
1180     Result:=TCodeTreeNodeCache.Create(AnOwner);
1181     {$IFDEF DebugCTMemManager}
1182     inc(FAllocatedCount);
1183     {$ENDIF}
1184   end;
1185   inc(FCount);
1186 end;
1187 
1188 //------------------------------------------------------------------------------
1189 
1190 procedure InitializeNodeStack(NodeStack: PCodeTreeNodeStack);
1191 begin
1192   NodeStack^.StackPtr:=-1;
1193   NodeStack^.DynItems:=nil;
1194   NodeStack^.Capacity:=0;
1195 end;
1196 
GetNodeStackEntrynull1197 function GetNodeStackEntry(NodeStack: PCodeTreeNodeStack;
1198   Index: integer): PCodeTreeNodeStackEntry;
1199 begin
1200   if Index<CodeTreeNodeFixedItemCount then begin
1201     Result:=@NodeStack^.FixedItems[Index];
1202   end else begin
1203     Result:=@NodeStack^.DynItems[Index-CodeTreeNodeFixedItemCount];
1204   end;
1205 end;
1206 
1207 procedure AddNodeToStack(NodeStack: PCodeTreeNodeStack;
1208   NewTool: TPascalParserTool; NewNode: TCodeTreeNode);
1209 var
1210   Entry: PCodeTreeNodeStackEntry;
1211   i: Integer;
1212 begin
1213   inc(NodeStack^.StackPtr);
1214   if NodeStack^.StackPtr<CodeTreeNodeFixedItemCount then begin
1215     Entry:=@NodeStack^.FixedItems[NodeStack^.StackPtr];
1216   end else begin
1217     i:=NodeStack^.StackPtr-CodeTreeNodeFixedItemCount;
1218     if NodeStack^.Capacity<=i then begin
1219       inc(NodeStack^.Capacity,CodeTreeNodeFixedItemCount);
1220       ReAllocMem(NodeStack^.DynItems,NodeStack^.Capacity*SizeOf(TCodeTreeNodeStackEntry));
1221     end;
1222     Entry:=@NodeStack^.DynItems[i];
1223   end;
1224   Entry^.Tool:=NewTool;
1225   Entry^.Node:=NewNode;
1226 end;
1227 
NodeExistsInStacknull1228 function NodeExistsInStack(NodeStack: PCodeTreeNodeStack;
1229   Node: TCodeTreeNode): boolean;
1230 var i: integer;
1231 begin
1232   Result:=true;
1233   i:=0;
1234   while i<=NodeStack^.StackPtr do begin
1235     if i<CodeTreeNodeFixedItemCount then begin
1236       if NodeStack^.FixedItems[i].Node=Node then exit;
1237     end else begin
1238       if NodeStack^.DynItems[i-CodeTreeNodeFixedItemCount].Node=Node then
1239         exit;
1240     end;
1241     inc(i);
1242   end;
1243   Result:=false;
1244 end;
1245 
1246 procedure FinalizeNodeStack(NodeStack: PCodeTreeNodeStack);
1247 begin
1248   if NodeStack^.DynItems=nil then exit;
1249   ReAllocMem(NodeStack^.DynItems,0);
1250 end;
1251 
1252 
1253 { TBaseTypeCacheMemManager }
1254 
1255 procedure TBaseTypeCacheMemManager.DisposeBaseTypeCache(
1256   BaseTypeCache: TBaseTypeCache);
1257 begin
1258   BaseTypeCache.UnbindFromOwner;
1259   if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio)) then
1260   begin
1261     // add Entry to Free list
1262     BaseTypeCache.NextCache:=TBaseTypeCache(FFirstFree);
1263     TBaseTypeCache(FFirstFree):=BaseTypeCache;
1264     inc(FFreeCount);
1265   end else begin
1266     // free list full -> free the BaseType
1267     BaseTypeCache.Free;
1268     {$IFDEF DebugCTMemManager}
1269     inc(FFreedCount);
1270     {$ENDIF}
1271   end;
1272   dec(FCount);
1273 end;
1274 
1275 procedure TBaseTypeCacheMemManager.FreeFirstItem;
1276 var BaseTypeCache: TBaseTypeCache;
1277 begin
1278   BaseTypeCache:=TBaseTypeCache(FFirstFree);
1279   TBaseTypeCache(FFirstFree):=BaseTypeCache.NextCache;
1280   BaseTypeCache.Free;
1281 end;
1282 
TBaseTypeCacheMemManager.NewBaseTypeCachenull1283 function TBaseTypeCacheMemManager.NewBaseTypeCache(
1284   AnOwner: TCodeTreeNode): TBaseTypeCache;
1285 begin
1286   if FFirstFree<>nil then begin
1287     // take from free list
1288     Result:=TBaseTypeCache(FFirstFree);
1289     TBaseTypeCache(FFirstFree):=Result.NextCache;
1290     Result.BindToOwner(AnOwner);
1291     dec(FFreeCount);
1292   end else begin
1293     // free list empty -> create new BaseType
1294     Result:=TBaseTypeCache.Create(AnOwner);
1295     {$IFDEF DebugCTMemManager}
1296     inc(FAllocatedCount);
1297     {$ENDIF}
1298   end;
1299   inc(FCount);
1300 end;
1301 
1302 { TBaseTypeCache }
1303 
1304 procedure TBaseTypeCache.BindToOwner(NewOwner: TCodeTreeNode);
1305 begin
1306   if NewOwner<>nil then begin
1307     if NewOwner.Cache<>nil then
1308       raise Exception.Create('[TBaseTypeCache.BindToOwner] internal error:'
1309         +' NewOwner.Cache<>nil');
1310     NewOwner.Cache:=Self;
1311   end;
1312   Owner:=NewOwner;
1313 end;
1314 
1315 constructor TBaseTypeCache.Create(AnOwner: TCodeTreeNode);
1316 begin
1317   inherited Create;
1318   if AnOwner<>nil then BindToOwner(AnOwner);
1319 end;
1320 
1321 destructor TBaseTypeCache.Destroy;
1322 begin
1323   UnbindFromOwner;
1324   inherited Destroy;
1325 end;
1326 
CalcMemSizenull1327 function TBaseTypeCache.CalcMemSize: PtrUInt;
1328 begin
1329   Result:=PtrUInt(InstanceSize);
1330 end;
1331 
1332 procedure TBaseTypeCache.UnbindFromOwner;
1333 begin
1334   if Owner<>nil then begin
1335     if Owner.Cache<>Self then
1336       raise Exception.Create('[TBaseTypeCache.UnbindFromOwner] '
1337         +' internal error: Owner.Cache<>Self');
1338     Owner.Cache:=nil;
1339     Owner:=nil;
1340   end;
1341 end;
1342 
1343 //------------------------------------------------------------------------------
1344 
1345 procedure InternalInit;
1346 begin
1347   GlobalIdentifierTree:=TGlobalIdentifierTree.Create;
1348   InterfaceIdentCacheEntryMemManager:=TInterfaceIdentCacheEntryMemManager.Create;
1349   NodeCacheEntryMemManager:=TNodeCacheEntryMemManager.Create;
1350   NodeCacheMemManager:=TNodeCacheMemManager.Create;
1351   BaseTypeCacheMemManager:=TBaseTypeCacheMemManager.Create;
1352 end;
1353 
1354 procedure InternalFinal;
1355 begin
1356   BaseTypeCacheMemManager.Free;
1357   BaseTypeCacheMemManager:=nil;
1358   NodeCacheMemManager.Free;
1359   NodeCacheMemManager:=nil;
1360   NodeCacheEntryMemManager.Free;
1361   NodeCacheEntryMemManager:=nil;
1362   InterfaceIdentCacheEntryMemManager.Free;
1363   InterfaceIdentCacheEntryMemManager:=nil;
1364   GlobalIdentifierTree.Free;
1365   GlobalIdentifierTree:=nil;
1366 end;
1367 
1368 initialization
1369   InternalInit;
1370 
1371 finalization
1372   InternalFinal;
1373 
1374 
1375 end.
1376 
1377