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

implemented class to Pointer assignment compatibility check

Browse Source 
git-svn-id: trunk@5030 -
This commit is contained in:
mattias 2004-01-08 16:13:47 +00:00
parent c3ce1eb4ef
commit f8cac4fbb4
4 changed files with 218 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
components/codetools/eventcodetool.pas
View File

@ -434,13 +434,14 @@ begin
SearchedCompatibilityList:=nil;
end;
try
// check for compatibility
// check if the method fits into the TypeData
FirstParameterNode:=FoundContext.Tool.GetFirstParameterNode(
FoundContext.Node);
ParamCompatibility:=FoundContext.Tool.IsParamListCompatible(
FirstParameterNode,
SearchedExprList,false,
Params,SearchedCompatibilityList);
ParamCompatibility:=
FoundContext.Tool.IsParamNodeListCompatibleToExprList(
SearchedExprList,
FirstParameterNode,
Params,SearchedCompatibilityList);
if ParamCompatibility=tcExact then begin
MethodIsCompatible:=true;
end;
@ -701,9 +702,11 @@ begin
{$ENDIF}
FirstParameterNode:=FoundContext.Tool.GetFirstParameterNode(
FoundContext.Node);
ParamCompatibility:=FoundContext.Tool.IsParamListCompatible(
// check if the found proc fits into
// the method mask (= current expression list)
ParamCompatibility:=FoundContext.Tool.IsParamNodeListCompatibleToExprList(
SearchedExprList,
FirstParameterNode,
SearchedExprList,false,
Params,SearchedCompatibilityList);
{$IFDEF ShowAllProcs}
writeln('[TEventsCodeTool.CollectPublishedMethods] A',

162
components/codetools/finddeclarationtool.pas
View File

@ -309,13 +309,16 @@ const
xtAllRealTypes = [xtReal, xtConstReal, xtSingle, xtDouble, xtExtended,
xtCurrency, xtComp];
xtAllStringTypes = [xtConstString, xtShortString, xtString, xtAnsiString];
xtAllStringCompatibleTypes = xtAllStringTypes+[xtChar];
xtAllWideStringTypes = [xtConstString, xtWideString];
xtAllWideStringCompatibleTypes = xtAllWideStringTypes+[xtWideChar,xtChar];
xtAllPointerTypes = [xtPointer, xtNil];
xtAllStringCompatibleTypes = xtAllStringTypes+[xtChar];
xtAllWideStringCompatibleTypes = xtAllWideStringTypes+[xtWideChar,xtChar];
xtAllIntegerConvertibles = xtAllIntegerTypes;
xtAllRealConvertibles = xtAllRealTypes+xtAllIntegerTypes;
xtAllStringConvertibles = xtAllStringTypes+[xtChar,xtPChar];
xtAllStringConvertibles = xtAllStringCompatibleTypes+[xtPChar];
xtAllWideStringConvertibles = xtAllWideStringCompatibleTypes+[xtPChar];
xtAllBooleanConvertibles = xtAllBooleanTypes+[xtConstBoolean];
xtAllPointerConvertibles = xtAllPointerTypes+[xtPChar];
@ -597,12 +600,18 @@ type
function GetInterfaceNode: TCodeTreeNode;
function CompatibilityList1IsBetter(List1, List2: TTypeCompatibilityList;
ListCount: integer): boolean;
function IsParamListCompatible(FirstParameterNode: TCodeTreeNode;
ExprParamList: TExprTypeList; IgnoreMissingParameters: boolean;
function IsParamExprListCompatibleToNodeList(
FirstTargetParameterNode: TCodeTreeNode;
SourceExprParamList: TExprTypeList; IgnoreMissingParameters: boolean;
Params: TFindDeclarationParams;
CompatibilityList: TTypeCompatibilityList): TTypeCompatibility;
function IsParamListCompatible(FirstParameterNode1,
FirstParameterNode2: TCodeTreeNode;
function IsParamNodeListCompatibleToExprList(
TargetExprParamList: TExprTypeList;
FirstSourceParameterNode: TCodeTreeNode;
Params: TFindDeclarationParams;
CompatibilityList: TTypeCompatibilityList): TTypeCompatibility;
function IsParamNodeListCompatibleToParamNodeList(FirstTargetParameterNode,
FirstSourceParameterNode: TCodeTreeNode;
Params: TFindDeclarationParams;
CompatibilityList: TTypeCompatibilityList): TTypeCompatibility;
function CreateParamExprListFromStatement(StartPos: integer;
@ -4760,19 +4769,19 @@ begin
Result:=RightOperand;
end;
function TFindDeclarationTool.IsParamListCompatible(
FirstParameterNode: TCodeTreeNode;
ExprParamList: TExprTypeList; IgnoreMissingParameters: boolean;
function TFindDeclarationTool.IsParamExprListCompatibleToNodeList(
FirstTargetParameterNode: TCodeTreeNode;
SourceExprParamList: TExprTypeList; IgnoreMissingParameters: boolean;
Params: TFindDeclarationParams;
CompatibilityList: TTypeCompatibilityList): TTypeCompatibility;
// tests if ExprParamList fits into the FirstParameterNode
// tests if SourceExprParamList fits into the TargetFirstParameterNode
var
ParamNode: TCodeTreeNode;
i, MinParamCnt, MaxParamCnt: integer;
ParamCompatibility: TTypeCompatibility;
begin
// quick check: parameter count
ParamNode:=FirstParameterNode;
ParamNode:=FirstTargetParameterNode;
MinParamCnt:=0;
while (ParamNode<>nil)
and ((ParamNode.SubDesc and ctnsHasDefaultValue)=0) do begin
@ -4786,28 +4795,29 @@ begin
end;
{$IFDEF ShowExprEval}
writeln('[TFindDeclarationTool.IsParamListCompatible] ',
' ExprParamList.Count=',ExprParamList.Count,
writeln('[TFindDeclarationTool.IsParamExprListCompatibleToNodeList] ',
' ExprParamList.Count=',SourceExprParamList.Count,
' MinParamCnt=',MinParamCnt,' MaxParamCnt=',MaxParamCnt
);
try
{$ENDIF}
Result:=tcExact;
if (ExprParamlist.Count>MaxParamCnt)
or ((not IgnoreMissingParameters) and (ExprParamList.Count<MinParamCnt)) then
begin
if (SourceExprParamlist.Count>MaxParamCnt)
or ((not IgnoreMissingParameters) and (SourceExprParamList.Count<MinParamCnt))
then begin
Result:=tcIncompatible;
exit;
end;
// check each parameter for compatibility
ParamNode:=FirstParameterNode;
ParamNode:=FirstTargetParameterNode;
i:=0;
while (ParamNode<>nil) and (i<ExprParamList.Count) do begin
ParamCompatibility:=IsCompatible(ParamNode,ExprParamList.Items[i],Params);
while (ParamNode<>nil) and (i<SourceExprParamList.Count) do begin
ParamCompatibility:=IsCompatible(ParamNode,SourceExprParamList.Items[i],
Params);
{$IFDEF ShowExprEval}
writeln('[TFindDeclarationTool.IsParamListCompatible] B ',ExprTypeToString(ExprParamList.Items[i]));
writeln('[TFindDeclarationTool.IsParamExprListCompatibleToNodeList] B ',ExprTypeToString(SourceExprParamList.Items[i]));
{$ENDIF}
if CompatibilityList<>nil then
CompatibilityList[i]:=ParamCompatibility;
@ -4820,7 +4830,7 @@ begin
ParamNode:=ParamNode.NextBrother;
inc(i);
end;
if (i<ExprParamList.Count) then begin
if (i<SourceExprParamList.Count) then begin
// there are more expressions, then the param list has variables
Result:=tcIncompatible;
end else if (ParamNode<>nil) then begin
@ -4842,26 +4852,95 @@ begin
end;
{$IFDEF ShowExprEval}
finally
writeln('[TFindDeclarationTool.IsParamListCompatible] END ',
writeln('[TFindDeclarationTool.IsParamExprListCompatibleToNodeList] END ',
' Result=',TypeCompatibilityNames[Result],' ! ONLY VALID if no error !'
);
end;
{$ENDIF}
end;
function TFindDeclarationTool.IsParamListCompatible(FirstParameterNode1,
FirstParameterNode2: TCodeTreeNode; Params: TFindDeclarationParams;
function TFindDeclarationTool.IsParamNodeListCompatibleToExprList(
TargetExprParamList: TExprTypeList; FirstSourceParameterNode: TCodeTreeNode;
Params: TFindDeclarationParams;
CompatibilityList: TTypeCompatibilityList): TTypeCompatibility;
// tests if FirstSourceParameterNode fits into the TargetExprParamList
var
ParamNode: TCodeTreeNode;
i, MinParamCnt, MaxParamCnt: integer;
ParamCompatibility: TTypeCompatibility;
SourceExprType: TExpressionType;
begin
// quick check: parameter count
MinParamCnt:=0;
ParamNode:=FirstSourceParameterNode;
while (ParamNode<>nil) do begin
ParamNode:=ParamNode.NextBrother;
inc(MinParamCnt);
end;
MaxParamCnt:=MinParamCnt;
{$IFDEF ShowExprEval}
writeln('[TFindDeclarationTool.IsParamNodeListCompatibleToExprList] ',
' ExprParamList.Count=',TargetExprParamList.Count,
' MinParamCnt=',MinParamCnt,' MaxParamCnt=',MaxParamCnt
);
try
{$ENDIF}
Result:=tcExact;
if (TargetExprParamList.Count<>MaxParamCnt) then begin
Result:=tcIncompatible;
exit;
end;
// check each parameter for compatibility
ParamNode:=FirstSourceParameterNode;
i:=0;
while (ParamNode<>nil) and (i<TargetExprParamList.Count) do begin
SourceExprType:=ConvertNodeToExpressionType(ParamNode,Params);
ParamCompatibility:=IsCompatible(TargetExprParamList.Items[i],
SourceExprType,Params);
{$IFDEF ShowExprEval}
writeln('[TFindDeclarationTool.IsParamNodeListCompatibleToExprList] B ',ExprTypeToString(TargetExprParamList.Items[i]));
{$ENDIF}
if CompatibilityList<>nil then
CompatibilityList[i]:=ParamCompatibility;
if ParamCompatibility=tcIncompatible then begin
Result:=tcIncompatible;
exit;
end else if ParamCompatibility=tcCompatible then begin
Result:=tcCompatible;
end;
ParamNode:=ParamNode.NextBrother;
inc(i);
end;
if (ParamNode<>nil) or (i<TargetExprParamList.Count) then
RaiseException('Internal Error: one param list has changed');
{$IFDEF ShowExprEval}
finally
writeln('[TFindDeclarationTool.IsParamNodeListCompatibleToExprList] END ',
' Result=',TypeCompatibilityNames[Result],' ! ONLY VALID if no error !'
);
end;
{$ENDIF}
end;
function TFindDeclarationTool.IsParamNodeListCompatibleToParamNodeList(
FirstTargetParameterNode, FirstSourceParameterNode: TCodeTreeNode;
Params: TFindDeclarationParams;
CompatibilityList: TTypeCompatibilityList): TTypeCompatibility;
var
CurParamNode1, CurParamNode2: TCodeTreeNode;
ParamCompatibility: TTypeCompatibility;
ExprType1, ExprType2: TExpressionType;
SourceExprType, TargetExprType: TExpressionType;
OldFlags: TFindDeclarationFlags;
i: integer;
begin
// quick check: parameter count
CurParamNode1:=FirstParameterNode1;
CurParamNode2:=FirstParameterNode2;
CurParamNode1:=FirstTargetParameterNode;
CurParamNode2:=FirstSourceParameterNode;
while (CurParamNode1<>nil) and (CurParamNode2<>nil) do begin
CurParamNode1:=CurParamNode1.NextBrother;
CurParamNode2:=CurParamNode2.NextBrother;
@ -4874,14 +4953,14 @@ begin
// check each parameter
OldFlags:=Params.Flags;
Params.Flags:=Params.Flags-[fdfFindVariable]+[fdfIgnoreOverloadedProcs];
CurParamNode1:=FirstParameterNode1;
CurParamNode2:=FirstParameterNode2;
CurParamNode1:=FirstTargetParameterNode;
CurParamNode2:=FirstSourceParameterNode;
Result:=tcExact;
i:=0;
while (CurParamNode1<>nil) and (CurParamNode2<>nil) do begin
ExprType1:=ConvertNodeToExpressionType(CurParamNode1,Params);
ExprType2:=ConvertNodeToExpressionType(CurParamNode2,Params);
ParamCompatibility:=IsBaseCompatible(ExprType1,ExprType2,Params);
TargetExprType:=ConvertNodeToExpressionType(CurParamNode1,Params);
SourceExprType:=ConvertNodeToExpressionType(CurParamNode2,Params);
ParamCompatibility:=IsBaseCompatible(TargetExprType,SourceExprType,Params);
if CompatibilityList<>nil then
CompatibilityList[i]:=ParamCompatibility;
if ParamCompatibility=tcIncompatible then begin
@ -5067,7 +5146,7 @@ begin
Params.FoundProc^.Context.Node);
Params.Save(OldInput);
ParamCompatibility:=
Params.FoundProc^.Context.Tool.IsParamListCompatible(
Params.FoundProc^.Context.Tool.IsParamExprListCompatibleToNodeList(
FirstParameterNode,
Params.FoundProc^.ExprInputList,
fdfIgnoreMissingParams in Params.Flags,
@ -5108,7 +5187,7 @@ begin
FoundContext.Tool.GetFirstParameterNode(FoundContext.Node);
Params.Save(OldInput);
ParamCompatibility:=
FoundContext.Tool.IsParamListCompatible(
FoundContext.Tool.IsParamExprListCompatibleToNodeList(
FirstParameterNode,
Params.FoundProc^.ExprInputList,
fdfIgnoreMissingParams in Params.Flags,
@ -5423,8 +5502,8 @@ var TargetNode, ExprNode: TCodeTreeNode;
begin
{$IFDEF ShowExprEval}
writeln('[TFindDeclarationTool.IsBaseCompatible] B ',
' TargetType=',ExpressionTypeDescNames[TargetType.Desc],
' ExpressionType=',ExpressionTypeDescNames[ExpressionType.Desc]);
' TargetType=',ExprTypeToString(TargetType),
' ExpressionType=',ExprTypeToString(ExpressionType));
{$ENDIF}
Result:=tcIncompatible;
if (TargetType.Desc=ExpressionType.Desc) then begin
@ -5472,12 +5551,21 @@ begin
Result:=tcExact;
end;
end else if ((TargetType.Desc=xtPointer)
and (ExpressionType.Desc=xtContext)
and (ExpressionType.Context.Node.Desc in [ctnClass,ctnClassInterface]))
then begin
// assigning a class to a pointer
Result:=tcExact;
end else begin
// check, if ExpressionType can be auto converted into TargetType
if ((TargetType.Desc in xtAllRealTypes)
and (ExpressionType.Desc in xtAllRealConvertibles))
or ((TargetType.Desc in xtAllStringTypes)
and (ExpressionType.Desc in xtAllStringConvertibles))
or ((TargetType.Desc in xtAllWideStringTypes)
and (ExpressionType.Desc in xtAllWideStringCompatibleTypes))
or ((TargetType.Desc in xtAllIntegerTypes)
and (ExpressionType.Desc in xtAllIntegerConvertibles))
or ((TargetType.Desc in xtAllBooleanTypes)

7
ide/main.pp
View File

@ -2359,7 +2359,6 @@ Begin
then
exit;
if DoCreateProjectForProgram(PreReadBuf)=mrOk then begin
exit;
end;
end;
@ -4596,7 +4595,7 @@ begin
// check for special files
if ([ofRegularFile,ofRevert,ofProjectLoading]*Flags=[])
and FilenameIsAbsolute(AFilename) and FileExists(AFilename) then begin
// check for project information files (.lpi)
// check if file is a lazarus project (.lpi)
if (CompareFileExt(AFilename,'.lpi',false)=0) then begin
if MessageDlg(lisOpenProject,
Format(lisOpenTheProjectAnswerNoToLoadItAsXmlFile, [AFilename, #13]),
@ -4606,6 +4605,7 @@ begin
exit;
end;
end;
// check if file is a lazarus package (.lpi)
if (CompareFileExt(AFilename,'.lpk',false)=0) then begin
if MessageDlg(lisOpenPackage,
Format(lisOpenThePackageAnswerNoToLoadItAsXmlFile, [AFilename, #13]),
@ -10267,6 +10267,9 @@ end.
{ =============================================================================
$Log$
Revision 1.696 2004/01/08 16:13:47 mattias
implemented class to Pointer assignment compatibility check
Revision 1.695 2004/01/05 15:22:41 mattias
improved debugger: saved log, error handling in initialization, better reinitialize

156
ideintf/propedits.pp
View File

@ -5069,6 +5069,84 @@ begin
inherited Destroy;
end;
{ TBackupComponentList }
function TBackupComponentList.GetComponents(Index: integer): TComponent;
begin
Result:=TComponent(FComponentList[Index]);
end;
procedure TBackupComponentList.SetComponents(Index: integer;
const AValue: TComponent);
begin
FComponentList[Index]:=AValue;
end;
procedure TBackupComponentList.SetLookupRoot(const AValue: TPersistent);
var
i: Integer;
begin
FLookupRoot:=AValue;
FComponentList.Clear;
if (FLookupRoot<>nil) and (FLookupRoot is TComponent) then
for i:=0 to TComponent(FLookupRoot).ComponentCount-1 do
FComponentList.Add(TComponent(FLookupRoot).Components[i]);
FSelection.Clear;
end;
procedure TBackupComponentList.SetSelection(
const AValue: TPersistentSelectionList);
begin
if FSelection=AValue then exit;
FSelection.Assign(AValue);
end;
constructor TBackupComponentList.Create;
begin
FSelection:=TPersistentSelectionList.Create;
FComponentList:=TList.Create;
end;
destructor TBackupComponentList.Destroy;
begin
FreeAndNil(FSelection);
FreeAndNil(FComponentList);
inherited Destroy;
end;
function TBackupComponentList.IndexOf(AComponent: TComponent): integer;
begin
Result:=FComponentList.IndexOf(AComponent);
end;
procedure TBackupComponentList.Clear;
begin
LookupRoot:=nil;
end;
function TBackupComponentList.ComponentCount: integer;
begin
Result:=FComponentList.Count;
end;
function TBackupComponentList.IsEqual(ALookupRoot: TPersistent;
ASelection: TPersistentSelectionList): boolean;
var
i: Integer;
begin
Result:=false;
if ALookupRoot<>LookupRoot then exit;
if not FSelection.IsEqual(ASelection) then exit;
if (ALookupRoot<>nil) and (FLookupRoot is TComponent) then begin
if ComponentCount<>TComponent(ALookupRoot).ComponentCount then exit;
for i:=0 to FComponentList.Count-1 do
if TComponent(FComponentList[i])<>TComponent(ALookupRoot).Components[i]
then exit;
end;
Result:=true;
end;
//******************************************************************************
// XXX
// workaround for missing typeinfo function
@ -5185,84 +5263,6 @@ begin
DummyClassForPropTypes.Free;
end;
{ TBackupComponentList }
function TBackupComponentList.GetComponents(Index: integer): TComponent;
begin
Result:=TComponent(FComponentList[Index]);
end;
procedure TBackupComponentList.SetComponents(Index: integer;
const AValue: TComponent);
begin
FComponentList[Index]:=AValue;
end;
procedure TBackupComponentList.SetLookupRoot(const AValue: TPersistent);
var
i: Integer;
begin
FLookupRoot:=AValue;
FComponentList.Clear;
if (FLookupRoot<>nil) and (FLookupRoot is TComponent) then
for i:=0 to TComponent(FLookupRoot).ComponentCount-1 do
FComponentList.Add(TComponent(FLookupRoot).Components[i]);
FSelection.Clear;
end;
procedure TBackupComponentList.SetSelection(
const AValue: TPersistentSelectionList);
begin
if FSelection=AValue then exit;
FSelection.Assign(AValue);
end;
constructor TBackupComponentList.Create;
begin
FSelection:=TPersistentSelectionList.Create;
FComponentList:=TList.Create;
end;
destructor TBackupComponentList.Destroy;
begin
FreeAndNil(FSelection);
FreeAndNil(FComponentList);
inherited Destroy;
end;
function TBackupComponentList.IndexOf(AComponent: TComponent): integer;
begin
Result:=FComponentList.IndexOf(AComponent);
end;
procedure TBackupComponentList.Clear;
begin
LookupRoot:=nil;
end;
function TBackupComponentList.ComponentCount: integer;
begin
Result:=FComponentList.Count;
end;
function TBackupComponentList.IsEqual(ALookupRoot: TPersistent;
ASelection: TPersistentSelectionList): boolean;
var
i: Integer;
begin
Result:=false;
if ALookupRoot<>LookupRoot then exit;
if not FSelection.IsEqual(ASelection) then exit;
if (ALookupRoot<>nil) and (FLookupRoot is TComponent) then begin
if ComponentCount<>TComponent(ALookupRoot).ComponentCount then exit;
for i:=0 to FComponentList.Count-1 do
if TComponent(FComponentList[i])<>TComponent(ALookupRoot).Components[i]
then exit;
end;
Result:=true;
end;
initialization
InitPropEdits;