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

pastojs: specialize with interface constraints, issue #37690

Browse Source 
git-svn-id: trunk@46971 -
This commit is contained in:
Mattias Gaertner 2020-09-27 08:21:21 +00:00
parent 35f59b6736
commit ea0fb9a8b4
3 changed files with 54 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16315,7 +16315,7 @@ begin
ParamType,ConstraintClass,ErrorPos);
exit(cIncompatible);
end;
if TPasClassType(ParamType).ObjKind<>okClass then
if not (TPasClassType(ParamType).ObjKind in [okClass,okInterface]) then
begin
if ErrorPos<>nil then
RaiseMsg(20190904175144,nXExpectedButYFound,sXExpectedButYFound,
@ -29830,7 +29830,7 @@ begin
Result:=nil;
while ClassEl<>nil do
begin
if IndexOfImplementedInterface(ClassEl,Intf)>=0 then
if (ClassEl=Intf) or (IndexOfImplementedInterface(ClassEl,Intf)>=0) then
exit(ClassEl);
ClassEl:=GetPasClassAncestor(ClassEl,true) as TPasClassType;
end;

16
packages/pastojs/src/fppas2js.pp
View File

@ -5658,12 +5658,18 @@ begin
else
if not (ConEl is TPasType) then
RaiseNotYetImplemented(20191018180031,ConEl,GetObjPath(Param));
if ConEl is TPasClassType then
begin
if TPasClassType(ConEl).IsExternal then
TIName:=Pas2JSBuiltInNames[pbitnTIExtClass]
TypeEl:=ResolveAliasType(TPasType(ConEl));
if TypeEl is TPasClassType then
case TPasClassType(TypeEl).ObjKind of
okClass:
if TPasClassType(TypeEl).IsExternal then
TIName:=Pas2JSBuiltInNames[pbitnTIExtClass]
else
TIName:=Pas2JSBuiltInNames[pbitnTIClass];
okInterface:
TIName:=Pas2JSBuiltInNames[pbitnTIInterface];
else
TIName:=Pas2JSBuiltInNames[pbitnTIClass];
RaiseNotYetImplemented(20200927100825,ConEl,GetObjPath(Param));
end
else
RaiseNotYetImplemented(20191018180131,ConEl,GetObjPath(Param));

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

@ -52,6 +52,7 @@ type
// class interfaces
procedure TestGen_ClassInterface_Corba;
procedure TestGen_ClassInterface_InterfacedObject;
procedure TestGen_ClassInterface_COM_RTTI;
// statements
Procedure TestGen_InlineSpec_Constructor;
@ -1478,6 +1479,46 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_ClassInterface_COM_RTTI;
begin
StartProgram(true,[supTInterfacedObject]);
Add([
'{$mode delphi}',
'type',
' TBird = class',
' function Fly<T: IInterface>: T;',
' end;',
' IAnt = interface',
' procedure InterfaceProc;',
' end;',
'function TBird.Fly<T>: T;',
'begin',
' if TypeInfo(T)=nil then ;',
'end;',
'var Bird: TBird;',
' Ant: IAnt;',
'begin',
' Ant := Bird.Fly<IAnt>;',
'']);
ConvertProgram;
CheckSource('TestGen_ClassInterface_COM_RTTI',
LinesToStr([ // statements
'rtl.createClass(this, "TBird", pas.system.TObject, function () {',
' this.Fly$G1 = function () {',
' var Result = null;',
' if ($mod.$rtti["IAnt"] === null) ;',
' return Result;',
' };',
'});',
'rtl.createInterface(this, "IAnt", "{B9D0FF27-A446-3A1B-AA85-F167837AA297}", ["InterfaceProc"], pas.system.IUnknown);',
'this.Bird = null;',
'this.Ant = null;',
'']),
LinesToStr([ // $mod.$main
'rtl.setIntfP($mod, "Ant", $mod.Bird.Fly$G1(), true);',
'']));
end;
procedure TTestGenerics.TestGen_InlineSpec_Constructor;
begin
StartProgram(false);