pastojs: started array of interface

packages/pastojs/src/fppas2js.pp

@@ -585,6 +585,7 @@ type
     pbifnHelperNew,
     pbifnIntf_AddRef,
     pbifnIntf_Release,
+    pbifnIntf_ReleaseArray,
     pbifnIntfAddMap,
     pbifnIntfAsClass,
     pbifnIntfAsIntfT, // COM intfvar as intftype
@@ -775,6 +776,7 @@ const
     '$new', // helpertype.$new
     '_AddRef', // rtl._AddRef
     '_Release', // rtl._Release
+    '_ReleaseArray', // rtl._ReleaseArray
     'addIntf', // rtl.addIntf  pbifnIntfAddMap
     'intfAsClass', // rtl.intfAsClass
     'intfAsIntfT', // rtl.intfAsIntfT
@@ -2200,7 +2202,7 @@ type
     Procedure CreateFunctionTryFinally(FuncContext: TFunctionContext);
     Procedure AddFunctionFinallySt(NewEl: TJSElement; PosEl: TPasElement;
       FuncContext: TFunctionContext);
-    Procedure AddFunctionFinallyRelease(SubEl: TPasElement; FuncContext: TFunctionContext);
+    Procedure AddFunctionFinallyRelease(SubEl: TPasElement; FuncContext: TFunctionContext; IsArray: boolean = false);
     Procedure AddInFrontOfFunctionTry(NewEl: TJSElement; PosEl: TPasElement;
       FuncContext: TFunctionContext);
     Procedure AddInterfaceReleases(FuncContext: TFunctionContext; PosEl: TPasElement);
@@ -4352,7 +4354,11 @@ begin
   while ElType is TPasArrayType do
     ElType:=ResolveAliasType(TPasArrayType(ElType).ElType);
   if IsInterfaceType(ElType,citCom) then
+    {$IFDEF EnableCOMArrayOfIntf}
+    ;
+    {$ELSE}
     RaiseMsg(20180404134515,nNotSupportedX,sNotSupportedX,['array of COM-interface'],El);
+    {$ENDIF}
 end;
 
 procedure TPas2JSResolver.FinishAncestors(aClass: TPasClassType);
@@ -21386,13 +21392,17 @@ var
   Proc: TPasProcedure;
   ok, SkipAddRef: Boolean;
 begin
+  {$IFDEF VerbosePas2JS}
+  writeln('TPasToJSConverter.CreateAssignComIntfVar LeftResolved=',GetResolverResultDbg(LeftResolved),' LHS=',LHS.ClassName,' RHS=',RHS.ClassName);
+  {$ENDIF}
+
   Result:=nil;
   ok:=false;
   try
     SkipAddRef:=false;
     if IsInterfaceRef(RHS) then
       begin
-      // simplify: $ir.ref(id,expr)  ->  expr
+      // simplify RHS: $ir.ref(id,expr)  ->  expr
       RHS:=RemoveIntfRef(TJSCallExpression(RHS),AContext);
       SkipAddRef:=true;
       end;
@@ -21401,7 +21411,7 @@ begin
     Result:=Call;
     if LHS is TJSDotMemberExpression then
       begin
-      // path.name = RHS  ->  rtl.setIntfP(path,"IntfVar",RHS)
+      // path.name = RHS  ->  rtl.setIntfP(path,"name",RHS)
       Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnIntfSetIntfP)]);
       Call.AddArg(TJSDotMemberExpression(LHS).MExpr);
       TJSDotMemberExpression(LHS).MExpr:=nil;
@@ -21419,6 +21429,7 @@ begin
       Call.AddArg(TJSBracketMemberExpression(LHS).MExpr);
       TJSBracketMemberExpression(LHS).MExpr:=nil;
       Call.AddArg(TJSBracketMemberExpression(LHS).Name);
+      TJSBracketMemberExpression(LHS).Name:=nil;
       FreeAndNil(LHS);
       Call.AddArg(RHS);
       RHS:=nil;
@@ -21559,14 +21570,19 @@ begin
 end;
 
 procedure TPasToJSConverter.AddFunctionFinallyRelease(SubEl: TPasElement;
-  FuncContext: TFunctionContext);
+  FuncContext: TFunctionContext; IsArray: boolean);
 // add to finally: rtl._Release(IntfVar)
 var
   Call: TJSCallExpression;
+  FuncName: String;
 begin
   Call:=CreateCallExpression(SubEl);
   AddFunctionFinallySt(Call,SubEl,FuncContext);
-  Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnIntf_Release)]);
+  if IsArray then
+    FuncName:=GetBIName(pbifnIntf_ReleaseArray)
+  else
+    FuncName:=GetBIName(pbifnIntf_Release);
+  Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),FuncName]);
   Call.AddArg(CreateReferencePathExpr(SubEl,FuncContext));
 end;
 
@@ -21599,12 +21615,22 @@ end;
 
 procedure TPasToJSConverter.AddInterfaceReleases(FuncContext: TFunctionContext;
   PosEl: TPasElement);
+var
+  aResolver: TPas2JSResolver;
+
+  function IsArray(aType: TPasType): boolean;
+  begin
+    aType:=aResolver.ResolveAliasType(aType);
+    Result:=aType is TPasArrayType;
+  end;
+
 var
   i: Integer;
   P: TPasElement;
   Call: TJSCallExpression;
   VarSt: TJSVariableStatement;
 begin
+  aResolver:=FuncContext.Resolver;
   if FuncContext.IntfExprReleaseCount>0 then
     begin
     // add in front of try..finally "var $ir = rtl.createIntfRefs();"
@@ -21624,9 +21650,13 @@ begin
       // enclose body in try..finally and add release statement
       P:=TPasElement(FuncContext.IntfElReleases[i]);
       if P.ClassType=TPasVariable then
-        AddFunctionFinallyRelease(P,FuncContext)
+        begin
+        AddFunctionFinallyRelease(P,FuncContext,IsArray(TPasVariable(P).VarType));
+        end
       else if P.ClassType=TPasArgument then
         begin
+        if IsArray(TPasArgument(P).ArgType) then
+          continue;
         // add in front of try..finally "rtl._AddRef(arg);"
         Call:=CreateCallExpression(P);
         AddInFrontOfFunctionTry(Call,PosEl,FuncContext);

packages/pastojs/tests/tcmodules.pas

@@ -696,20 +696,21 @@ type
 
     // class interfaces
     Procedure TestClassInterface_Corba;
-    Procedure TestClassInterface_ProcExternalFail;
-    Procedure TestClassInterface_Overloads;
-    Procedure TestClassInterface_DuplicateGUIInIntfListFail;
-    Procedure TestClassInterface_DuplicateGUIInAncestorFail;
-    Procedure TestClassInterface_AncestorImpl;
-    Procedure TestClassInterface_ImplReintroduce;
-    Procedure TestClassInterface_MethodResolution;
-    Procedure TestClassInterface_AncestorMoreInterfaces;
-    Procedure TestClassInterface_MethodOverride;
+    Procedure TestClassInterface_Corba_ProcExternalFail;
+    Procedure TestClassInterface_Corba_Overloads;
+    Procedure TestClassInterface_Corba_DuplicateGUIInIntfListFail;
+    Procedure TestClassInterface_Corba_DuplicateGUIInAncestorFail;
+    Procedure TestClassInterface_Corba_AncestorImpl;
+    Procedure TestClassInterface_Corba_ImplReintroduce;
+    Procedure TestClassInterface_Corba_MethodResolution;
+    Procedure TestClassInterface_COM_AncestorMoreInterfaces;
+    Procedure TestClassInterface_Corba_MethodOverride;
     Procedure TestClassInterface_Corba_Delegation;
     Procedure TestClassInterface_Corba_DelegationStatic;
     Procedure TestClassInterface_Corba_Operators;
     Procedure TestClassInterface_Corba_Args;
     Procedure TestClassInterface_Corba_ForIn;
+    Procedure TestClassInterface_Corba_ArrayOfIntf;
     Procedure TestClassInterface_COM_AssignVar;
     Procedure TestClassInterface_COM_AssignArg;
     Procedure TestClassInterface_COM_FunctionResult;
@@ -723,11 +724,12 @@ type
     Procedure TestClassInterface_COM_Delegation;
     Procedure TestClassInterface_COM_With;
     Procedure TestClassInterface_COM_ForIn;
+    Procedure TestClassInterface_COM_ArrayOfIntf;
     Procedure TestClassInterface_COM_ArrayOfIntfFail;
     Procedure TestClassInterface_COM_RecordIntfFail;
     Procedure TestClassInterface_COM_UnitInitialization;
-    Procedure TestClassInterface_GUID;
-    Procedure TestClassInterface_GUIDProperty;
+    Procedure TestClassInterface_Corba_GUID;
+    Procedure TestClassInterface_Corba_GUIDProperty;
 
     // helpers
     Procedure TestClassHelper_ClassVar;
@@ -20653,7 +20655,7 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestClassInterface_ProcExternalFail;
+procedure TTestModule.TestClassInterface_Corba_ProcExternalFail;
 begin
   StartProgram(false);
   Add([
@@ -20669,7 +20671,7 @@ begin
   ConvertProgram;
 end;
 
-procedure TTestModule.TestClassInterface_Overloads;
+procedure TTestModule.TestClassInterface_Corba_Overloads;
 begin
   StartProgram(false);
   Add([
@@ -20736,7 +20738,7 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestClassInterface_DuplicateGUIInIntfListFail;
+procedure TTestModule.TestClassInterface_Corba_DuplicateGUIInIntfListFail;
 begin
   StartProgram(false);
   Add([
@@ -20756,7 +20758,7 @@ begin
   ConvertProgram;
 end;
 
-procedure TTestModule.TestClassInterface_DuplicateGUIInAncestorFail;
+procedure TTestModule.TestClassInterface_Corba_DuplicateGUIInAncestorFail;
 begin
   StartProgram(false);
   Add([
@@ -20776,7 +20778,7 @@ begin
   ConvertProgram;
 end;
 
-procedure TTestModule.TestClassInterface_AncestorImpl;
+procedure TTestModule.TestClassInterface_Corba_AncestorImpl;
 begin
   StartProgram(false);
   Add([
@@ -20800,7 +20802,7 @@ begin
   'begin',
   '']);
   ConvertProgram;
-  CheckSource('TestClassInterface_AncestorIntf',
+  CheckSource('TestClassInterface_Corba_AncestorImpl',
     LinesToStr([ // statements
     'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-BDC4-8A2800000000}", ["DoIt"], null);',
     'rtl.createInterface(this, "IBird", "{B92D5841-6264-3AE3-BF20-000000000000}", ["Fly"], null);',
@@ -20824,7 +20826,7 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestClassInterface_ImplReintroduce;
+procedure TTestModule.TestClassInterface_Corba_ImplReintroduce;
 begin
   StartProgram(false);
   Add([
@@ -20845,7 +20847,7 @@ begin
   'begin',
   '']);
   ConvertProgram;
-  CheckSource('TestClassInterface_ImplReintroduce',
+  CheckSource('TestClassInterface_Corba_ImplReintroduce',
     LinesToStr([ // statements
     'rtl.createInterface(this, "IBird", "{B92D5841-6264-3AE2-8594-000000000000}", ["DoIt"], null);',
     'rtl.createClass(this, "TObject", null, function () {',
@@ -20868,7 +20870,7 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestClassInterface_MethodResolution;
+procedure TTestModule.TestClassInterface_Corba_MethodResolution;
 begin
   StartProgram(false);
   Add([
@@ -20901,7 +20903,7 @@ begin
   '  BirdIntf.Fly(''abc'');',
   '']);
   ConvertProgram;
-  CheckSource('TestClassInterface_MethodResolution',
+  CheckSource('TestClassInterface_Corba_MethodResolution',
     LinesToStr([ // statements
     'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-BDD7-23D600000000}", ["Walk"], null);',
     'rtl.createInterface(this, "IBird", "{CF8A4986-80F6-396E-AE88-000B86AAE208}", ["Walk$1", "Fly"], this.IUnknown);',
@@ -20933,7 +20935,7 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestClassInterface_AncestorMoreInterfaces;
+procedure TTestModule.TestClassInterface_COM_AncestorMoreInterfaces;
 begin
   StartProgram(false);
   Add([
@@ -20954,7 +20956,7 @@ begin
   'begin',
   '']);
   ConvertProgram;
-  CheckSource('TestClassInterface_COM_AncestorLess',
+  CheckSource('TestClassInterface_COM_AncestorMoreInterfaces',
     LinesToStr([ // statements
     'rtl.createInterface(this, "IUnknown", "{8F2D5841-758A-322B-BDDF-21CD521DD723}", ["_AddRef", "Walk"], null);',
     'rtl.createInterface(this, "IBird", "{CCE11D4C-6504-3AEE-AE88-000B86AAE675}", [], this.IUnknown);',
@@ -20977,7 +20979,7 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestClassInterface_MethodOverride;
+procedure TTestModule.TestClassInterface_Corba_MethodOverride;
 begin
   StartProgram(false);
   Add([
@@ -21005,7 +21007,7 @@ begin
   'begin',
   '']);
   ConvertProgram;
-  CheckSource('TestClassInterface_MethodOverride',
+  CheckSource('TestClassInterface_Corba_MethodOverride',
     LinesToStr([ // statements
     'rtl.createInterface(this, "IUnknown", "{D6D98E5B-8A10-4FEC-856A-7BFC847FE74B}", ["Go"], null);',
     'rtl.createClass(this, "TObject", null, function () {',
@@ -21440,6 +21442,45 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestClassInterface_Corba_ArrayOfIntf;
+begin
+  StartProgram(false);
+  Add([
+  '{$interfaces corba}',
+  'type',
+  '  IUnknown = interface end;',
+  '  IBird = interface(IUnknown)',
+  '    function Fly(w: word): word;',
+  '  end;',
+  '  TBirdArray = array of IBird;',
+  'var',
+  '  i: IBird;',
+  '  a: TBirdArray;',
+  'begin',
+  '  SetLength(a,3);',
+  '  i:=a[1];',
+  '  a[2]:=i;',
+  '  for i in a do i.fly(3);',
+  '']);
+  ConvertProgram;
+  CheckSource('TestClassInterface_Corba_ArrayOfIntf',
+    LinesToStr([ // statements
+    'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
+    'rtl.createInterface(this, "IBird", "{478D080B-C0F6-396E-AE88-000B87785B07}", ["Fly"], this.IUnknown);',
+    'this.i = null;',
+    'this.a = [];',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.a = rtl.arraySetLength($mod.a, null, 3);',
+    '$mod.i = $mod.a[1];',
+    '$mod.a[2] = $mod.i;',
+    'for (var $in = $mod.a, $l = 0, $end = rtl.length($in) - 1; $l <= $end; $l++) {',
+    '  $mod.i = $in[$l];',
+    '  $mod.i.Fly(3);',
+    '};',
+    '']));
+end;
+
 procedure TTestModule.TestClassInterface_COM_AssignVar;
 begin
   StartProgram(false);
@@ -22394,6 +22435,61 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestClassInterface_COM_ArrayOfIntf;
+begin
+  {$IFNDEF EnableCOMArrayOfIntf}
+  exit;
+  {$ENDIF}
+  StartProgram(false);
+  Add([
+  '{$interfaces com}',
+  'type',
+  '  IUnknown = interface end;',
+  '  IBird = interface(IUnknown)',
+  '    function Fly(w: word): word;',
+  '  end;',
+  '  TBirdArray = array of IBird;',
+  'procedure Run;',
+  'var',
+  '  i: IBird;',
+  '  a,b: TBirdArray;',
+  'begin',
+  //'  SetLength(a,3);',
+  '  a:=b;',
+  '  i:=a[1];',
+  '  a[2]:=i;',
+  //'  for i in a do i.fly(3);',
+  // a:=copy(b,1,2);
+  // a:=concat(b,a);
+  // insert(i,b,1);
+  // a:=[i,i];
+  'end;',
+  // ToDo: pass TBirdArray as arg
+  'begin',
+  '']);
+  ConvertProgram;
+  CheckSource('TestClassInterface_COM_ArrayOfIntf',
+    LinesToStr([ // statements
+    'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
+    'rtl.createInterface(this, "IBird", "{478D080B-C0F6-396E-AE88-000B87785B07}", ["Fly"], this.IUnknown);',
+    'this.Run = function () {',
+    '  var i = null;',
+    '  var a = [];',
+    '  var b = [];',
+    '  try {',
+    '    a = rtl.arrayRef(b);',
+    '    i = rtl.setIntfL(i, a[1]);',
+    '    rtl.setIntfP(a, 2, i);',
+    '  } finally {',
+    '    rtl._Release(i);',
+    '    rtl._ReleaseArray(a,1);',
+    '  };',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
 procedure TTestModule.TestClassInterface_COM_ArrayOfIntfFail;
 begin
   StartProgram(false);
@@ -22490,7 +22586,7 @@ begin
     );
 end;
 
-procedure TTestModule.TestClassInterface_GUID;
+procedure TTestModule.TestClassInterface_Corba_GUID;
 begin
   StartProgram(false);
   Add([
@@ -22542,7 +22638,7 @@ begin
   '  if g=s then ;',
   '']);
   ConvertProgram;
-  CheckSource('TestClassInterface_GUID',
+  CheckSource('TestClassInterface_Corba_GUID',
     LinesToStr([ // statements
     'rtl.createInterface(this, "IUnknown", "{F31DB68F-3010-D355-4EBA-CDD4EF4A737C}", [], null);',
     'rtl.createClass(this, "TObject", null, function () {',
@@ -22634,7 +22730,7 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestClassInterface_GUIDProperty;
+procedure TTestModule.TestClassInterface_Corba_GUIDProperty;
 begin
   StartProgram(false);
   Add([

utils/pas2js/dist/rtl.js

@@ -814,6 +814,18 @@ var rtl = {
     return intf;
   },
 
+  _ReleaseArray: function(a,dim){
+    if (!a) return null;
+    for (var i=0; i<a.length; i++){
+      if (dim<=1){
+        if (a[i]) a[i]._Release();
+      } else {
+        rtl._ReleaseArray(a[i],dim-1);
+      }
+    }
+    return null;
+  },
+
   trunc: function(a){
     return a<0 ? Math.ceil(a) : Math.floor(a);
   },