paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-22 16:19:36 +02:00
Code Issues Packages Projects Releases Wiki Activity

MG: fixed a node cache range bug

Browse Source 
git-svn-id: trunk@1435 -
This commit is contained in:
lazarus 2002-02-10 20:44:01 +00:00
parent 2a0d19493f
commit c2bcc86b61
5 changed files with 402 additions and 205 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
components/codetools/codetoolmanager.pas
View File

@ -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;
TypeData: PTypeData; Proc: TGetStringProc): boolean;
function MethodExists(Code:TCodeBuffer; const AClassName,
AMethodName: string; TypeData: PTypeData): boolean;
function JumpToMethodBody(Code: TCodeBuffer;
function GetCompatiblePublishedMethods(Code: TCodeBuffer;
const AClassName: string; TypeData: PTypeData;
Proc: TGetStringProc): boolean;
function PublishedMethodExists(Code:TCodeBuffer; const AClassName,
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,
NewMethodName: string; TypeData: PTypeData): boolean;
function CreateMethod(Code: TCodeBuffer; const AClassName,
NewMethodName: string; TypeData: PTypeData): boolean;
function RenamePublishedMethod(Code: TCodeBuffer;
const AClassName, OldMethodName,
NewMethodName: string): 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;
const AClassName, AMethodName: string; TypeData: PTypeData): boolean;
function TCodeToolManager.PublishedMethodExists(Code:TCodeBuffer;
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,
OldMethodName, NewMethodName: string; TypeData: PTypeData): boolean;
function TCodeToolManager.RenamePublishedMethod(Code: TCodeBuffer;
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,
NewMethodName: string; TypeData: PTypeData): boolean;
function TCodeToolManager.CreatePublishedMethod(Code: TCodeBuffer;
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;

398
components/codetools/eventcodetool.pas
View File

@ -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;
SourceChangeCache: TSourceChangeCache): boolean;
NewMethodName: string; 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;
BuildTreeBefore: boolean): TCodeTreeNode;
UpperMethodName: string; 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;
//SectionNode, ANode: TCodeTreeNode;
//CurProcHead, CurProcName: string;
var
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;
TypeData: PTypeData): TCodeTreeNode;
ClassNode: TCodeTreeNode; const UpperMethodName: string): TFindContext;
var
SectionNode, ANode: TCodeTreeNode;
SearchedProcHead, CurProcHead: string;
Params: TFindDeclarationParams;
begin
Result:=nil;
Result:=CleanFindContext;
if (ClassNode=nil) or (ClassNode.Desc<>ctnClass) or (UpperMethodName='')
or (Scanner=nil) or (TypeData=nil) then exit;
SearchedProcHead:=UpperMethodName+MethodTypeDataToStr(TypeData,
[phpInUpperCase]);
{$IFDEF CTDEBUG}
writeln('TEventsCodeTool.FindPublishedMethodNodeInClass A SearchedProcHead="',
SearchedProcHead,'"');
{$ENDIF}
BuildSubTreeForClass(ClassNode);
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]);
{$IFDEF CTDEBUG}
writeln('TEventsCodeTool.FindPublishedMethodNodeInClass "',SearchedProcHead,
'"="',CurProcHead,'"');
{$ENDIF}
if (CurProcHead<>'')
and (CompareTextIgnoringSpace(CurProcHead,SearchedProcHead,true)=0) then
begin
Result:=ANode;
exit;
end;
or (Scanner=nil) then exit;
ActivateGlobalWriteLock;
try
Params:=TFindDeclarationParams.Create;
try
Params.ContextNode:=ClassNode;
Params.SetIdentifier(Self,@UpperMethodName[1],nil);
Params.Flags:=[fdfSearchInAncestors,fdfClassPublished];
if FindIdentifierInContext(Params)
and (Params.NewNode.Desc=ctnProcedure) then begin
Result:=CreateFindContext(Params);
end;
ANode:=ANode.NextBrother;
until ANode=nil;
SectionNode:=SectionNode.NextBrother;
finally
Params.Free;
end;
finally
DeactivateGlobalWriteLock;
end;
end;
function TEventsCodeTool.FindProcNodeInImplementation(const UpperClassName,
UpperMethodName: string; TypeData: PTypeData;
BuildTreeBefore: boolean): TCodeTreeNode;
UpperMethodName: string; 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;
while (SectionNode<>nil) and (SectionNode.Desc<>ctnImplementation) do
SectionNode:=SectionNode.NextBrother;
SectionNode:=FindImplementationNode;
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
CurProcHead:=ExtractProcHead(ANode,[phpInUpperCase]);
{$IFDEF CTDEBUG}
writeln('[TEventsCodeTool.FindProcNodeInImplementation] CurProcHead=',CurProcHead);
{$ENDIF}
if (CurProcHead<>'')
and (CompareTextIgnoringSpace(CurProcHead,SearchedProcHead,true)=0) then
begin
Result:=ANode;
exit;
if (ANode.Desc=ctnProcedure) and (ANode.FirstChild<>nil)
and CompareSrcIdentifiers(ANode.FirstChild.StartPos,@UpperClassName[1])
then begin
MoveCursorToNodeStart(ANode.FirstChild);
ReadNextAtom; // read class name
ReadNextAtom; // read '.'
if AtomIsChar('.') then begin
ReadNextAtom;
if CompareSrcIdentifiers(CurPos.StartPos,@UpperMethodName[1]) then
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);
if not InterfaceSectionFound then exit;
ClassNode:=FindClassNodeInInterface(UpperClassName,true,false);
Result:=PublishedMethodExists(ClassNode,UpperMethodName,TypeData);
ActivateGlobalWriteLock;
try
{$IFDEF CTDEBUG}
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)
<>nil);
Result:=false;
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,
true);
ANode:=FindProcNodeInImplementation(UpperClassName,UpperMethodName,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;
SourceChangeCache: TSourceChangeCache): boolean;
const UpperOldMethodName, NewMethodName: string;
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 (TypeData=nil) then exit;
or (NewMethodName='') or (SourceChangeCache=nil) or (Scanner=nil) then
exit;
SourceChangeCache.MainScanner:=Scanner;
// rename in class
ANode:=FindPublishedMethodNodeInClass(ClassNode,UpperOldMethodName,TypeData);
{$IFDEF CTDEBUG}
writeln('TEventsCodeTool.RenamePublishedMethod A ',ANode<>nil);
{$ENDIF}
if ANode=nil then exit;
ANode:=FindIdentifierNodeInClass(ClassNode,@UpperOldMethodName[1]);
if (ANode=nil) then begin
MoveCursorToNodeStart(ClassNode);
RaiseException('old method not found: '+UpperOldMethodName);
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}
writeln('TEventsCodeTool.RenamePublishedMethod B ClassName=',UpperClassName);
{$ENDIF}
ANode:=FindProcNodeInImplementation(UpperClassName,UpperOldMethodName,
TypeData,false);
{$IFDEF CTDEBUG}
writeln('TEventsCodeTool.RenamePublishedMethod C ',ANode<>nil);
{$ENDIF}
ANode:=FindProcNodeInImplementation(UpperClassName,UpperOldMethodName,false);
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);
if not EndOfSourceFound then exit;
ClassNode:=FindClassNodeInInterface(UpperClassName,true,false);
Result:=CreatePublishedMethod(ClassNode,AMethodName,TypeData,
SourceChangeCache);
ActivateGlobalWriteLock;
try
BuildTree(false);
if not EndOfSourceFound then exit;
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;
SourceChangeCache.MainScanner:=Scanner;
// add method to published section
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]);
or (ATypeInfo=nil) or (SourceChangeCache=nil) or (Scanner=nil) then exit;
ActivateGlobalWriteLock;
try
// convert TypeInfo to string
NewMethod:=MethodTypeInfoToStr(ATypeInfo);
{$IFDEF CTDEBUG}
writeln('[TEventsCodeTool.CreatePublishedMethod] A NewMethod="',NewMethod,'"');
{$ENDIF}
Result:=InsertNewMethodToClass(PublishedNode,AMethodName,NewMethod,
SourceChangeCache);
// add method to published section
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.

56
components/codetools/finddeclarationtool.pas
View File

@ -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
AddResultToNodeCaches(Params.Identifier,StartContextNode,ContextNode,
fdfSearchForward in Params.Flags,nil);
if FirstSearchedNode<>nil then begin
// add result to cache
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);
if (DummyNode<>nil) or (Result.Node.Parent.Desc<>ctnParameterList) then
Result.Node:=DummyNode
else
// in parameter lists are definitions without type allowed
exit;
Result.Node:=FindTypeNodeOfDefinition(Result.Node);
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

33
components/codetools/pascalparsertool.pas
View File

@ -72,12 +72,25 @@ type
destructor Destroy; override;
end;
TProcHeadAttribute = (phpWithStart, phpAddClassname, phpWithoutClassName,
phpWithoutName, phpWithVarModifiers, phpWithParameterNames,
phpWithDefaultValues, phpWithResultType, phpWithComments, phpInUpperCase,
phpWithoutBrackets, phpIgnoreForwards, phpIgnoreProcsWithBody,
phpOnlyWithClassname, phpFindCleanPosition, phpWithoutParamList,
phpCreateNodes);
TProcHeadAttribute = (
phpWithStart, // proc keyword e.g. 'function', 'class procedure'
phpAddClassname, // extract/add 'ClassName.'
phpWithoutClassName, // skip classname
phpWithoutName, // skip function name
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;

58
ide/main.pp
View File

@ -271,10 +271,15 @@ 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;
TheEnvironmentOptions: TEnvironmentOptions);
@ -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