paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-14 16:19:35 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: specialize varargs of t

Browse Source 
git-svn-id: trunk@45526 -
This commit is contained in:
Mattias Gaertner 2020-05-29 12:48:42 +00:00
parent 651f5cb8a1
commit 73a2b46263
4 changed files with 70 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
packages/fcl-passrc/src/pasresolver.pp
View File

@ -17524,9 +17524,6 @@ var
i: Integer;
GenScope: TPasGenericScope;
begin
if GenEl.VarArgsType<>nil then
RaiseNotYetImplemented(20200524214316,GenEl,'specialize varargs of type');
if GenEl.GenericTemplateTypes<>nil then
begin
GenScope:=TPasGenericScope(PushScope(SpecEl,TPasProcTypeScope));
@ -17548,6 +17545,8 @@ begin
{$IFDEF CheckPasTreeRefCount},'TPasProcedureType.Args'{$ENDIF});
for i:=0 to SpecEl.Args.Count-1 do
FinishArgument(TPasArgument(SpecEl.Args[i]));
// varargs
SpecializeElType(GenEl,SpecEl,GenEl.VarArgsType,SpecEl.VarArgsType);
// calling convention and proc type modifiers
SpecEl.CallingConvention:=GenEl.CallingConvention;

28
packages/fcl-passrc/tests/tcresolvegenerics.pas
View File

@ -95,6 +95,7 @@ type
// generic external class
procedure TestGen_ExtClass_Array;
procedure TestGen_ExtClass_VarargsOfType;
// generic interface
procedure TestGen_ClassInterface;
@ -1561,6 +1562,33 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_ExtClass_VarargsOfType;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'{$modeswitch externalclass}',
'type',
' TJSObject = class external name ''Object''',
' end;',
' generic TGJSSet<T> = class external name ''Set''',
' constructor new(aElement1: T); varargs of T; overload;',
' function bind(thisArg: TJSObject): T; varargs of T;',
' end;',
' TJSWordSet = specialize TGJSSet<word>;',
'var',
' s: TJSWordSet;',
' w: word;',
'begin',
' s:=TJSWordSet.new(3);',
' s:=TJSWordSet.new(3,5);',
' w:=s.bind(nil);',
' w:=s.bind(nil,6);',
' w:=s.bind(nil,7,8);',
'']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_ClassInterface;
begin
StartProgram(false);

40
packages/pastojs/tests/tcgenerics.pas
View File

@ -36,6 +36,7 @@ type
// ToDo: rename local const T
Procedure TestGen_Class_TypeCastSpecializesWarn;
Procedure TestGen_Class_TypeCastSpecializesJSValueNoWarn;
procedure TestGen_Class_VarArgsOfType;
// generic external class
procedure TestGen_ExtClass_Array;
@ -728,6 +729,45 @@ begin
CheckResolverUnexpectedHints();
end;
procedure TTestGenerics.TestGen_Class_VarArgsOfType;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'{$modeswitch externalclass}',
'type',
' TJSObject = class external name ''Object''',
' end;',
' generic TGJSSet<T> = class external name ''Set''',
' constructor new(aElement1: T); varargs of T; overload;',
' function bind(thisArg: TJSObject): T; varargs of T;',
' end;',
' TJSWordSet = specialize TGJSSet<word>;',
'var',
' s: TJSWordSet;',
' w: word;',
'begin',
' s:=TJSWordSet.new(3);',
' s:=TJSWordSet.new(3,5);',
' w:=s.bind(nil);',
' w:=s.bind(nil,6);',
' w:=s.bind(nil,7,8);',
'']);
ConvertProgram;
CheckSource('TestGen_Class_VarArgsOfType',
LinesToStr([ // statements
'this.s = null;',
'this.w = 0;',
'']),
LinesToStr([ // $mod.$main
'$mod.s = new Set(3);',
'$mod.s = new Set(3, 5);',
'$mod.w = $mod.s.bind(null);',
'$mod.w = $mod.s.bind(null, 6);',
'$mod.w = $mod.s.bind(null, 7, 8);',
'']));
end;
procedure TTestGenerics.TestGen_ExtClass_Array;
begin
StartProgram(false);

4
packages/pastojs/tests/tcmodules.pas
View File

@ -874,10 +874,6 @@ type
Procedure TestAsync_ProcType;
Procedure TestAsync_ProcTypeAsyncModMismatchFail;
Procedure TestAsync_Inherited;
// ToDo: inherited;
// ToDo: inherited asyncproc;
// ToDo: await(inherited asyncproc);
// ToDo: i:=await(inherited asyncfunc)
end;
function LinesToStr(Args: array of const): string;