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

fcl-passrc: specialize class interface

Browse Source 
git-svn-id: trunk@42714 -
This commit is contained in:
Mattias Gaertner 2019-08-17 08:29:15 +00:00
parent f0213a2c46
commit 5bf43bd1d4
5 changed files with 357 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -196,6 +196,9 @@ const
nWrongNumberOfParametersForGenericType = 3130;
nGenericsWithoutSpecializationAsType = 3131;
nDeclOfXDiffersFromPrevAtY = 3132;
nTypeParamXIsMissingConstraintY = 3133;
nTypeParamXIsNotCompatibleWithY = 3134;
nTypeParamXMustSupportIntfY = 3135;
// using same IDs as FPC
nVirtualMethodXHasLowerVisibility = 3250; // was 3050
@ -339,6 +342,9 @@ resourcestring
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';
sTypeParamXIsMissingConstraintY = 'Type parameter "%s" is missing constraint "%s"';
sTypeParamXIsNotCompatibleWithY = 'Type parameter "%s" is not compatible with type "%s"';
sTypeParamXMustSupportIntfY = 'Type parameter "%s" must support interface "%s"';
type
{ TResolveData - base class for data stored in TPasElement.CustomData }

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

@ -1726,7 +1726,7 @@ type
procedure AddGenericTemplateIdentifiers(GenericTemplateTypes: TFPList;
Scope: TPasIdentifierScope);
procedure AddSpecializedTemplateIdentifiers(GenericTemplateTypes: TFPList;
SpecializedTypes: TPasTypeArray; Scope: TPasIdentifierScope);
ParamTypes: TPasTypeArray; Scope: TPasIdentifierScope);
function GetSpecializedType(El: TPasSpecializeType): TPasGenericType;
function CheckSpecializeConstraints(El : TPasSpecializeType): boolean; virtual; // false = not fully specialized
function CreateSpecializedType(El: TPasSpecializeType;
@ -14486,16 +14486,16 @@ begin
end;
procedure TPasResolver.AddSpecializedTemplateIdentifiers(
GenericTemplateTypes: TFPList; SpecializedTypes: TPasTypeArray;
GenericTemplateTypes: TFPList; ParamTypes: TPasTypeArray;
Scope: TPasIdentifierScope);
var
i: Integer;
TemplType: TPasGenericTemplateType;
begin
for i:=0 to length(SpecializedTypes)-1 do
for i:=0 to length(ParamTypes)-1 do
begin
TemplType:=TPasGenericTemplateType(GenericTemplateTypes[i]);
AddIdentifier(Scope,TemplType.Name,SpecializedTypes[i],pikSimple);
AddIdentifier(Scope,TemplType.Name,ParamTypes[i],pikSimple);
end;
end;
@ -14534,8 +14534,8 @@ begin
if not CheckSpecializeConstraints(El) then
begin
// not fully specialized -> use generic type
// e.g. the TAnc<T> in "type TGen<T> = class(TAnc<T>)"
// El is actually the GenericType
// e.g. "type A<T> = class v: A<T> end;"
exit(GenericType);
end;
@ -14591,16 +14591,157 @@ end;
function TPasResolver.CheckSpecializeConstraints(El: TPasSpecializeType
): boolean;
procedure CheckTemplateFitsTemplate(ParamTemplType,
GenTempl: TPasGenericTemplateType; ErrorPos: TPasElement);
var
ParamConstraints: TPasExprArray;
j, k: Integer;
ConExpr, ParamConstraintExpr: TPasExpr;
ConToken: TToken;
ResolvedConstraint, ResolvedParamCon: TPasResolverResult;
ConstraintClass, ParamClassType: TPasClassType;
begin
// specialize via template type (not fully specialized)
ParamConstraints:=ParamTemplType.Constraints;
for j:=0 to length(GenTempl.Constraints)-1 do
begin
ConExpr:=GenTempl.Constraints[j];
ConToken:=GetGenericConstraintKeyword(ConExpr);
if ConToken<>tkEOF then
begin
// constraint is keyword
// -> check if keyword is in ParamConstraints
k:=length(ParamConstraints)-1;
while (k>=0) and (GetGenericConstraintKeyword(ParamConstraints[k])<>ConToken) do
dec(k);
if k<0 then
RaiseMsg(20190816230021,nTypeParamXIsMissingConstraintY,
sTypeParamXIsMissingConstraintY,[ParamTemplType.Name,TokenInfos[ConToken]],ErrorPos);
end
else
begin
// constraint is identifier
ComputeElement(ConExpr,ResolvedConstraint,[rcType]);
if ResolvedConstraint.IdentEl=nil then
RaiseMsg(20190816231846,nXIsNotAValidConstraint,sXIsNotAValidConstraint,[GetElementSourcePosStr(ConExpr)],ConExpr);
if not (ResolvedConstraint.LoTypeEl is TPasClassType) then
RaiseMsg(20190816231849,nXIsNotAValidConstraint,sXIsNotAValidConstraint,[GetElementSourcePosStr(ConExpr)],ConExpr);
ConstraintClass:=TPasClassType(ResolvedConstraint.LoTypeEl);
// constraint is class/interface type
// -> check if one of ParamConstraints fits the constraint type
// i.e. ParamConstraints must be more strict than target constraints
k:=length(ParamConstraints)-1;
while k>=0 do
begin
ParamConstraintExpr:=ParamConstraints[k];
ConToken:=GetGenericConstraintKeyword(ParamConstraintExpr);
if ConToken=tkEOF then
begin
ComputeElement(ParamConstraintExpr,ResolvedParamCon,[rcType]);
if not (ResolvedParamCon.IdentEl is TPasClassType) then
RaiseMsg(20190816232459,nXExpectedButYFound,sXExpectedButYFound,['type',GetResolverResultDescription(ResolvedParamCon)],ParamConstraintExpr);
ParamClassType:=TPasClassType(ResolvedParamCon.IdentEl);
if (ConstraintClass.ObjKind=okInterface)
and (ParamClassType.ObjKind=okClass) then
begin
if GetClassImplementsIntf(ParamClassType,ConstraintClass)<>nil then
break;
end
else
begin
if CheckClassIsClass(ParamClassType,ConstraintClass)<cIncompatible then
break;
end;
end;
dec(k);
end;
if k<0 then
begin
if ConstraintClass.ObjKind=okInterface then
RaiseMsg(20190816233102,nTypeParamXMustSupportIntfY,
sTypeParamXMustSupportIntfY,[ParamTemplType.Name,GetTypeDescription(ConstraintClass)],ErrorPos)
else
RaiseMsg(20190816230021,nTypeParamXIsNotCompatibleWithY,
sTypeParamXIsNotCompatibleWithY,[ParamTemplType.Name,GetTypeDescription(ConstraintClass)],ErrorPos);
end;
end;
end;
end;
procedure CheckTypeFitsTemplate(ParamType: TPasType;
GenTempl: TPasGenericTemplateType; ErrorPos: TPasElement);
var
j: Integer;
ConExpr: TPasExpr;
ConToken: TToken;
ResolvedConstraint: TPasResolverResult;
ConstraintClass: TPasClassType;
begin
// check if the specialized ParamType fits the constraints
for j:=0 to length(GenTempl.Constraints)-1 do
begin
ConExpr:=GenTempl.Constraints[j];
ConToken:=GetGenericConstraintKeyword(ConExpr);
case ConToken of
tkrecord:
begin
if not (ParamType is TPasRecordType) then
RaiseXExpectedButTypeYFound(20190725200015,'record type',ParamType,ErrorPos);
continue;
end;
tkclass,tkconstructor:
begin
if not (ParamType is TPasClassType) then
RaiseXExpectedButTypeYFound(20190726133231,'class type',ParamType,ErrorPos);
if TPasClassType(ParamType).ObjKind<>okClass then
RaiseXExpectedButTypeYFound(20190726133232,'class type',ParamType,ErrorPos);
if TPasClassType(ParamType).IsExternal then
RaiseXExpectedButTypeYFound(20190726133233,'non external class type',ParamType,ErrorPos);
if ConToken=tkconstructor then
begin
// check if ParamType has the default constructor
// ToDo
RaiseMsg(20190726133722,nXIsNotSupported,sXIsNotSupported,['constraint keyword construcor'],ConExpr);
end;
continue;
end;
else
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)],ConExpr);
if not (ResolvedConstraint.LoTypeEl is TPasClassType) then
RaiseMsg(20190726134223,nXIsNotAValidConstraint,sXIsNotAValidConstraint,[GetElementSourcePosStr(ConExpr)],ConExpr);
ConstraintClass:=TPasClassType(ResolvedConstraint.LoTypeEl);
if not (ParamType is TPasClassType) then
RaiseIncompatibleType(20190726135859,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,ErrorPos);
case ConstraintClass.ObjKind of
okClass:
// Param must be a ConstraintClass
if CheckClassIsClass(ParamType,ConstraintClass)=cIncompatible then
RaiseIncompatibleType(20190726135309,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,ErrorPos);
okInterface:
// ParamType must implement ConstraintClass
if GetClassImplementsIntf(TPasClassType(ParamType),ConstraintClass)=nil then
RaiseIncompatibleType(20190726135458,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,ErrorPos);
else
RaiseIncompatibleType(20190726135310,nIncompatibleTypesGotExpected,[''],ParamType,ConstraintClass,ErrorPos);
end;
end;
end;// case-end
end;// for-end
end;
var
Params, GenericTemplateList: TFPList;
i, j: Integer;
P, ParentEl: TPasElement;
i: Integer;
P, ErrorPos: TPasElement;
ParamType, DestType: TPasType;
ResolvedEl, ResolvedConstraint: TPasResolverResult;
ResolvedEl: TPasResolverResult;
GenTempl: TPasGenericTemplateType;
ConExpr: TPasExpr;
ConstraintClass: TPasClassType;
ConToken: TToken;
begin
Result:=false;
Params:=El.Params;
@ -14614,97 +14755,34 @@ begin
RaiseMsg(20190726193107,nXExpectedButYFound,sXExpectedButYFound,['type with '+IntToStr(Params.Count)+' generic templates',DestType.Name],El);
// check constraints
Result:=true;
for i:=0 to Params.Count-1 do
begin
GenTempl:=TPasGenericTemplateType(GenericTemplateList[i]);
P:=TPasElement(Params[i]);
if P.Parent=El then
ErrorPos:=P
else
ErrorPos:=El;
// check if P fits into GenTempl
ComputeElement(P,ResolvedEl,[rcType]);
if not (ResolvedEl.IdentEl is TPasType) then
RaiseMsg(20190725195434,nXExpectedButYFound,sXExpectedButYFound,['type',GetResolverResultDescription(ResolvedEl)],P);
ParamType:=TPasType(ResolvedEl.IdentEl);
if ParamType is TPasGenericTemplateType then
ParamType:=ResolvedEl.LoTypeEl;
if ParamType=GenTempl then
// circle
// e.g. type A<S,T> = class
// v: A<S,T>; // circle, do not specialize
// u: A<S,word>; // specialize
// end;
else if ParamType is TPasGenericTemplateType then
begin
// not fully specialized
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.CheckSpecializeConstraints ',GetObjName(El),' i=',i,' P=',GetObjName(P),' ParamType=',GetObjName(ParamType));
{$ENDIF}
Result:=false;
// ToDo: check if both constraints fit
continue;
end;
GenTempl:=TPasGenericTemplateType(GenericTemplateList[i]);
for j:=0 to length(GenTempl.Constraints)-1 do
CheckTemplateFitsTemplate(TPasGenericTemplateType(ParamType),GenTempl,ErrorPos);
Result:=true;
end
else
begin
ConExpr:=GenTempl.Constraints[j];
ConToken:=GetGenericConstraintKeyword(ConExpr);
case ConToken of
tkrecord:
begin
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;
else
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
begin
// check ParentEl types are specialized
ParentEl:=DestType.Parent;
while ParentEl<>nil do
begin
if (ParentEl is TPasGenericType)
and (GetTypeParameterCount(TPasGenericType(ParentEl))>0) then
begin
{$IFDEF VerbosePasResolver}
//writeln('TPasResolver.CheckSpecializeConstraints El=',GetObjName(El),' not specialized Parent=',GetObjName(ParentEl));
{$ENDIF}
exit(false); // parent is not specialized
end;
ParentEl:=ParentEl.Parent;
CheckTypeFitsTemplate(ParamType,GenTempl,ErrorPos);
Result:=true;
end;
end;
end;

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

@ -3750,7 +3750,7 @@ function TPasParser.AddUseUnit(ASection: TPasSection;
const NamePos: TPasSourcePos; AUnitName: string; NameExpr: TPasExpr;
InFileExpr: TPrimitiveExpr): TPasUsesUnit;
procedure CheckDuplicateInUsesList(AUnitName : string; UsesClause: TPasUsesClause);
procedure CheckDuplicateInUsesList(UsesClause: TPasUsesClause);
var
i: Integer;
begin
@ -3760,6 +3760,16 @@ function TPasParser.AddUseUnit(ASection: TPasSection;
ParseExc(nParserDuplicateIdentifier,SParserDuplicateIdentifier,[AUnitName]);
end;
procedure CheckDuplicateInUsesList(UnitRef: TPasElement; UsesClause: TPasUsesClause);
var
i: Integer;
begin
if UsesClause=nil then exit;
for i:=0 to length(UsesClause)-1 do
if UsesClause[i].Module=UnitRef then
ParseExc(nParserDuplicateIdentifier,SParserDuplicateIdentifier,[AUnitName]);
end;
var
UnitRef: TPasElement;
UsesUnit: TPasUsesUnit;
@ -3777,16 +3787,23 @@ begin
exit; // for compatibility ignore implicit use of system in system
ParseExc(nParserDuplicateIdentifier,SParserDuplicateIdentifier,[AUnitName]);
end;
CheckDuplicateInUsesList(AUnitName,ASection.UsesClause);
if ASection.ClassType=TImplementationSection then
CheckDuplicateInUsesList(AUnitName,CurModule.InterfaceSection.UsesClause);
UnitRef := Engine.FindModule(AUnitName,NameExpr,InFileExpr);
if Assigned(UnitRef) then
UnitRef.AddRef{$IFDEF CheckPasTreeRefCount}('TPasUsesUnit.Module'){$ENDIF}
begin
UnitRef.AddRef{$IFDEF CheckPasTreeRefCount}('TPasUsesUnit.Module'){$ENDIF};
CheckDuplicateInUsesList(UnitRef,ASection.UsesClause);
if ASection.ClassType=TImplementationSection then
CheckDuplicateInUsesList(UnitRef,CurModule.InterfaceSection.UsesClause);
end
else
begin
CheckDuplicateInUsesList(ASection.UsesClause);
if ASection.ClassType=TImplementationSection then
CheckDuplicateInUsesList(CurModule.InterfaceSection.UsesClause);
UnitRef := TPasUnresolvedUnitRef(CreateElement(TPasUnresolvedUnitRef,
AUnitName, ASection, NamePos));
end;
UsesUnit:=TPasUsesUnit(CreateElement(TPasUsesUnit,AUnitName,ASection,NamePos));
Result:=ASection.AddUnitToUsesList(AUnitName,NameExpr,InFileExpr,UnitRef,UsesUnit);
@ -4315,12 +4332,14 @@ begin
NextToken;
Case CurToken of
tkObject,
tkClass :
tkClass,
tkinterface:
begin
if CurToken=tkobject then
AObjKind:=okObject
else
AObjKind:=okClass;
case CurToken of
tkobject: AObjKind:=okObject;
tkinterface: AObjKind:=okInterface;
else AObjKind:=okClass;
end;
NextToken;
if (AObjKind = okClass) and (CurToken = tkOf) then
ParseExcExpectedIdentifier;
@ -4328,6 +4347,9 @@ begin
ClassEl := TPasClassType(CreateElement(TPasClassType,
TypeName, Parent, visDefault, NamePos, TypeParams));
ClassEl.ObjKind:=AObjKind;
if AObjKind=okInterface then
if SameText(Scanner.CurrentValueSwitch[vsInterfaces],'CORBA') then
ClassEl.InterfaceType:=citCorba;
if AddToParent and (Parent is TPasDeclarations) then
TPasDeclarations(Parent).Classes.Add(ClassEl);
ClassEl.IsExternal:=(AExternalName<>'');

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

@ -31,6 +31,8 @@ type
// ToDo: constraint T:Unit2.TBird
// ToDo: constraint T:Unit2.TGen<word>
procedure TestGen_TemplNameEqTypeNameFail;
procedure TestGen_ConstraintInheritedMissingRecordFail;
procedure TestGen_ConstraintInheritedMissingClassTypeFail;
// generic record
procedure TestGen_RecordLocalNameDuplicateFail;
@ -47,10 +49,12 @@ type
procedure TestGen_ClassDelphi;
procedure TestGen_ClassForward;
procedure TestGen_ClassForwardConstraints;
procedure TestGen_ClassForwardConstraintNameMismatchFail;
procedure TestGen_ClassForwardConstraintKeywordMismatchFail;
procedure TestGen_ClassForwardConstraintTypeMismatchFail;
procedure TestGen_ClassForwardConstraintNameMismatch;
procedure TestGen_ClassForwardConstraintKeywordMismatch;
procedure TestGen_ClassForwardConstraintTypeMismatch;
procedure TestGen_ClassForward_Circle;
procedure TestGen_Class_Method;
// ToDo: procedure TestGen_Class_MethodOverride;
procedure TestGen_Class_SpecializeSelfInside;
// ToDo: generic class overload <T> <S,T>
procedure TestGen_Class_GenAncestor;
@ -59,14 +63,16 @@ type
// ToDo: UnitA.impl uses UnitB.intf uses UnitA.intf, UnitB has specialize of UnitA
procedure TestGen_Class_NestedType;
procedure TestGen_Class_NestedRecord;
procedure TestGen_Class_NestedClass; // ToDo
procedure TestGen_Class_NestedClass;
procedure TestGen_Class_Enums_NotPropagating;
procedure TestGen_Class_List;
// generic external class
procedure TestGen_ExtClass_Array;
// ToDo: generic interface
// generic interface
procedure TestGen_ClassInterface;
procedure TestGen_ClassInterface_Method;
// generic array
procedure TestGen_Array;
@ -265,6 +271,39 @@ begin
nDuplicateIdentifier);
end;
procedure TTestResolveGenerics.TestGen_ConstraintInheritedMissingRecordFail;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' generic TBird<T: record> = class v: T; end;',
' generic TEagle<U> = class(TBird<U>)',
' end;',
'begin',
'']);
CheckResolverException('Type parameter "U" is missing constraint "record"',
nTypeParamXIsMissingConstraintY);
end;
procedure TTestResolveGenerics.TestGen_ConstraintInheritedMissingClassTypeFail;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' TAnt = class end;',
' generic TBird<T: TAnt> = class v: T; end;',
' generic TEagle<U> = class(TBird<U>)',
' end;',
'begin',
'']);
CheckResolverException('Type parameter "U" is not compatible with type "TAnt"',
nTypeParamXIsNotCompatibleWithY);
end;
procedure TTestResolveGenerics.TestGen_RecordLocalNameDuplicateFail;
begin
StartProgram(false);
@ -469,7 +508,7 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_ClassForwardConstraintNameMismatchFail;
procedure TTestResolveGenerics.TestGen_ClassForwardConstraintNameMismatch;
begin
StartProgram(false);
Add([
@ -486,8 +525,7 @@ begin
nDeclOfXDiffersFromPrevAtY);
end;
procedure TTestResolveGenerics.
TestGen_ClassForwardConstraintKeywordMismatchFail;
procedure TTestResolveGenerics.TestGen_ClassForwardConstraintKeywordMismatch;
begin
StartProgram(false);
Add([
@ -504,7 +542,7 @@ begin
nDeclOfXDiffersFromPrevAtY);
end;
procedure TTestResolveGenerics.TestGen_ClassForwardConstraintTypeMismatchFail;
procedure TTestResolveGenerics.TestGen_ClassForwardConstraintTypeMismatch;
begin
StartProgram(false);
Add([
@ -523,6 +561,40 @@ begin
nDeclOfXDiffersFromPrevAtY);
end;
procedure TTestResolveGenerics.TestGen_ClassForward_Circle;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' generic TAnt<T> = class;',
' generic TFish<U> = class',
' private type AliasU = U;',
' var a: TAnt<AliasU>;',
' Size: AliasU;',
' end;',
' generic TAnt<T> = class',
' private type AliasT = T;',
' var f: TFish<AliasT>;',
' Speed: AliasT;',
' end;',
'var',
' WordFish: specialize TFish<word>;',
' BoolAnt: specialize TAnt<boolean>;',
' w: word;',
' b: boolean;',
'begin',
' WordFish.Size:=w;',
' WordFish.a.Speed:=w;',
' WordFish.a.f.Size:=w;',
' BoolAnt.Speed:=b;',
' BoolAnt.f.Size:=b;',
' BoolAnt.f.a.Speed:=b;',
'']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_Class_Method;
begin
StartProgram(false);
@ -795,6 +867,48 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_ClassInterface;
begin
StartProgram(false);
Add([
'type',
' {$interfaces corba}',
' generic ICorbaIntf<T> = interface',
' procedure Fly(a: T);',
' end;',
' {$interfaces com}',
' IUnknown = interface',
' end;',
' IInterface = IUnknown;',
' generic IComIntf<T> = interface',
' procedure Run(b: T);',
' end;',
'begin']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_ClassInterface_Method;
begin
StartProgram(false);
Add([
'type',
' {$interfaces corba}',
' generic IBird<T> = interface',
' procedure Fly(a: T);',
' end;',
' TObject = class end;',
' generic TBird<U> = class(IBird<U>)',
' procedure Fly(a: U);',
' end;',
'procedure TBird.Fly(a: U);',
'begin',
'end;',
'var b: specialize IBird<word>;',
'begin',
' b.Fly(3);']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_Array;
begin
StartProgram(false);

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

@ -360,6 +360,7 @@ type
Procedure TestUnitUseIntf;
Procedure TestUnitUseImplFail;
Procedure TestUnit_DuplicateUsesFail;
Procedure TestUnit_DuplicateUsesIntfImplFail;
Procedure TestUnit_NestedFail;
Procedure TestUnitUseDotted;
Procedure TestUnit_ProgramDefaultNamespace;
@ -5674,6 +5675,28 @@ begin
nParserDuplicateIdentifier);
end;
procedure TTestResolver.TestUnit_DuplicateUsesIntfImplFail;
begin
AddModuleWithIntfImplSrc('unit2.pp',
LinesToStr([
'type number = longint;']),
LinesToStr([
'']));
StartUnit(true);
Add([
'interface',
'uses unit2;',
'var j: number;',
'implementation',
'uses unit2;',
'initialization',
' if number(3) then ;',
'']);
CheckParserException('Duplicate identifier "unit2" at token ";" in file afile.pp at line 6 column 11',
nParserDuplicateIdentifier);
end;
procedure TTestResolver.TestUnit_NestedFail;
begin
AddModuleWithIntfImplSrc('unit2.pp',