pas2js: safecall for procedure

git-svn-id: trunk@45416 -

packages/pastojs/src/fppas2js.pp

@@ -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

packages/pastojs/tests/tcmodules.pas

@@ -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:[email protected];',
-  '  p:[email protected];',
-  '  p:=TEvent(@obj.dosome);', // no safecall
+  '  e:=e;',
+  '  e:[email protected];',
+  '  e:[email protected];',
+  '  e:=TEvent(@obj.dosome);', // no safecall
   '  obj.OnClick:[email protected];',
   '  obj.OnClick:[email protected];',
   '  obj.setonclick(@obj.doit);',
   '  obj.setonclick(@obj.dosome);',
+  '  p:=@Run;',
+  '  p:[email protected];',
+  '  obj.OnShow:=@Run;',
+  '  obj.OnShow:[email protected];',
+  '  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;