pas2js: fixed check if specialized class interface is needed

git-svn-id: trunk@45545 -

packages/fcl-passrc/src/pasresolver.pp

@@ -18122,6 +18122,10 @@ begin
     end;
 
   FinishAncestors(SpecEl);
+
+  if GenEl.Interfaces.Count<>SpecEl.Interfaces.Count then
+    RaiseNotYetImplemented(20200601125556,GenEl,IntToStr(GenEl.Interfaces.Count)+'<>'+IntToStr(SpecEl.Interfaces.Count));
+
   // Note: class scope was created by FinishAncestors
   SpecClassScope:=NoNil(SpecEl.CustomData) as TPasClassScope;
 

packages/pastojs/src/fppas2js.pp

@@ -753,7 +753,7 @@ const
     '$new', // helpertype.$new
     '_AddRef', // rtl._AddRef
     '_Release', // rtl._Release
-    'addIntf', // rtl.addIntf
+    'addIntf', // rtl.addIntf  pbifnIntfAddMap
     'intfAsClass', // rtl.intfAsClass
     'intfAsIntfT', // rtl.intfAsIntfT
     'createInterface', // rtl.createInterface
@@ -19139,8 +19139,15 @@ end;
 procedure TPasToJSConverter.AddClassSupportedInterfaces(El: TPasClassType;
   Src: TJSSourceElements; FuncContext: TFunctionContext);
 
-  function IsMemberNeeded(aMember: TPasElement): boolean;
+  function IsClassInterfaceNeeded(aMember: TPasElement): boolean;
+  var
+    SpecData: TPasSpecializeTypeData;
   begin
+    if aMember is TPasSpecializeType then
+      begin
+      SpecData:=aMember.CustomData as TPasSpecializeTypeData;
+      aMember:=SpecData.SpecializedType;
+      end;
     if IsElementUsed(aMember) then exit(true);
     Result:=false;
   end;
@@ -19202,7 +19209,7 @@ begin
       for i:=0 to Scope.Interfaces.Count-1 do
         begin
         CurEl:=TPasClassType(Scope.Element);
-        if not IsMemberNeeded(TPasElement(CurEl.Interfaces[i])) then continue;
+        if not IsClassInterfaceNeeded(TPasElement(CurEl.Interfaces[i])) then continue;
         HasInterfaces:=true;
         o:=TObject(Scope.Interfaces[i]);
         if o is TPasProperty then
@@ -19225,7 +19232,7 @@ begin
         for i:=0 to Scope.Interfaces.Count-1 do
           begin
           CurEl:=TPasClassType(Scope.Element);
-          if not IsMemberNeeded(TPasElement(CurEl.Interfaces[i])) then continue;
+          if not IsClassInterfaceNeeded(TPasElement(CurEl.Interfaces[i])) then continue;
           if NeedIntfMap then
             begin
             // add "this.$intfmaps = {};"

packages/pastojs/tests/tcgenerics.pas

@@ -44,6 +44,10 @@ type
     procedure TestGen_ExtClass_AliasMemberType;
     Procedure TestGen_ExtClass_RTTI;
 
+    // class interfaces
+    procedure TestGen_ClassInterface_Corba;
+    procedure TestGen_ClassInterface_InterfacedObject;
+
     // statements
     Procedure TestGen_InlineSpec_Constructor;
     Procedure TestGen_CallUnitImplProc;
@@ -918,6 +922,95 @@ begin
     '']));
 end;
 
+procedure TTestGenerics.TestGen_ClassInterface_Corba;
+begin
+  StartProgram(false);
+  Add([
+  '{$interfaces corba}',
+  'type',
+  '  IUnknown = interface;',
+  '  IUnknown = interface',
+  '    [''{00000000-0000-0000-C000-000000000046}'']',
+  '  end;',
+  '  IInterface = IUnknown;',
+  '  generic IBird<T> = interface(IInterface)',
+  '    function GetSize: T;',
+  '    procedure SetSize(i: T);',
+  '    property Size: T read GetSize write SetSize;',
+  '    procedure DoIt(i: T);',
+  '  end;',
+  '  TObject = class',
+  '  end;',
+  '  generic TBird<T> = class(TObject,specialize IBird<T>)',
+  '    function GetSize: T; virtual; abstract;',
+  '    procedure SetSize(i: T); virtual; abstract;',
+  '    procedure DoIt(i: T); virtual; abstract;',
+  '  end;',
+  '  IWordBird = specialize IBird<Word>;',
+  '  TWordBird = specialize TBird<Word>;',
+  'var',
+  '  BirdIntf: IWordBird;',
+  'begin',
+  '  BirdIntf.Size:=BirdIntf.Size;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_ClassInterface_Corba',
+    LinesToStr([ // statements
+    'rtl.createInterface($mod, "IUnknown", "{00000000-0000-0000-C000-000000000046}", [], null);',
+    'rtl.createInterface($mod, "IBird$G2", "{7D9907A1-5178-37B5-9D32-7BC020005905}", ["GetSize", "SetSize", "DoIt"], $mod.IUnknown);',
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'rtl.createClass($mod, "TBird$G1", $mod.TObject, function () {',
+    '  rtl.addIntf(this, $mod.IBird$G2);',
+    '});',
+    'this.BirdIntf = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.BirdIntf.SetSize($mod.BirdIntf.GetSize());',
+    '']));
+end;
+
+procedure TTestGenerics.TestGen_ClassInterface_InterfacedObject;
+begin
+  StartProgram(true,[supTInterfacedObject]);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  IComparer<T> = interface [''{505778ED-F783-4456-9691-32F419CC5E18}'']',
+  '    function Compare(const Left, Right: T): Integer; overload;',
+  '  end;',
+  '  TComparer<T> = class(TInterfacedObject, IComparer<T>)',
+  '    function Compare(const Left, Right: T): Integer;',
+  '  end;',
+  'function TComparer<T>.Compare(const Left, Right: T): Integer; begin end;',
+  'var',
+  '  aComparer : IComparer<Integer>;',
+  'begin',
+  '  aComparer:=TComparer<Integer>.Create;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_ClassInterface_InterfacedObject',
+    LinesToStr([ // statements
+    'rtl.createInterface($mod, "IComparer$G2", "{505778ED-F783-4456-9691-32F419CC5E18}", ["Compare"], pas.system.IUnknown);',
+    'rtl.createClass($mod, "TComparer$G1", pas.system.TInterfacedObject, function () {',
+    '  this.Compare = function (Left, Right) {',
+    '    var Result = 0;',
+    '    return Result;',
+    '  };',
+    '  rtl.addIntf(this, $mod.IComparer$G2);',
+    '  rtl.addIntf(this, pas.system.IUnknown);',
+    '});',
+    'this.aComparer = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    'rtl.setIntfP($mod, "aComparer", rtl.queryIntfT($mod.TComparer$G1.$create("Create"), $mod.IComparer$G2), true);',
+    '']));
+end;
+
 procedure TTestGenerics.TestGen_InlineSpec_Constructor;
 begin
   StartProgram(false);

packages/pastojs/tests/tcmodules.pas

@@ -52,7 +52,8 @@ type
   TSystemUnitPart = (
     supTObject,
     supTVarRec,
-    supTypeInfo
+    supTypeInfo,
+    supTInterfacedObject
     );
   TSystemUnitParts = set of TSystemUnitPart;
 
@@ -1587,7 +1588,9 @@ var
   Intf, Impl: TStringList;
 begin
   Intf:=TStringList.Create;
-  // interface
+  if supTInterfacedObject in Parts then Include(Parts,supTObject);
+
+  // unit interface
   if [supTVarRec,supTypeInfo]*Parts<>[] then
     Intf.Add('{$modeswitch externalclass}');
   Intf.Add('type');
@@ -1617,6 +1620,27 @@ begin
     '    function Equals(Obj: TObject): boolean; virtual;',
     '    function ToString: String; virtual;',
     '  end;']);
+  if supTInterfacedObject in Parts then
+    Intf.AddStrings([
+    '  {$Interfaces COM}',
+    '  IUnknown = interface',
+    '    [''{00000000-0000-0000-C000-000000000046}'']',
+    //'    function QueryInterface(const iid: TGuid; out obj): Integer;',
+    '    function _AddRef: Integer;',
+    '    function _Release: Integer;',
+    '  end;',
+    '  IInterface = IUnknown;',
+    '  TInterfacedObject = class(TObject,IUnknown)',
+    '  protected',
+    '    fRefCount: Integer;',
+    '    { implement methods of IUnknown }',
+    //'    function QueryInterface(const iid: TGuid; out obj): Integer; virtual;',
+    '    function _AddRef: Integer; virtual;',
+    '    function _Release: Integer; virtual;',
+    '  end;',
+    '  TInterfacedClass = class of TInterfacedObject;',
+    '',
+    '']);
   if supTVarRec in Parts then
     Intf.AddStrings([
     'const',
@@ -1659,7 +1683,7 @@ begin
   Intf.Add('var');
   Intf.Add('  ExitCode: Longint = 0;');
 
-  // implementation
+  // unit implementation
   Impl:=TStringList.Create;
   if supTObject in Parts then
     Impl.AddStrings([
@@ -1699,6 +1723,18 @@ begin
       '  Result:=ClassName;',
       'end;'
       ]);
+  if supTInterfacedObject in Parts then
+    Impl.AddStrings([
+    //'function TInterfacedObject.QueryInterface(const iid: TGuid; out obj): Integer;',
+    //'begin',
+    //'end;',
+    'function TInterfacedObject._AddRef: Integer;',
+    'begin',
+    'end;',
+    'function TInterfacedObject._Release: Integer;',
+    'begin',
+    'end;',
+    '']);
   if supTVarRec in Parts then
     Impl.AddStrings([
     'function VarRecs: TVarRecArray; varargs;',