diff --git a/packages/fcl-passrc/src/pasresolveeval.pas b/packages/fcl-passrc/src/pasresolveeval.pas index b352c1c8ca..4ee638df2e 100644 --- a/packages/fcl-passrc/src/pasresolveeval.pas +++ b/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; diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 1ecb156934..cfa3b57a75 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/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; diff --git a/packages/pastojs/tests/tcgenerics.pas b/packages/pastojs/tests/tcgenerics.pas index 624333552c..3f0cffa1de 100644 --- a/packages/pastojs/tests/tcgenerics.pas +++ b/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 TestGeneric_Class_EmptyMethod; + Procedure TestGen_ClassEmpty; + 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 = 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;', + '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);