pas2js: safecall calling convention for of-object proctypes

git-svn-id: trunk@45392 -

packages/fcl-passrc/src/pasresolver.pp

@@ -1426,7 +1426,8 @@ type
     //ToDo: proStaticArrayCopy, // copy works with static arrays, returning a dynamic array
     //ToDo: proStaticArrayConcat, // concat works with static arrays, returning a dynamic array
     proProcTypeWithoutIsNested, // proc types can use nested procs without 'is nested'
-    proMethodAddrAsPointer   // can assign @method to a pointer
+    proMethodAddrAsPointer,  // can assign @method to a pointer
+    proSafecallAllowsDefault // allow assigning a default calling convetnion to a SafeCall proc
     );
   TPasResolverOptions = set of TPasResolverOption;
 
@@ -23178,10 +23179,17 @@ begin
     end;
   if Proc1.CallingConvention<>Proc2.CallingConvention then
     begin
-    if RaiseOnIncompatible then
-      RaiseMsg(20170402112253,nCallingConventionMismatch,sCallingConventionMismatch,
-        [],ErrorEl);
-    exit;
+    if (proSafecallAllowsDefault in Options)
+        and (Proc1.CallingConvention=ccSafeCall)
+        and (Proc2.CallingConvention=ccDefault) then
+      // ok
+    else
+      begin
+      if RaiseOnIncompatible then
+        RaiseMsg(20170402112253,nCallingConventionMismatch,sCallingConventionMismatch,
+          [],ErrorEl);
+      exit;
+      end;
     end;
   ProcArgs1:=Proc1.Args;
   ProcArgs2:=Proc2.Args;

packages/pastojs/src/fppas2js.pp

@@ -600,6 +600,7 @@ type
     pbifnFreeVar,
     pbifnOverflowCheckInt,
     pbifnProcType_Create,
+    pbifnProcType_CreateSafe,
     pbifnProcType_Equal,
     pbifnProgramMain,
     pbifnRaiseException, // rtl.raiseE
@@ -776,6 +777,7 @@ const
     'free', // rtl.free
     'oc', //  rtl.oc  pbifnOverflowCheckInt
     'createCallback', // rtl.createCallback  pbifnProcType_Create
+    'createSafeCallback', // rtl.createSafeCallback  pbifnProcType_CreateSafe
     'eqCallback', // rtl.eqCallback
     '$main',
     'raiseE', // rtl.raiseE
@@ -1286,7 +1288,8 @@ const
     proExtClassInstanceNoTypeMembers,
     proOpenAsDynArrays,
     proProcTypeWithoutIsNested,
-    proMethodAddrAsPointer
+    proMethodAddrAsPointer,
+    proSafecallAllowsDefault
     ];
 type
   TPas2JSResolver = class;
@@ -1878,7 +1881,8 @@ type
       FuncContext: TFunctionContext; pbivn: TPas2JSBuiltInName);
     // misc
     Function CreateCallback(Expr: TPasExpr; ResolvedEl: TPasResolverResult;
-      AContext: TConvertContext): TJSElement; virtual;
+      aSafeCall: boolean; AContext: TConvertContext): TJSElement; virtual;
+    Function CreateSafeCallback(Expr: TPasExpr; JS: TJSElement; AContext: TConvertContext): TJSElement; virtual;
     Function CreateExternalBracketAccessorCall(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function CreateAssignStatement(LeftEl: TPasExpr; AssignContext: TAssignContext): TJSElement; virtual;
     Function CreateGetEnumeratorLoop(El: TPasImplForLoop;
@@ -2057,6 +2061,7 @@ type
       pfStatic = 1;
       pfVarargs = 2;
       pfExternal = 4;
+      pfSafeCall = 8;
       // PropertyFlag
       pfGetFunction = 1; // getter is a function
       pfSetProcedure = 2; // setter is a function
@@ -4074,9 +4079,9 @@ begin
     Proc:=TPasProcedure(El.Parent);
 
     // calling convention
-    if Proc.CallingConvention<>ccDefault then
-      RaiseMsg(20170211214731,nPasElementNotSupported,sPasElementNotSupported,
-        [cCallingConventions[Proc.CallingConvention]],Proc);
+    if El.CallingConvention<>ccDefault then
+      RaiseMsg(20170211214731,nNotSupportedX,sNotSupportedX,
+        [cCallingConventions[El.CallingConvention]],Proc);
 
     for pm in Proc.Modifiers do
       if (not (pm in [pmVirtual, pmAbstract, pmOverride,
@@ -4257,6 +4262,13 @@ begin
         AddExternalPath(ExtName,Proc.LibrarySymbolName);
 
       end;
+    end
+  else
+    begin
+    // proc type, not proc
+    if not (El.CallingConvention in [ccDefault,ccSafeCall]) then
+      RaiseMsg(20200516134717,nNotSupportedX,sNotSupportedX,
+        [cCallingConventions[El.CallingConvention]],El);
     end;
 end;
 
@@ -7143,7 +7155,7 @@ begin
         begin
         if ResolvedEl.IdentEl is TPasProcedure then
           begin
-          Result:=CreateCallback(El.Operand,ResolvedEl,AContext);
+          Result:=CreateCallback(El.Operand,ResolvedEl,false,AContext);
           exit;
           end;
         end
@@ -11573,6 +11585,7 @@ begin
       RaiseNotSupported(Expr,AContext,20170501151316);
       end;
 
+    // inc(a,b)  ->  a = a+b  or setter(getter()+b)
     AssignContext:=TAssignContext.Create(Expr,nil,AContext);
     AContext.Resolver.ComputeElement(Expr,AssignContext.LeftResolved,[rcNoImplicitProc]);
     SetResolverValueExpr(AssignContext.RightResolved,
@@ -14527,7 +14540,7 @@ begin
   if El.IsNested then
     DoError(20170222231636,nPasElementNotSupported,sPasElementNotSupported,
       ['is nested'],El);
-  if El.CallingConvention<>ccDefault then
+  if not (El.CallingConvention in [ccDefault,ccSafeCall]) then
     DoError(20170222231532,nPasElementNotSupported,sPasElementNotSupported,
         ['calling convention '+cCallingConventions[El.CallingConvention]],El);
   if not HasTypeInfo(El,AContext) then exit;
@@ -14564,6 +14577,8 @@ begin
     Flags:=0;
     if ptmVarargs in El.Modifiers then
       inc(Flags,pfVarargs);
+    if El.CallingConvention=ccSafeCall then
+      inc(Flags,pfSafeCall);
     if Flags>0 then
       InnerCall.AddArg(CreateLiteralNumber(El,Flags));
 
@@ -16894,8 +16909,10 @@ begin
 end;
 
 function TPasToJSConverter.CreateCallback(Expr: TPasExpr;
-  ResolvedEl: TPasResolverResult; AContext: TConvertContext): TJSElement;
+  ResolvedEl: TPasResolverResult; aSafeCall: boolean; AContext: TConvertContext
+  ): TJSElement;
 // El 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)"
 
@@ -16932,17 +16949,19 @@ begin
   aResolver:=AContext.Resolver;
 
   Proc:=TPasProcedure(ResolvedEl.IdentEl);
-  if (not (Proc.Parent is TPasMembersType))
+  if not (Proc.Parent is TPasMembersType)
       or (ptmStatic in Proc.ProcType.Modifiers) then
     begin
     // not an "of object" method -> simply use the function
     Result:=CreateReferencePathExpr(Proc,AContext);
+    if aSafeCall then
+      RaiseNotSupported(Expr,AContext,20200516144151,'safecall without object');
     exit;
     end;
   IsHelper:=aResolver.IsHelperMethod(Proc);
   NeedClass:=aResolver.IsClassMethod(Proc) and not aResolver.MethodIsStatic(Proc);
 
-  // an of-object method -> create "rtl.createCallback(Target,func)"
+  // a safcall or of-object method -> create "rtl.createCallback(Target,func)"
   TargetJS:=nil;
   Call:=nil;
   try
@@ -16988,7 +17007,7 @@ begin
         else if SelfScope.ClassRecScope<>nil then
           begin
           TargetName:=CreateReferencePath(SelfScope.ClassRecScope.Element,
-                                                        AContext,rpkPathAndName);
+                                                       AContext,rpkPathAndName);
           NeedClass:=false;
           end
         else
@@ -17006,11 +17025,15 @@ begin
     if NeedClass then
       // append '.$class'
       TargetJS:=CreateDotExpression(Expr,TargetJS,
-                             CreatePrimitiveDotExpr(GetBIName(pbivnPtrClass),PosEl));
+                        CreatePrimitiveDotExpr(GetBIName(pbivnPtrClass),PosEl));
 
     Call:=CreateCallExpression(Expr);
     // "rtl.createCallback"
-    Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnProcType_Create)]);
+    if aSafeCall then
+      TargetName:=GetBIName(pbifnProcType_CreateSafe)
+    else
+      TargetName:=GetBIName(pbifnProcType_Create);
+    Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),TargetName]);
     // add target
     Call.AddArg(TargetJS);
     TargetJS:=nil;
@@ -17036,6 +17059,59 @@ begin
   end;
 end;
 
+function TPasToJSConverter.CreateSafeCallback(Expr: TPasExpr; JS: TJSElement;
+  AContext: TConvertContext): TJSElement;
+var
+  Call: TJSCallExpression;
+  DotExpr: TJSDotMemberExpression;
+  Prim: TJSPrimaryExpressionIdent;
+begin
+  Result:=JS;
+  if AContext=nil then ;
+  if JS is TJSCallExpression then
+    begin
+    Call:=TJSCallExpression(JS);
+    if Call.Expr is TJSDotMemberExpression then
+      begin
+      DotExpr:=TJSDotMemberExpression(Call.Expr);
+      if DotExpr.MExpr is TJSPrimaryExpressionIdent then
+        begin
+        Prim:=TJSPrimaryExpressionIdent(DotExpr.MExpr);
+        if Prim.Name=TJSString(GetBIName(pbivnRTL)) then
+          begin
+          if DotExpr.Name=TJSString(GetBIName(pbifnProcType_Create)) then
+            // rtl.createCallback - > rtl.createSafeCallback
+            DotExpr.Name:=TJSString(GetBIName(pbifnProcType_CreateSafe));
+          end;
+        end;
+      end;
+    // Note: if the call is not a rtl.createCallback then there is no SafeCall
+    // e.g.  aSafeCall:=Btn1.GetOnClick();
+    end
+  else
+    begin
+    // enclose JS in rtl.createSafeCallback()
+    Call:=CreateCallExpression(Expr);
+    Result:=Call;
+    Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnProcType_CreateSafe)]);
+    if JS is TJSDotMemberExpression then
+      begin
+      // convert "a.fn"  to "rtl.createSafeCallback(a,fn)"
+      DotExpr:=TJSDotMemberExpression(JS);
+      Call.AddArg(DotExpr.MExpr);
+      DotExpr.MExpr:=nil;
+      Call.AddArg(CreateLiteralJSString(Expr,DotExpr.Name));
+      JS.Free;
+      end
+    else
+      begin
+      // convert "JS"  to  "rtl.createSafeCallback(null,JS)"
+      Call.AddArg(CreateLiteralNull(Expr));
+      Call.AddArg(JS);
+      end;
+    end;
+end;
+
 function TPasToJSConverter.CreateExternalBracketAccessorCall(El: TParamsExpr;
   AContext: TConvertContext): TJSElement;
 var
@@ -19731,7 +19807,7 @@ Var
   LeftIsProcType: Boolean;
   Call: TJSCallExpression;
   MinVal, MaxVal: TMaxPrecInt;
-  RightTypeEl, LeftTypeEl: TPasType;
+  LeftTypeEl, RightTypeEl: TPasType;
   aResolver: TPas2JSResolver;
   ObjLit: TJSObjectLiteral;
   GUID: TGUID;
@@ -19747,7 +19823,7 @@ begin
       begin
       aResolver.ComputeElement(El.left,AssignContext.LeftResolved,[rcNoImplicitProc]);
       Flags:=[];
-      LeftIsProcType:=aResolver.IsProcedureType(AssignContext.LeftResolved,true);
+      LeftIsProcType:=aResolver.IsProcedureType(AssignContext.LeftResolved,false);
       if LeftIsProcType then
         begin
         if msDelphi in AContext.CurrentModeSwitches then
@@ -19764,7 +19840,11 @@ begin
           and (AssignContext.RightResolved.IdentEl is TPasProcedure) then
         begin
         // Delphi allows assigning a proc without @: proctype:=proc
-        AssignContext.RightSide:=CreateCallback(El.right,AssignContext.RightResolved,AContext);
+        LeftTypeEl:=AssignContext.LeftResolved.LoTypeEl;
+        AssignContext.RightSide:=CreateCallback(El.right,
+             AssignContext.RightResolved,
+             TPasProcedureType(LeftTypeEl).CallingConvention=ccSafeCall,
+             AContext);
         end
       else if AssignContext.RightResolved.BaseType=btNil then
         begin
@@ -19966,6 +20046,18 @@ begin
             AssignContext.RightSide:=Call;
             end;
           end;
+        end
+      else if RightTypeEl is TPasProcedureType then
+        begin
+        LeftTypeEl:=AssignContext.LeftResolved.LoTypeEl;
+        if (LeftTypeEl is TPasProcedureType)
+            and (TPasProcedureType(AssignContext.LeftResolved.LoTypeEl).CallingConvention=ccSafeCall)
+            and (El.right is TUnaryExpr)
+            and (TUnaryExpr(El.right).OpCode=eopAddress) then
+          begin
+          // aSafeCall:=@Proc
+          AssignContext.RightSide:=CreateSafeCallback(El.right,AssignContext.RightSide,AContext);
+          end;
         end;
       end;
     // convert left side
@@ -22702,6 +22794,9 @@ begin
 
   aResolver.ComputeElement(El,ExprResolved,ExprFlags);
   ExprIsTempValid:=false;
+  {$IFDEF VerbosePas2JS}
+  writeln('TPasToJSConverter.CreateProcCallArg Arg=',GetResolverResultDbg(ArgResolved),' Expr=',GetResolverResultDbg(ExprResolved));
+  {$ENDIF}
 
   if (TargetArg.ArgType=nil) and (ExprResolved.LoTypeEl is TPasRecordType) then
     NeedVar:=false; // pass aRecord to UntypedArg -> no reference needed
@@ -22731,6 +22826,18 @@ begin
         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,
+             TPasProcedureType(ArgTypeEl).CallingConvention=ccSafeCall,
+             AContext);
+        end;
       end;
 
     if Result=nil then
@@ -22910,6 +23017,13 @@ begin
           {$ENDIF}
           Result:=CreateRecordCallClone(El,TPasRecordType(ExprTypeEl),Result,AContext);
           end;
+        end
+      else if (ExprResolved.LoTypeEl is TPasProcedureType)
+          and (ArgResolved.LoTypeEl is TPasProcedureType)
+          and (TPasProcedureType(ArgResolved.LoTypeEl).CallingConvention=ccSafeCall) then
+        begin
+        // pass proc to SafeCall proc type
+        Result:=CreateSafeCallback(El,Result,AContext);
         end;
       end;
     end;

packages/pastojs/tests/tcmodules.pas

@@ -736,6 +736,8 @@ type
     Procedure TestProcType_Typecast;
     Procedure TestProcType_PassProcToUntyped;
     Procedure TestProcType_PassProcToArray;
+    Procedure TestProcType_SafeCallObjFPC;
+    Procedure TestProcType_SafeCallDelphi;
 
     // pointer
     Procedure TestPointer;
@@ -16238,22 +16240,22 @@ end;
 procedure TTestModule.TestExternalClass_Method;
 begin
   StartProgram(false);
-  Add('{$modeswitch externalclass}');
-  Add('type');
-  Add('  TExtA = class external name ''ExtObj''');
-  Add('    procedure DoIt(Id: longint = 1); external name ''$Execute'';');
-  Add('    procedure DoSome(Id: longint = 1);');
-  Add('  end;');
-  Add('var Obj: texta;');
-  Add('begin');
-  Add('  obj.doit;');
-  Add('  obj.doit();');
-  Add('  obj.doit(2);');
-  Add('  with obj do begin');
-  Add('    doit;');
-  Add('    doit();');
-  Add('    doit(3);');
-  Add('  end;');
+  Add(['{$modeswitch externalclass}',
+  'type',
+  '  TExtA = class external name ''ExtObj''',
+  '    procedure DoIt(Id: longint = 1); external name ''$Execute'';',
+  '    procedure DoSome(Id: longint = 1);',
+  '  end;',
+  'var Obj: texta;',
+  'begin',
+  '  obj.doit;',
+  '  obj.doit();',
+  '  obj.doit(2);',
+  '  with obj do begin',
+  '    doit;',
+  '    doit();',
+  '    doit(3);',
+  '  end;']);
   ConvertProgram;
   CheckSource('TestExternalClass_Method',
     LinesToStr([ // statements
@@ -25489,29 +25491,31 @@ end;
 procedure TTestModule.TestProcType_MethodDelphi;
 begin
   StartProgram(false);
-  Add('{$mode delphi}');
-  Add('type');
-  Add('  TFuncInt = function(vA: longint = 1): longint of object;');
-  Add('  TObject = class');
-  Add('    function DoIt(vA: longint = 1): longint;');
-  Add('  end;');
-  Add('function TObject.DoIt(vA: longint = 1): longint;');
-  Add('begin');
-  Add('end;');
-  Add('var');
-  Add('  Obj: TObject;');
-  Add('  vP: tfuncint;');
-  Add('  b: boolean;');
-  Add('begin');
-  Add('  vp:[email protected];'); // ok in fpc and delphi
-  Add('  vp:=obj.doit;'); // illegal in fpc, ok in delphi
-  Add('  vp;'); // ok in fpc and delphi
-  Add('  vp();');
-  Add('  vp(2);');
-  //Add('  b:[email protected];'); // ok in fpc, illegal in delphi
-  //Add('  b:[email protected]=vp;'); // ok in fpc, illegal in delphi
-  //Add('  b:=vp<>@obj.doit;'); // ok in fpc, illegal in delphi
-  //Add('  b:[email protected]<>vp;'); // ok in fpc, illegal in delphi
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TFuncInt = function(vA: longint = 1): longint of object;',
+  '  TObject = class',
+  '    function DoIt(vA: longint = 1): longint;',
+  '  end;',
+  'function TObject.DoIt(vA: longint = 1): longint;',
+  'begin',
+  'end;',
+  'var',
+  '  Obj: TObject;',
+  '  vP: tfuncint;',
+  '  b: boolean;',
+  'begin',
+  '  vp:[email protected];', // ok in fpc and delphi
+  '  vp:=obj.doit;', // illegal in fpc, ok in delphi
+  '  vp;', // ok in fpc and delphi
+  '  vp();',
+  '  vp(2);',
+  //'  b:[email protected];', // ok in fpc, illegal in delphi
+  //'  b:[email protected]=vp;', // ok in fpc, illegal in delphi
+  //'  b:=vp<>@obj.doit;', // ok in fpc, illegal in delphi
+  //'  b:[email protected]<>vp;'); // ok in fpc, illegal in delphi
+  '']);
   ConvertProgram;
   CheckSource('TestProcType_MethodDelphi',
     LinesToStr([ // statements
@@ -26344,6 +26348,123 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestProcType_SafeCallObjFPC;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch externalclass}',
+  'type',
+  '  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;',
+  '  end;',
+  'var',
+  '  Obj: texta;',
+  '  p: TEvent;',
+  'begin',
+  '  p:=p;',
+  '  p:[email protected];',
+  '  p:[email protected];',
+  '  p:=TEvent(@obj.dosome);', // no safecall
+  '  obj.OnClick:[email protected];',
+  '  obj.OnClick:[email protected];',
+  '  obj.setonclick(@obj.doit);',
+  '  obj.setonclick(@obj.dosome);',
+  '  with obj do begin',
+  '    p:=@doit;',
+  '    p:=@dosome;',
+  '    OnClick:=@doit;',
+  '    OnClick:=@dosome;',
+  '    setonclick(@doit);',
+  '    setonclick(@dosome);',
+  '  end;']);
+  ConvertProgram;
+  CheckSource('TestProcType_SafeCallObjFPC',
+    LinesToStr([ // statements
+    'this.Obj = 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.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"));',
+    'var $with1 = $mod.Obj;',
+    '$mod.p = rtl.createSafeCallback($with1, "$Execute");',
+    '$mod.p = 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"));',
+    '']));
+end;
+
+procedure TTestModule.TestProcType_SafeCallDelphi;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  '{$modeswitch externalclass}',
+  'type',
+  '  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;',
+  '  end;',
+  'var',
+  '  Obj: texta;',
+  '  p: TEvent;',
+  'begin',
+  '  p:=p;',
+  '  p:=obj.doit;',
+  '  p:=obj.dosome;',
+  '  p:=TEvent(@obj.dosome);', // no safecall
+  '  obj.OnClick:=obj.doit;',
+  '  obj.OnClick:=obj.dosome;',
+  '  obj.setonclick(obj.doit);',
+  '  obj.setonclick(obj.dosome);',
+  '  with obj do begin',
+  '    p:=doit;',
+  '    p:=dosome;',
+  '    OnClick:=doit;',
+  '    OnClick:=dosome;',
+  '    setonclick(doit);',
+  '    setonclick(dosome);',
+  '  end;']);
+  ConvertProgram;
+  CheckSource('TestProcType_SafeCallDelphi',
+    LinesToStr([ // statements
+    'this.Obj = 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.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"));',
+    'var $with1 = $mod.Obj;',
+    '$mod.p = rtl.createSafeCallback($with1, "$Execute");',
+    '$mod.p = 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"));',
+    '']));
+end;
+
 procedure TTestModule.TestPointer;
 begin
   StartProgram(false);

utils/pas2js/dist/rtl.js

@@ -129,8 +129,7 @@ var rtl = {
   exitcode: 0,
 
   run: function(module_name){
-  
-    function doRun(){
+    try {
       if (!rtl.hasString(module_name)) module_name='program';
       if (rtl.debug_load_units) rtl.debug('rtl.run module="'+module_name+'"');
       rtl.initRTTI();
@@ -143,17 +142,13 @@ var rtl = {
         var r = pas.program.$main();
         if (rtl.isNumber(r)) rtl.exitcode = r;
       }
-    }
-    
-    try {
-      doRun();
     } catch(re) {
       if (!rtl.showUncaughtExceptions) {
         throw re
       } else {  
         if (rtl.handleUncaughtException(re)) {
           rtl.showException(re);
-          rtl.exitCode = 216;
+          rtl.exitcode = 216;
         }  
       }
     } 
@@ -164,7 +159,8 @@ var rtl = {
     var errMsg = rtl.hasString(re.$classname) ? re.$classname : '';
     errMsg +=  ((errMsg) ? ': ' : '') + (re.hasOwnProperty('fMessage') ? re.fMessage : re);
     alert('Uncaught Exception : '+errMsg);
-  },        
+  },
+
   handleUncaughtException: function (e) {
     if (rtl.onUncaughtException) {
       try {
@@ -247,6 +243,23 @@ var rtl = {
     return cb;
   },
 
+  createSafeCallback: function(scope, fn){
+    var cb = function(){
+      try{
+        if (typeof(fn)==='string'){
+          return scope[fn].apply(scope,arguments);
+        } else {
+          return fn.apply(scope,arguments);
+        };
+      } catch (err) {
+        if (!rtl.handleUncaughtException(err)) throw err;
+      }
+    };
+    cb.scope = scope;
+    cb.fn = fn;
+    return cb;
+  },
+
   cloneCallback: function(cb){
     return rtl.createCallback(cb.scope,cb.fn);
   },