fcl-passrc: replace method impl arguments with intf arguments

git-svn-id: trunk@42690 -

packages/fcl-passrc/src/pasresolveeval.pas

@@ -778,6 +778,7 @@ function CodePointToString(CodePoint: longword): String;
 function CodePointToUnicodeString(u: longword): UnicodeString;
 
 function GetObjName(o: TObject): string;
+function GetObjPath(o: TObject): string;
 function dbgs(const Flags: TResEvalFlags): string; overload;
 function dbgs(v: TResEvalValue): string; overload;
 
@@ -1004,6 +1005,34 @@ begin
     Result:=o.ClassName;
 end;
 
+function GetObjPath(o: TObject): string;
+var
+  El: TPasElement;
+begin
+  if o is TPasElement then
+    begin
+    El:=TPasElement(o);
+    Result:=':'+El.ClassName;
+    while El<>nil do
+      begin
+      if El<>o then
+        Result:='.'+Result;
+      if El.Name<>'' then
+        begin
+        if IsValidIdent(El.Name) then
+          Result:=El.Name+Result
+        else
+          Result:='"'+El.Name+'"'+Result;
+        end
+      else
+        Result:='['+El.ClassName+']'+Result;
+      El:=El.Parent;
+      end;
+    end
+  else
+    Result:=GetObjName(o);
+end;
+
 function dbgs(const Flags: TResEvalFlags): string;
 var
   s: string;

packages/fcl-passrc/src/pasresolver.pp

@@ -6673,7 +6673,12 @@ begin
     // finish interface/implementation/nested procedure
     if (ProcName<>'') and ProcNeedsBody(Proc) then
       begin
-      if not (ppsfIsSpecialized in ProcScope.Flags) then
+      if ppsfIsSpecialized in ProcScope.Flags then
+        begin
+        if ProcScope.DeclarationProc<>nil then
+          ReplaceProcScopeImplArgsWithDeclArgs(ProcScope);
+        end
+      else
         begin
         // check if there is a forward declaration
         //writeln('TPasResolver.FinishProcedureType ',GetObjName(TopScope),' ',GetObjName(Scopes[ScopeCount-2]));
@@ -6943,6 +6948,8 @@ begin
     DeclProcScope:=DeclProc.CustomData as TPasProcedureScope;
     if DeclProcScope.ImplProc<>ImplProc then
       RaiseNotYetImplemented(20190804182220,ImplProc);
+    // replace arguments in scope with declaration arguments
+    ReplaceProcScopeImplArgsWithDeclArgs(ImplProcScope);
     end
   else
     RaiseNotYetImplemented(20190804181222,ImplProc);
@@ -14938,9 +14945,10 @@ var
   GenIntfProcScope, SpecIntfProcScope, GenImplProcScope,
     SpecImplProcScope: TPasProcedureScope;
   NewClass: TPTreeElement;
-  OldStashCount, i: Integer;
+  OldStashCount, i, p, LastDotP: Integer;
   SpecClassOrRecScope: TPasClassOrRecordScope;
   GenScope: TPasGenericScope;
+  NewImplProcName, OldClassname: String;
 begin
   // check generic type is resolved completely
   GenScope:=TPasGenericScope(GenericType.CustomData);
@@ -15006,7 +15014,17 @@ begin
           RaiseNotYetImplemented(20190804130322,GenImplProc,GetObjName(ImplParent));
 
         // create impl proc
-        SpecImplProc:=TPasProcedure(NewClass.Create(GenImplProc.Name,GenImplProc.Parent));
+        NewImplProcName:=GenImplProc.Name;
+        p:=length(NewImplProcName);
+        while (p>1) and (NewImplProcName[p]<>'.') do dec(p);
+        LastDotP:=p;
+        while (p>1) and (NewImplProcName[p-1]<>'.') do dec(p);
+        OldClassname:=copy(NewImplProcName,p,LastDotP-p);
+        if not SameText(OldClassname,GenClassOrRec.Name) then
+          RaiseNotYetImplemented(20190814141833,GenImplProc);
+        NewImplProcName:=LeftStr(NewImplProcName,p-1)+SpecClassOrRec.Name+copy(NewImplProcName,LastDotP,length(NewImplProcName));
+
+        SpecImplProc:=TPasProcedure(NewClass.Create(NewImplProcName,GenImplProc.Parent));
         SpecIntfProcScope.ImplProc:=SpecImplProc;
         if SpecializedItem.ImplProcs=nil then
           SpecializedItem.ImplProcs:=TFPList.Create;

packages/pastojs/tests/tcgenerics.pas

@@ -15,11 +15,12 @@ type
   TTestGenerics = class(TCustomTestModule)
   Published
     // generic record
-    Procedure TestGeneric_RecordEmpty;
+    Procedure TestGen_RecordEmpty;
 
     // generic class
-    Procedure TestGeneric_ClassEmpty;
+    Procedure TestGen_ClassEmpty;
-    Procedure TestGeneric_Class_EmptyMethod;
+    Procedure TestGen_Class_EmptyMethod;
+    Procedure TestGen_Class_TList;
 
     // generic external class
     procedure TestGen_ExtClass_Array;
@@ -29,7 +30,7 @@ implementation
 
 { TTestGenerics }
 
-procedure TTestGenerics.TestGeneric_RecordEmpty;
+procedure TTestGenerics.TestGen_RecordEmpty;
 begin
   StartProgram(false);
   Add([
@@ -40,7 +41,7 @@ begin
   'begin',
   '  if a=b then ;']);
   ConvertProgram;
-  CheckSource('TestGeneric_RecordEmpty',
+  CheckSource('TestGen_RecordEmpty',
     LinesToStr([ // statements
     'rtl.recNewT($mod, "TRecA$G1", function () {',
     '  this.$eq = function (b) {',
@@ -58,7 +59,7 @@ begin
     ]));
 end;
 
-procedure TTestGenerics.TestGeneric_ClassEmpty;
+procedure TTestGenerics.TestGen_ClassEmpty;
 begin
   StartProgram(false);
   Add([
@@ -70,7 +71,7 @@ begin
   'begin',
   '  if a=b then ;']);
   ConvertProgram;
-  CheckSource('TestGeneric_ClassEmpty',
+  CheckSource('TestGen_ClassEmpty',
     LinesToStr([ // statements
     'rtl.createClass($mod, "TObject", null, function () {',
     '  this.$init = function () {',
@@ -88,7 +89,7 @@ begin
     ]));
 end;
 
-procedure TTestGenerics.TestGeneric_Class_EmptyMethod;
+procedure TTestGenerics.TestGen_Class_EmptyMethod;
 begin
   StartProgram(false);
   Add([
@@ -104,7 +105,7 @@ begin
   'begin',
   '  if a.Fly(3)=4 then ;']);
   ConvertProgram;
-  CheckSource('TestGeneric_Class_EmptyMethod',
+  CheckSource('TestGen_Class_EmptyMethod',
     LinesToStr([ // statements
     'rtl.createClass($mod, "TObject", null, function () {',
     '  this.$init = function () {',
@@ -125,6 +126,84 @@ begin
     ]));
 end;
 
+procedure TTestGenerics.TestGen_Class_TList;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  'type',
+  '  TObject = class end;',
+  '  generic TList<T> = class',
+  '  strict private',
+  '    FItems: array of T;',
+  '    function GetItems(Index: longint): T;',
+  '    procedure SetItems(Index: longint; Value: T);',
+  '  public',
+  '    procedure Alter(w: T);',
+  '    property Items[Index: longint]: T read GetItems write SetItems; default;',
+  '  end;',
+  '  TWordList = specialize TList<word>;',
+  'function TList.GetItems(Index: longint): T;',
+  'begin',
+  '  Result:=FItems[Index];',
+  'end;',
+  'procedure TList.SetItems(Index: longint; Value: T);',
+  'begin',
+  '  FItems[Index]:=Value;',
+  'end;',
+  'procedure TList.Alter(w: T);',
+  'begin',
+  '  SetLength(FItems,length(FItems)+1);',
+  '  Insert(w,FItems,2);',
+  '  Delete(FItems,2,3);',
+  'end;',
+  'var l: TWordList;',
+  '  w: word;',
+  'begin',
+  '  l[1]:=w;',
+  '  w:=l[2];',
+  '']);
+  ConvertProgram;
+  CheckSource('TestGen_Class_TList',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'rtl.createClass($mod, "TList$G1", $mod.TObject, function () {',
+    '  this.$init = function () {',
+    '    $mod.TObject.$init.call(this);',
+    '    this.FItems = [];',
+    '  };',
+    '  this.$final = function () {',
+    '    this.FItems = undefined;',
+    '    $mod.TObject.$final.call(this);',
+    '  };',
+    '  this.GetItems = function (Index) {',
+    '    var Result = 0;',
+    '    Result = this.FItems[Index];',
+    '    return Result;',
+    '  };',
+    '  this.SetItems = function (Index, Value) {',
+    '    this.FItems[Index] = Value;',
+    '  };',
+    '  this.Alter = function (w) {',
+    '    this.FItems = rtl.arraySetLength(this.FItems, 0, rtl.length(this.FItems) + 1);',
+    '    this.FItems.splice(2, 0, w);',
+    '    this.FItems.splice(2, 3);',
+    '  };',
+    '});',
+    'this.l = null;',
+    'this.w = 0;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.l.SetItems(1, $mod.w);',
+    '$mod.w = $mod.l.GetItems(2);',
+    '']));
+end;
+
 procedure TTestGenerics.TestGen_ExtClass_Array;
 begin
   StartProgram(false);