From 5bf43bd1d4dac6e946ddf9336a21aa82f2793143 Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Sat, 17 Aug 2019 08:29:15 +0000 Subject: [PATCH] fcl-passrc: specialize class interface git-svn-id: trunk@42714 - --- packages/fcl-passrc/src/pasresolveeval.pas | 6 + packages/fcl-passrc/src/pasresolver.pp | 268 +++++++++++------- packages/fcl-passrc/src/pparser.pp | 42 ++- .../fcl-passrc/tests/tcresolvegenerics.pas | 132 ++++++++- packages/fcl-passrc/tests/tcresolver.pas | 23 ++ 5 files changed, 357 insertions(+), 114 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolveeval.pas b/packages/fcl-passrc/src/pasresolveeval.pas index 4ee638df2e..e9ef3ac62b 100644 --- a/packages/fcl-passrc/src/pasresolveeval.pas +++ b/packages/fcl-passrc/src/pasresolveeval.pas @@ -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 } diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 5e5933d564..6f034e958b 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -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 in "type TGen = class(TAnc)" + // El is actually the GenericType + // e.g. "type A = class v: A 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)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 = class + // v: A; // circle, do not specialize + // u: A; // 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; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index eb9cdd4168..cb9de93a3c 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -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<>''); diff --git a/packages/fcl-passrc/tests/tcresolvegenerics.pas b/packages/fcl-passrc/tests/tcresolvegenerics.pas index 80aeb0d25e..292643a0ac 100644 --- a/packages/fcl-passrc/tests/tcresolvegenerics.pas +++ b/packages/fcl-passrc/tests/tcresolvegenerics.pas @@ -31,6 +31,8 @@ type // ToDo: constraint T:Unit2.TBird // ToDo: constraint T:Unit2.TGen 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 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 = class v: T; end;', + ' generic TEagle = class(TBird)', + ' 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 = class v: T; end;', + ' generic TEagle = class(TBird)', + ' 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 = class;', + ' generic TFish = class', + ' private type AliasU = U;', + ' var a: TAnt;', + ' Size: AliasU;', + ' end;', + ' generic TAnt = class', + ' private type AliasT = T;', + ' var f: TFish;', + ' Speed: AliasT;', + ' end;', + 'var', + ' WordFish: specialize TFish;', + ' BoolAnt: specialize TAnt;', + ' 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 = interface', + ' procedure Fly(a: T);', + ' end;', + ' {$interfaces com}', + ' IUnknown = interface', + ' end;', + ' IInterface = IUnknown;', + ' generic IComIntf = interface', + ' procedure Run(b: T);', + ' end;', + 'begin']); + ParseProgram; +end; + +procedure TTestResolveGenerics.TestGen_ClassInterface_Method; +begin + StartProgram(false); + Add([ + 'type', + ' {$interfaces corba}', + ' generic IBird = interface', + ' procedure Fly(a: T);', + ' end;', + ' TObject = class end;', + ' generic TBird = class(IBird)', + ' procedure Fly(a: U);', + ' end;', + 'procedure TBird.Fly(a: U);', + 'begin', + 'end;', + 'var b: specialize IBird;', + 'begin', + ' b.Fly(3);']); + ParseProgram; +end; + procedure TTestResolveGenerics.TestGen_Array; begin StartProgram(false); diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 43c2e77a46..d948d841f0 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -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',