paweld/pas2js
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/pas2js.git synced 2025-04-13 15:39:22 +02:00
Code Issues Packages Projects Releases Wiki Activity

pastojs: fixed pass proc adress to proc type arg

Browse Source
This commit is contained in:
mattias 2020-10-21 23:29:41 +00:00
parent b6c3045172
commit 7e1adf88b7
2 changed files with 65 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
compiler/packages/pastojs/src/fppas2js.pp
View File

@ -16268,7 +16268,7 @@ begin
if NeedClass then
// append '.$class'
TargetJS:=CreateDotExpression(Expr,TargetJS,
CreatePrimitiveDotExpr(GetBIName(pbivnPtrClass),PosEl));
CreatePrimitiveDotExpr(GetBIName(pbivnPtrClass),PosEl));
Call:=CreateCallExpression(Expr);
// "rtl.createCallback"
@ -21525,6 +21525,9 @@ begin
aResolver.ComputeElement(El,ExprResolved,ExprFlags);
ExprIsTempValid:=false;
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.CreateProcCallArg Arg=',GetResolverResultDbg(ArgResolved),' Expr=',GetResolverResultDbg(ExprResolved));
{$ENDIF}
// consider TargetArg access
if NeedVar then
@ -21536,14 +21539,25 @@ begin
if ArgTypeIsArray then
begin
// array as argument
if ExprResolved.BaseType=btNil then
begin
// nil to array -> pass []
Result:=TJSArrayLiteral(CreateElement(TJSArrayLiteral,El));
exit;
end
else
Result:=CreateArrayInit(TPasArrayType(ArgTypeEl),El,El,AContext);
end
else if ExprResolved.BaseType=btProc then
begin
if (ArgTypeEl is TPasProcedureType)
and (msDelphi in AContext.CurrentModeSwitches)
and (ExprResolved.IdentEl is TPasProcedure) then
begin
// Delphi allows passing a proc address without @
Result:=CreateCallback(El,ExprResolved,AContext);
end;
// array as argument
Result:=CreateArrayInit(TPasArrayType(ArgTypeEl),El,El,AContext);
end;
if Result=nil then

48
compiler/packages/pastojs/tests/tcmodules.pas
View File

@ -518,6 +518,7 @@ type
Procedure TestClass_WithClassInstDoProperty;
Procedure TestClass_WithClassInstDoPropertyWithParams;
Procedure TestClass_WithClassInstDoFunc;
Procedure TestClass_ProcVarDelphi;
Procedure TestClass_TypeCast;
Procedure TestClass_TypeCastUntypedParam;
Procedure TestClass_Overloads;
@ -13479,6 +13480,53 @@ begin
'']));
end;
procedure TTestModule.TestClass_ProcVarDelphi;
begin
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TProc = procedure of object;',
' TObject = class',
' procedure Run;',
' procedure Fly(const p: TProc);',
' end;',
'procedure TObject.Run;',
'var o: TObject;',
'begin',
' Fly(Run);',
' Fly(Self.Run);',
' with Self do Fly(Run);',
' with o do Fly(Run);',
'end;',
'procedure TObject.Fly(const p: TProc);',
'begin',
'end;',
'begin',
'']);
ConvertProgram;
CheckSource('TestClass_ProcVarDelphi',
LinesToStr([ // statements
'rtl.createClass($mod, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
' this.Run = function () {',
' var o = null;',
' this.Fly(rtl.createCallback(this, "Run"));',
' this.Fly(rtl.createCallback(this, "Run"));',
' this.Fly(rtl.createCallback(this, "Run"));',
' o.Fly(rtl.createCallback(o, "Run"));',
' };',
' this.Fly = function (p) {',
' };',
'});',
'']),
LinesToStr([ // $mod.$main
'']));
end;
procedure TTestModule.TestClass_TypeCast;
begin
StartProgram(false);