pastojs: convert exit(ComIntf) to setting Result variable, issue #39292

packages/pastojs/src/fppas2js.pp

@@ -13422,8 +13422,10 @@ var
   St: TJSStatementList;
   ImplProc, DeclProc: TPasProcedure;
   ImplTry: TPasImplTry;
-  ResultIsRead: Boolean;
+  ResultIsRead, IsCOMIntf: Boolean;
   ResultEl: TPasResultElement;
+  TypeEl: TPasType;
+  Call: TJSCallExpression;
 begin
   {$IFDEF VerbosePas2JS}
   writeln('TPasToJSConverter.ConvertBuiltIn_Exit ',GetObjName(El));
@@ -13434,16 +13436,30 @@ begin
   // ParentEl can be nil, when exit is in program begin block
   ImplProc:=TPasProcedure(ParentEl);
   ResultVarName:='';
+  ResultEl:=nil;
+  IsCOMIntf:=false;
   if ImplProc<>nil then
     begin
     ImplProcScope:=ImplProc.CustomData as TPas2JSProcedureScope;
-    if ImplProc.ProcType is TPasFunctionType then
+    DeclProc:=ImplProcScope.DeclarationProc;
+    if DeclProc=nil then
+      DeclProc:=ImplProc; // Note: references refer to ResultEl of DeclProc
+    if DeclProc.ProcType is TPasFunctionType then
       begin
       ResultVarName:=ImplProcScope.ResultVarName; // ResultVarName needs ImplProc
       if ResultVarName='' then
         ResultVarName:=ResolverResultVar;
+      ResultEl:=TPasFunctionType(DeclProc.ProcType).ResultEl;
+      TypeEl:=AContext.Resolver.ResolveAliasType(ResultEl.ResultType);
+      IsCOMIntf:=(TypeEl is TPasClassType)
+          and (TPasClassType(TypeEl).ObjKind=okInterface)
+          and (TPasClassType(TypeEl).InterfaceType=citCom);
       end;
-    end;
+    end
+  else
+    DeclProc:=nil;
+  FuncContext:=AContext.GetFunctionContext;
+
   Result:=TJSReturnStatement(CreateElement(TJSReturnStatement,El));
   if (El is TParamsExpr) and (length(TParamsExpr(El).Params)>0) then
     begin
@@ -13451,10 +13467,6 @@ begin
     ResultIsRead:=false;
     if (ResultVarName<>'') then
       begin
-      DeclProc:=ImplProcScope.DeclarationProc;
-      if DeclProc=nil then
-        DeclProc:=ImplProc; // Note: references refer to ResultEl of DeclProc
-      ResultEl:=TPasFunctionType(DeclProc.ProcType).ResultEl;
       ParentEl:=El.Parent;
       while (ParentEl<>ImplProc) do
         begin
@@ -13474,7 +13486,24 @@ begin
         end;
       end;
 
-    if ResultIsRead then
+    if IsCOMIntf then
+      begin
+      FuncContext.ResultNeedsIntfRelease:=true;
+      // create "Result = rtl.setIntfL(Result,param); return Result;"
+      Call:=CreateCallExpression(El);
+      Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnIntfSetIntfL)]);
+      Call.AddArg(CreatePrimitiveDotExpr(ResultVarName,El));
+      Call.AddArg(ConvertExpression(TParamsExpr(El).Params[0],AContext));
+      AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
+      AssignSt.LHS:=CreatePrimitiveDotExpr(ResultVarName,El);
+      AssignSt.Expr:=Call;
+      TJSReturnStatement(Result).Expr:=CreatePrimitiveDotExpr(ResultVarName,El);
+      St:=TJSStatementList(CreateElement(TJSStatementList,El));
+      St.A:=AssignSt;
+      St.B:=Result;
+      Result:=St;
+      end
+    else if ResultIsRead then
       begin
       // create "Result = param; return Result;"
       AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
@@ -13504,7 +13533,6 @@ begin
       ; // in a procedure, "return;" which means "return undefined;"
     end;
 
-  FuncContext:=AContext.GetFunctionContext;
   if (FuncContext<>nil) and FuncContext.ResultNeedsIntfRelease then
     begin
     // add "$ok = true;"

packages/pastojs/tests/tcmodules.pas

@@ -722,6 +722,7 @@ type
     Procedure TestClassInterface_COM_AssignArg;
     Procedure TestClassInterface_COM_FunctionResult;
     Procedure TestClassInterface_COM_InheritedFuncResult;
+    Procedure TestClassInterface_COM_FunctionExit;
     Procedure TestClassInterface_COM_IsAsTypeCasts;
     Procedure TestClassInterface_COM_PassAsArg;
     Procedure TestClassInterface_COM_PassToUntypedParam;
@@ -22083,6 +22084,67 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestClassInterface_COM_FunctionExit;
+begin
+  StartProgram(false);
+  Add([
+  '{$interfaces com}',
+  'type',
+  '  IUnknown = interface',
+  '    function _AddRef: longint;',
+  '    function _Release: longint;',
+  '  end;',
+  '  TObject = class(IUnknown)',
+  '    function _AddRef: longint; virtual; abstract;',
+  '    function _Release: longint; virtual; abstract;',
+  '    constructor Create;',
+  '  end;',
+  'constructor TObject.Create;',
+  'begin',
+  'end;',
+  'function GetIntf: IUnknown;',
+  'var Intf: IUnknown;',
+  'begin',
+  '  Intf := TObject.Create;',
+  '  Exit(Intf);',
+  'end;',
+  'begin',
+  '']);
+  ConvertProgram;
+  CheckSource('TestClassInterface_COM_FunctionExit',
+    LinesToStr([ // statements
+    'rtl.createInterface(this, "IUnknown", "{D7ADB0E1-758A-322B-BDDF-21CD521DDFA9}", ["_AddRef", "_Release"], null);',
+    'rtl.createClass(this, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  this.Create = function () {',
+    '    return this;',
+    '  };',
+    '  rtl.addIntf(this, $mod.IUnknown);',
+    '});',
+    'this.GetIntf = function () {',
+    '  var Result = null;',
+    '  var Intf = null;',
+    '  var $ok = false;',
+    '  try {',
+    '    Intf = rtl.setIntfL(Intf, rtl.queryIntfT($mod.TObject.$create("Create"), $mod.IUnknown), true);',
+    '    $ok = true;',
+    '    Result = rtl.setIntfL(Result, Intf);',
+    '    return Result;',
+    '    $ok = true;',
+    '  } finally {',
+    '    rtl._Release(Intf);',
+    '    if (!$ok) rtl._Release(Result);',
+    '  };',
+    '  return Result;',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '']));
+end;
+
 procedure TTestModule.TestClassInterface_COM_IsAsTypeCasts;
 begin
   StartProgram(false);