pastojs: typecast function to TJSFunction

git-svn-id: trunk@39207 -

packages/pastojs/src/fppas2js.pp

@@ -344,6 +344,7 @@ Works:
   - p^.x, p.x
   - dispose, new
 - typecast byte(longword) -> value & $ff
+- typecast TJSFunction(func)
 
 ToDos:
 - bug:
@@ -4012,6 +4013,13 @@ begin
               if IsExternalClassName(ToClass,'Object') then
                 // TJSObject(ImgClass)
                 exit(cExact);
+              end
+            else if FromTypeEl.InheritsFrom(TPasProcedureType) then
+              begin
+              if IsExternalClassName(ToClass,'Function')
+                  or IsExternalClassName(ToClass,'Object') then
+                // TJSFunction(@Proc) or TJSFunction(ProcVar)
+                exit(cExact);
               end;
             end;
           end;
@@ -4047,6 +4055,20 @@ begin
           end
         else
           exit(Incompatible(20180503134528));
+        end
+      else if C.InheritsFrom(TPasProcedureType) then
+        begin
+        // typecast to proctype
+        if FromResolved.BaseType=btContext then
+          begin
+          FromTypeEl:=FromResolved.LoTypeEl;
+          if FromTypeEl.ClassType=TPasClassType then
+            begin
+            if IsExternalClassName(TPasClassType(FromTypeEl),'Function') then
+              // TProcType(aJSFunction)
+              exit(cCompatible);
+            end;
+          end;
         end;
       end;
     end
@@ -14812,8 +14834,8 @@ begin
       if LeftIsProcType and (msDelphi in AContext.CurrentModeSwitches)
           and (AssignContext.RightResolved.BaseType=btProc) then
         begin
-          // Delphi allows assigning a proc without @: proctype:=proc
-          AssignContext.RightSide:=CreateCallback(El.right,AssignContext.RightResolved,AContext);
+        // Delphi allows assigning a proc without @: proctype:=proc
+        AssignContext.RightSide:=CreateCallback(El.right,AssignContext.RightResolved,AContext);
         end
       else if AssignContext.RightResolved.BaseType=btNil then
         begin

packages/pastojs/tests/tcmodules.pas

@@ -525,6 +525,7 @@ type
     Procedure TestExternalClass_TypeCastToRootClass;
     Procedure TestExternalClass_TypeCastToJSObject;
     Procedure TestExternalClass_TypeCastStringToExternalString;
+    Procedure TestExternalClass_TypeCastToJSFunction;
     Procedure TestExternalClass_CallClassFunctionOfInstanceFail;
     Procedure TestExternalClass_BracketAccessor;
     Procedure TestExternalClass_BracketAccessor_Call;
@@ -13359,6 +13360,84 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestExternalClass_TypeCastToJSFunction;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch externalclass}',
+  'type',
+  '  TJSObject = class external name ''Object'' end;',
+  '  TJSFunction = class external name ''Function''',
+  '    function bind(thisArg: TJSObject): TJSFunction; varargs;',
+  '    function call(thisArg: TJSObject): JSValue; varargs;',
+  '  end;',
+  '  TObject = class',
+  '    procedure DoIt(i: longint);',
+  '  end;',
+  '  TFuncInt = function(o: TObject): longint;',
+  'function GetIt(o: TObject): longint;',
+  '  procedure Sub; begin end;',
+  'var',
+  '  f: TJSFunction;',
+  '  fi: TFuncInt;',
+  'begin',
+  '  fi:=TFuncInt(f);',
+  '  f:=TJSFunction(fi);',
+  '  f:=TJSFunction(@GetIt);',
+  '  f:=TJSFunction(@GetIt).bind(nil,3);',
+  '  f:=TJSFunction(@Sub);',
+  '  f:=TJSFunction(@o.doit);',
+  '  f:=TJSFunction(fi).bind(nil,4)',
+  'end;',
+  'procedure TObject.DoIt(i: longint);',
+  '  procedure Sub; begin end;',
+  'var f: TJSFunction;',
+  'begin',
+  '  f:=TJSFunction(@DoIt);',
+  '  f:=TJSFunction(@DoIt).bind(nil,13);',
+  '  f:=TJSFunction(@Sub);',
+  '  f:=TJSFunction(@GetIt);',
+  'end;',
+  'begin']);
+  ConvertProgram;
+  CheckSource('TestExternalClass_TypeCastToJSFunction',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  this.DoIt = function (i) {',
+    '    var Self = this;',
+    '    function Sub() {',
+    '    };',
+    '    var f = null;',
+    '    f = rtl.createCallback(Self, "DoIt");',
+    '    f = rtl.createCallback(Self, "DoIt").bind(null, 13);',
+    '    f = Sub;',
+    '    f = $mod.GetIt;',
+    '  };',
+    '});',
+    'this.GetIt = function (o) {',
+    '  var Result = 0;',
+    '  function Sub() {',
+    '  };',
+    '  var f = null;',
+    '  var fi = null;',
+    '  fi = f;',
+    '  f = fi;',
+    '  f = $mod.GetIt;',
+    '  f = $mod.GetIt.bind(null, 3);',
+    '  f = Sub;',
+    '  f = rtl.createCallback(o, "DoIt");',
+    '  f = fi.bind(null, 4);',
+    '  return Result;',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
 procedure TTestModule.TestExternalClass_CallClassFunctionOfInstanceFail;
 begin
   StartProgram(false);