pastojs: proc type reference-to

git-svn-id: trunk@35847 -

packages/pastojs/src/fppas2js.pp

@@ -169,6 +169,7 @@ Works:
   - mode delphi: proctype:=proc
   - mode delphi: functype=funcresulttype
   - nested functions
+  - reference to
 - class-of
   - assign :=   nil, var
   - call class method
@@ -243,8 +244,6 @@ Works:
   - use 0o for octal literals
 
 ToDos:
-- documentation: $mod, Self, createCallBack on method,proc,nested
-- reference to
 - RTTI
   - open array param
   - codetools function typeinfo
@@ -293,8 +292,11 @@ Not in Version 1.0:
 - option range checking -Cr
 - option overflow checking -Co
 - optimizations:
+  - add $mod only if needed
+  - add Self only if needed
   - set operators on literals without temporary arrays, a in [b], [a]*b<>[]
   - use a number for small sets
+  - nested procs without var, instead as "function name(){}"
   -O1 insert local/unit vars for global type references:
       at start of intf var $r1;
       at end of impl: $r1=path;
@@ -414,6 +416,7 @@ type
     pbifnRTTINewProcSig,// rtl.newTIProcSig
     pbifnRTTINewProcVar,// typeinfo of tkProcVar $ProcVar
     pbifnRTTINewRecord,// typeinfo creator of tkRecord $Record
+    pbifnRTTINewRefToProcVar,// typeinfo of tkRefToProcVar $RefToProcVar
     pbifnRTTINewSet,// typeinfo of tkSet $Set
     pbifnRTTINewStaticArray,// typeinfo of tkArray $StaticArray
     pbifnSetCharAt,
@@ -467,6 +470,7 @@ type
     pbitnTIPointer,
     pbitnTIProcVar,
     pbitnTIRecord,
+    pbitnTIRefToProcVar,
     pbitnTISet,
     pbitnTIStaticArray
     );
@@ -506,6 +510,7 @@ const
     'newTIProcSig',
     '$ProcVar',
     '$Record',
+    '$RefToProcVar',
     '$Set',
     '$StaticArray',
     'setCharAt', // rtl.setCharAt
@@ -559,6 +564,7 @@ const
     'tTypeInfoPointer',
     'tTypeInfoProcVar',
     'tTypeInfoRecord',
+    'tTypeInfoRefToProcVar',
     'tTypeInfoSet',
     'tTypeInfoStaticArray'
     );
@@ -2461,7 +2467,9 @@ begin
       TIName:=Pas2JSBuiltInNames[pbitnTISet]
     else if C.InheritsFrom(TPasProcedureType) then
       begin
-      if TPasProcedureType(TypeEl).IsOfObject then
+      if TPasProcedureType(TypeEl).IsReferenceTo then
+        TIName:=Pas2JSBuiltInNames[pbitnTIRefToProcVar]
+      else if TPasProcedureType(TypeEl).IsOfObject then
         TIName:=Pas2JSBuiltInNames[pbitnTIMethodVar]
       else
         TIName:=Pas2JSBuiltInNames[pbitnTIProcVar];
@@ -7740,7 +7748,9 @@ begin
   if not HasTypeInfo(El,AContext) then exit;
 
   // module.$rtti.$ProcVar("name",function(){})
-  if El.IsOfObject then
+  if El.IsReferenceTo then
+    FunName:=FBuiltInNames[pbifnRTTINewRefToProcVar]
+  else if El.IsOfObject then
     FunName:=FBuiltInNames[pbifnRTTINewMethodVar]
   else
     FunName:=FBuiltInNames[pbifnRTTINewProcVar];

packages/pastojs/tests/tcmodules.pas

@@ -414,6 +414,8 @@ type
     Procedure TestProcType_WithClassInstDoPropertyFPC;
     Procedure TestProcType_Nested;
     Procedure TestProcType_NestedOfObject;
+    Procedure TestProcType_ReferenceToProc;
+    Procedure TestProcType_ReferenceToMethod;
     Procedure TestProcType_Typecast;
 
     // pointer
@@ -10425,6 +10427,113 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestProcType_ReferenceToProc;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TProcRef = reference to procedure(i: longint = 0);',
+  '  TFuncRef = reference to function(i: longint = 0): longint;',
+  'var',
+  '  p: TProcRef;',
+  '  f: TFuncRef;',
+  'procedure DoIt(i: longint);',
+  'begin',
+  'end;',
+  'function GetIt(i: longint): longint;',
+  'begin',
+  '  p:=@DoIt;',
+  '  f:=@GetIt;',
+  '  f;',
+  '  f();',
+  '  f(1);',
+  'end;',
+  'begin',
+  '  p:=@DoIt;',
+  '  f:=@GetIt;',
+  '  f;',
+  '  f();',
+  '  f(1);',
+  '  p:=TProcRef(f);',
+  '']);
+  ConvertProgram;
+  CheckSource('TestProcType_ReferenceToProc',
+    LinesToStr([ // statements
+    'this.p = null;',
+    'this.f = null;',
+    'this.DoIt = function (i) {',
+    '};',
+    'this.GetIt = function (i) {',
+    '  var Result = 0;',
+    '  $mod.p = $mod.DoIt;',
+    '  $mod.f = $mod.GetIt;',
+    '  $mod.f(0);',
+    '  $mod.f(0);',
+    '  $mod.f(1);',
+    '  return Result;',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.p = $mod.DoIt;',
+    '$mod.f = $mod.GetIt;',
+    '$mod.f(0);',
+    '$mod.f(0);',
+    '$mod.f(1);',
+    '$mod.p = $mod.f;',
+    '']));
+end;
+
+procedure TTestModule.TestProcType_ReferenceToMethod;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TFuncRef = reference to function(i: longint = 5): longint;',
+  '  TObject = class',
+  '    function Grow(s: longint): longint;',
+  '  end;',
+  'var',
+  '  f: tfuncref;',
+  'function tobject.grow(s: longint): longint;',
+  '  function GrowSub(i: longint): longint;',
+  '  begin',
+  '    f:=@grow;',
+  '    f:=@growsub;',
+  '  end;',
+  'begin',
+  '  f:=@grow;',
+  '  f:=@growsub;',
+  'end;',
+  'begin',
+  '']);
+  ConvertProgram;
+  CheckSource('TestProcType_ReferenceToMethod',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  this.Grow = function (s) {',
+    '    var Self = this;',
+    '    var Result = 0;',
+    '    function GrowSub(i) {',
+    '      var Result = 0;',
+    '      $mod.f = rtl.createCallback(Self, "Grow");',
+    '      $mod.f = GrowSub;',
+    '      return Result;',
+    '    };',
+    '    $mod.f = rtl.createCallback(Self, "Grow");',
+    '    $mod.f = GrowSub;',
+    '    return Result;',
+    '  };',
+    '});',
+    'this.f = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
 procedure TTestModule.TestProcType_Typecast;
 begin
   StartProgram(false);