MG: get compatible published methods now works

git-svn-id: trunk@1434 -

components/codetools/eventcodetool.pas

@@ -50,6 +50,8 @@ type
   TEventsCodeTool = class(TMethodJumpingCodeTool)
   private
     GetCompatibleMethodsProc: TGetStringProc;
+    SearchedExprList: TExprTypeList;
+    SearchedCompatibilityList: TTypeCompatibilityList;
   protected
     function InsertNewMethodToClass(ClassSectionNode: TCodeTreeNode;
         const AMethodName,NewMethod: string;
@@ -57,10 +59,10 @@ type
     function CollectPublishedMethods(Params: TFindDeclarationParams;
       FoundContext: TFindContext): TIdentifierFoundResult;
   public
-    procedure GetCompatiblePublishedMethods(const UpperClassName: string;
-        TypeData: PTypeData; Proc: TGetStringProc);
-    procedure GetCompatiblePublishedMethods(ClassNode: TCodeTreeNode;
-        TypeData: PTypeData; Proc: TGetStringProc);
+    function GetCompatiblePublishedMethods(const UpperClassName: string;
+        TypeData: PTypeData; Proc: TGetStringProc): boolean;
+    function GetCompatiblePublishedMethods(ClassNode: TCodeTreeNode;
+        TypeData: PTypeData; Proc: TGetStringProc): boolean;
     function PublishedMethodExists(const UpperClassName,
         UpperMethodName: string; TypeData: PTypeData): boolean;
     function PublishedMethodExists(ClassNode: TCodeTreeNode;
@@ -177,47 +179,81 @@ begin
   Result:=Result+';';
 end;
 
-procedure TEventsCodeTool.GetCompatiblePublishedMethods(
-  const UpperClassName: string; TypeData: PTypeData; Proc: TGetStringProc);
+function TEventsCodeTool.GetCompatiblePublishedMethods(
+  const UpperClassName: string; TypeData: PTypeData;
+  Proc: TGetStringProc): boolean;
 var ClassNode: TCodeTreeNode;
 begin
-  BuildTree(true);
-  if not InterfaceSectionFound then exit;
-  ClassNode:=FindClassNodeInInterface(UpperClassName,true,false);
-  GetCompatiblePublishedMethods(ClassNode,TypeData,Proc);
+  Result:=false;
+  ActivateGlobalWriteLock;
+  try
+{$IFDEF CTDEBUG}
+writeln('[TEventsCodeTool.GetCompatiblePublishedMethods] A UpperClassName=',UpperClassName);
+{$ENDIF}
+    BuildTree(true);
+    if not InterfaceSectionFound then exit;
+    ClassNode:=FindClassNodeInInterface(UpperClassName,true,false);
+{$IFDEF CTDEBUG}
+writeln('[TEventsCodeTool.GetCompatiblePublishedMethods] B ',ClassNode<>nil);
+{$ENDIF}
+    Result:=GetCompatiblePublishedMethods(ClassNode,TypeData,Proc);
+  finally
+    DeactivateGlobalWriteLock;
+  end;
 end;
 
-procedure TEventsCodeTool.GetCompatiblePublishedMethods(
-  ClassNode: TCodeTreeNode; TypeData: PTypeData; Proc: TGetStringProc);
+function TEventsCodeTool.GetCompatiblePublishedMethods(
+  ClassNode: TCodeTreeNode; TypeData: PTypeData; Proc: TGetStringProc): boolean;
 var //SearchedProc: string;
   //SectionNode, ANode: TCodeTreeNode;
   //CurProcHead, CurProcName: string;
   Params: TFindDeclarationParams;
-  ExprList: TExprTypeList;
+  CompListSize: integer;
 begin
+  Result:=false;
+{$IFDEF CTDEBUG}
+writeln('[TEventsCodeTool.GetCompatiblePublishedMethods] C ',ClassNode<>nil);
+{$ENDIF}
   if (ClassNode=nil) or (ClassNode.Desc<>ctnClass) or (TypeData=nil)
   or (Proc=nil) then exit;
-  BuildSubTreeForClass(ClassNode);
+  ActivateGlobalWriteLock;
+  try
+    BuildSubTreeForClass(ClassNode);
 {$IFDEF CTDEBUG}
 writeln('[TEventsCodeTool.GetCompatiblePublishedMethods]');
 {$ENDIF}
-  // 1. convert the TypeData to an expression type list
-  Params:=TFindDeclarationParams.Create;
-  try
-    Params.ContextNode:=ClassNode.Parent;
-    ExprList:=CreateExprListFromMethodTypeData(TypeData,Params);
+    // 1. convert the TypeData to an expression type list
+    Params:=TFindDeclarationParams.Create;
     try
-      // 2. search all compatible published procs
-      GetCompatibleMethodsProc:=Proc;
-      Params.ContextNode:=ClassNode;
-      Params.Flags:=[fdfCollect,fdfSearchInAncestors,fdfClassPublished];
-      Params.SetIdentifier(Self,nil,@CollectPublishedMethods);
-      FindIdentifierInContext(Params);
+      Params.ContextNode:=ClassNode.Parent;
+      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
+        // 2. search all compatible published procs
+        GetCompatibleMethodsProc:=Proc;
+        Params.ContextNode:=ClassNode;
+        Params.Flags:=[fdfCollect,fdfSearchInAncestors,fdfClassPublished];
+        Params.SetIdentifier(Self,nil,@CollectPublishedMethods);
+        FindIdentifierInContext(Params);
+      finally
+        SearchedExprList.Free;
+        SearchedExprList:=nil;
+        if SearchedCompatibilityList<>nil then
+          FreeMem(SearchedCompatibilityList);
+        SearchedCompatibilityList:=nil;
+      end;
     finally
-      ExprList.Free;
+      Params.Free;
     end;
+    Result:=true;
   finally
-    Params.Free;
+    DeactivateGlobalWriteLock;
   end;
   {
   SearchedProc:=MethodTypeDataToStr(TypeData,[phpInUpperCase]);
@@ -781,12 +817,34 @@ end;
 function TEventsCodeTool.CollectPublishedMethods(
   Params: TFindDeclarationParams; FoundContext: TFindContext
   ): TIdentifierFoundResult;
+var
+  ParamCompatibility: TTypeCompatibility;
+  FirstParameterNode: TCodeTreeNode;
 begin
+  if (FoundContext.Node.Desc=ctnProcedure) then begin
 {$IFDEF CTDEBUG}
 writeln('[TEventsCodeTool.CollectPublishedMethods] ',
 ' Node=',FoundContext.Node.DescAsString,
+' "',copy(FoundContext.Tool.Src,FoundContext.Node.StartPos,20),'"',
 ' Tool=',FoundContext.Tool.MainFilename);
 {$ENDIF}
+    FirstParameterNode:=FoundContext.Tool.GetFirstParameterNode(
+      FoundContext.Node);
+    ParamCompatibility:=FoundContext.Tool.IsParamListCompatible(
+      FirstParameterNode,
+      SearchedExprList,false,
+      Params,SearchedCompatibilityList);
+    if ParamCompatibility=tcExact then begin
+{$IFDEF CTDEBUG}
+writeln('ParamCompatibility=',TypeCompatibilityNames[ParamCompatibility]);
+{$ENDIF}
+
+      // ToDo: ppu, ppw, dcu
+
+      GetCompatibleMethodsProc(
+        FoundContext.Tool.ExtractProcName(FoundContext.Node,false));
+    end;
+  end;
   Result:=ifrProceedSearch;
 end;
 

components/codetools/finddeclarationtool.pas

@@ -268,20 +268,6 @@ type
       Params: TFindDeclarationParams): boolean;
     function FindIdentifierInUsedUnit(const AnUnitName: string;
       Params: TFindDeclarationParams): boolean;
-    // expressions, operands, variables
-    function FindEndOfVariable(StartPos: integer): integer;
-    function FindExpressionTypeOfVariable(StartPos: integer;
-      Params: TFindDeclarationParams; var EndPos: integer): TExpressionType;
-    function ConvertNodeToExpressionType(Node: TCodeTreeNode;
-      Params: TFindDeclarationParams): TExpressionType;
-    function ReadOperandTypeAtCursor(
-      Params: TFindDeclarationParams): TExpressionType;
-    function CalculateBinaryOperator(LeftOperand, RightOperand: TExpressionType;
-      BinaryOperator: TAtomPosition;
-      Params: TFindDeclarationParams): TExpressionType;
-    function GetParameterNode(Node: TCodeTreeNode): TCodeTreeNode;
-    function GetFirstParameterNode(Node: TCodeTreeNode): TCodeTreeNode;
-    function PredefinedIdentToTypeDesc(Identifier: PChar): TExpressionTypeDesc;
   protected
     procedure DoDeleteNodes; override;
     procedure ClearNodeCaches(Force: boolean);
@@ -333,6 +319,20 @@ type
       Params: TFindDeclarationParams): TTypeCompatibility;
     function IsCompatible(Node: TCodeTreeNode; ExpressionType: TExpressionType;
       Params: TFindDeclarationParams): TTypeCompatibility;
+    // expressions, operands, variables
+    function FindEndOfVariable(StartPos: integer): integer;
+    function FindExpressionTypeOfVariable(StartPos: integer;
+      Params: TFindDeclarationParams; var EndPos: integer): TExpressionType;
+    function ConvertNodeToExpressionType(Node: TCodeTreeNode;
+      Params: TFindDeclarationParams): TExpressionType;
+    function ReadOperandTypeAtCursor(
+      Params: TFindDeclarationParams): TExpressionType;
+    function CalculateBinaryOperator(LeftOperand, RightOperand: TExpressionType;
+      BinaryOperator: TAtomPosition;
+      Params: TFindDeclarationParams): TExpressionType;
+    function GetParameterNode(Node: TCodeTreeNode): TCodeTreeNode;
+    function GetFirstParameterNode(Node: TCodeTreeNode): TCodeTreeNode;
+    function PredefinedIdentToTypeDesc(Identifier: PChar): TExpressionTypeDesc;
   public
     destructor Destroy; override;
     function FindDeclaration(CursorPos: TCodeXYPosition;
@@ -1080,14 +1080,14 @@ writeln('[TFindDeclarationTool.FindIdentifierInContext] no prior node accessible
 {$IFDEF ShowTriedContexts}
 //writeln('[TFindDeclarationTool.FindIdentifierInContext] Searching prior node of ',ContextNode.DescAsString);
 {$ENDIF}
-          if (ContextNode.Desc=ctnClass)
-          and (fdfSearchInAncestors in Params.Flags) then
-          begin
+          if (ContextNode.Desc=ctnClass) then begin
+            if (fdfSearchInAncestors in Params.Flags) then begin
           
-            // ToDo: check for circles in ancestors
-          
-            Result:=FindIdentifierInAncestors(ContextNode,Params);
-            if Result then exit;
+              // ToDo: check for circles in ancestors
+
+              Result:=FindIdentifierInAncestors(ContextNode,Params);
+              if Result then exit;
+            end;
           end;
           
           if ((not (fdfSearchForward in Params.Flags))
@@ -1115,7 +1115,10 @@ writeln('[TFindDeclarationTool.FindIdentifierInContext] Searching in PriorBrothe
             else
               break;
             end;
-          end else if ContextNode.Parent<>nil then begin
+          end else if (ContextNode.Parent<>nil)
+          and ((fdfSearchInParentNodes in Params.Flags)
+            or (ContextNode.HasAsParent(StartContextNode))) then
+          begin
             // search next in parent
             ContextNode:=ContextNode.Parent;
 {$IFDEF ShowTriedContexts}
@@ -1697,7 +1700,12 @@ 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
-        Result.Node:=FindTypeNodeOfDefinition(Result.Node);
+        DummyNode:=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
@@ -1835,11 +1843,11 @@ writeln('[TFindDeclarationTool.FindBaseTypeOfNode] Class is forward');
         break;
     end;
     if (Result.Node=nil) and (fdfExceptionOnNotFound in Params.Flags) then begin
-      if Result.Tool<>nil then begin
+      if (Result.Tool<>nil) and (Params.Identifier<>nil) then begin
 
         // ToDo ppu, ppw, dcu
 
-        if not Params.IdentifierTool.IsPCharInSrc(Params.Identifier) then
+        if (not Params.IdentifierTool.IsPCharInSrc(Params.Identifier)) then
           Params.IdentifierTool.RaiseException(
             '[TFindDeclarationTool.FindBaseTypeOfNode]'
            +' internal error: not IsPCharInSrc(Params.Identifier) '
@@ -2906,6 +2914,8 @@ writeln('[TFindDeclarationTool.ConvertNodeToExpressionType] B',
       // predefined identifiers
       if UpAtomIs('NIL') then
         Result.Desc:=xtNil
+      else if UpAtomIs('POINTER') then
+        Result.Desc:=xtPointer
       else if UpAtomIs('TRUE') or UpAtomIs('FALSE') then
         Result.Desc:=xtConstBoolean
       else if UpAtomIs('STRING') then

components/codetools/pascalparsertool.pas

@@ -2798,8 +2798,6 @@ begin
     ProcNode:=ProcNode.Parent;
   if ProcNode=nil then exit;
   ProcHeadNode:=ProcNode.FirstChild;
-  while (ProcHeadNode<>nil) and (ProcHeadNode.Desc<>ctnProcedureHead) do
-    ProcHeadNode:=ProcHeadNode.NextBrother;
   if (ProcHeadNode=nil) or (ProcHeadNode.StartPos<1) then exit;
   MoveCursorToNodeStart(ProcHeadNode);
   repeat

ide/main.pp

@@ -898,23 +898,17 @@ procedure TMainIDE.OnPropHookGetMethods(TypeData:PTypeData;
   Proc:TGetStringProc);
 var ActiveSrcEdit: TSourceEditor;
   ActiveUnitInfo: TUnitInfo;
-  NewSource: TCodeBuffer;
-  NewX, NewY, NewTopLine: integer;
 begin
   if not BeginCodeTool(ActiveSrcEdit,ActiveUnitInfo,true) then exit;
 {$IFDEF IDE_DEBUG}
 writeln('');
 writeln('[TMainIDE.OnPropHookGetMethods] ************');
 {$ENDIF}
-  if CodeToolBoss.FindDeclaration(ActiveUnitInfo.Source,
-    ActiveSrcEdit.EditorComponent.CaretX,
-    ActiveSrcEdit.EditorComponent.CaretY,
-    NewSource,NewX,NewY,NewTopLine) then
+  if not CodeToolBoss.GetCompatibleMethods(ActiveUnitInfo.Source,
+    ActiveUnitInfo.Form.ClassName,TypeData,Proc) then
   begin
-    DoJumpToCodePos(ActiveSrcEdit, ActiveUnitInfo,
-      NewSource, NewX, NewY, NewTopLine, true);
-  end else
     DoJumpToCodeToolBossError;
+  end;
 end;
 
 Procedure TMainIDE.ToolButtonClick(Sender : TObject);
@@ -5817,13 +5811,15 @@ procedure TMainIDE.DoSwitchToFormSrc(var ActiveSourceEditor: TSourceEditor;
   var ActiveUnitInfo: TUnitInfo);
 var i: integer;
 begin
-  i:=Project.IndexOfUnitWithForm(PropertyEditorHook1.LookupRoot,false);
-  if (i>=0) then begin
-    i:=Project.Units[i].EditorIndex;
+  if PropertyEditorHook1.LookupRoot<>nil then begin
+    i:=Project.IndexOfUnitWithForm(PropertyEditorHook1.LookupRoot,false);
     if (i>=0) then begin
-      SourceNoteBook.NoteBook.PageIndex:=i;
-      GetCurrentUnit(ActiveSourceEditor,ActiveUnitInfo);
-      exit;
+      i:=Project.Units[i].EditorIndex;
+      if (i>=0) then begin
+        SourceNoteBook.NoteBook.PageIndex:=i;
+        GetCurrentUnit(ActiveSourceEditor,ActiveUnitInfo);
+        exit;
+      end;
     end;
   end;
   ActiveSourceEditor:=nil;
@@ -5844,6 +5840,9 @@ end.
 
 { =============================================================================
   $Log$
+  Revision 1.220  2002/02/09 22:24:50  lazarus
+  MG: get compatible published methods now works
+
   Revision 1.219  2002/02/09 21:09:19  lazarus
   MG: fixed sourcenotebook closing and form-unit switching