paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-09 07:28:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: check forward generic class constraints match

Browse Source 
git-svn-id: trunk@42688 -
This commit is contained in:
Mattias Gaertner 2019-08-14 10:42:16 +00:00
parent 71df2911da
commit b4b6efc5a0
4 changed files with 333 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
packages/fcl-passrc/src/pasresolveeval.pas
View File

@ -195,6 +195,7 @@ const
nXIsNotAValidConstraint = 3129;
nWrongNumberOfParametersForGenericType = 3130;
nGenericsWithoutSpecializationAsType = 3131;
nDeclOfXDiffersFromPrevAtY = 3132;
// using same IDs as FPC
nVirtualMethodXHasLowerVisibility = 3250; // was 3050
@ -337,6 +338,7 @@ resourcestring
sXIsNotAValidConstraint = '"%s" is not a valid constraint';
sWrongNumberOfParametersForGenericType = 'wrong number of parameters for generic type %s';
sGenericsWithoutSpecializationAsType = 'Generics without specialization cannot be used as a type for a %s';
sDeclOfXDiffersFromPrevAtY = 'Declaration of "%s" differs from previous declaration at %s';
type
{ TResolveData - base class for data stored in TPasElement.CustomData }

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

@ -2205,6 +2205,7 @@ type
function IsArrayOperatorAdd(Expr: TPasExpr): boolean;
function IsTypeCast(Params: TParamsExpr): boolean;
function GetTypeParameterCount(aType: TPasGenericType): integer;
function GetGenericConstraintKeyword(El: TPasExpr): TToken;
function IsGenericTemplType(const ResolvedEl: TPasResolverResult): boolean;
function IsInterfaceType(const ResolvedEl: TPasResolverResult;
IntfType: TPasClassInterfaceType): boolean; overload;
@ -6189,12 +6190,12 @@ procedure TPasResolver.FinishGenericTemplateType(El: TPasGenericTemplateType);
var
i: Integer;
Expr: TPasExpr;
Value: String;
IsClass, IsRecord, IsConstructor: Boolean;
LastType: TPasType;
ResolvedEl: TPasResolverResult;
MemberType: TPasMembersType;
aClass: TPasClassType;
ExprToken: TToken;
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.FinishGenericTemplateType ',GetObjName(El),' El.Parent=',GetObjName(El.Parent),' Constraints=',length(El.Constraints));
@ -6206,106 +6207,103 @@ begin
for i:=0 to length(El.Constraints)-1 do
begin
Expr:=El.Constraints[i];
if (Expr.ClassType=TPrimitiveExpr) and (TPrimitiveExpr(Expr).Kind=pekIdent) then
ExprToken:=GetGenericConstraintKeyword(Expr);
case ExprToken of
tkclass:
begin
Value:=TPrimitiveExpr(Expr).Value;
if SameText(Value,'class') then
if IsClass then
RaiseMsg(20190720202412,nConstraintXSpecifiedMoreThanOnce,
sConstraintXSpecifiedMoreThanOnce,['class'],Expr);
if IsRecord then
RaiseMsg(20190720202516,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,['record','class'],Expr);
if LastType<>nil then
RaiseMsg(20190720205708,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,[LastType.Name,'class'],Expr);
IsClass:=true;
end;
tkrecord:
begin
if IsRecord then
RaiseMsg(20190720203028,nConstraintXSpecifiedMoreThanOnce,
sConstraintXSpecifiedMoreThanOnce,['record'],Expr);
if IsClass then
RaiseMsg(20190720203039,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,['class','record'],Expr);
if IsConstructor then
RaiseMsg(20190720203056,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,['constructor','record'],Expr);
if LastType<>nil then
RaiseMsg(20190720205938,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,[LastType.Name,'record'],Expr);
IsRecord:=true;
end;
tkconstructor:
begin
if IsConstructor then
RaiseMsg(20190720203123,nConstraintXSpecifiedMoreThanOnce,
sConstraintXSpecifiedMoreThanOnce,['constructor'],Expr);
if IsRecord then
RaiseMsg(20190720203148,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,['record','constructor'],Expr);
if LastType<>nil then
RaiseMsg(20190720210005,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,[LastType.Name,'constructor'],Expr);
IsConstructor:=true;
end;
else
begin
// type identifier: class, record or interface
ResolveExpr(Expr,rraNone);
ComputeElement(Expr,ResolvedEl,[rcType]);
if (ResolvedEl.BaseType<>btContext)
or not (ResolvedEl.IdentEl is TPasMembersType) then
begin
if IsClass then
RaiseMsg(20190720202412,nConstraintXSpecifiedMoreThanOnce,
sConstraintXSpecifiedMoreThanOnce,['class'],Expr);
if IsRecord then
RaiseMsg(20190720202516,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,['record','class'],Expr);
if LastType<>nil then
RaiseMsg(20190720205708,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,[LastType.Name,'class'],Expr);
IsClass:=true;
end
else if SameText(Value,'record') then
RaiseMsg(20190720204604,nXIsNotAValidConstraint,sXIsNotAValidConstraint,
[GetResolverResultDescription(ResolvedEl)],Expr);
end;
MemberType:=TPasMembersType(ResolvedEl.LoTypeEl);
if IsRecord then
RaiseMsg(20190720210130,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,['record',MemberType.Name],Expr);
if IsClass then
RaiseMsg(20190720210202,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,['class',MemberType.Name],Expr);
if IsConstructor then
RaiseMsg(20190720210244,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,['constructor',MemberType.Name],Expr);
if MemberType is TPasClassType then
begin
if IsRecord then
RaiseMsg(20190720203028,nConstraintXSpecifiedMoreThanOnce,
sConstraintXSpecifiedMoreThanOnce,['record'],Expr);
if IsClass then
RaiseMsg(20190720203039,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,['class','record'],Expr);
if IsConstructor then
RaiseMsg(20190720203056,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,['constructor','record'],Expr);
if LastType<>nil then
RaiseMsg(20190720205938,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,[LastType.Name,'record'],Expr);
IsRecord:=true;
end
else if SameText(Value,'constructor') then
begin
if IsConstructor then
RaiseMsg(20190720203123,nConstraintXSpecifiedMoreThanOnce,
sConstraintXSpecifiedMoreThanOnce,['constructor'],Expr);
if IsRecord then
RaiseMsg(20190720203148,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,['record','constructor'],Expr);
if LastType<>nil then
RaiseMsg(20190720210005,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,[LastType.Name,'constructor'],Expr);
IsConstructor:=true;
end
else
begin
// type identifier: class, record or interface
ResolveNameExpr(Expr,Value,rraNone);
ComputeElement(Expr,ResolvedEl,[rcType]);
if (ResolvedEl.BaseType<>btContext)
or not (ResolvedEl.IdentEl is TPasMembersType) then
aClass:=TPasClassType(MemberType);
case aClass.ObjKind of
okClass:
begin
RaiseMsg(20190720204604,nXIsNotAValidConstraint,sXIsNotAValidConstraint,
[Value],Expr);
// there can be at most one classtype constraint
if LastType<>nil then
RaiseMsg(20190720210351,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,[LastType.Name,MemberType.Name],Expr);
end;
MemberType:=TPasMembersType(ResolvedEl.LoTypeEl);
if IsRecord then
RaiseMsg(20190720210130,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,['record',MemberType.Name],Expr);
if IsClass then
RaiseMsg(20190720210202,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,['class',MemberType.Name],Expr);
if IsConstructor then
RaiseMsg(20190720210244,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,['constructor',MemberType.Name],Expr);
if MemberType is TPasClassType then
okInterface:
begin
aClass:=TPasClassType(MemberType);
case aClass.ObjKind of
okClass:
begin
// there can be at most one classtype constraint
if LastType<>nil then
RaiseMsg(20190720210351,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,[LastType.Name,MemberType.Name],Expr);
end;
okInterface:
begin
// there can be multiple interfacetype constraint
if not (LastType is TPasClassType) then
RaiseMsg(20190720211236,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,[LastType.Name,MemberType.Name],Expr);
if TPasClassType(LastType).ObjKind<>okInterface then
RaiseMsg(20190720211304,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,[LastType.Name,MemberType.Name],Expr);
end
else
RaiseMsg(20190720210919,nXIsNotAValidConstraint,
sXIsNotAValidConstraint,[MemberType.Name],Expr);
end;
// there can be multiple interfacetype constraint
if not (LastType is TPasClassType) then
RaiseMsg(20190720211236,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,[LastType.Name,MemberType.Name],Expr);
if TPasClassType(LastType).ObjKind<>okInterface then
RaiseMsg(20190720211304,nConstraintXAndConstraintYCannotBeTogether,
sConstraintXAndConstraintYCannotBeTogether,[LastType.Name,MemberType.Name],Expr);
end
else
RaiseMsg(20190720210809,nXIsNotAValidConstraint,
RaiseMsg(20190720210919,nXIsNotAValidConstraint,
sXIsNotAValidConstraint,[MemberType.Name],Expr);
LastType:=MemberType;
end;
end
else
RaiseMsg(20190720203419,nParserSyntaxError,SParserSyntaxError,[],Expr);
end
else
RaiseMsg(20190720210809,nXIsNotAValidConstraint,
sXIsNotAValidConstraint,[MemberType.Name],Expr);
LastType:=MemberType;
end;
end;
end;
end;
@ -11105,9 +11103,14 @@ var
Duplicate: TPasIdentifier;
ForwardDecl: TPasClassType;
CurScope, LocalScope: TPasIdentifierScope;
GenTemplCnt: Integer;
GenTemplCnt, i, j: Integer;
DuplEl: TPasElement;
ClassScope: TPasClassScope;
ForwGenTempl, ActGenTempl: TPasGenericTemplateType;
ForwConstraints, ActConstraints: TPasExprArray;
ForwExpr, ActExpr: TPasExpr;
ForwToken, ActToken: TToken;
ForwConstraintResolved, ActConstraintResolved: TPasResolverResult;
begin
// Beware: El.ObjKind is not yet set!
{$IFDEF VerbosePasResolver}
@ -11149,6 +11152,42 @@ begin
{$IFDEF VerbosePasResolver}
writeln(' Resolving Forward=',GetObjName(ForwardDecl),' ',GetElementSourcePosStr(ForwardDecl));
{$ENDIF}
if GenTemplCnt>0 then
begin
// check generic constraints match exactly
for i:=0 to GenTemplCnt-1 do
begin
ForwGenTempl:=TPasGenericTemplateType(ForwardDecl.GenericTemplateTypes[i]);
ActGenTempl:=TPasGenericTemplateType(TypeParams[i]);
if not SameText(ForwGenTempl.Name,ActGenTempl.Name) then
RaiseMsg(20190814114811,nDeclOfXDiffersFromPrevAtY,sDeclOfXDiffersFromPrevAtY,
[GetTypeDescription(ActGenTempl),GetElementSourcePosStr(ForwGenTempl)],ActGenTempl);
ForwConstraints:=ForwGenTempl.Constraints;
ActConstraints:=ActGenTempl.Constraints;
if length(ForwConstraints)<>length(ActConstraints) then
RaiseMsg(20190814121031,nDeclOfXDiffersFromPrevAtY,sDeclOfXDiffersFromPrevAtY,
[GetTypeDescription(ActGenTempl),GetElementSourcePosStr(ForwGenTempl)],ActGenTempl);
for j:=0 to length(ForwConstraints)-1 do
begin
ForwExpr:=ForwConstraints[j];
ActExpr:=ActConstraints[j];
ForwToken:=GetGenericConstraintKeyword(ForwExpr);
ActToken:=GetGenericConstraintKeyword(ActExpr);
if ForwToken<>ActToken then
RaiseMsg(20190814121139,nDeclOfXDiffersFromPrevAtY,sDeclOfXDiffersFromPrevAtY,
[GetTypeDescription(ActGenTempl),GetElementSourcePosStr(ForwExpr)],ActExpr);
if ForwToken=tkEOF then
begin
ComputeElement(ForwExpr,ForwConstraintResolved,[rcType]);
ComputeElement(ActExpr,ActConstraintResolved,[rcType]);
if not CheckElTypeCompatibility(ForwConstraintResolved.LoTypeEl,ActConstraintResolved.LoTypeEl,prraNone) then
RaiseMsg(20190814121509,nDeclOfXDiffersFromPrevAtY,sDeclOfXDiffersFromPrevAtY,
[GetTypeDescription(ActGenTempl),GetElementSourcePosStr(ForwExpr)],ActExpr);
end;
end;
end;
end;
if ForwardDecl.CustomData<>nil then
begin
// move the classscope to the real declaration
@ -14473,8 +14512,15 @@ begin
begin
Item:=TPSSpecializedItem(SpecializedTypes[i]);
j:=length(Item.Params)-1;
while (j>=0) and IsSameType(Item.Params[j],ParamsResolved[j],prraNone) do
while j>=0 do
begin
if not IsSameType(Item.Params[j],ParamsResolved[j],prraNone) then
begin
if not CheckElTypeCompatibility(Item.Params[j],ParamsResolved[j],prraNone) then
break;
end;
dec(j);
end;
if j<0 then
break;
Item:=nil;
@ -14506,8 +14552,8 @@ var
ResolvedEl, ResolvedConstraint: TPasResolverResult;
GenTempl: TPasGenericTemplateType;
ConExpr: TPasExpr;
Value: String;
ConstraintClass: TPasClassType;
ConToken: TToken;
begin
Result:=false;
Params:=El.Params;
@ -14543,55 +14589,58 @@ begin
for j:=0 to length(GenTempl.Constraints)-1 do
begin
ConExpr:=GenTempl.Constraints[j];
if (ConExpr.Kind=pekIdent) then
ConToken:=GetGenericConstraintKeyword(ConExpr);
case ConToken of
tkrecord:
begin
Value:=TPrimitiveExpr(ConExpr).Value;
if SameText(Value,'record') then
begin
if not (ParamType is TPasRecordType) then
RaiseXExpectedButTypeYFound(20190725200015,'record type',ParamType,P);
continue;
end
else if SameText(Value,'class') or SameText(Value,'constructor') then
begin
if not (ParamType is TPasClassType) then
RaiseXExpectedButTypeYFound(20190726133231,'class type',ParamType,P);
if TPasClassType(ParamType).ObjKind<>okClass then
RaiseXExpectedButTypeYFound(20190726133232,'class type',ParamType,P);
if TPasClassType(ParamType).IsExternal then
RaiseXExpectedButTypeYFound(20190726133233,'non external class type',ParamType,P);
if SameText(Value,'constructor') then
begin
// check if ParamType has the default constructor
// ToDo
RaiseMsg(20190726133722,nXIsNotSupported,sXIsNotSupported,['constraint keyword construcor'],P);
end;
continue;
end;
if not (ParamType is TPasRecordType) then
RaiseXExpectedButTypeYFound(20190725200015,'record type',ParamType,P);
continue;
end;
tkclass,tkconstructor:
begin
if not (ParamType is TPasClassType) then
RaiseXExpectedButTypeYFound(20190726133231,'class type',ParamType,P);
if TPasClassType(ParamType).ObjKind<>okClass then
RaiseXExpectedButTypeYFound(20190726133232,'class type',ParamType,P);
if TPasClassType(ParamType).IsExternal then
RaiseXExpectedButTypeYFound(20190726133233,'non external class type',ParamType,P);
if ConToken=tkconstructor then
begin
// check if ParamType has the default constructor
// ToDo
RaiseMsg(20190726133722,nXIsNotSupported,sXIsNotSupported,['constraint keyword construcor'],P);
end;
continue;
end;
// constraint can be a class type or interface type
// Param must be a class
ComputeElement(ConExpr,ResolvedConstraint,[rcType]);
if ResolvedConstraint.IdentEl=nil then
RaiseMsg(20190726134037,nXIsNotAValidConstraint,sXIsNotAValidConstraint,[GetElementSourcePosStr(ConExpr)],P);
if not (ResolvedConstraint.LoTypeEl is TPasClassType) then
RaiseMsg(20190726134223,nXIsNotAValidConstraint,sXIsNotAValidConstraint,[GetElementSourcePosStr(ConExpr)],P);
ConstraintClass:=TPasClassType(ResolvedConstraint.LoTypeEl);
if not (ParamType is TPasClassType) then
RaiseIncompatibleType(20190726135859,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,P);
case ConstraintClass.ObjKind of
okClass:
// Param must be a ConstraintClass
if CheckClassIsClass(ParamType,ConstraintClass)=cIncompatible then
RaiseIncompatibleType(20190726135309,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,P);
okInterface:
// ParamType must implement ConstraintClass
if GetClassImplementsIntf(TPasClassType(ParamType),ConstraintClass)=nil then
RaiseIncompatibleType(20190726135458,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,P);
else
RaiseIncompatibleType(20190726135310,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,P);
end;
end;
begin
// constraint can be a class type or interface type
// Param must be a class
ComputeElement(ConExpr,ResolvedConstraint,[rcType]);
if ResolvedConstraint.IdentEl=nil then
RaiseMsg(20190726134037,nXIsNotAValidConstraint,sXIsNotAValidConstraint,[GetElementSourcePosStr(ConExpr)],P);
if not (ResolvedConstraint.LoTypeEl is TPasClassType) then
RaiseMsg(20190726134223,nXIsNotAValidConstraint,sXIsNotAValidConstraint,[GetElementSourcePosStr(ConExpr)],P);
ConstraintClass:=TPasClassType(ResolvedConstraint.LoTypeEl);
if not (ParamType is TPasClassType) then
RaiseIncompatibleType(20190726135859,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,P);
case ConstraintClass.ObjKind of
okClass:
// Param must be a ConstraintClass
if CheckClassIsClass(ParamType,ConstraintClass)=cIncompatible then
RaiseIncompatibleType(20190726135309,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,P);
okInterface:
// ParamType must implement ConstraintClass
if GetClassImplementsIntf(TPasClassType(ParamType),ConstraintClass)=nil then
RaiseIncompatibleType(20190726135458,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,P);
else
RaiseIncompatibleType(20190726135310,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,P);
end;
end;
end; // end case
end; // end for
end;
if Result then
@ -25189,6 +25238,17 @@ begin
Result:=aType.GenericTemplateTypes.Count;
end;
function TPasResolver.GetGenericConstraintKeyword(El: TPasExpr): TToken;
begin
if (El=nil) or (El.Kind<>pekIdent) then exit(tkEOF);
case lowercase(TPrimitiveExpr(El).Value) of
'record': Result:=tkrecord;
'class': Result:=tkclass;
'constructor': Result:=tkconstructor;
else Result:=tkEOF;
end;
end;
function TPasResolver.IsInterfaceType(const ResolvedEl: TPasResolverResult;
IntfType: TPasClassInterfaceType): boolean;
begin

1
packages/fcl-passrc/src/pparser.pp
View File

@ -6247,6 +6247,7 @@ begin
// simple statement (function call)
El:=TPasImplSimple(CreateElement(TPasImplSimple,'',CurBlock,SrcPos));
TPasImplSimple(El).Expr:=Left;
Left.Parent:=El;
Left:=nil;
AddStatement(El);
El:=nil;

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

@ -39,17 +39,18 @@ type
procedure TestGen_RecordNestedSpecialized;
procedure TestGen_Record_SpecializeSelfInsideFail;
procedure TestGen_RecordAnoArray;
// ToDo: procedure TestGen_SpecializeArg_ArrayOf; type TBird = specialize<array of word>
// ToDo: unitname.specialize TBird<word>.specialize
// generic class
procedure TestGen_Class;
procedure TestGen_ClassDelphi;
procedure TestGen_ClassForward;
procedure TestGen_ClassForwardConstraints;
procedure TestGen_ClassForwardConstraintNameMismatchFail;
procedure TestGen_ClassForwardConstraintKeywordMismatchFail;
procedure TestGen_ClassForwardConstraintTypeMismatchFail;
procedure TestGen_Class_Method;
procedure TestGen_Class_SpecializeSelfInside;
// ToDo: generic class forward (constraints must be repeated)
// ToDo: generic class forward constraints mismatch fail
// ToDo: generic class overload <T> <S,T>
procedure TestGen_Class_GenAncestor;
procedure TestGen_Class_AncestorSelfFail;
@ -59,6 +60,7 @@ type
procedure TestGen_NestedType;
// ToDo: procedure TestGen_NestedDottedType;
procedure TestGen_Class_Enums_NotPropagating;
procedure TestGen_Class_List;
// generic external class
procedure TestGen_ExtClass_Array;
@ -165,7 +167,7 @@ begin
'end;',
'begin',
'']);
CheckResolverException('"string" is not a valid constraint',
CheckResolverException('"String" is not a valid constraint',
nXIsNotAValidConstraint);
end;
@ -242,7 +244,7 @@ begin
' generic TBird<T:TArr> = record v: T; end;',
'begin',
'']);
CheckResolverException('"TArr" is not a valid constraint',
CheckResolverException('"array of Word" is not a valid constraint',
nXIsNotAValidConstraint);
end;
@ -348,8 +350,11 @@ begin
'{$mode objfpc}',
'type',
' generic TBird<T> = record v: T; end;',
'var b: specialize TBird<array of word>;',
'var',
' a: specialize TBird<array of word>;',
' b: specialize TBird<array of word>;',
'begin',
' a:=b;',
'']);
ParseProgram;
end;
@ -420,6 +425,86 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_ClassForwardConstraints;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' TAnt = class end;',
' generic TBird<T: class; U; V: TAnt> = class;',
' TRec = record',
' b: specialize TBird<TAnt,word,TAnt>;',
' end;',
' generic TBird<T: class; U; V: TAnt> = class',
' i: U;',
' r: TRec;',
' end;',
'var',
' s: TRec;',
' w: word;',
'begin',
' s.b.i:=w;',
' s.b.r:=s;',
'']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_ClassForwardConstraintNameMismatchFail;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' generic TBird<T> = class;',
' generic TBird<U> = class',
' i: U;',
' end;',
'begin',
'']);
CheckResolverException('Declaration of "U" differs from previous declaration at afile.pp(5,18)',
nDeclOfXDiffersFromPrevAtY);
end;
procedure TTestResolveGenerics.
TestGen_ClassForwardConstraintKeywordMismatchFail;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' generic TBird<T: class, constructor> = class;',
' generic TBird<U: class> = class',
' i: U;',
' end;',
'begin',
'']);
CheckResolverException('Declaration of "U" differs from previous declaration at afile.pp(5,18)',
nDeclOfXDiffersFromPrevAtY);
end;
procedure TTestResolveGenerics.TestGen_ClassForwardConstraintTypeMismatchFail;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' TAnt = class end;',
' TFish = class end;',
' generic TBird<T: TAnt> = class;',
' generic TBird<T: TFish> = class',
' i: U;',
' end;',
'begin',
'']);
CheckResolverException('Declaration of "T" differs from previous declaration at afile.pp(7,20)',
nDeclOfXDiffersFromPrevAtY);
end;
procedure TTestResolveGenerics.TestGen_Class_Method;
begin
StartProgram(false);
@ -544,6 +629,45 @@ begin
CheckResolverException('identifier not found "red"',nIdentifierNotFound);
end;
procedure TTestResolveGenerics.TestGen_Class_List;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' generic TList<T> = class',
' strict private',
' FItems: array of T;',
' function GetItems(Index: longint): T;',
' procedure SetItems(Index: longint; Value: T);',
' public',
' procedure Alter(w: T);',
' property Items[Index: longint]: T read GetItems write SetItems; default;',
' end;',
' TWordList = specialize TList<word>;',
'function TList.GetItems(Index: longint): T;',
'begin',
' Result:=FItems[Index];',
'end;',
'procedure TList.SetItems(Index: longint; Value: T);',
'begin',
' FItems[Index]:=Value;',
'end;',
'procedure TList.Alter(w: T);',
'begin',
' SetLength(FItems,length(FItems)+1);',
' Insert(w,FItems,2);',
' Delete(FItems,2,3);',
'end;',
'var l: TWordList;',
' w: word;',
'begin',
' l[1]:=w;',
' w:=l[2];']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_ExtClass_Array;
begin
StartProgram(false);