MG: started basetype chaching

git-svn-id: trunk@664 -

components/codetools/finddeclarationcache.pas

@@ -148,6 +148,11 @@ type
     NewNode: TCodeTreeNode;
     NewTool: TPascalParserTool;
     Next: TBaseTypeCache; // used for mem manager
+    Owner: TCodeTreeNode;
+    procedure BindToOwner(NewOwner: TCodeTreeNode);
+    procedure UnbindFromOwner;
+    constructor Create(AnOwner: TCodeTreeNode);
+    destructor Destroy; override;
   end;
 
 
@@ -200,7 +205,7 @@ type
     procedure FreeFirstItem; override;
   public
     procedure DisposeBaseTypeCache(BaseTypeCache: TBaseTypeCache);
-    function NewBaseTypeCache: TBaseTypeCache;
+    function NewBaseTypeCache(AnOwner: TCodeTreeNode): TBaseTypeCache;
   end;
 
   //----------------------------------------------------------------------------
@@ -922,6 +927,7 @@ begin
     // add Entry to Free list
     BaseTypeCache.Next:=TBaseTypeCache(FFirstFree);
     TBaseTypeCache(FFirstFree):=BaseTypeCache;
+    BaseTypeCache.UnbindFromOwner;
     inc(FFreeCount);
   end else begin
     // free list full -> free the BaseType
@@ -939,16 +945,18 @@ begin
   BaseTypeCache.Free;
 end;
 
-function TBaseTypeCacheMemManager.NewBaseTypeCache: TBaseTypeCache;
+function TBaseTypeCacheMemManager.NewBaseTypeCache(
+  AnOwner: TCodeTreeNode): TBaseTypeCache;
 begin
   if FFirstFree<>nil then begin
     // take from free list
     Result:=TBaseTypeCache(FFirstFree);
     TBaseTypeCache(FFirstFree):=Result.Next;
+    Result.Owner:=AnOwner;
     dec(FFreeCount);
   end else begin
     // free list empty -> create new BaseType
-    Result:=TBaseTypeCache.Create;
+    Result:=TBaseTypeCache.Create(AnOwner);
     inc(FAllocatedCount);
   end;
   inc(FCount);
@@ -979,6 +987,42 @@ begin
   BaseTypeCacheMemManager:=nil;
 end;
 
+{ TBaseTypeCache }
+
+procedure TBaseTypeCache.BindToOwner(NewOwner: TCodeTreeNode);
+begin
+  if NewOwner<>nil then begin
+    if NewOwner.Cache<>nil then
+      raise Exception.Create('[TBaseTypeCache.BindToOwner] internal error:'
+        +' NewOwner.Cache<>nil');
+    NewOwner.Cache:=Self;
+  end;
+  Owner:=NewOwner;
+end;
+
+constructor TBaseTypeCache.Create(AnOwner: TCodeTreeNode);
+begin
+  inherited Create;
+  if AnOwner<>nil then BindToOwner(AnOwner);
+end;
+
+destructor TBaseTypeCache.Destroy;
+begin
+  UnbindFromOwner;
+  inherited Destroy;
+end;
+
+procedure TBaseTypeCache.UnbindFromOwner;
+begin
+  if Owner<>nil then begin
+    if Owner.Cache<>Self then
+      raise Exception.Create('[TBaseTypeCache.UnbindFromOwner] '
+        +' internal error: Owner.Cache<>Self');
+    Owner.Cache:=nil;
+    Owner:=nil;
+  end;
+end;
+
 initialization
   InternalInit;
 

components/codetools/finddeclarationtool.pas

@@ -232,6 +232,7 @@ type
     FFirstNodeCache: TCodeTreeNodeCache;
     FLastNodeCachesGlobalWriteLockStep: integer;
     FRootNodeCache: TCodeTreeNodeCache;
+    FFirstBaseTypeCache: TBaseTypeCache;
     {$IFDEF CTDEBUG}
     DebugPrefix: string;
     procedure IncPrefix;
@@ -280,6 +281,7 @@ type
     procedure DoDeleteNodes; override;
     procedure ClearNodeCaches(Force: boolean);
     function CreateNewNodeCache(Node: TCodeTreeNode): TCodeTreeNodeCache;
+    function CreateNewBaseTypeCache(Node: TCodeTreeNode): TCodeTreeNodeCache;
     function GetNodeCache(Node: TCodeTreeNode;
       CreateIfNotExists: boolean): TCodeTreeNodeCache;
     procedure AddResultToNodeCaches(Identifier: PChar;
@@ -1622,6 +1624,9 @@ begin
 {$IFDEF ShowTriedContexts}
 writeln('[TFindDeclarationTool.FindBaseTypeOfNode] LOOP Result=',Result.Node.DescAsString,' ',HexStr(Cardinal(Result.Node),8));
 {$ENDIF}
+
+      // ToDo: BaseTypeCache
+
       if (Result.Node.Desc in AllIdentifierDefinitions) then begin
         // instead of variable/const/type definition, return the type
         Result.Node:=FindTypeNodeOfDefinition(Result.Node);
@@ -1635,7 +1640,7 @@ writeln('[TFindDeclarationTool.FindBaseTypeOfNode] Class is forward');
 {$ENDIF}
 
         // ToDo: check for circles in ancestor chain
-
+        
         ClassIdentNode:=Result.Node.Parent;
         if (ClassIdentNode=nil) or (not (ClassIdentNode.Desc=ctnTypeDefinition))
         then begin
@@ -3568,6 +3573,7 @@ var
   NodeCache: TCodeTreeNodeCache;
   GlobalWriteLockIsSet: boolean;
   GlobalWriteLockStep: integer;
+  BaseTypeCache: TBaseTypeCache;
 begin
   if not Force then begin
     // check if node cache must be cleared
@@ -3587,11 +3593,17 @@ begin
       end;
     end;
   end;
+  // clear node caches
   while FFirstNodeCache<>nil do begin
     NodeCache:=FFirstNodeCache;
     FFirstNodeCache:=NodeCache.Next;
     NodeCacheMemManager.DisposeNodeCache(NodeCache);
   end;
+  while FFirstBaseTypeCache<>nil do begin
+    BaseTypeCache:=FFirstBaseTypeCache;
+    FFirstBaseTypeCache:=BaseTypeCache.Next;
+    BaseTypeCacheMemManager.DisposeBaseTypeCache(BaseTypeCache);
+  end;
   if FRootNodeCache<>nil then begin
     NodeCacheMemManager.DisposeNodeCache(FRootNodeCache);
     FRootNodeCache:=nil;
@@ -3719,6 +3731,14 @@ begin
   FFirstNodeCache:=Result;
 end;
 
+function TFindDeclarationTool.CreateNewBaseTypeCache(Node: TCodeTreeNode
+  ): TCodeTreeNodeCache;
+begin
+  Result:=BaseTypeCacheMemManager.NewBaseTypeCache(Node);
+  Result.Next:=FFirstBaseTypeCache;
+  FFirstBaseTypeCache:=Result;
+end;
+
 
 { TFindDeclarationParams }