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

pastojs: fixed pass non safecall proctype to safecall proc type arg, issue #39261

Browse Source
This commit is contained in:
mattias 2023-05-13 11:06:57 +02:00 committed by Pierre Muller
parent a9a4f225c2
commit 0211c085e9
2 changed files with 40 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -460,6 +460,9 @@ unit FPPas2Js;
{$ifdef fpc}
{$define UsePChar}
{$define HasInt64}
{$IF FPC_FULLVERSION>30300}
{$WARN 6018 off : Unreachable code}
{$ENDIF}
{$endif}
{$IFOPT Q+}{$DEFINE OverflowCheckOn}{$ENDIF}
@ -19709,7 +19712,7 @@ end;
function TPasToJSConverter.CreateCallback(Expr: TPasExpr;
ResolvedEl: TPasResolverResult; aSafeCall: boolean; AContext: TConvertContext
): TJSElement;
// El is a reference to a proc
// Expr is a reference to a proc
// if aSafeCall then create "rtl.createSafeCallback(Target,func)"
// for a proc or nested proc simply use the function
// for a method create "rtl.createCallback(Target,func)"
@ -26716,9 +26719,10 @@ begin
end
else if (ExprResolved.LoTypeEl is TPasProcedureType)
and (ArgResolved.LoTypeEl is TPasProcedureType)
and (TPasProcedureType(ArgResolved.LoTypeEl).CallingConvention=ccSafeCall) then
and (TPasProcedureType(ArgResolved.LoTypeEl).CallingConvention=ccSafeCall)
and (TPasProcedureType(ExprResolved.LoTypeEl).CallingConvention<>ccSafeCall) then
begin
// pass proc to SafeCall proc type
// pass non safecall proc to SafeCall proc type -> make safecall
Result:=CreateSafeCallback(El,Result,AContext);
end;
end;

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

@ -811,6 +811,7 @@ type
Procedure TestProcType_PassProcToArray;
Procedure TestProcType_SafeCallObjFPC;
Procedure TestProcType_SafeCallDelphi;
Procedure TestProcType_SafeCall_Arg;
// pointer
Procedure TestPointer;
@ -29321,6 +29322,38 @@ begin
'']));
end;
procedure TTestModule.TestProcType_SafeCall_Arg;
begin
StartProgram(false);
Add([
'type',
' TSafecallProc = reference to procedure; safecall;',
'procedure Fly(const aHandler: TSafecallProc);',
'var',
' P: TSafecallProc;',
'begin',
' P := aHandler;',
' Fly(P);',
' Fly(aHandler);',
'end;',
'begin',
' Fly(nil);',
'']);
ConvertProgram;
CheckSource('TestProcType_SafeCall_Arg',
LinesToStr([ // statements
'this.Fly = function (aHandler) {',
' var P = null;',
' P = aHandler;',
' $mod.Fly(P);',
' $mod.Fly(aHandler);',
'};',
'']),
LinesToStr([ // $mod.$main
'$mod.Fly(null);',
'']));
end;
procedure TTestModule.TestPointer;
begin
StartProgram(false);