paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-06 16:50:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: fixed inherited create on abstract class

Browse Source 
git-svn-id: trunk@41456 -
This commit is contained in:
Mattias Gaertner 2019-02-25 11:16:49 +00:00
parent 57ee0dd00a
commit c987aa77f9
2 changed files with 77 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
packages/fcl-passrc/src/pasresolver.pp
View File

@ -16283,23 +16283,25 @@ begin
if (TypeEl.ClassType=TPasClassType)
and (TPasClassType(TypeEl).HelperForType<>nil) then
TypeEl:=ResolveAliasType(TPasClassType(TypeEl).HelperForType) as TPasType;
if (TypeEl.ClassType=TPasClassType) and
TPasClassType(TypeEl).IsAbstract then
LogMsg(20190224153450,mtWarning,nCreatingAnInstanceOfAbstractClassY,
sCreatingAnInstanceOfAbstractClassY,[TypeEl.Name],FindData.ErrorPosEl);
TResolvedRefCtxConstructor(Ref.Context).Typ:=TypeEl;
if OnlyTypeMembers and (ClassRecScope is TPasClassScope) then
begin
AbstractProcs:=TPasClassScope(ClassRecScope).AbstractProcs;
if (length(AbstractProcs)>0) then
if TPasClassType(TypeEl).IsAbstract then
LogMsg(20190224153450,mtWarning,nCreatingAnInstanceOfAbstractClassY,
sCreatingAnInstanceOfAbstractClassY,[TypeEl.Name],FindData.ErrorPosEl)
else
begin
if IsClassOf then
// aClass.Create: do not warn
else
for i:=0 to length(AbstractProcs)-1 do
LogMsg(20171227110746,mtWarning,nConstructingClassXWithAbstractMethodY,
sConstructingClassXWithAbstractMethodY,
[TypeEl.Name,AbstractProcs[i].Name],FindData.ErrorPosEl);
AbstractProcs:=TPasClassScope(ClassRecScope).AbstractProcs;
if (length(AbstractProcs)>0) then
begin
if IsClassOf then
// aClass.Create: do not warn
else
for i:=0 to length(AbstractProcs)-1 do
LogMsg(20171227110746,mtWarning,nConstructingClassXWithAbstractMethodY,
sConstructingClassXWithAbstractMethodY,
[TypeEl.Name,AbstractProcs[i].Name],FindData.ErrorPosEl);
end;
end;
end;
end;

95
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -609,6 +609,7 @@ type
Procedure TestClass_UntypedParam_TypeCast;
Procedure TestClass_Sealed;
Procedure TestClass_SealedDescendFail;
Procedure TestClass_Abstract;
Procedure TestClass_AbstractCreateFail;
Procedure TestClass_VarExternal;
Procedure TestClass_WarnOverrideLowerVisibility;
@ -9703,40 +9704,42 @@ end;
procedure TTestResolver.TestClassCallInherited;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' procedure {#TOBJ_ProcA}ProcA(vI: longint); virtual;');
Add(' procedure {#TOBJ_ProcB}ProcB(vJ: longint); virtual;');
Add(' end;');
Add(' {#A}TClassA = class');
Add(' procedure {#A_ProcA}ProcA({#i1}vI: longint); override;');
Add(' procedure {#A_ProcB}ProcB(vJ: longint); override;');
Add(' procedure {#A_ProcC}ProcC; virtual;');
Add(' end;');
Add('procedure TObject.ProcA(vi: longint);');
Add('begin');
Add(' inherited; // ignore, do not raise error');
Add('end;');
Add('procedure TObject.ProcB(vj: longint);');
Add('begin');
Add('end;');
Add('procedure TClassA.ProcA(vi: longint);');
Add('begin');
Add(' {@A_ProcA}ProcA({@i1}vI);');
Add(' {@TOBJ_ProcA}inherited;');
Add(' inherited {@TOBJ_ProcA}ProcA({@i1}vI);');
Add(' {@A_ProcB}ProcB({@i1}vI);');
Add(' inherited {@TOBJ_ProcB}ProcB({@i1}vI);');
Add('end;');
Add('procedure TClassA.ProcB(vJ: longint);');
Add('begin');
Add('end;');
Add('procedure TClassA.ProcC;');
Add('begin');
Add(' inherited; // ignore, do not raise error');
Add('end;');
Add('begin');
Add([
'type',
' TObject = class',
' procedure {#TOBJ_ProcA}ProcA(vI: longint); virtual;',
' procedure {#TOBJ_ProcB}ProcB(vJ: longint); virtual;',
' end;',
' {#A}TClassA = class',
' procedure {#A_ProcA}ProcA({#i1}vI: longint); override;',
' procedure {#A_ProcB}ProcB(vJ: longint); override;',
' procedure {#A_ProcC}ProcC; virtual;',
' end;',
'procedure TObject.ProcA(vi: longint);',
'begin',
' inherited; // ignore, do not raise error',
'end;',
'procedure TObject.ProcB(vj: longint);',
'begin',
'end;',
'procedure TClassA.ProcA(vi: longint);',
'begin',
' {@A_ProcA}ProcA({@i1}vI);',
' {@TOBJ_ProcA}inherited;',
' inherited {@TOBJ_ProcA}ProcA({@i1}vI);',
' {@A_ProcB}ProcB({@i1}vI);',
' inherited {@TOBJ_ProcB}ProcB({@i1}vI);',
'end;',
'procedure TClassA.ProcB(vJ: longint);',
'begin',
'end;',
'procedure TClassA.ProcC;',
'begin',
' inherited; // ignore, do not raise error',
'end;',
'begin']);
ParseProgram;
CheckResolverUnexpectedHints;
end;
procedure TTestResolver.TestClassCallInheritedNoParamsAbstractFail;
@ -10836,6 +10839,32 @@ begin
nCannotCreateADescendantOfTheSealedXY);
end;
procedure TTestResolver.TestClass_Abstract;
begin
StartProgram(false);
Add([
'type',
' TObject = class',
' constructor Create;',
' end;',
' TNop = class abstract(TObject)',
' end;',
' TBird = class(TNop)',
' constructor Create(w: word);',
' end;',
'constructor TObject.Create;',
'begin',
'end;',
'constructor TBird.Create(w: word);',
'begin',
' inherited Create;',
'end;',
'begin',
' TBird.Create;']);
ParseProgram;
CheckResolverUnexpectedHints;
end;
procedure TTestResolver.TestClass_AbstractCreateFail;
begin
StartProgram(false);