Browse Source

pastojs: fixed pass proc adress to proc type arg

mattias 4 years ago
parent
commit
7e1adf88b7

+ 17 - 3
compiler/packages/pastojs/src/fppas2js.pp

@@ -16268,7 +16268,7 @@ begin
     if NeedClass then
       // append '.$class'
       TargetJS:=CreateDotExpression(Expr,TargetJS,
-                             CreatePrimitiveDotExpr(GetBIName(pbivnPtrClass),PosEl));
+                        CreatePrimitiveDotExpr(GetBIName(pbivnPtrClass),PosEl));
 
     Call:=CreateCallExpression(Expr);
     // "rtl.createCallback"
@@ -21525,6 +21525,9 @@ begin
 
   aResolver.ComputeElement(El,ExprResolved,ExprFlags);
   ExprIsTempValid:=false;
+  {$IFDEF VerbosePas2JS}
+  writeln('TPasToJSConverter.CreateProcCallArg Arg=',GetResolverResultDbg(ArgResolved),' Expr=',GetResolverResultDbg(ExprResolved));
+  {$ENDIF}
 
   // consider TargetArg access
   if NeedVar then
@@ -21536,14 +21539,25 @@ begin
 
     if ArgTypeIsArray then
       begin
+      // array as argument
       if ExprResolved.BaseType=btNil then
         begin
         // nil to array ->  pass []
         Result:=TJSArrayLiteral(CreateElement(TJSArrayLiteral,El));
         exit;
+        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,AContext);
         end;
-      // array as argument
-      Result:=CreateArrayInit(TPasArrayType(ArgTypeEl),El,El,AContext);
       end;
 
     if Result=nil then

+ 48 - 0
compiler/packages/pastojs/tests/tcmodules.pas

@@ -518,6 +518,7 @@ type
     Procedure TestClass_WithClassInstDoProperty;
     Procedure TestClass_WithClassInstDoPropertyWithParams;
     Procedure TestClass_WithClassInstDoFunc;
+    Procedure TestClass_ProcVarDelphi;
     Procedure TestClass_TypeCast;
     Procedure TestClass_TypeCastUntypedParam;
     Procedure TestClass_Overloads;
@@ -13479,6 +13480,53 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestClass_ProcVarDelphi;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TProc = procedure of object;',
+  '  TObject = class',
+  '    procedure Run;',
+  '    procedure Fly(const p: TProc);',
+  '  end;',
+  'procedure TObject.Run;',
+  'var o: TObject;',
+  'begin',
+  '  Fly(Run);',
+  '  Fly(Self.Run);',
+  '  with Self do Fly(Run);',
+  '  with o do Fly(Run);',
+  'end;',
+  'procedure TObject.Fly(const p: TProc);',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  ConvertProgram;
+  CheckSource('TestClass_ProcVarDelphi',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  this.Run = function () {',
+    '    var o = null;',
+    '    this.Fly(rtl.createCallback(this, "Run"));',
+    '    this.Fly(rtl.createCallback(this, "Run"));',
+    '    this.Fly(rtl.createCallback(this, "Run"));',
+    '    o.Fly(rtl.createCallback(o, "Run"));',
+    '  };',
+    '  this.Fly = function (p) {',
+    '  };',
+    '});',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
 procedure TTestModule.TestClass_TypeCast;
 begin
   StartProgram(false);