mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-09 07:08:29 +02:00
fcl-passrc: replace method impl arguments with intf arguments
git-svn-id: trunk@42690 -
This commit is contained in:
Mattias Gaertner
parent
55b1f676dc
commit
35d7fade97
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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<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);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user