paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-15 20:49:23 +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); ParamType,ConstraintClass,ErrorPos);
exit(cIncompatible); exit(cIncompatible);
end; end;
if TPasClassType(ParamType).ObjKind<>okClass then if not (TPasClassType(ParamType).ObjKind in [okClass,okInterface]) then
begin begin
if ErrorPos<>nil then if ErrorPos<>nil then
RaiseMsg(20190904175144,nXExpectedButYFound,sXExpectedButYFound, RaiseMsg(20190904175144,nXExpectedButYFound,sXExpectedButYFound,
@ -29830,7 +29830,7 @@ begin
Result:=nil; Result:=nil;
while ClassEl<>nil do while ClassEl<>nil do
begin begin
if IndexOfImplementedInterface(ClassEl,Intf)>=0 then if (ClassEl=Intf) or (IndexOfImplementedInterface(ClassEl,Intf)>=0) then
exit(ClassEl); exit(ClassEl);
ClassEl:=GetPasClassAncestor(ClassEl,true) as TPasClassType; ClassEl:=GetPasClassAncestor(ClassEl,true) as TPasClassType;
end; end;

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

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

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

@ -52,6 +52,7 @@ type
// class interfaces // class interfaces
procedure TestGen_ClassInterface_Corba; procedure TestGen_ClassInterface_Corba;
procedure TestGen_ClassInterface_InterfacedObject; procedure TestGen_ClassInterface_InterfacedObject;
procedure TestGen_ClassInterface_COM_RTTI;
// statements // statements
Procedure TestGen_InlineSpec_Constructor; Procedure TestGen_InlineSpec_Constructor;
@ -1478,6 +1479,46 @@ begin
''])); '']));
end; 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; procedure TTestGenerics.TestGen_InlineSpec_Constructor;
begin begin
StartProgram(false); StartProgram(false);