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

fcl-passrc: resolver: generic class is specialized class

Browse Source 
git-svn-id: trunk@42824 -
This commit is contained in:
Mattias Gaertner 2019-08-26 08:23:52 +00:00
parent 30fa7de7c7
commit f9e66e49be
2 changed files with 98 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -684,6 +684,7 @@ type
FSpecializedType: TPasGenericType;
procedure SetSpecializedType(AValue: TPasGenericType);
public
GenericType: TPasGenericType;
Step: TPSSpecializeStep;
FirstSpecialize: TPasElement;
Params: TPasTypeArray;
@ -7017,7 +7018,7 @@ begin
end;
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.FinishMethodBodyHeader END "',ImplProc.Name,'" ...');
writeln('TPasResolver.FinishMethodImplHeader END "',ImplProc.Name,'" ...');
{$ENDIF}
end;
@ -11605,6 +11606,8 @@ begin
if (TypeParams<>nil) then
if HasDot<>(TypeParams.Count>1) then
RaiseNotYetImplemented(20190818093923,El);
IsClassConDestructor:=(El.ClassType=TPasClassConstructor)
or (El.ClassType=TPasClassDestructor);
if El.CustomData is TPasProcedureScope then
begin
@ -11618,14 +11621,19 @@ begin
RaiseNotYetImplemented(20190804175518,El);
if ProcScope.GroupScope<>nil then
RaiseNotYetImplemented(20190804175451,El);
if (not HasDot) and IsClassConDestructor then
begin
if El.ClassType=TPasClassConstructor then
AddClassConDestructor(ClassOrRecScope,TPasProcedure(ClassOrRecScope.ClassConstructor))
else
AddClassConDestructor(ClassOrRecScope,TPasProcedure(ClassOrRecScope.ClassDestructor));
end;
PushScope(ProcScope);
end
else
begin
IsDelphi:=msDelphi in CurrentParser.CurrentModeswitches;
IsClassConDestructor:=(El.ClassType=TPasClassConstructor)
or (El.ClassType=TPasClassDestructor);
if (not HasDot) and IsClassConDestructor then
begin
if ProcName='' then
@ -15014,6 +15022,7 @@ begin
{$ENDIF}
Result:=TPSSpecializedItem.Create;
Result.GenericType:=GenericType;
Result.FirstSpecialize:=El;
Result.Params:=ParamsResolved;
SpecializedTypes.Add(Result);
@ -21686,7 +21695,14 @@ begin
begin
LBT:=GetActualBaseType(LHS.BaseType);
RBT:=GetActualBaseType(RHS.BaseType);
if IsGenericTemplType(LHS) or IsGenericTemplType(RHS) then
if IsGenericTemplType(LHS) then
begin
// not fully specified -> maybe
if IsGenericTemplType(RHS) and (LHS.LoTypeEl=RHS.LoTypeEl) then
exit(cExact);
exit(cCompatible);
end
else if IsGenericTemplType(RHS) then
begin
// not fully specified -> maybe
exit(cCompatible);
@ -26520,12 +26536,15 @@ function TPasResolver.CheckClassIsClass(SrcType, DestType: TPasType): integer;
// check if Src is equal or descends from Dest
var
ClassEl: TPasClassType;
DestScope: TPasClassScope;
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.CheckClassIsClass SrcType=',GetObjName(SrcType),' DestType=',GetObjName(DestType));
{$ENDIF}
if DestType=nil then exit(cIncompatible);
DestType:=ResolveAliasType(DestType);
if DestType.ClassType<>TPasClassType then
exit(cIncompatible);
Result:=cExact;
while SrcType<>nil do
@ -26544,6 +26563,9 @@ begin
SrcType:=TPasAliasType(SrcType).DestType;
inc(Result);
end
else if SrcType.ClassType=TPasSpecializeType then
// specialize -> skip
SrcType:=TPasSpecializeType(SrcType).DestType
else if SrcType.ClassType=TPasClassType then
begin
ClassEl:=TPasClassType(SrcType);
@ -26552,6 +26574,20 @@ begin
SrcType:=(ClassEl.CustomData as TResolvedReference).Declaration as TPasType
else
begin
if (ClassEl.GenericTemplateTypes<>nil) and (ClassEl.GenericTemplateTypes.Count>0) then
begin
// SrcType is a generic
DestScope:=DestType.CustomData as TPasClassScope;
if DestScope.SpecializedItem<>nil then
begin
// DestType is specialized
{$IFDEF VerbosePasResolver}
writeln(' DestType is specialized from ',GetObjName(DestScope.SpecializedItem.GenericType));
{$ENDIF}
if SrcType=DestScope.SpecializedItem.GenericType then
exit; // DestType is a specialized SrcType
end;
end;
// class ancestor -> increase distance
SrcType:=(ClassEl.CustomData as TPasClassScope).DirectAncestor;
inc(Result);

58
packages/fcl-passrc/tests/tcresolvegenerics.pas
View File

@ -71,6 +71,8 @@ type
procedure TestGen_Class_NestedRecord;
procedure TestGen_Class_NestedClass;
procedure TestGen_Class_Enums_NotPropagating;
procedure TestGen_Class_Self;
procedure TestGen_Class_MemberTypeConstructor;
procedure TestGen_Class_List;
// generic external class
@ -950,6 +952,62 @@ begin
CheckResolverException('identifier not found "red"',nIdentifierNotFound);
end;
procedure TTestResolveGenerics.TestGen_Class_Self;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class',
' end;',
' generic TAnimal<T> = class end;',
' generic TBird<T> = class(TAnimal<T>)',
' function GetObj: TObject;',
' procedure Fly(Obj: TObject); virtual; abstract;',
' end;',
' TProc = procedure(Obj: TObject) of object;',
' TWordBird = specialize TBird<word>;',
'function TBird.GetObj: TObject;',
'var p: TProc;',
'begin',
' Result:=Self;',
' if Self.GetObj=Result then ;',
' Fly(Self);',
' p:=@Fly;',
' p(Self);',
'end;',
'begin']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_Class_MemberTypeConstructor;
begin
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TObject = class end;',
' TAnimal<A> = class',
' end;',
' TAnt<L> = class',
' constructor Create(A: TAnimal<L>);',
' end;',
' TBird<T> = class(TAnimal<T>)',
' type TMyAnt = TAnt<T>;',
' function Fly: TMyAnt;',
' end;',
' TWordBird = TBird<word>;',
'constructor TAnt<L>.Create(A: TAnimal<L>);',
'begin',
'end;',
'function TBird<T>.Fly: TMyAnt;',
'begin',
' Result:=TMyAnt.Create(Self);',
'end;',
'begin']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_Class_List;
begin
StartProgram(false);