pastojs: fixed refcount for-Intf-in-something-do, issue #39293

packages/pastojs/src/fppas2js.pp

@@ -20182,7 +20182,7 @@ var
   Statements: TJSStatementList;
   VarSt: TJSVariableStatement;
   FuncContext: TFunctionContext;
-  List, GetCurrent, J: TJSElement;
+  List, GetCurrent, J, LHS, RHS: TJSElement;
   Call: TJSCallExpression;
   TrySt: TJSTryFinallyStatement;
   WhileSt: TJSWhileStatement;
@@ -20190,9 +20190,9 @@ var
   GetEnumeratorFunc, MoveNextFunc: TPasFunction;
   CurrentProp: TPasProperty;
   DotContext: TDotContext;
-  ResolvedEl: TPasResolverResult;
-  EnumeratorTypeEl: TPasType;
-  NeedTryFinally, NeedIntfRef: Boolean;
+  ResolvedEl, VarResolved: TPasResolverResult;
+  EnumeratorTypeEl, CurrentPropTypeEl: TPasType;
+  NeedTryFinally, NeedIntfRef, IsCurrentPropCOMIntf: Boolean;
 begin
   aResolver:=AContext.Resolver;
   ForScope:=TPasForLoopScope(El.CustomData);
@@ -20242,6 +20242,10 @@ begin
     RaiseNotSupported(El,AContext,20171225104316);
   if CurrentProp.Parent.ClassType<>TPasClassType then
     RaiseNotSupported(El,AContext,20190208154003);
+  CurrentPropTypeEl:=AContext.Resolver.ResolveAliasType(CurrentProp.VarType);
+  IsCurrentPropCOMIntf:=(CurrentPropTypeEl is TPasClassType)
+      and (TPasClassType(CurrentPropTypeEl).ObjKind=okInterface)
+      and (TPasClassType(CurrentPropTypeEl).InterfaceType=citCom);
 
   // get function context
   FuncContext:=AContext.GetFunctionContext;
@@ -20292,19 +20296,41 @@ begin
 
     // read property "Current"
     // Item=$in.GetCurrent();  or Item=$in.FCurrent;
-    AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,PosEl));
-    WhileSt.Body:=AssignSt;
-    AssignSt.LHS:=ConvertExpression(El.VariableName,AContext); // beware: might fail
-
-    DotContext:=TDotContext.Create(El.StartExpr,nil,AContext);
+    LHS:=nil;
+    RHS:=nil;
+    DotContext:=nil;
     try
+      LHS:=ConvertExpression(El.VariableName,AContext); // beware: might fail
+
+      DotContext:=TDotContext.Create(El.StartExpr,nil,AContext);
       GetCurrent:=CreatePropertyGet(CurrentProp,nil,DotContext,PosEl); // beware: might fail
       if DotContext.JS<>nil then
         RaiseNotSupported(El,AContext,20180509134302,GetObjName(DotContext.JS));
+      RHS:=CreateDotExpression(PosEl,CreateInName,GetCurrent,true);
+
+      if IsCurrentPropCOMIntf then
+        begin
+        // create "Item = rtl.setIntfL(Item,$in.GetCurrent);"
+        aResolver.ComputeElement(El.VariableName,VarResolved,[]);
+        WhileSt.Body:=CreateAssignComIntfVar(VarResolved,LHS,RHS,AContext,El.VariableName);
+        LHS:=nil;
+        RHS:=nil;
+        end
+      else
+        begin
+        // Item=$in.GetCurrent();  or Item=$in.FCurrent;
+        AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,PosEl));
+        WhileSt.Body:=AssignSt;
+        AssignSt.LHS:=LHS;
+        LHS:=nil;
+        AssignSt.Expr:=RHS;
+        RHS:=nil;
+        end;
     finally
       FreeAndNil(DotContext);
+      FreeAndNil(LHS);
+      FreeAndNil(RHS);
     end;
-    AssignSt.Expr:=CreateDotExpression(PosEl,CreateInName,GetCurrent,true);
 
     // add body
     if El.Body<>nil then
@@ -23903,6 +23929,7 @@ var
         // for v in <variable> do
         if InResolved.BaseType in btAllStrings then
           begin
+          // for v in string do
           InKind:=ikString;
           StartInt:=0;
           end

packages/pastojs/tests/tcmodules.pas

@@ -731,8 +731,9 @@ type
     Procedure TestClassInterface_COM_IntfProperty;
     Procedure TestClassInterface_COM_Delegation;
     Procedure TestClassInterface_COM_With;
-    Procedure TestClassInterface_COM_ForIn;
-    Procedure TestClassInterface_COM_ArrayOfIntf;
+    Procedure TestClassInterface_COM_ForObjectInInterface;
+    Procedure TestClassInterface_COM_ForInterfaceInObject;
+    Procedure TestClassInterface_COM_ArrayOfIntf; // todo
     Procedure TestClassInterface_COM_ArrayOfIntfFail;
     Procedure TestClassInterface_COM_RecordIntfFail;
     Procedure TestClassInterface_COM_UnitInitialization;
@@ -22799,7 +22800,7 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestClassInterface_COM_ForIn;
+procedure TTestModule.TestClassInterface_COM_ForObjectInInterface;
 begin
   StartProgram(false);
   Add([
@@ -22824,7 +22825,7 @@ begin
   '  for o in i do o.Id:=3;',
   '']);
   ConvertProgram;
-  CheckSource('TestClassInterface_COM_ForIn',
+  CheckSource('TestClassInterface_COM_ForObjectInInterface',
     LinesToStr([ // statements
     'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
     'rtl.createClass(this, "TObject", null, function () {',
@@ -22852,6 +22853,88 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestClassInterface_COM_ForInterfaceInObject;
+begin
+  StartProgram(false);
+  Add([
+  '{$interfaces com}',
+  'type',
+  '  IUnknown = interface end;',
+  '  TObject = class',
+  '  end;',
+  '  IWing = interface',
+  '    function Id: longint;',
+  '  end;',
+  '  TEnumerator = class',
+  '    function GetCurrent: IWing; virtual; abstract;',
+  '    function MoveNext: Boolean; virtual; abstract;',
+  '    property Current: IWing read GetCurrent;',
+  '  end;',
+  '  TBird = class',
+  '    function GetEnumerator: TEnumerator; virtual; abstract;',
+  '    procedure Test;',
+  '  end;',
+  'procedure TBird.Test;',
+  'var',
+  '  Wing: IWing;',
+  'begin',
+  '  for Wing in Self do',
+  '    if Wing.Id=1 then ;',
+  'end;',
+  'var',
+  '  Bird: TBird;',
+  '  Wing: IWing;',
+  'begin',
+  '  for Wing in Bird do',
+  '    if Wing.Id=2 then ;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestClassInterface_COM_ForInterfaceInObject',
+    LinesToStr([ // statements
+    'rtl.createInterface(this, "IUnknown", "{B92D5841-758A-322B-B800-000000000000}", [], null);',
+    'rtl.createClass(this, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'rtl.createInterface(this, "IWing", "{8B0D080B-C0F6-396E-AE88-000BDB74730C}", ["Id"], this.IUnknown);',
+    'rtl.createClass(this, "TEnumerator", this.TObject, function () {',
+    '});',
+    'rtl.createClass(this, "TBird", this.TObject, function () {',
+    '  this.Test = function () {',
+    '    var Wing = null;',
+    '    try {',
+    '      var $in = this.GetEnumerator();',
+    '      try {',
+    '        while ($in.MoveNext()) {',
+    '          Wing = rtl.setIntfL(Wing, $in.GetCurrent(), true);',
+    '          if (Wing.Id() === 1) ;',
+    '        }',
+    '      } finally {',
+    '        $in = rtl.freeLoc($in)',
+    '      };',
+    '    } finally {',
+    '      rtl._Release(Wing);',
+    '    };',
+    '  };',
+    '});',
+    'this.Bird = null;',
+    'this.Wing = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    'var $in = $mod.Bird.GetEnumerator();',
+    'try {',
+    '  while ($in.MoveNext()) {',
+    '    rtl.setIntfP($mod, "Wing", $in.GetCurrent(), true);',
+    '    if ($mod.Wing.Id() === 2) ;',
+    '  }',
+    '} finally {',
+    '  $in = rtl.freeLoc($in)',
+    '};',
+    '']));
+end;
+
 procedure TTestModule.TestClassInterface_COM_ArrayOfIntf;
 begin
   {$IFNDEF EnableCOMArrayOfIntf}