paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-15 08:59:10 +02:00
Code Issues Packages Projects Releases Wiki Activity

codetools: complete event assignment: procs

Browse Source 
git-svn-id: trunk@35538 -
This commit is contained in:
mattias 2012-02-21 15:31:30 +00:00
parent 973cb8b092
commit 90f9933ecb
1 changed files with 131 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

194
components/codetools/codecompletiontool.pas
View File

@ -75,6 +75,8 @@ interface
{$DEFINE VerboseCompletionAdds} {$DEFINE VerboseCompletionAdds}
{off $DEFINE VerboseUpdateProcBodySignatures} {off $DEFINE VerboseUpdateProcBodySignatures}
{off $DEFINE VerboseCompleteMethod} {off $DEFINE VerboseCompleteMethod}
{off $DEFINE VerboseCompleteLocalVarAssign}
{off $DEFINE VerboseCompleteEventAssign}
uses uses
{$IFDEF MEM_CHECK} {$IFDEF MEM_CHECK}
@ -942,10 +944,10 @@ begin
// find variable name // find variable name
GetIdentStartEndAtPosition(Src,CleanCursorPos, GetIdentStartEndAtPosition(Src,CleanCursorPos,
VarNameAtom.StartPos,VarNameAtom.EndPos); VarNameAtom.StartPos,VarNameAtom.EndPos);
debugln('TCodeCompletionCodeTool.CheckLocalVarAssignmentSyntax A ',GetAtom(VarNameAtom),' "',copy(Src,CleanCursorPos,10),'"'); debugln('TCodeCompletionCodeTool.CheckLocalVarForInSyntax A ',GetAtom(VarNameAtom),' "',copy(Src,CleanCursorPos,10),'"');
if VarNameAtom.StartPos=VarNameAtom.EndPos then begin if VarNameAtom.StartPos=VarNameAtom.EndPos then begin
{$IFDEF VerboseForInCompletion} {$IFDEF VerboseForInCompletion}
debugln('TCodeCompletionCodeTool.CheckLocalVarAssignmentSyntax no identifier at cursor ',GetAtom(VarNameAtom),' "',copy(Src,CleanCursorPos,10),'"'); debugln('TCodeCompletionCodeTool.CheckLocalVarForInSyntax no identifier at cursor ',GetAtom(VarNameAtom),' "',copy(Src,CleanCursorPos,10),'"');
{$ENDIF} {$ENDIF}
exit; exit;
end; end;
@ -956,7 +958,7 @@ begin
ReadNextAtom; ReadNextAtom;
if not UpAtomIs('IN') then begin if not UpAtomIs('IN') then begin
{$IFDEF VerboseForInCompletion} {$IFDEF VerboseForInCompletion}
debugln('TCodeCompletionCodeTool.CheckLocalVarAssignmentSyntax no in keyword ',GetAtom(VarNameAtom)); debugln('TCodeCompletionCodeTool.CheckLocalVarForInSyntax no in keyword ',GetAtom(VarNameAtom));
{$ENDIF} {$ENDIF}
exit; exit;
end; end;
@ -967,7 +969,7 @@ begin
ReadPriorAtom; ReadPriorAtom;
if not UpAtomIs('FOR') then begin if not UpAtomIs('FOR') then begin
{$IFDEF VerboseForInCompletion} {$IFDEF VerboseForInCompletion}
debugln('TCodeCompletionCodeTool.CheckLocalVarAssignmentSyntax no for keyword ',GetAtom); debugln('TCodeCompletionCodeTool.CheckLocalVarForInSyntax no for keyword ',GetAtom);
{$ENDIF} {$ENDIF}
exit; exit;
end; end;
@ -979,7 +981,7 @@ begin
TermAtom.EndPos:=FindEndOfExpression(TermAtom.StartPos); TermAtom.EndPos:=FindEndOfExpression(TermAtom.StartPos);
{$IFDEF VerboseForInCompletion} {$IFDEF VerboseForInCompletion}
debugln('TCodeCompletionCodeTool.CheckLocalVarAssignmentSyntax term="',GetAtom(TermAtom),'"'); debugln('TCodeCompletionCodeTool.CheckLocalVarForInSyntax term="',GetAtom(TermAtom),'"');
{$ENDIF} {$ENDIF}
Result:=TermAtom.EndPos>TermAtom.StartPos; Result:=TermAtom.EndPos>TermAtom.StartPos;
end; end;
@ -1540,7 +1542,7 @@ var
begin begin
Result:=false; Result:=false;
{$IFDEF CTDEBUG} {$IFDEF VerboseCompleteLocalVarAssign}
DebugLn(' CompleteLocalVariableAssignment: A'); DebugLn(' CompleteLocalVariableAssignment: A');
{$ENDIF} {$ENDIF}
if not ((CursorNode.Desc=ctnBeginBlock) if not ((CursorNode.Desc=ctnBeginBlock)
@ -1549,19 +1551,19 @@ begin
BuildSubTreeForBeginBlock(CursorNode); BuildSubTreeForBeginBlock(CursorNode);
CursorNode:=FindDeepestNodeAtPos(CleanCursorPos,true); CursorNode:=FindDeepestNodeAtPos(CleanCursorPos,true);
{$IFDEF CTDEBUG} {$IFDEF VerboseCompleteLocalVarAssign}
DebugLn(' CompleteLocalVariableAssignment: B CheckLocalVarAssignmentSyntax ...'); DebugLn(' CompleteLocalVariableAssignment: B CheckLocalVarAssignmentSyntax ...');
{$ENDIF} {$ENDIF}
// check assignment syntax // check assignment syntax
if not CheckLocalVarAssignmentSyntax(CleanCursorPos, if not CheckLocalVarAssignmentSyntax(CleanCursorPos,
VarNameAtom,AssignmentOperator,TermAtom) VarNameAtom,AssignmentOperator,TermAtom)
then begin then begin
{$IFDEF CTDEBUG} {$IFDEF VerboseCompleteLocalVarAssign}
debugln(['TCodeCompletionCodeTool.CompleteLocalVariableAssignment CheckLocalVarAssignmentSyntax=false']); debugln(['TCodeCompletionCodeTool.CompleteLocalVariableAssignment CheckLocalVarAssignmentSyntax=false']);
{$ENDIF} {$ENDIF}
exit; exit;
end; end;
{$IFDEF CTDEBUG} {$IFDEF VerboseCompleteLocalVarAssign}
debugln(['TCodeCompletionCodeTool.CompleteLocalVariableAssignment VarNameAtom=',dbgstr(Src,VarNameAtom.StartPos,VarNameAtom.EndPos-VarNameAtom.StartPos),' AssignmentOperator=',dbgstr(Src,AssignmentOperator.StartPos,AssignmentOperator.EndPos-AssignmentOperator.StartPos),' TermAtom=',dbgstr(Src,TermAtom.StartPos,TermAtom.EndPos-TermAtom.StartPos)]); debugln(['TCodeCompletionCodeTool.CompleteLocalVariableAssignment VarNameAtom=',dbgstr(Src,VarNameAtom.StartPos,VarNameAtom.EndPos-VarNameAtom.StartPos),' AssignmentOperator=',dbgstr(Src,AssignmentOperator.StartPos,AssignmentOperator.EndPos-AssignmentOperator.StartPos),' TermAtom=',dbgstr(Src,TermAtom.StartPos,TermAtom.EndPos-TermAtom.StartPos)]);
{$ENDIF} {$ENDIF}
@ -1569,7 +1571,7 @@ begin
ActivateGlobalWriteLock; ActivateGlobalWriteLock;
Params:=TFindDeclarationParams.Create; Params:=TFindDeclarationParams.Create;
try try
{$IFDEF CTDEBUG} {$IFDEF VerboseCompleteLocalVarAssign}
DebugLn(' CompleteLocalVariableAssignment: check if variable is already defined ...'); DebugLn(' CompleteLocalVariableAssignment: check if variable is already defined ...');
{$ENDIF} {$ENDIF}
// check if identifier exists // check if identifier exists
@ -1581,7 +1583,7 @@ begin
RaiseExceptionFmt(ctsIdentifierAlreadyDefined,[GetAtom]); RaiseExceptionFmt(ctsIdentifierAlreadyDefined,[GetAtom]);
end; end;
{$IFDEF CTDEBUG} {$IFDEF VerboseCompleteLocalVarAssign}
DebugLn(' CompleteLocalVariableAssignment: Find type of term ...', DebugLn(' CompleteLocalVariableAssignment: Find type of term ...',
' Term="',copy(Src,TermAtom.StartPos,TermAtom.EndPos-TermAtom.StartPos),'"'); ' Term="',copy(Src,TermAtom.StartPos,TermAtom.EndPos-TermAtom.StartPos),'"');
{$ENDIF} {$ENDIF}
@ -1622,7 +1624,7 @@ var
be added to the published section of the class of the Begin..End Block. be added to the published section of the class of the Begin..End Block.
} }
function CheckEventAssignmentSyntax(out PropertyAtom: TAtomPosition; function CheckEventAssignmentSyntax(out PropVarAtom: TAtomPosition;
out AssignmentOperator, AddrOperatorPos: integer; out AssignmentOperator, AddrOperatorPos: integer;
out UserEventAtom: TAtomPosition; out UserEventAtom: TAtomPosition;
out SemicolonPos: integer): boolean; out SemicolonPos: integer): boolean;
@ -1654,7 +1656,7 @@ var
ReadPriorAtom; ReadPriorAtom;
// check event name // check event name
if not AtomIsIdentifier(false) then exit; if not AtomIsIdentifier(false) then exit;
PropertyAtom:=CurPos; PropVarAtom:=CurPos;
// check for semicolon at end of statement // check for semicolon at end of statement
MoveCursorToCleanPos(UserEventAtom.EndPos); MoveCursorToCleanPos(UserEventAtom.EndPos);
@ -1672,32 +1674,37 @@ var
Result:=true; Result:=true;
end; end;
function FindEventTypeAtCursor(PropertyAtom: TAtomPosition; function FindEventTypeAtCursor(PropVarAtom: TAtomPosition;
out PropertyContext, ProcContext: TFindContext; out PropVarContext, ProcContext: TFindContext;
Params: TFindDeclarationParams): boolean; Params: TFindDeclarationParams): boolean;
begin begin
Result:=false; Result:=false;
// find declaration of property identifier // find declaration of property identifier
Params.ContextNode:=CursorNode; Params.ContextNode:=CursorNode;
MoveCursorToCleanPos(PropertyAtom.StartPos); MoveCursorToCleanPos(PropVarAtom.StartPos);
Params.SetIdentifier(Self,@Src[CurPos.StartPos],nil); Params.SetIdentifier(Self,@Src[CurPos.StartPos],nil);
fFullTopLvlName:=''; fFullTopLvlName:='';
Params.OnTopLvlIdentifierFound:=@OnTopLvlIdentifierFound; Params.OnTopLvlIdentifierFound:=@OnTopLvlIdentifierFound;
Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors, Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors,
fdfTopLvlResolving,fdfFindVariable]; fdfTopLvlResolving,fdfFindVariable];
if (not FindDeclarationOfIdentAtParam(Params)) if (not FindDeclarationOfIdentAtParam(Params)) then begin
or (Params.NewNode.Desc<>ctnProperty) then begin
{$IFDEF CTDEBUG} {$IFDEF CTDEBUG}
DebugLn('FindEventTypeAtCursor not a property'); DebugLn('FindEventTypeAtCursor identifier "',GetIdentifier(@Src[CurPos.StartPos]),'" not found');
{$ENDIF} {$ENDIF}
exit; exit;
end; end;
PropertyContext:=CreateFindContext(Params); if not (Params.NewNode.Desc in [ctnProperty,ctnVarDefinition]) then begin
{$IFDEF CTDEBUG}
DebugLn('FindEventTypeAtCursor not a property/variable');
{$ENDIF}
exit;
end;
PropVarContext:=CreateFindContext(Params);
// identifier is property // identifier is property
// -> check type of property // -> check type of property
Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors]; Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors];
ProcContext:=PropertyContext.Tool.FindBaseTypeOfNode( ProcContext:=PropVarContext.Tool.FindBaseTypeOfNode(
Params,PropertyContext.Node); Params,PropVarContext.Node);
if (ProcContext.Node=nil) or (ProcContext.Node.Desc<>ctnProcedureType) if (ProcContext.Node=nil) or (ProcContext.Node.Desc<>ctnProcedureType)
then begin then begin
{$IFDEF CTDEBUG} {$IFDEF CTDEBUG}
@ -1705,22 +1712,22 @@ var
{$ENDIF} {$ENDIF}
exit; exit;
end; end;
// identifier is property of type proc => this is an event // identifier is property/var of type proc => this is an event
Result:=true; Result:=true;
end; end;
function CreateEventFullName(AClassNode: TCodeTreeNode; UserEventAtom, function CreateEventFullName(AClassNode: TCodeTreeNode; UserEventAtom,
PropertyAtom: TAtomPosition): string; PropVarAtom: TAtomPosition): string;
var PropertyName, AClassName: string; var PropVarName, AClassName: string;
l: integer; l: integer;
begin begin
if UserEventAtom.StartPos=UserEventAtom.EndPos then begin if UserEventAtom.StartPos=UserEventAtom.EndPos then begin
Result:=fFullTopLvlName; Result:=fFullTopLvlName;
l:=PropertyAtom.EndPos-PropertyAtom.StartPos; l:=PropVarAtom.EndPos-PropVarAtom.StartPos;
PropertyName:=copy(Src,PropertyAtom.StartPos,l); PropVarName:=copy(Src,PropVarAtom.StartPos,l);
if SysUtils.CompareText(PropertyName,RightStr(Result,l))<>0 then if SysUtils.CompareText(PropVarName,RightStr(Result,l))<>0 then
Result:=Result+PropertyName; Result:=Result+PropVarName;
if SysUtils.CompareText(PropertyName,Result)=0 then begin if SysUtils.CompareText(PropVarName,Result)=0 then begin
// this is an event of the class (not event of published objects) // this is an event of the class (not event of published objects)
// -> add form name // -> add form name
MoveCursorToNodeStart(AClassNode.Parent); MoveCursorToNodeStart(AClassNode.Parent);
@ -1731,8 +1738,8 @@ var
Result:=AClassName+Result; Result:=AClassName+Result;
end; end;
// convert OnClick to Click // convert OnClick to Click
if (UpperCaseStr(LeftStr(PropertyName,2))='ON') if (UpperCaseStr(LeftStr(PropVarName,2))='ON')
and (SysUtils.CompareText(RightStr(Result,l),PropertyName)=0) and (SysUtils.CompareText(RightStr(Result,l),PropVarName)=0)
then then
Result:=LeftStr(Result,length(Result)-l)+RightStr(Result,l-2); Result:=LeftStr(Result,length(Result)-l)+RightStr(Result,l-2);
end else begin end else begin
@ -1744,12 +1751,13 @@ var
{$ENDIF} {$ENDIF}
end; end;
function FindClassAndProcNode(out ProcNode, AClassNode: TCodeTreeNode function FindProcAndClassNode(out ProcNode, AClassNode: TCodeTreeNode
): boolean; ): boolean;
var var
ANode: TCodeTreeNode; ANode: TCodeTreeNode;
begin begin
Result:=false; Result:=false;
AClassNode:=nil;
ProcNode:=CursorNode; ProcNode:=CursorNode;
while (ProcNode<>nil) do begin while (ProcNode<>nil) do begin
if (ProcNode.Desc=ctnProcedure) then begin if (ProcNode.Desc=ctnProcedure) then begin
@ -1759,12 +1767,15 @@ var
ProcNode:=ProcNode.Parent; ProcNode:=ProcNode.Parent;
end; end;
if (ProcNode=nil) then exit; if (ProcNode=nil) then exit;
ANode:=FindFirstNodeOnSameLvl(ProcNode); ANode:=FindClassNodeForMethodBody(ProcNode,true,false);
if (ANode=nil) then exit; if (ANode=nil) then exit;
// search class node // search class node
AClassNode:=FindClassNode(ANode,UpperCaseStr(SearchedClassName), while ANode<>nil do begin
true,false); if ANode.Desc in AllClassObjects then break;
if AClassNode=nil then exit; ANode:=ANode.Parent;
end;
if ANode=nil then exit;
AClassNode:=ANode;
Result:=true; Result:=true;
end; end;
@ -1798,25 +1809,52 @@ var
StartInsertPos,EndInsertPos,RValue); StartInsertPos,EndInsertPos,RValue);
end; end;
procedure AddProcedure(Identifier: string;
TypeTool: TFindDeclarationTool; TypeNode: TCodeTreeNode);
var
ProcContext: TFindContext;
AMethodDefinition: string;
AMethodAttr: TProcHeadAttributes;
begin
// create new method
ProcContext:=CreateFindContext(TypeTool,TypeNode);
AddProcedureCompatibleToProcType(Identifier,
ProcContext,AMethodDefinition,AMethodAttr,SourceChangeCache,
CursorNode);
// apply the changes
if not SourceChangeCache.Apply then
RaiseException(ctsUnableToApplyChanges);
{$IFDEF CTDEBUG}
DebugLn(' CompleteLocalIdentifierByParameter.AddProcedure: jumping to new method body...');
{$ENDIF}
// jump to new method body
if not JumpToMethod(AMethodDefinition,AMethodAttr,NewPos,NewTopLine,false)
then
RaiseException('CompleteLocalIdentifierByParameter.AddProcedure JumpToMethod failed');
end;
// function CompleteEventAssignment: boolean // function CompleteEventAssignment: boolean
var var
UserEventAtom, PropertyAtom: TAtomPosition; UserEventAtom, PropVarAtom: TAtomPosition;
AssignmentOperator, AddrOperatorPos, SemicolonPos: integer; AssignmentOperator, AddrOperatorPos, SemicolonPos: integer;
Params: TFindDeclarationParams; Params: TFindDeclarationParams;
PropertyContext, ProcContext: TFindContext; PropertyContext, ProcContext: TFindContext;
FullEventName, AMethodDefinition: string; FullEventName, AMethodDefinition: string;
AMethodAttr: TProcHeadAttributes; AMethodAttr: TProcHeadAttributes;
ProcNode, AClassNode: TCodeTreeNode; ProcNode, AClassNode: TCodeTreeNode;
Identifier: String;
begin begin
IsEventAssignment:=false; IsEventAssignment:=false;
Result:=false; Result:=false;
{$IFDEF CTDEBUG} {$IFDEF VerboseCompleteEventAssign}
DebugLn(' CompleteEventAssignment: CheckEventAssignmentSyntax...'); DebugLn(' CompleteEventAssignment: CheckEventAssignmentSyntax...');
{$ENDIF} {$ENDIF}
// check assigment syntax // check assigment syntax
if not CheckEventAssignmentSyntax(PropertyAtom, AssignmentOperator, if not CheckEventAssignmentSyntax(PropVarAtom, AssignmentOperator,
AddrOperatorPos, UserEventAtom, SemicolonPos) AddrOperatorPos, UserEventAtom, SemicolonPos)
then then
exit; exit;
IsEventAssignment:=true; IsEventAssignment:=true;
@ -1829,49 +1867,79 @@ begin
BuildSubTreeForBeginBlock(CursorNode); BuildSubTreeForBeginBlock(CursorNode);
CursorNode:=FindDeepestNodeAtPos(CleanCursorPos,true); CursorNode:=FindDeepestNodeAtPos(CleanCursorPos,true);
{$IFDEF CTDEBUG} {$IFDEF VerboseCompleteEventAssign}
DebugLn(' CompleteEventAssignment: find class of method...'); DebugLn(' CompleteEventAssignment: check if a method and find class...');
{$ENDIF} {$ENDIF}
if not FindClassAndProcNode(ProcNode,AClassNode) then exit; FindProcAndClassNode(ProcNode,AClassNode);
ActivateGlobalWriteLock;
Params:=TFindDeclarationParams.Create; Params:=TFindDeclarationParams.Create;
try try
{$IFDEF CTDEBUG} {$IFDEF VerboseCompleteEventAssign}
DebugLn(' CompleteEventAssignment: FindEventTypeAtCursor...'); DebugLn(' CompleteEventAssignment: FindEventTypeAtCursor...');
{$ENDIF} {$ENDIF}
// check if identifier is event property and build // check if identifier is event property and build
Result:=FindEventTypeAtCursor(PropertyAtom,PropertyContext,ProcContext, Result:=FindEventTypeAtCursor(PropVarAtom,PropertyContext,ProcContext,
Params); Params);
if not Result then exit; if not Result then exit;
{$IFDEF CTDEBUG} if ProcContext.Tool.ProcNodeHasOfObject(ProcContext.Node) then begin
DebugLn(' CompleteEventAssignment: CreateEventFullName... UserEventAtom.StartPos=',dbgs(UserEventAtom.StartPos)); if AClassNode<>nil then begin
{$ENDIF} {$IFDEF VerboseCompleteEventAssign}
// create a nice event name DebugLn(' CompleteEventAssignment: CreateEventFullName... UserEventAtom.StartPos=',dbgs(UserEventAtom.StartPos));
FullEventName:=CreateEventFullName(AClassNode,UserEventAtom,PropertyAtom); {$ENDIF}
if FullEventName='' then exit; // create a nice event name
FullEventName:=CreateEventFullName(AClassNode,UserEventAtom,PropVarAtom);
if FullEventName='' then exit;
// add published method and method body and right side of assignment
AddMethodCompatibleToProcType(AClassNode,FullEventName,ProcContext,
AMethodDefinition,AMethodAttr,SourceChangeCache);
if not CompleteAssignment(FullEventName,AssignmentOperator,
AddrOperatorPos,SemicolonPos,UserEventAtom)
then
RaiseException('CompleteEventAssignment CompleteAssignment failed');
end else if ProcContext.Tool.ProcNodeHasOfObject(ProcContext.Node) then begin
{$IFDEF VerboseCompleteEventAssign}
debugln([' CompleteEventAssignment: proc is "of object"']);
{$ENDIF}
MoveCursorToCleanPos(PropVarAtom.StartPos);
RaiseException('Complete event failed: procedure of object needs a class');
end;
end else begin
// create procedure (not method)
{$IFDEF VerboseCompleteEventAssign}
debugln([' CompleteEventAssignment: create a proc name']);
{$ENDIF}
// get name
Identifier:='';
if (UserEventAtom.StartPos>1) and (UserEventAtom.StartPos<=SrcLen) then
Identifier:=GetIdentifier(@Src[UserEventAtom.StartPos]);
if Identifier='' then
Identifier:=GetIdentifier(@Src[PropVarAtom.StartPos]);
if Identifier='' then begin
MoveCursorToCleanPos(PropVarAtom.StartPos);
RaiseException('Complete event failed: need a name');
end;
// create proc
{$IFDEF VerboseCompleteEventAssign}
debugln([' CompleteEventAssignment: create a proc name']);
{$ENDIF}
AddProcedureCompatibleToProcType(Identifier,
ProcContext,AMethodDefinition,AMethodAttr,SourceChangeCache,
CursorNode);
end;
finally finally
Params.Free; Params.Free;
DeactivateGlobalWriteLock;
end; end;
// add published method and method body and right side of assignment {$IFDEF VerboseCompleteEventAssign}
AddMethodCompatibleToProcType(AClassNode,FullEventName,ProcContext,
AMethodDefinition,AMethodAttr,SourceChangeCache);
if not CompleteAssignment(FullEventName,AssignmentOperator,
AddrOperatorPos,SemicolonPos,UserEventAtom)
then
RaiseException('CompleteEventAssignment CompleteAssignment failed');
{$IFDEF CTDEBUG}
DebugLn(' CompleteEventAssignment: Applying changes...'); DebugLn(' CompleteEventAssignment: Applying changes...');
{$ENDIF} {$ENDIF}
// apply the changes // apply the changes
if not SourceChangeCache.Apply then if not SourceChangeCache.Apply then
RaiseException(ctsUnableToApplyChanges); RaiseException(ctsUnableToApplyChanges);
{$IFDEF CTDEBUG} {$IFDEF VerboseCompleteEventAssign}
DebugLn(' CompleteEventAssignment: jumping to new method body...'); DebugLn(' CompleteEventAssignment: jumping to new method body...');
{$ENDIF} {$ENDIF}
// jump to new method body // jump to new method body