paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-18 12:39:36 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: type helper for class/interface

Browse Source 
git-svn-id: trunk@41557 -
This commit is contained in:
Mattias Gaertner 2019-03-02 15:08:57 +00:00
parent eb5aa0f8cf
commit 624549ae34
2 changed files with 74 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5846,6 +5846,7 @@ var
ptm: TProcTypeModifier;
ObjKind: TPasObjKind;
ParentBody: TProcedureBody;
HelperForType: TPasType;
begin
if El.Parent is TPasProcedure then
Proc:=TPasProcedure(El.Parent)
@ -5940,19 +5941,28 @@ begin
{if msDelphi in CurrentParser.CurrentModeswitches then
begin
// Delphi allows virtual/override in class helpers
// But this works differently to normal virtual/override and
// requires helpers to be TInterfacedObject
// But using them crashes in Delphi 10.3
// -> do not support them
end
}
if Proc.IsVirtual then
RaiseMsg(20190116215823,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'virtual'],Proc);
if Proc.IsOverride then
RaiseMsg(20190116215825,nInvalidXModifierY,sInvalidXModifierY,[ObjKindNames[ObjKind]+' '+GetElementTypeName(Proc),'override'],Proc);
if (ObjKind<>okClassHelper) and IsClassMethod(Proc) and not IsClassConDestructor then
HelperForType:=ResolveAliasType(TPasClassType(Proc.Parent).HelperForType);
if (not Proc.IsStatic) and IsClassMethod(Proc) and not IsClassConDestructor then
begin
if not Proc.IsStatic then
// non static class methods require a class
if (not (HelperForType.ClassType=TPasClassType))
or (TPasClassType(HelperForType).ObjKind<>okClass) then
RaiseMsg(20190201153831,nClassMethodsMustBeStaticInX,sClassMethodsMustBeStaticInX,[ObjKindNames[ObjKind]],Proc);
end;
if Proc.ClassType=TPasDestructor then
RaiseMsg(20190302151019,nXIsNotSupported,sXIsNotSupported,['destructor'],Proc);
if (Proc.ClassType=TPasConstructor)
and (HelperForType.ClassType=TPasClassType)
and (TPasClassType(HelperForType).ObjKind<>okClass) then
RaiseMsg(20190302151514,nXIsNotSupported,sXIsNotSupported,['constructor'],Proc);
end;
end;
if Proc.IsAbstract then
@ -6345,7 +6355,8 @@ begin
SelfType:=TPasClassType(SelfType).HelperForType;
end;
LoSelfType:=ResolveAliasType(SelfType);
if LoSelfType is TPasClassType then
if (LoSelfType is TPasClassType)
and (TPasClassType(LoSelfType).ObjKind=okClass) then
SelfArg.Access:=argConst
else
SelfArg.Access:=argVar;
@ -7234,7 +7245,7 @@ begin
else if ((HelperForType.ClassType=TPasUnresolvedSymbolRef)
and (HelperForType.CustomData is TResElDataBaseType)) then
else if (HelperForType.ClassType=TPasClassType)
and (TPasClassType(HelperForType).ObjKind=okClass) then
and (TPasClassType(HelperForType).ObjKind in [okClass,okInterface]) then
begin
if TPasClassType(HelperForType).IsForward then
RaiseMsg(20190116200940,nTypeXIsNotYetCompletelyDefined,

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

@ -932,7 +932,8 @@ type
Procedure TestTypeHelper_Boolean;
Procedure TestTypeHelper_Double;
Procedure TestTypeHelper_Constructor_NewInstance;
Procedure TestTypeHelper_InterfaceFail;
Procedure TestTypeHelper_Interface;
Procedure TestTypeHelper_Interface_ConstructorFail;
// attributes
Procedure TestAttributes_Globals;
@ -17593,18 +17594,69 @@ begin
end;
end;
procedure TTestResolver.TestTypeHelper_InterfaceFail;
procedure TTestResolver.TestTypeHelper_Interface;
begin
StartProgram(false);
Add([
'{$modeswitch typehelpers}',
'type',
' IUnknown = interface end;',
' THelper = type helper for IUnknown',
' IUnknown = interface',
' function GetSizes(Index: word): word;',
' procedure SetSizes(Index: word; value: word);',
' end;',
' TObject = class(IUnknown)',
' function GetSizes(Index: word): word; virtual; abstract;',
' procedure SetSizes(Index: word; value: word); virtual; abstract;',
' end;',
' THelper = type helper for IUnknown',
' procedure Fly;',
' class procedure Run; static;',
' property Sizes[Index: word]: word read GetSizes write SetSizes; default;',
' end;',
'var',
' i: IUnknown;',
' o: TObject;',
'procedure THelper.Fly;',
'begin',
' i:=Self;',
' o:=Self as TObject;',
' Self:=nil;',
' Self:=i;',
' Self:=o;',
'end;',
'class procedure THelper.Run;',
'begin',
'end;',
'begin',
' i.Fly;',
' i.Fly();',
' i.Run;',
' i.Run();',
' i.Sizes[3]:=i.Sizes[4];',
' i[5]:=i[6];',
' IUnknown.Run;',
' IUnknown.Run();',
'']);
ParseProgram;
end;
procedure TTestResolver.TestTypeHelper_Interface_ConstructorFail;
begin
StartProgram(false);
Add([
'{$modeswitch typehelpers}',
'type',
' IUnknown = interface',
' end;',
' THelper = type helper for IUnknown',
' constructor Fly;',
' end;',
'constructor THelper.Fly;',
'begin',
'end;',
'begin',
'']);
CheckResolverException('Type "IUnknown" cannot be extended by a type helper',nTypeXCannotBeExtendedByATypeHelper);
CheckResolverException('constructor is not supported',nXIsNotSupported);
end;
procedure TTestResolver.TestAttributes_Globals;