fcl-passrc: template is, is template, template(), atype(template)

git-svn-id: trunk@42881 -

packages/fcl-passrc/src/pasresolver.pp

@@ -4789,14 +4789,15 @@ begin
         or (C=TPasProcedureType)
         or (C=TPasFunctionType)
         or (C=TPasArrayType)
-        or (C=TPasRangeType) then
+        or (C=TPasRangeType)
+        or (C=TPasGenericTemplateType) then
       begin
       // type cast to user type
       Abort:=true; // can't be overloaded
       if Data^.Found<>nil then exit;
       Distance:=CheckTypeCast(TPasType(El),Data^.Params,false);
       {$IFDEF VerbosePasResolver}
-      writeln('TPasResolver.OnFindCallElements type cast to =',GetObjName(El),' Distance=',Distance);
+      writeln('TPasResolver.OnFindCallElements type cast to "',GetObjName(El),'" Distance=',Distance);
       {$ENDIF}
       CandidateFound:=true;
       end;
@@ -10209,7 +10210,8 @@ begin
         or (C=TPasSetType)
         or (C=TPasPointerType)
         or (C=TPasArrayType)
-        or (C=TPasRangeType) then
+        or (C=TPasRangeType)
+        or (C=TPasGenericTemplateType) then
       begin
       // type cast
       FinishUntypedParams(Access);
@@ -24217,6 +24219,10 @@ var
   ToTypeBaseType: TResolverBaseType;
   C: TClass;
   ToProcType, FromProcType: TPasProcedureType;
+  TemplType: TPasGenericTemplateType;
+  i: Integer;
+  Expr: TPasExpr;
+  ExprToken: TToken;
 begin
   Result:=cIncompatible;
   ToTypeEl:=ToResolved.LoTypeEl;
@@ -24372,6 +24378,25 @@ begin
           if Result=cIncompatible then
             Result:=CheckTypeCastClassInstanceToClass(FromResolved,ToResolved,ErrorEl);
           end
+        else if FromTypeEl.ClassType=TPasGenericTemplateType then
+          begin
+          // e.g. classtype(T)
+          TemplType:=TPasGenericTemplateType(FromTypeEl);
+          for i:=0 to length(TemplType.Constraints)-1 do
+            begin
+            Expr:=TemplType.Constraints[i];
+            ExprToken:=GetGenericConstraintKeyword(Expr);
+            case ExprToken of
+            tkrecord: ; // invalid type cast
+            tkClass, tkconstructor:
+              Result:=cExact;
+            else
+              // identifier constraint: class or interface -> allow
+              Result:=cExact;
+              break;
+            end;
+            end;
+          end;
         end
       else if FromResolved.BaseType=btPointer then
         begin
@@ -24381,6 +24406,35 @@ begin
       else if FromResolved.BaseType=btNil then
         Result:=cExact; // nil to class or interface
       end
+    else if C=TPasGenericTemplateType then
+      begin
+      // e.g. T(var)
+      TemplType:=TPasGenericTemplateType(ToTypeEl);
+      FromTypeEl:=FromResolved.LoTypeEl;
+      for i:=0 to length(TemplType.Constraints)-1 do
+        begin
+        Expr:=TemplType.Constraints[i];
+        ExprToken:=GetGenericConstraintKeyword(Expr);
+        case ExprToken of
+        tkrecord:
+          if FromResolved.BaseType=btContext then
+            begin
+            if FromTypeEl.ClassType=TPasRecordType then
+              // typecast record to template record
+              Result:=cExact
+            else if FromTypeEl.ClassType=TPasGenericType then
+              // typecast template to template record
+              Result:=cExact;
+            end;
+        tkClass, tkconstructor:
+          Result:=cExact;
+        else
+          // identifier constraint: class or interface -> allow
+          Result:=cExact;
+          break;
+        end;
+        end;
+      end
     else if C=TPasClassOfType then
       begin
       //writeln('TPasResolver.CheckTypeCast class-of FromRes.TypeEl=',GetObjName(FromResolved.LoTypeEl),' FromRes.IdentEl=',GetObjName(FromResolved.IdentEl));

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -36,6 +36,7 @@ type
     procedure TestGen_ConstraintInheritedMissingClassTypeFail;
     procedure TestGen_ConstraintMultiParam;
     procedure TestGen_ConstraintMultiParamClassMismatch;
+    procedure TestGen_ConstraintClassType_DotIsAsTypeCast;
 
     // generic record
     procedure TestGen_RecordLocalNameDuplicateFail;
@@ -109,9 +110,6 @@ type
     // ToDo: for-in
     procedure TestGen_TryExcept;
     // ToDo: call
-    // ToDo: dot
-    // ToDo: is as
-    // ToDo: typecast
     // ToTo: nested proc
   end;
 
@@ -392,6 +390,41 @@ begin
     nIncompatibleTypesGotExpected);
 end;
 
+procedure TTestResolveGenerics.TestGen_ConstraintClassType_DotIsAsTypeCast;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  'type',
+  '  TObject = class end;',
+  '  TAnt = class',
+  '    procedure Run; external; overload;',
+  '  end;',
+  '  TRedAnt = class(TAnt)',
+  '    procedure Run(w: word); external; overload;',
+  '  end;',
+  '  generic TBird<T: TRedAnt> = class',
+  '    y: T;',
+  '    procedure Fly;',
+  '  end;',
+  '  TFireAnt = class(TRedAnt);',
+  '  generic TEagle<U: TRedAnt> = class(TBird<U>) end;',
+  '  TRedEagle = specialize TEagle<TRedAnt>;',
+  'procedure TBird.Fly;',
+  'var f: TFireAnt;',
+  'begin',
+  '  y.Run;',
+  '  y.Run(3);',
+  '  if y is TFireAnt then',
+  '    f:=y as TFireAnt;',
+  '  f:=TFireAnt(y);',
+  '  y:=T(f);',
+  'end;',
+  'begin',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolveGenerics.TestGen_RecordLocalNameDuplicateFail;
 begin
   StartProgram(false);