paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-29 20:00:19 +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} {$ifdef fpc}
{$define UsePChar} {$define UsePChar}
{$define HasInt64} {$define HasInt64}
{$IF FPC_FULLVERSION>30300}
{$WARN 6018 off : Unreachable code}
{$ENDIF}
{$endif} {$endif}
{$IFOPT Q+}{$DEFINE OverflowCheckOn}{$ENDIF} {$IFOPT Q+}{$DEFINE OverflowCheckOn}{$ENDIF}
@ -19709,7 +19712,7 @@ end;
function TPasToJSConverter.CreateCallback(Expr: TPasExpr; function TPasToJSConverter.CreateCallback(Expr: TPasExpr;
ResolvedEl: TPasResolverResult; aSafeCall: boolean; AContext: TConvertContext ResolvedEl: TPasResolverResult; aSafeCall: boolean; AContext: TConvertContext
): TJSElement; ): TJSElement;
// El is a reference to a proc // Expr is a reference to a proc
// if aSafeCall then create "rtl.createSafeCallback(Target,func)" // if aSafeCall then create "rtl.createSafeCallback(Target,func)"
// for a proc or nested proc simply use the function // for a proc or nested proc simply use the function
// for a method create "rtl.createCallback(Target,func)" // for a method create "rtl.createCallback(Target,func)"
@ -26716,9 +26719,10 @@ begin
end end
else if (ExprResolved.LoTypeEl is TPasProcedureType) else if (ExprResolved.LoTypeEl is TPasProcedureType)
and (ArgResolved.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 begin
// pass proc to SafeCall proc type // pass non safecall proc to SafeCall proc type -> make safecall
Result:=CreateSafeCallback(El,Result,AContext); Result:=CreateSafeCallback(El,Result,AContext);
end; end;
end; end;

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

@ -811,6 +811,7 @@ type
Procedure TestProcType_PassProcToArray; Procedure TestProcType_PassProcToArray;
Procedure TestProcType_SafeCallObjFPC; Procedure TestProcType_SafeCallObjFPC;
Procedure TestProcType_SafeCallDelphi; Procedure TestProcType_SafeCallDelphi;
Procedure TestProcType_SafeCall_Arg;
// pointer // pointer
Procedure TestPointer; Procedure TestPointer;
@ -29321,6 +29322,38 @@ begin
''])); '']));
end; 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; procedure TTestModule.TestPointer;
begin begin
StartProgram(false); StartProgram(false);