pastojs: specialize with interface constraints, issue #37690

git-svn-id: trunk@46971 -

packages/fcl-passrc/src/pasresolver.pp

@@ -16315,7 +16315,7 @@ begin
                               ParamType,ConstraintClass,ErrorPos);
       exit(cIncompatible);
       end;
-    if TPasClassType(ParamType).ObjKind<>okClass then
+    if not (TPasClassType(ParamType).ObjKind in [okClass,okInterface]) then
       begin
       if ErrorPos<>nil then
         RaiseMsg(20190904175144,nXExpectedButYFound,sXExpectedButYFound,
@@ -29830,7 +29830,7 @@ begin
   Result:=nil;
   while ClassEl<>nil do
     begin
-    if IndexOfImplementedInterface(ClassEl,Intf)>=0 then
+    if (ClassEl=Intf) or (IndexOfImplementedInterface(ClassEl,Intf)>=0) then
       exit(ClassEl);
     ClassEl:=GetPasClassAncestor(ClassEl,true) as TPasClassType;
     end;

packages/pastojs/src/fppas2js.pp

@@ -5658,12 +5658,18 @@ begin
         else
           if not (ConEl is TPasType) then
             RaiseNotYetImplemented(20191018180031,ConEl,GetObjPath(Param));
-          if ConEl is TPasClassType then
-            begin
-            if TPasClassType(ConEl).IsExternal then
-              TIName:=Pas2JSBuiltInNames[pbitnTIExtClass]
+          TypeEl:=ResolveAliasType(TPasType(ConEl));
+          if TypeEl is TPasClassType then
+            case TPasClassType(TypeEl).ObjKind of
+            okClass:
+              if TPasClassType(TypeEl).IsExternal then
+                TIName:=Pas2JSBuiltInNames[pbitnTIExtClass]
+              else
+                TIName:=Pas2JSBuiltInNames[pbitnTIClass];
+            okInterface:
+              TIName:=Pas2JSBuiltInNames[pbitnTIInterface];
             else
-              TIName:=Pas2JSBuiltInNames[pbitnTIClass];
+              RaiseNotYetImplemented(20200927100825,ConEl,GetObjPath(Param));
             end
           else
             RaiseNotYetImplemented(20191018180131,ConEl,GetObjPath(Param));

packages/pastojs/tests/tcgenerics.pas

@@ -52,6 +52,7 @@ type
     // class interfaces
     procedure TestGen_ClassInterface_Corba;
     procedure TestGen_ClassInterface_InterfacedObject;
+    procedure TestGen_ClassInterface_COM_RTTI;
 
     // statements
     Procedure TestGen_InlineSpec_Constructor;
@@ -1478,6 +1479,46 @@ begin
     '']));
 end;
 
+procedure TTestGenerics.TestGen_ClassInterface_COM_RTTI;
+begin
+  StartProgram(true,[supTInterfacedObject]);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TBird = class',
+  '    function Fly<T: IInterface>: T;',
+  '  end;',
+  '  IAnt = interface',
+  '    procedure InterfaceProc;',
+  '  end;',
+  'function TBird.Fly<T>: T;',
+  'begin',
+  '  if TypeInfo(T)=nil then ;',
+  'end;',
+  'var Bird: TBird;',
+  '  Ant: IAnt;',
+  'begin',
+  '  Ant := Bird.Fly<IAnt>;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_ClassInterface_COM_RTTI',
+    LinesToStr([ // statements
+    'rtl.createClass(this, "TBird", pas.system.TObject, function () {',
+    '  this.Fly$G1 = function () {',
+    '    var Result = null;',
+    '    if ($mod.$rtti["IAnt"] === null) ;',
+    '    return Result;',
+    '  };',
+    '});',
+    'rtl.createInterface(this, "IAnt", "{B9D0FF27-A446-3A1B-AA85-F167837AA297}", ["InterfaceProc"], pas.system.IUnknown);',
+    'this.Bird = null;',
+    'this.Ant = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    'rtl.setIntfP($mod, "Ant", $mod.Bird.Fly$G1(), true);',
+    '']));
+end;
+
 procedure TTestGenerics.TestGen_InlineSpec_Constructor;
 begin
   StartProgram(false);