fcl-passrc: check generic constraint

git-svn-id: trunk@42473 -

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 }

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;
 

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<word>
+    // ToDo: generic array
   end;
 
 implementation
@@ -38,6 +44,20 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolveGenerics.TestGen_ConstraintStringFail;
+begin
+  StartProgram(false);
+  Add([
+  'generic function DoIt<T:string>(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<TBird>(3);',
   '']);
-  ParseProgram;
+  CheckResolverException('''TBird'' constraint and ''TBear'' constraint cannot be specified together',
+    nConstraintXAndConstraintYCannotBeTogether);
 end;
 
 initialization