MG: fixed a node cache range bug

git-svn-id: trunk@1435 -

components/codetools/codetoolmanager.pas

@@ -178,18 +178,22 @@ type
           var NewX, NewY, NewTopLine: integer): boolean;
 
     // functions for events in the object inspector
-    function GetCompatibleMethods(Code: TCodeBuffer; const AClassName: string;
+    function GetCompatiblePublishedMethods(Code: TCodeBuffer;
-          TypeData: PTypeData; Proc: TGetStringProc): boolean;
+          const AClassName: string; TypeData: PTypeData;
-    function MethodExists(Code:TCodeBuffer; const AClassName,
+          Proc: TGetStringProc): boolean;
-          AMethodName: string; TypeData: PTypeData): boolean;
+    function PublishedMethodExists(Code:TCodeBuffer; const AClassName,
-    function JumpToMethodBody(Code: TCodeBuffer;
+          AMethodName: string; TypeData: PTypeData;
+          var MethodIsCompatible, MethodIsPublished, IdentIsMethod: boolean
+          ): boolean;
+    function JumpToPublishedMethodBody(Code: TCodeBuffer;
           const AClassName, AMethodName: string;  TypeData: PTypeData;
           var NewCode: TCodeBuffer;
           var NewX, NewY, NewTopLine: integer): boolean;
-    function RenameMethod(Code: TCodeBuffer; const AClassName, OldMethodName,
+    function RenamePublishedMethod(Code: TCodeBuffer;
-          NewMethodName: string; TypeData: PTypeData): boolean;
+          const AClassName, OldMethodName,
-    function CreateMethod(Code: TCodeBuffer; const AClassName,
+          NewMethodName: string): boolean;
-          NewMethodName: string; TypeData: PTypeData): boolean;
+    function CreatePublishedMethod(Code: TCodeBuffer; const AClassName,
+          NewMethodName: string; ATypeInfo: PTypeInfo): boolean;
           
     // code completion = auto class completion, auto forward proc completion
     function CompleteCode(Code: TCodeBuffer; X,Y: integer;
@@ -712,11 +716,11 @@ writeln('TCodeToolManager.GuessUnclosedBlock END ');
 {$ENDIF}
 end;
 
-function TCodeToolManager.GetCompatibleMethods(Code: TCodeBuffer;
+function TCodeToolManager.GetCompatiblePublishedMethods(Code: TCodeBuffer;
   const AClassName: string; TypeData: PTypeData; Proc: TGetStringProc): boolean;
 begin
 {$IFDEF CTDEBUG}
-writeln('TCodeToolManager.GetCompatibleMethods A ',Code.Filename,' Classname=',AClassname);
+writeln('TCodeToolManager.GetCompatiblePublishedMethods A ',Code.Filename,' Classname=',AClassname);
 {$ENDIF}
   Result:=InitCurCodeTool(Code);
   if not InitCurCodeTool(Code) then exit;
@@ -728,29 +732,31 @@ writeln('TCodeToolManager.GetCompatibleMethods A ',Code.Filename,' Classname=',A
   end;
 end;
 
-function TCodeToolManager.MethodExists(Code:TCodeBuffer;
+function TCodeToolManager.PublishedMethodExists(Code:TCodeBuffer;
-  const AClassName, AMethodName: string;  TypeData: PTypeData): boolean;
+  const AClassName, AMethodName: string; TypeData: PTypeData;
+  var MethodIsCompatible, MethodIsPublished, IdentIsMethod: boolean): boolean;
 begin
 {$IFDEF CTDEBUG}
-writeln('TCodeToolManager.MethodExists A ',Code.Filename,' ',AClassName,':',AMethodName);
+writeln('TCodeToolManager.PublishedMethodExists A ',Code.Filename,' ',AClassName,':',AMethodName);
 {$ENDIF}
   Result:=InitCurCodeTool(Code);
   if not Result then exit;
   try
     Result:=FCurCodeTool.PublishedMethodExists(UpperCaseStr(AClassName),
-              UpperCaseStr(AMethodName),TypeData);
+              UpperCaseStr(AMethodName),TypeData,
+              MethodIsCompatible,MethodIsPublished,IdentIsMethod);
   except
     on e: Exception do Result:=HandleException(e);
   end;
 end;
 
-function TCodeToolManager.JumpToMethodBody(Code: TCodeBuffer;
+function TCodeToolManager.JumpToPublishedMethodBody(Code: TCodeBuffer;
   const AClassName, AMethodName: string;  TypeData: PTypeData;
   var NewCode: TCodeBuffer; var NewX, NewY, NewTopLine: integer): boolean;
 var NewPos: TCodeXYPosition;
 begin
 {$IFDEF CTDEBUG}
-writeln('TCodeToolManager.JumpToMethodBody A ',Code.Filename,' ',AClassName,':',AMethodName);
+writeln('TCodeToolManager.JumpToPublishedMethodBody A ',Code.Filename,' ',AClassName,':',AMethodName);
 {$ENDIF}
   Result:=InitCurCodeTool(Code);
   if not Result then exit;
@@ -767,36 +773,36 @@ writeln('TCodeToolManager.JumpToMethodBody A ',Code.Filename,' ',AClassName,':',
   end;
 end;
 
-function TCodeToolManager.RenameMethod(Code: TCodeBuffer; const AClassName,
+function TCodeToolManager.RenamePublishedMethod(Code: TCodeBuffer;
-  OldMethodName, NewMethodName: string; TypeData: PTypeData): boolean;
+  const AClassName, OldMethodName, NewMethodName: string): boolean;
 begin
 {$IFDEF CTDEBUG}
-writeln('TCodeToolManager.RenameMethod A');
+writeln('TCodeToolManager.RenamePublishedMethod A');
 {$ENDIF}
   Result:=InitCurCodeTool(Code);
   if not Result then exit;
   try
     SourceChangeCache.Clear;
     Result:=FCurCodeTool.RenamePublishedMethod(UpperCaseStr(AClassName),
-              UpperCaseStr(OldMethodName),NewMethodName,TypeData,
+              UpperCaseStr(OldMethodName),NewMethodName,
               SourceChangeCache);
   except
     on e: Exception do Result:=HandleException(e);
   end;
 end;
 
-function TCodeToolManager.CreateMethod(Code: TCodeBuffer; const AClassName,
+function TCodeToolManager.CreatePublishedMethod(Code: TCodeBuffer;
-  NewMethodName: string; TypeData: PTypeData): boolean;
+  const AClassName, NewMethodName: string; ATypeInfo: PTypeInfo): boolean;
 begin
 {$IFDEF CTDEBUG}
-writeln('TCodeToolManager.CreateMethod A');
+writeln('TCodeToolManager.CreatePublishedMethod A');
 {$ENDIF}
   Result:=InitCurCodeTool(Code);
   if not Result then exit;
   try
     SourceChangeCache.Clear;
     Result:=FCurCodeTool.CreatePublishedMethod(UpperCaseStr(AClassName),
-              NewMethodName,TypeData,SourceChangeCache);
+              NewMethodName,ATypeInfo,SourceChangeCache);
   except
     on e: Exception do Result:=HandleException(e);
   end;
@@ -1385,11 +1391,17 @@ begin
       FWriteLockStep:=-$7fffffff;
   end;
   inc(FWriteLockCount);
+{$IFDEF CTDEBUG}
+writeln('[TCodeToolManager.ActivateWriteLock] FWriteLockCount=',FWriteLockCount,' FWriteLockStep=',FWriteLockStep);
+{$ENDIF}
 end;
 
 procedure TCodeToolManager.DeactivateWriteLock;
 begin
   if FWriteLockCount>0 then dec(FWriteLockCount);
+{$IFDEF CTDEBUG}
+writeln('[TCodeToolManager.DeactivateWriteLock] FWriteLockCount=',FWriteLockCount,' FWriteLockStep=',FWriteLockStep);
+{$ENDIF}
 end;
 
 procedure TCodeToolManager.OnToolGetWriteLockInfo(var WriteLockIsSet: boolean;

components/codetools/eventcodetool.pas

@@ -52,6 +52,8 @@ type
     GetCompatibleMethodsProc: TGetStringProc;
     SearchedExprList: TExprTypeList;
     SearchedCompatibilityList: TTypeCompatibilityList;
+    function FindIdentifierNodeInClass(ClassNode: TCodeTreeNode;
+      Identifier: PChar): TCodeTreeNode;
   protected
     function InsertNewMethodToClass(ClassSectionNode: TCodeTreeNode;
         const AMethodName,NewMethod: string;
@@ -64,23 +66,26 @@ type
     function GetCompatiblePublishedMethods(ClassNode: TCodeTreeNode;
         TypeData: PTypeData; Proc: TGetStringProc): boolean;
     function PublishedMethodExists(const UpperClassName,
-        UpperMethodName: string; TypeData: PTypeData): boolean;
+        UpperMethodName: string; TypeData: PTypeData;
+        var MethodIsCompatible, MethodIsPublished, IdentIsMethod: boolean
+        ): boolean;
     function PublishedMethodExists(ClassNode: TCodeTreeNode;
-        const UpperMethodName: string; TypeData: PTypeData): boolean;
+        const UpperMethodName: string; TypeData: PTypeData;
+        var MethodIsCompatible, MethodIsPublished, IdentIsMethod: boolean
+        ): boolean;
     function JumpToPublishedMethodBody(const UpperClassName,
         UpperMethodName: string; TypeData: PTypeData;
         var NewPos: TCodeXYPosition; var NewTopLine: integer): boolean;
     function RenamePublishedMethod(const UpperClassName, UpperOldMethodName,
-        NewMethodName: string; TypeData: PTypeData;
+        NewMethodName: string; SourceChangeCache: TSourceChangeCache): boolean;
-        SourceChangeCache: TSourceChangeCache): boolean;
     function RenamePublishedMethod(ClassNode: TCodeTreeNode;
-        const UpperOldMethodName, NewMethodName: string; TypeData: PTypeData;
+        const UpperOldMethodName, NewMethodName: string;
         SourceChangeCache: TSourceChangeCache): boolean;
     function CreatePublishedMethod(const UpperClassName,
-        AMethodName: string; TypeData: PTypeData;
+        AMethodName: string; ATypeInfo: PTypeInfo;
         SourceChangeCache: TSourceChangeCache): boolean;
     function CreatePublishedMethod(ClassNode: TCodeTreeNode;
-        const AMethodName: string; TypeData: PTypeData;
+        const AMethodName: string; ATypeInfo: PTypeInfo;
         SourceChangeCache: TSourceChangeCache): boolean;
 
     function MethodTypeDataToStr(TypeData: PTypeData;
@@ -88,10 +93,10 @@ type
     function CreateExprListFromMethodTypeData(TypeData: PTypeData;
         Params: TFindDeclarationParams): TExprTypeList;
     function FindPublishedMethodNodeInClass(ClassNode: TCodeTreeNode;
-        const UpperMethodName: string; TypeData: PTypeData): TCodeTreeNode;
+        const UpperMethodName: string): TFindContext;
     function FindProcNodeInImplementation(const UpperClassName,
-        UpperMethodName: string; TypeData: PTypeData;
+        UpperMethodName: string; BuildTreeBefore: boolean): TCodeTreeNode;
-        BuildTreeBefore: boolean): TCodeTreeNode;
+    function MethodTypeInfoToStr(ATypeInfo: PTypeInfo): string;
   end;
 
 
@@ -204,9 +209,7 @@ end;
 
 function TEventsCodeTool.GetCompatiblePublishedMethods(
   ClassNode: TCodeTreeNode; TypeData: PTypeData; Proc: TGetStringProc): boolean;
-var //SearchedProc: string;
+var
-  //SectionNode, ANode: TCodeTreeNode;
-  //CurProcHead, CurProcName: string;
   Params: TFindDeclarationParams;
   CompListSize: integer;
 begin
@@ -255,109 +258,63 @@ writeln('[TEventsCodeTool.GetCompatiblePublishedMethods]');
   finally
     DeactivateGlobalWriteLock;
   end;
-  {
-  SearchedProc:=MethodTypeDataToStr(TypeData,[phpInUpperCase]);
-  SectionNode:=ClassNode.FirstChild;
-  while (SectionNode<>nil) do begin
-    while (SectionNode.Desc<>ctnClassPublished) or (SectionNode.FirstChild=nil)
-    do begin
-      SectionNode:=SectionNode.NextBrother;
-      if SectionNode=nil then exit;
-    end;
-    ANode:=SectionNode.FirstChild;
-    repeat
-      if (ANode.Desc=ctnProcedure) then begin
-        CurProcHead:=ExtractProcHead(ANode,[phpInUpperCase,phpWithoutName]);
-        if (CurProcHead<>'')
-        and (CompareTextIgnoringSpace(CurProcHead,SearchedProc,true)=0) then
-        begin
-          CurProcName:=ExtractProcName(ANode,false);
-          if (CurProcName<>'') and (length(CurProcName)<256) then
-            Proc(CurProcName);
-        end;
-      end;
-      ANode:=ANode.NextBrother;
-    until ANode=nil;
-    SectionNode:=SectionNode.NextBrother;
-  end;
-  }
 end;
 
 function TEventsCodeTool.FindPublishedMethodNodeInClass(
-  ClassNode: TCodeTreeNode; const UpperMethodName: string;
+  ClassNode: TCodeTreeNode; const UpperMethodName: string): TFindContext;
-  TypeData: PTypeData): TCodeTreeNode;
 var
-  SectionNode, ANode: TCodeTreeNode;
+  Params: TFindDeclarationParams;
-  SearchedProcHead, CurProcHead: string;
 begin
-  Result:=nil;
+  Result:=CleanFindContext;
   if (ClassNode=nil) or (ClassNode.Desc<>ctnClass) or (UpperMethodName='')
-  or (Scanner=nil) or (TypeData=nil) then exit;
+  or (Scanner=nil) then exit;
-  SearchedProcHead:=UpperMethodName+MethodTypeDataToStr(TypeData,
+  ActivateGlobalWriteLock;
-                       [phpInUpperCase]);
+  try
-{$IFDEF CTDEBUG}
+    Params:=TFindDeclarationParams.Create;
-writeln('TEventsCodeTool.FindPublishedMethodNodeInClass A SearchedProcHead="',
+    try
-SearchedProcHead,'"');
+      Params.ContextNode:=ClassNode;
-{$ENDIF}
+      Params.SetIdentifier(Self,@UpperMethodName[1],nil);
-  BuildSubTreeForClass(ClassNode);
+      Params.Flags:=[fdfSearchInAncestors,fdfClassPublished];
-  SectionNode:=ClassNode.FirstChild;
+      if FindIdentifierInContext(Params)
-  while (SectionNode<>nil) do begin
+      and (Params.NewNode.Desc=ctnProcedure) then begin
-    while (SectionNode.Desc<>ctnClassPublished) or (SectionNode.FirstChild=nil)
+        Result:=CreateFindContext(Params);
-    do begin
-      SectionNode:=SectionNode.NextBrother;
-      if SectionNode=nil then exit;
-    end;
-    ANode:=SectionNode.FirstChild;
-    repeat
-      if (ANode.Desc=ctnProcedure) then begin
-        CurProcHead:=ExtractProcHead(ANode,[phpInUpperCase]);
-{$IFDEF CTDEBUG}
-writeln('TEventsCodeTool.FindPublishedMethodNodeInClass "',SearchedProcHead,
-'"="',CurProcHead,'"');
-{$ENDIF}
-        if (CurProcHead<>'')
-        and (CompareTextIgnoringSpace(CurProcHead,SearchedProcHead,true)=0) then
-        begin
-          Result:=ANode;
-          exit;
-        end;
       end;
-      ANode:=ANode.NextBrother;
+    finally
-    until ANode=nil;
+      Params.Free;
-    SectionNode:=SectionNode.NextBrother;
+    end;
+  finally
+    DeactivateGlobalWriteLock;
   end;
 end;
 
 function TEventsCodeTool.FindProcNodeInImplementation(const UpperClassName,
-  UpperMethodName: string; TypeData: PTypeData;
+  UpperMethodName: string; BuildTreeBefore: boolean): TCodeTreeNode;
-  BuildTreeBefore: boolean): TCodeTreeNode;
 var SectionNode, ANode: TCodeTreeNode;
-  SearchedProcHead, CurProcHead: string;
 begin
   Result:=nil;
+  if (UpperMethodName='') or (UpperClassName='') then exit;
   if BuildTreeBefore then BuildTree(false);
   // find implementation node
-  SectionNode:=Tree.Root;
+  SectionNode:=FindImplementationNode;
-  while (SectionNode<>nil) and (SectionNode.Desc<>ctnImplementation) do
-    SectionNode:=SectionNode.NextBrother;
   if SectionNode=nil then exit;
   ANode:=SectionNode.FirstChild;
-  SearchedProcHead:=UpperClassName+'.'+UpperMethodName
-       +MethodTypeDataToStr(TypeData,[phpInUpperCase,phpWithParameterNames]);
 {$IFDEF CTDEBUG}
-writeln('[TEventsCodeTool.FindProcNodeInImplementation] SearchedProcHead=',SearchedProcHead);
+writeln('[TEventsCodeTool.FindProcNodeInImplementation] A');
 {$ENDIF}
   while (ANode<>nil) do begin
-    if (ANode.Desc=ctnProcedure) then begin
+    if (ANode.Desc=ctnProcedure) and (ANode.FirstChild<>nil)
-      CurProcHead:=ExtractProcHead(ANode,[phpInUpperCase]);
+    and CompareSrcIdentifiers(ANode.FirstChild.StartPos,@UpperClassName[1])
-{$IFDEF CTDEBUG}
+    then begin
-writeln('[TEventsCodeTool.FindProcNodeInImplementation] CurProcHead=',CurProcHead);
+      MoveCursorToNodeStart(ANode.FirstChild);
-{$ENDIF}
+      ReadNextAtom; // read class name
-      if (CurProcHead<>'')
+      ReadNextAtom; // read '.'
-      and (CompareTextIgnoringSpace(CurProcHead,SearchedProcHead,true)=0) then
+      if AtomIsChar('.') then begin
-      begin
+        ReadNextAtom;
-        Result:=ANode;
+        if CompareSrcIdentifiers(CurPos.StartPos,@UpperMethodName[1]) then
-        exit;
+        begin
+          Result:=ANode;
+          exit;
+        end;
       end;
     end;
     ANode:=ANode.NextBrother;
@@ -365,20 +322,95 @@ writeln('[TEventsCodeTool.FindProcNodeInImplementation] CurProcHead=',CurProcHea
 end;
 
 function TEventsCodeTool.PublishedMethodExists(const UpperClassName,
-  UpperMethodName: string; TypeData: PTypeData): boolean;
+  UpperMethodName: string; TypeData: PTypeData;
+  var MethodIsCompatible, MethodIsPublished, IdentIsMethod: boolean): boolean;
 var ClassNode: TCodeTreeNode;
 begin
-  BuildTree(true);
+  ActivateGlobalWriteLock;
-  if not InterfaceSectionFound then exit;
+  try
-  ClassNode:=FindClassNodeInInterface(UpperClassName,true,false);
+{$IFDEF CTDEBUG}
-  Result:=PublishedMethodExists(ClassNode,UpperMethodName,TypeData);
+writeln('[TEventsCodeTool.PublishedMethodExists] A UpperClassName=',UpperClassName);
+{$ENDIF}
+    BuildTree(true);
+    if not InterfaceSectionFound then exit;
+    ClassNode:=FindClassNodeInInterface(UpperClassName,true,false);
+{$IFDEF CTDEBUG}
+writeln('[TEventsCodeTool.PublishedMethodExists] B ',ClassNode<>nil);
+{$ENDIF}
+    Result:=PublishedMethodExists(ClassNode,UpperMethodName,TypeData,
+               MethodIsCompatible,MethodIsPublished,IdentIsMethod);
+  finally
+    DeactivateGlobalWriteLock;
+  end;
 end;
 
 function TEventsCodeTool.PublishedMethodExists(ClassNode: TCodeTreeNode;
-  const UpperMethodName: string; TypeData: PTypeData): boolean;
+  const UpperMethodName: string; TypeData: PTypeData;
+  var MethodIsCompatible, MethodIsPublished, IdentIsMethod: boolean): boolean;
+var
+  FoundContext: TFindContext;
+  CompListSize: integer;
+  ParamCompatibility: TTypeCompatibility;
+  FirstParameterNode: TCodeTreeNode;
+  Params: TFindDeclarationParams;
 begin
-  Result:=(FindPublishedMethodNodeInClass(ClassNode,UpperMethodName,TypeData)
+  Result:=false;
-            <>nil);
+  MethodIsCompatible:=false;
+  IdentIsmethod:=false;
+  MethodIsPublished:=false;
+  ActivateGlobalWriteLock;
+  try
+    Params:=TFindDeclarationParams.Create;
+    try
+      // first search a published method definition with same name
+      Params.ContextNode:=ClassNode;
+      Params.SetIdentifier(Self,@UpperMethodName[1],nil);
+      Params.Flags:=[fdfSearchInAncestors,fdfClassPublished];
+      if FindIdentifierInContext(Params) then begin
+        IdentIsmethod:=(Params.NewNode.Desc=ctnProcedure);
+        MethodIsPublished:=(Params.NewNode.Parent.Desc=ctnClassPublished);
+        if IdentIsmethod and MethodIsPublished then begin
+          // published method with same name found
+          FoundContext:=CreateFindContext(Params);
+          // -> test for compatibility
+
+          // convert the TypeData to an expression type list
+          Params.ContextNode:=Params.NewNode;
+          SearchedExprList:=CreateExprListFromMethodTypeData(TypeData,Params);
+          // create compatibility list
+          CompListSize:=SizeOf(TTypeCompatibility)*SearchedExprList.Count;
+          if CompListSize>0 then begin
+            GetMem(SearchedCompatibilityList,CompListSize);
+          end else begin
+            SearchedCompatibilityList:=nil;
+          end;
+          try
+            // check for compatibility
+            FirstParameterNode:=FoundContext.Tool.GetFirstParameterNode(
+              FoundContext.Node);
+            ParamCompatibility:=FoundContext.Tool.IsParamListCompatible(
+              FirstParameterNode,
+              SearchedExprList,false,
+              Params,SearchedCompatibilityList);
+            if ParamCompatibility=tcExact then begin
+              MethodIsCompatible:=true;
+            end;
+          finally
+            SearchedExprList.Free;
+            SearchedExprList:=nil;
+            if SearchedCompatibilityList<>nil then
+              FreeMem(SearchedCompatibilityList);
+            SearchedCompatibilityList:=nil;
+          end;
+          Result:=true;
+        end;
+      end;
+    finally
+      Params.Free;
+    end;
+  finally
+    DeactivateGlobalWriteLock;
+  end;
 end;
 
 function TEventsCodeTool.JumpToPublishedMethodBody(const UpperClassName,
@@ -387,13 +419,12 @@ function TEventsCodeTool.JumpToPublishedMethodBody(const UpperClassName,
 var ANode: TCodeTreeNode;
 begin
   Result:=false;
-  ANode:=FindProcNodeInImplementation(UpperClassName,UpperMethodName,TypeData,
+  ANode:=FindProcNodeInImplementation(UpperClassName,UpperMethodName,true);
-            true);
   Result:=FindJumpPointInProcNode(ANode,NewPos,NewTopLine);
 end;
 
 function TEventsCodeTool.RenamePublishedMethod(const UpperClassName,
-  UpperOldMethodName, NewMethodName: string; TypeData: PTypeData;
+  UpperOldMethodName, NewMethodName: string;
   SourceChangeCache: TSourceChangeCache): boolean;
 var ClassNode: TCodeTreeNode;
 begin
@@ -401,12 +432,12 @@ begin
   if not EndOfSourceFound then exit;
   ClassNode:=FindClassNodeInInterface(UpperClassName,true,false);
   Result:=RenamePublishedMethod(ClassNode,UpperOldMethodName,NewMethodName,
-                 TypeData,SourceChangeCache);
+                                SourceChangeCache);
 end;
 
 function TEventsCodeTool.RenamePublishedMethod(ClassNode: TCodeTreeNode;
-    const UpperOldMethodName, NewMethodName: string; TypeData: PTypeData;
+  const UpperOldMethodName, NewMethodName: string;
-    SourceChangeCache: TSourceChangeCache): boolean;
+  SourceChangeCache: TSourceChangeCache): boolean;
 // rename published method in class and in procedure itself
 var ANode, ProcHeadNode: TCodeTreeNode;
   NameStart, NameEnd: integer;
@@ -414,15 +445,19 @@ var ANode, ProcHeadNode: TCodeTreeNode;
 begin
   Result:=false;
   if (ClassNode=nil) or (ClassNode.Desc<>ctnClass) or (UpperOldMethodName='')
-  or (NewMethodName='') or (SourceChangeCache=nil) or (Scanner=nil)
+  or (NewMethodName='') or (SourceChangeCache=nil) or (Scanner=nil) then
-  or (TypeData=nil) then exit;
+    exit;
   SourceChangeCache.MainScanner:=Scanner;
   // rename in class
-  ANode:=FindPublishedMethodNodeInClass(ClassNode,UpperOldMethodName,TypeData);
+  ANode:=FindIdentifierNodeInClass(ClassNode,@UpperOldMethodName[1]);
-{$IFDEF CTDEBUG}
+  if (ANode=nil) then begin
-writeln('TEventsCodeTool.RenamePublishedMethod A ',ANode<>nil);
+    MoveCursorToNodeStart(ClassNode);
-{$ENDIF}
+    RaiseException('old method not found: '+UpperOldMethodName);
-  if ANode=nil then exit;
+  end;
+  if (ANode.Desc<>ctnProcedure) then begin
+    MoveCursorToNodeStart(ANode);
+    RaiseException('old method not found: '+UpperOldMethodName);
+  end;
   ProcHeadNode:=ANode.FirstChild;
   if ProcHeadNode=nil then exit;
   NameStart:=ProcHeadNode.StartPos;
@@ -433,14 +468,7 @@ writeln('TEventsCodeTool.RenamePublishedMethod A ',ANode<>nil);
       NewMethodName) then exit;
   // rename procedure itself -> find implementation node
   UpperClassName:=ExtractClassName(ClassNode,true);
-{$IFDEF CTDEBUG}
+  ANode:=FindProcNodeInImplementation(UpperClassName,UpperOldMethodName,false);
-writeln('TEventsCodeTool.RenamePublishedMethod B ClassName=',UpperClassName);
-{$ENDIF}
-  ANode:=FindProcNodeInImplementation(UpperClassName,UpperOldMethodName,
-              TypeData,false);
-{$IFDEF CTDEBUG}
-writeln('TEventsCodeTool.RenamePublishedMethod C ',ANode<>nil);
-{$ENDIF}
   if ANode=nil then exit;
   ProcHeadNode:=ANode.FirstChild;
   if ProcHeadNode=nil then exit;
@@ -448,50 +476,62 @@ writeln('TEventsCodeTool.RenamePublishedMethod C ',ANode<>nil);
   ReadNextAtom; // read class name
   ReadNextAtom; // read '.'
   ReadNextAtom; // read method name
-{$IFDEF CTDEBUG}
-writeln('TEventsCodeTool.RenamePublishedMethod D "',GetAtom,'"');
-{$ENDIF}
   Result:=SourceChangeCache.Replace(gtNone,gtNone,
       CurPos.StartPos,CurPos.EndPos,NewMethodName);
 end;
 
 function TEventsCodeTool.CreatePublishedMethod(const UpperClassName,
-  AMethodName: string; TypeData: PTypeData;
+  AMethodName: string; ATypeInfo: PTypeInfo;
   SourceChangeCache: TSourceChangeCache): boolean;
 var ClassNode: TCodeTreeNode;
 begin
-  BuildTree(false);
+  ActivateGlobalWriteLock;
-  if not EndOfSourceFound then exit;
+  try
-  ClassNode:=FindClassNodeInInterface(UpperClassName,true,false);
+    BuildTree(false);
-  Result:=CreatePublishedMethod(ClassNode,AMethodName,TypeData,
+    if not EndOfSourceFound then exit;
-               SourceChangeCache);
+    ClassNode:=FindClassNodeInInterface(UpperClassName,true,false);
+    Result:=CreatePublishedMethod(ClassNode,AMethodName,ATypeInfo,
+                 SourceChangeCache);
+  finally
+    DeactivateGlobalWriteLock;
+  end;
 end;
 
 function TEventsCodeTool.CreatePublishedMethod(ClassNode: TCodeTreeNode;
-  const AMethodName: string; TypeData: PTypeData;
+  const AMethodName: string; ATypeInfo: PTypeInfo;
   SourceChangeCache: TSourceChangeCache): boolean;
-var PublishedNode: TCodeTreeNode;
+var PublishedNode, ANode: TCodeTreeNode;
   NewMethod: string;
 begin
   Result:=false;
   if (ClassNode=nil) or (ClassNode.Desc<>ctnClass) or (AMethodName='')
-  or (TypeData=nil) or (SourceChangeCache=nil) or (Scanner=nil) then exit;
+  or (ATypeInfo=nil) or (SourceChangeCache=nil) or (Scanner=nil) then exit;
-  SourceChangeCache.MainScanner:=Scanner;
+  ActivateGlobalWriteLock;
-  // add method to published section
+  try
-  BuildSubTreeForClass(ClassNode);
+    // convert TypeInfo to string
-  PublishedNode:=ClassNode.FirstChild;
+    NewMethod:=MethodTypeInfoToStr(ATypeInfo);
-  if PublishedNode=nil then exit;
-  if (PublishedNode.StartPos=PublishedNode.EndPos)
-  and (PublishedNode.NextBrother<>nil)
-  and (PublishedNode.NextBrother.Desc=ctnClassPublished) then
-    PublishedNode:=PublishedNode.NextBrother;
-  NewMethod:=MethodKindAsString[TypeData^.MethodKind]+' '+AMethodName+
-      MethodTypeDataToStr(TypeData,[phpWithVarModifiers,phpWithParameterNames]);
 {$IFDEF CTDEBUG}
 writeln('[TEventsCodeTool.CreatePublishedMethod] A NewMethod="',NewMethod,'"');
 {$ENDIF}
-  Result:=InsertNewMethodToClass(PublishedNode,AMethodName,NewMethod,
+    // add method to published section
-              SourceChangeCache);
+    SourceChangeCache.MainScanner:=Scanner;
+    BuildSubTreeForClass(ClassNode);
+    PublishedNode:=ClassNode.FirstChild;
+    if PublishedNode=nil then exit;
+    if (PublishedNode.StartPos=PublishedNode.EndPos)
+    and (PublishedNode.NextBrother<>nil)
+    and (PublishedNode.NextBrother.Desc=ctnClassPublished) then
+      PublishedNode:=PublishedNode.NextBrother;
+//    NewMethod:=MethodKindAsString[TypeData^.MethodKind]+' '+AMethodName+
+//        MethodTypeDataToStr(TypeData,[phpWithVarModifiers,phpWithParameterNames]);
+
+    // ToDo: check if parts already exists
+
+    Result:=InsertNewMethodToClass(PublishedNode,AMethodName,NewMethod,
+                SourceChangeCache);
+  finally
+    DeactivateGlobalWriteLock;
+  end;
 end;
 
 function TEventsCodeTool.InsertNewMethodToClass(
@@ -848,6 +888,66 @@ writeln('ParamCompatibility=',TypeCompatibilityNames[ParamCompatibility]);
   Result:=ifrProceedSearch;
 end;
 
+function TEventsCodeTool.MethodTypeInfoToStr(ATypeInfo: PTypeInfo): string;
+var TypeName: string;
+  Params: TFindDeclarationParams;
+begin
+  ActivateGlobalWriteLock;
+  try
+    // find method type declaration
+    TypeName:=ATypeInfo^.Name;
+    Params:=TFindDeclarationParams.Create;
+    try
+      // find method type in used units
+      Params.ContextNode:=FindMainUsesSection;
+      if Params.ContextNode=nil then
+        Params.ContextNode:=Tree.Root;
+      Params.SetIdentifier(Self,@TypeName[1],nil);
+      Params.Flags:=[fdfExceptionOnNotFound,fdfSearchInParentNodes];
+      FindIdentifierInContext(Params);
+      // find proc node
+      if Params.NewNode.Desc<>ctnTypeDefinition then begin
+        Params.NewCodeTool.MoveCursorToNodeStart(Params.NewNode);
+        Params.NewCodeTool.RaiseException('method type definition not found');
+      end;
+      Params.NewNode:=FindTypeNodeOfDefinition(Params.NewNode);
+      if Params.NewNode.Desc<>ctnProcedure then begin
+        Params.NewCodeTool.MoveCursorToNodeStart(Params.NewNode);
+        Params.NewCodeTool.RaiseException('method type definition not found');
+      end;
+      Result:=Params.NewCodeTool.ExtractProcHead(Params.NewNode,
+                  [phpWithStart, phpWithoutClassName, phpWithVarModifiers,
+                   phpWithParameterNames, phpWithResultType, phpWithComments]);
+    finally
+      Params.Free;
+    end;
+  finally
+    DeactivateGlobalWriteLock;
+  end;
+end;
+
+function TEventsCodeTool.FindIdentifierNodeInClass(ClassNode: TCodeTreeNode;
+  Identifier: PChar): TCodeTreeNode;
+var
+  VisibilityNode: TCodeTreeNode;
+begin
+  BuildSubTreeForClass(ClassNode);
+  VisibilityNode:=ClassNode.FirstChild;
+  while (VisibilityNode<>nil) do begin
+    Result:=VisibilityNode.FirstChild;
+    while Result<>nil do begin
+      if CompareSrcIdentifiers(Result.FirstChild.StartPos,Identifier) then
+      begin
+        exit;
+      end;
+      Result:=Result.NextBrother;
+    end;
+    VisibilityNode:=VisibilityNode.NextBrother;
+  end;
+  Result:=nil;
+end;
+
+
 
 end.
 

components/codetools/finddeclarationtool.pas

@@ -359,6 +359,11 @@ const
                               fdfExceptionOnNotFound]+fdfAllClassVisibilities;
 
 function ExprTypeToString(ExprType: TExpressionType): string;
+function CreateFindContext(NewTool: TFindDeclarationTool;
+  NewNode: TCodeTreeNode): TFindContext;
+function CreateFindContext(Params: TFindDeclarationParams): TFindContext;
+function CreateFindContext(BaseTypeCache: TBaseTypeCache): TFindContext;
+function FindContextAreEqual(Context1, Context2: TFindContext): boolean;
 
 
 implementation
@@ -827,7 +832,9 @@ function TFindDeclarationTool.FindIdentifierInContext(
   Result:
     true, if NewPos+NewTopLine valid
 }
-var LastContextNode, StartContextNode, ContextNode: TCodeTreeNode;
+var
+  LastContextNode, StartContextNode, FirstSearchedNode,
+  ContextNode: TCodeTreeNode;
   IsForward: boolean;
   IdentifierFoundResult: TIdentifierFoundResult;
   LastNodeCache: TCodeTreeNodeCache;
@@ -871,6 +878,7 @@ var LastContextNode, StartContextNode, ContextNode: TCodeTreeNode;
 begin
   ContextNode:=Params.ContextNode;
   StartContextNode:=ContextNode;
+  FirstSearchedNode:=nil;
   Result:=false;
   if ContextNode=nil then begin
     RaiseException('[TFindDeclarationTool.FindIdentifierInContext] '
@@ -891,15 +899,16 @@ writeln('[TFindDeclarationTool.FindIdentifierInContext] A Ident=',
 if (ContextNode.Desc=ctnClass) then
   writeln('  ContextNode.LastChild=',ContextNode.LastChild<>nil);
 {$ENDIF}
-      // search in cache
-      if FindInNodeCache then begin
-        Result:=(Params.NewNode<>nil);
-        exit;
-      end;
-      
       // search identifier in current context
       LastContextNode:=ContextNode;
       if not (fdfIgnoreCurContextNode in Params.Flags) then begin
+        // search in cache
+        if FindInNodeCache then begin
+          Result:=(Params.NewNode<>nil);
+          exit;
+        end;
+        if FirstSearchedNode=nil then FirstSearchedNode:=ContextNode;
+
         case ContextNode.Desc of
 
         ctnTypeSection, ctnVarSection, ctnConstSection, ctnResStrSection,
@@ -1159,16 +1168,19 @@ writeln('[TFindDeclarationTool.FindIdentifierInContext] Searching in Parent  Con
     until ContextNode=nil;
     
   finally
-    if Result and (not (fdfDoNotCache in Params.NewFlags)) then begin
+    if Result and (not (fdfDoNotCache in Params.NewFlags))
+    and (FirstSearchedNode<>nil) then begin
       // add result to caches
-      AddResultToNodeCaches(Params.Identifier,StartContextNode,ContextNode,
+      AddResultToNodeCaches(Params.Identifier,FirstSearchedNode,ContextNode,
         fdfSearchForward in Params.Flags,Params);
     end;
   end;
   // if we are here, the identifier was not found
-  // add result to cache
+  if FirstSearchedNode<>nil then begin
-  AddResultToNodeCaches(Params.Identifier,StartContextNode,ContextNode,
+    // add result to cache
-    fdfSearchForward in Params.Flags,nil);
+    AddResultToNodeCaches(Params.Identifier,FirstSearchedNode,ContextNode,
+      fdfSearchForward in Params.Flags,nil);
+  end;
 
   if fdfExceptionOnNotFound in Params.Flags then begin
     if Params.IdentifierTool.IsPCharInSrc(Params.Identifier) then
@@ -1700,12 +1712,7 @@ writeln('[TFindDeclarationTool.FindBaseTypeOfNode] LOOP Result=',Result.Node.Des
 {$ENDIF}
       if (Result.Node.Desc in AllIdentifierDefinitions) then begin
         // instead of variable/const/type definition, return the type
-        DummyNode:=FindTypeNodeOfDefinition(Result.Node);
+        Result.Node:=FindTypeNodeOfDefinition(Result.Node);
-        if (DummyNode<>nil) or (Result.Node.Parent.Desc<>ctnParameterList) then
-          Result.Node:=DummyNode
-        else
-          // in parameter lists are definitions without type allowed
-          exit;
       end else
       if (Result.Node.Desc=ctnClass)
       and ((Result.Node.SubDesc and ctnsForwardDeclaration)>0) then
@@ -3776,9 +3783,9 @@ begin
 {$IFDEF ShowNodeCache}
 write('TFindDeclarationTool.AddResultToNodeCaches ',
 ' Ident=',GetIdentifier(Identifier),
-' StartNode=',StartNode.DescAsString,'="',copy(Src,StartNode.StartPos,12),'"');
+' StartNode=',StartNode.DescAsString,'="',copy(Src,StartNode.StartPos-10,10),'|',copy(Src,StartNode.StartPos,15),'"');
 if EndNode<>nil then
-  write(' EndNode=',EndNode.DescAsString,'="',copy(Src,EndNode.StartPos,12),'"')
+  write(' EndNode=',EndNode.DescAsString,'="',copy(Src,EndNode.StartPos,25),'"')
 else
   write(' EndNode=nil');
 write(' SearchedForward=',SearchedForward);
@@ -3814,6 +3821,9 @@ end;
     else
       CleanEndPos:=SrcLen+1;
   end;
+{$IFDEF ShowNodeCache}
+writeln('  CleanStartPos=',CleanStartPos,' CleanEndPos=',CleanEndPos);
+{$ENDIF}
   while (Node<>nil) do begin
     if (Node.Desc in AllNodeCacheDescs) then begin
       if (Node.Cache=nil) then
@@ -3860,7 +3870,9 @@ write('[TFindDeclarationTool.CreateBaseTypeCaches] ',
 writeln(' Self=',MainFilename);
 if Result.Node<>nil then
   write(' Result=',Result.Node.DescAsString,
-     ' "',copy(Src,Result.Node.StartPos,10),'" ',Result.Tool.MainFilename)
+     ' Start=',Result.Node.StartPos,
+     ' End=',Result.Node.EndPos,
+     ' "',copy(Src,Result.Node.StartPos,15),'" ',Result.Tool.MainFilename)
 else
   write(' Result=nil');
 writeln('');
@@ -3870,7 +3882,7 @@ writeln('');
     if (Node.Cache=nil)
     and ((Result.Tool<>Self) or (Result.Node<>Node)) then begin
 {$IFDEF ShowBaseTypeCache}
-writeln('  i=',i,' Node=',Node.DescAsString,' "',copy(Src,Node.StartPos,10),'"');
+writeln('  i=',i,' Node=',Node.DescAsString,' "',copy(Src,Node.StartPos,15),'"');
 {$ENDIF}
       BaseTypeCache:=CreateNewBaseTypeCache(Node);
       if BaseTypeCache<>nil then begin

components/codetools/pascalparsertool.pas

@@ -72,12 +72,25 @@ type
     destructor Destroy; override;
   end;
 
-  TProcHeadAttribute = (phpWithStart, phpAddClassname, phpWithoutClassName,
+  TProcHeadAttribute = (
-      phpWithoutName, phpWithVarModifiers, phpWithParameterNames,
+      phpWithStart,          // proc keyword e.g. 'function', 'class procedure'
-      phpWithDefaultValues, phpWithResultType, phpWithComments, phpInUpperCase,
+      phpAddClassname,       // extract/add 'ClassName.'
-      phpWithoutBrackets, phpIgnoreForwards, phpIgnoreProcsWithBody,
+      phpWithoutClassName,   // skip classname
-      phpOnlyWithClassname, phpFindCleanPosition, phpWithoutParamList,
+      phpWithoutName,        // skip function name
-      phpCreateNodes);
+      phpWithVarModifiers,   // extract 'var', 'out', 'const'
+      phpWithParameterNames, // extract parameter names
+      phpWithDefaultValues,  // extract default values
+      phpWithResultType,     // extract colon + result type
+      phpWithComments,       // extract comments
+      phpInUpperCase,        // turn to uppercase
+      phpWithoutBrackets,    // skip start- and end-bracket of parameter list
+      phpIgnoreForwards,     // skip forward procs
+      phpIgnoreProcsWithBody,// skip procs with begin..end
+      phpOnlyWithClassname,  // skip procs without the right classname
+      phpFindCleanPosition,  // read til ExtractSearchPos
+      phpWithoutParamList,   // skip param list
+      phpCreateNodes         // create nodes during reading
+    );
   TProcHeadAttributes = set of TProcHeadAttribute;
   
   TProcHeadExtractPos = (phepNone, phepStart, phepName, phepParamList);
@@ -1000,6 +1013,14 @@ begin
           end;
         end;
       end;
+    end else begin
+      // no type -> variant
+      if (phpCreateNodes in Attr) then begin
+        CreateChildNode;
+        CurNode.Desc:=ctnVariantType;
+        CurNode.EndPos:=CurNode.StartPos;
+        EndChildNode;
+      end;
     end;
     if (phpCreateNodes in Attr) then begin
       CurNode.EndPos:=CurPos.EndPos;

ide/main.pp

@@ -271,9 +271,14 @@ type
     
     // ObjectInspector + PropertyEditorHook events
     procedure OIOnAddAvailableComponent(AComponent:TComponent;
-       var Allowed:boolean);
+      var Allowed:boolean);
     procedure OIOnSelectComponent(AComponent:TComponent);
     procedure OnPropHookGetMethods(TypeData:PTypeData; Proc:TGetStringProc);
+    function OnPropHookMethodExists(const AMethodName:ShortString;
+      TypeData: PTypeData;
+      var MethodIsCompatible,MethodIsPublished,IdentIsMethod: boolean):boolean;
+    function OnPropHookCreateMethod(const AMethodName:ShortString;
+      ATypeInfo:PTypeInfo): TMethod;
     
     // Environment options dialog events
     procedure OnLoadEnvironmentSettings(Sender: TObject; 
@@ -701,6 +706,7 @@ begin
   PropertyEditorHook1:=TPropertyEditorHook.Create;
   {$IFDEF TestEvents}
   PropertyEditorHook1.OnGetMethods:=@OnPropHookGetMethods;
+  PropertyEditorHook1.OnMethodExists:=@OnPropHookMethodExists;
   {$ENDIF}
   ObjectInspector1.PropertyEditorHook:=PropertyEditorHook1;
   ObjectInspector1.Show;
@@ -904,7 +910,7 @@ begin
 writeln('');
 writeln('[TMainIDE.OnPropHookGetMethods] ************');
 {$ENDIF}
-  if not CodeToolBoss.GetCompatibleMethods(ActiveUnitInfo.Source,
+  if not CodeToolBoss.GetCompatiblePublishedMethods(ActiveUnitInfo.Source,
     ActiveUnitInfo.Form.ClassName,TypeData,Proc) then
   begin
     DoJumpToCodeToolBossError;
@@ -5826,6 +5832,49 @@ begin
   ActiveUnitInfo:=nil;
 end;
 
+function TMainIDE.OnPropHookMethodExists(const AMethodName: ShortString;
+  TypeData: PTypeData;
+  var MethodIsCompatible,MethodIsPublished,IdentIsMethod: boolean): boolean;
+var ActiveSrcEdit: TSourceEditor;
+  ActiveUnitInfo: TUnitInfo;
+begin
+  if not BeginCodeTool(ActiveSrcEdit,ActiveUnitInfo,true) then exit;
+{$IFDEF IDE_DEBUG}
+writeln('');
+writeln('[TMainIDE.OnPropHookMethodExists] ************');
+{$ENDIF}
+  Result:=CodeToolBoss.PublishedMethodExists(ActiveUnitInfo.Source,
+                            ActiveUnitInfo.Form.ClassName,AMethodName,TypeData,
+                            MethodIsCompatible,MethodIsPublished,IdentIsMethod);
+  if CodeToolBoss.ErrorMessage<>'' then begin
+    DoJumpToCodeToolBossError;
+  end;
+end;
+
+function TMainIDE.OnPropHookCreateMethod(const AMethodName: ShortString;
+  ATypeInfo: PTypeInfo): TMethod;
+var ActiveSrcEdit: TSourceEditor;
+  ActiveUnitInfo: TUnitInfo;
+begin
+  Result.Code:=nil;
+  Result.Data:=nil;
+  if not BeginCodeTool(ActiveSrcEdit,ActiveUnitInfo,true) then exit;
+{$IFDEF IDE_DEBUG}
+writeln('');
+writeln('[TMainIDE.OnPropHookCreateMethod] ************');
+{$ENDIF}
+  // create published method
+  if CodeToolBoss.CreatePublishedMethod(ActiveUnitInfo.Source,
+              ActiveUnitInfo.Form.ClassName,AMethodName,ATypeInfo) then
+  begin
+
+    // ToDo: create published method in form
+
+  end else begin
+    DoJumpToCodeToolBossError;
+  end;
+end;
+
 
 //-----------------------------------------------------------------------------
 
@@ -5840,6 +5889,9 @@ end.
 
 { =============================================================================
   $Log$
+  Revision 1.221  2002/02/10 20:44:00  lazarus
+  MG: fixed a node cache range bug
+
   Revision 1.220  2002/02/09 22:24:50  lazarus
   MG: get compatible published methods now works