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

pas2js: safecall for procedure

Browse Source 
git-svn-id: trunk@45416 -
This commit is contained in:
Mattias Gaertner 2020-05-18 10:46:54 +00:00
parent ce6789bdbf
commit fef402f6e6
2 changed files with 82 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16955,13 +16955,13 @@ begin
// not an "of object" method -> simply use the function
Result:=CreateReferencePathExpr(Proc,AContext);
if aSafeCall then
RaiseNotSupported(Expr,AContext,20200516144151,'safecall without object');
Result:=CreateSafeCallback(Expr,Result,AContext);
exit;
end;
IsHelper:=aResolver.IsHelperMethod(Proc);
NeedClass:=aResolver.IsClassMethod(Proc) and not aResolver.MethodIsStatic(Proc);
// a safcall or of-object method -> create "rtl.createCallback(Target,func)"
// an of-object method -> create "rtl.createCallback(Target,func)"
TargetJS:=nil;
Call:=nil;
try

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

@ -26354,55 +26354,82 @@ begin
Add([
'{$modeswitch externalclass}',
'type',
' TProc = reference to procedure(i: longint); safecall;',
' TEvent = procedure(i: longint) of object; safecall;',
' TExtA = class external name ''ExtObj''',
' procedure DoIt(Id: longint = 1); external name ''$Execute'';',
' procedure DoSome(Id: longint = 1);',
' procedure SetOnClick(const e: TEvent);',
' property OnClick: TEvent write SetOnClick;',
' class procedure Fly(Id: longint = 1); static;',
' procedure SetOnShow(const p: TProc);',
' property OnShow: TProc write SetOnShow;',
' end;',
'procedure Run(i: longint = 1);',
'begin',
'end;',
'var',
' Obj: texta;',
' p: TEvent;',
' e: TEvent;',
' p: TProc;',
'begin',
' p:=p;',
' p:=@obj.doit;',
' p:=@obj.dosome;',
' p:=TEvent(@obj.dosome);', // no safecall
' e:=e;',
' e:=@obj.doit;',
' e:=@obj.dosome;',
' e:=TEvent(@obj.dosome);', // no safecall
' obj.OnClick:=@obj.doit;',
' obj.OnClick:=@obj.dosome;',
' obj.setonclick(@obj.doit);',
' obj.setonclick(@obj.dosome);',
' p:=@Run;',
' p:=@TExtA.Fly;',
' obj.OnShow:=@Run;',
' obj.OnShow:=@TExtA.Fly;',
' obj.setOnShow(@Run);',
' obj.setOnShow(@TExtA.Fly);',
' with obj do begin',
' p:=@doit;',
' p:=@dosome;',
' e:=@doit;',
' e:=@dosome;',
' OnClick:=@doit;',
' OnClick:=@dosome;',
' setonclick(@doit);',
' setonclick(@dosome);',
' OnShow:=@Run;',
' setOnShow(@Run);',
' end;']);
ConvertProgram;
CheckSource('TestProcType_SafeCallObjFPC',
LinesToStr([ // statements
'this.Run = function (i) {',
'};',
'this.Obj = null;',
'this.e = null;',
'this.p = null;',
'']),
LinesToStr([ // $mod.$main
'$mod.p = $mod.p;',
'$mod.p = rtl.createSafeCallback($mod.Obj, "$Execute");',
'$mod.p = rtl.createSafeCallback($mod.Obj, "DoSome");',
'$mod.p = rtl.createCallback($mod.Obj, "DoSome");',
'$mod.e = $mod.e;',
'$mod.e = rtl.createSafeCallback($mod.Obj, "$Execute");',
'$mod.e = rtl.createSafeCallback($mod.Obj, "DoSome");',
'$mod.e = rtl.createCallback($mod.Obj, "DoSome");',
'$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "$Execute"));',
'$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "DoSome"));',
'$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "$Execute"));',
'$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "DoSome"));',
'$mod.p = rtl.createSafeCallback($mod, "Run");',
'$mod.p = rtl.createSafeCallback(ExtObj, "Fly");',
'$mod.Obj.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
'$mod.Obj.SetOnShow(rtl.createSafeCallback(ExtObj, "Fly"));',
'$mod.Obj.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
'$mod.Obj.SetOnShow(rtl.createSafeCallback(ExtObj, "Fly"));',
'var $with1 = $mod.Obj;',
'$mod.p = rtl.createSafeCallback($with1, "$Execute");',
'$mod.p = rtl.createSafeCallback($with1, "DoSome");',
'$mod.e = rtl.createSafeCallback($with1, "$Execute");',
'$mod.e = rtl.createSafeCallback($with1, "DoSome");',
'$with1.SetOnClick(rtl.createSafeCallback($with1, "$Execute"));',
'$with1.SetOnClick(rtl.createSafeCallback($with1, "DoSome"));',
'$with1.SetOnClick(rtl.createSafeCallback($with1, "$Execute"));',
'$with1.SetOnClick(rtl.createSafeCallback($with1, "DoSome"));',
'$with1.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
'$with1.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
'']));
end;
@ -26413,55 +26440,82 @@ begin
'{$mode delphi}',
'{$modeswitch externalclass}',
'type',
' TProc = reference to procedure(i: longint); safecall;',
' TEvent = procedure(i: longint) of object; safecall;',
' TExtA = class external name ''ExtObj''',
' procedure DoIt(Id: longint = 1); external name ''$Execute'';',
' procedure DoSome(Id: longint = 1);',
' procedure SetOnClick(const e: TEvent);',
' property OnClick: TEvent write SetOnClick;',
' class procedure Fly(Id: longint = 1); static;',
' procedure SetOnShow(const p: TProc);',
' property OnShow: TProc write SetOnShow;',
' end;',
'procedure Run(i: longint = 1);',
'begin',
'end;',
'var',
' Obj: texta;',
' p: TEvent;',
' e: TEvent;',
' p: TProc;',
'begin',
' p:=p;',
' p:=obj.doit;',
' p:=obj.dosome;',
' p:=TEvent(@obj.dosome);', // no safecall
' e:=e;',
' e:=obj.doit;',
' e:=obj.dosome;',
' e:=TEvent(@obj.dosome);', // no safecall
' obj.OnClick:=obj.doit;',
' obj.OnClick:=obj.dosome;',
' obj.setonclick(obj.doit);',
' obj.setonclick(obj.dosome);',
' p:=Run;',
' p:=TExtA.Fly;',
' obj.OnShow:=Run;',
' obj.OnShow:=TExtA.Fly;',
' obj.setOnShow(Run);',
' obj.setOnShow(TExtA.Fly);',
' with obj do begin',
' p:=doit;',
' p:=dosome;',
' e:=doit;',
' e:=dosome;',
' OnClick:=doit;',
' OnClick:=dosome;',
' setonclick(doit);',
' setonclick(dosome);',
' OnShow:=@Run;',
' setOnShow(@Run);',
' end;']);
ConvertProgram;
CheckSource('TestProcType_SafeCallDelphi',
LinesToStr([ // statements
'this.Run = function (i) {',
'};',
'this.Obj = null;',
'this.e = null;',
'this.p = null;',
'']),
LinesToStr([ // $mod.$main
'$mod.p = $mod.p;',
'$mod.p = rtl.createSafeCallback($mod.Obj, "$Execute");',
'$mod.p = rtl.createSafeCallback($mod.Obj, "DoSome");',
'$mod.p = rtl.createCallback($mod.Obj, "DoSome");',
'$mod.e = $mod.e;',
'$mod.e = rtl.createSafeCallback($mod.Obj, "$Execute");',
'$mod.e = rtl.createSafeCallback($mod.Obj, "DoSome");',
'$mod.e = rtl.createCallback($mod.Obj, "DoSome");',
'$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "$Execute"));',
'$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "DoSome"));',
'$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "$Execute"));',
'$mod.Obj.SetOnClick(rtl.createSafeCallback($mod.Obj, "DoSome"));',
'$mod.p = rtl.createSafeCallback($mod, "Run");',
'$mod.p = rtl.createSafeCallback(ExtObj, "Fly");',
'$mod.Obj.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
'$mod.Obj.SetOnShow(rtl.createSafeCallback(ExtObj, "Fly"));',
'$mod.Obj.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
'$mod.Obj.SetOnShow(rtl.createSafeCallback(ExtObj, "Fly"));',
'var $with1 = $mod.Obj;',
'$mod.p = rtl.createSafeCallback($with1, "$Execute");',
'$mod.p = rtl.createSafeCallback($with1, "DoSome");',
'$mod.e = rtl.createSafeCallback($with1, "$Execute");',
'$mod.e = rtl.createSafeCallback($with1, "DoSome");',
'$with1.SetOnClick(rtl.createSafeCallback($with1, "$Execute"));',
'$with1.SetOnClick(rtl.createSafeCallback($with1, "DoSome"));',
'$with1.SetOnClick(rtl.createSafeCallback($with1, "$Execute"));',
'$with1.SetOnClick(rtl.createSafeCallback($with1, "DoSome"));',
'$with1.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
'$with1.SetOnShow(rtl.createSafeCallback($mod, "Run"));',
'']));
end;