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