From 93c130979f8851498edfbd67f7390c022aae7158 Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Sat, 20 Jul 2019 20:14:15 +0000 Subject: [PATCH] fcl-passrc: check generic constraint git-svn-id: trunk@42473 - --- packages/fcl-passrc/src/pasresolveeval.pas | 6 + packages/fcl-passrc/src/pasresolver.pp | 107 +++++++++++++++++- .../fcl-passrc/tests/tcresolvegenerics.pas | 27 ++++- 3 files changed, 134 insertions(+), 6 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolveeval.pas b/packages/fcl-passrc/src/pasresolveeval.pas index 9834c3a7c7..b01035bdfd 100644 --- a/packages/fcl-passrc/src/pasresolveeval.pas +++ b/packages/fcl-passrc/src/pasresolveeval.pas @@ -190,6 +190,9 @@ const nIllegalExpressionAfterX = 3124; nMethodHidesNonVirtualMethodExactly = 3125; nDuplicatePublishedMethodXAtY = 3126; + nConstraintXSpecifiedMoreThanOnce = 3127; + nConstraintXAndConstraintYCannotBeTogether = 3128; + nXIsNotAValidConstraint = 3129; // using same IDs as FPC nVirtualMethodXHasLowerVisibility = 3250; // was 3050 @@ -327,6 +330,9 @@ resourcestring sIllegalExpressionAfterX = 'illegal expression after %s'; sMethodHidesNonVirtualMethodExactly = 'method hides identifier at "%s". Use reintroduce'; sDuplicatePublishedMethodXAtY = 'Duplicate published method "%s" at %s'; + sConstraintXSpecifiedMoreThanOnce = 'Constraint ''%s'' specified more than once'; + sConstraintXAndConstraintYCannotBeTogether = '''%s'' constraint and ''%s'' constraint cannot be specified together'; + sXIsNotAValidConstraint = '''%s'' is not a valid constraint'; 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 ef79ab4ced..a1e09c07f0 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -5821,10 +5821,19 @@ var i: Integer; Expr: TPasExpr; Value: String; + IsClass, IsRecord, IsConstructor: Boolean; + LastType: TPasType; + ResolvedEl: TPasResolverResult; + MemberType: TPasMembersType; + aClass: TPasClassType; begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.FinishGenericTemplateType ',GetObjName(El),' El.Parent=',GetObjName(El.Parent),' Constraints=',length(El.Constraints)); {$ENDIF} + IsClass:=false; + IsRecord:=false; + IsConstructor:=false; + LastType:=nil; for i:=0 to length(El.Constraints)-1 do begin Expr:=El.Constraints[i]; @@ -5832,8 +5841,102 @@ begin begin Value:=TPrimitiveExpr(Expr).Value; if SameText(Value,'class') then - ; // ToDo - end; + 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 + 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 + begin + RaiseMsg(20190720204604,nXIsNotAValidConstraint,sXIsNotAValidConstraint, + [Value],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 + 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; + end + else + RaiseMsg(20190720210809,nXIsNotAValidConstraint, + sXIsNotAValidConstraint,[MemberType.Name],Expr); + LastType:=MemberType; + end; + end + else + RaiseMsg(20190720203419,nParserSyntaxError,SParserSyntaxError,[],Expr); end; end; diff --git a/packages/fcl-passrc/tests/tcresolvegenerics.pas b/packages/fcl-passrc/tests/tcresolvegenerics.pas index f9d5253146..24e7c848d2 100644 --- a/packages/fcl-passrc/tests/tcresolvegenerics.pas +++ b/packages/fcl-passrc/tests/tcresolvegenerics.pas @@ -5,7 +5,7 @@ unit tcresolvegenerics; interface uses - Classes, SysUtils, testregistry, tcresolver; + Classes, SysUtils, testregistry, tcresolver, PasResolveEval; type @@ -14,7 +14,13 @@ type TTestResolveGenerics = Class(TCustomTestResolver) Published procedure TestGen_GenericFunction; // ToDo + procedure TestGen_ConstraintStringFail; procedure TestGen_ConstraintMultiClassFail; + // ToDo: constraint keyword record + // ToDo: constraint keyword class, constructor, class+constructor + // ToDo: constraint Unit2.TBird + // ToDo: constraint Unit2.TGen + // ToDo: generic array end; implementation @@ -38,6 +44,20 @@ begin ParseProgram; end; +procedure TTestResolveGenerics.TestGen_ConstraintStringFail; +begin + StartProgram(false); + Add([ + 'generic function DoIt(a: T): T;', + 'begin', + ' Result:=a;', + 'end;', + 'begin', + '']); + CheckResolverException('''string'' is not a valid constraint', + nXIsNotAValidConstraint); +end; + procedure TTestResolveGenerics.TestGen_ConstraintMultiClassFail; begin StartProgram(false); @@ -51,11 +71,10 @@ begin 'begin', ' Result:=a;', 'end;', - 'var b: TBird;', 'begin', - //' b:=DoIt(3);', '']); - ParseProgram; + CheckResolverException('''TBird'' constraint and ''TBear'' constraint cannot be specified together', + nConstraintXAndConstraintYCannotBeTogether); end; initialization