paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-30 15:40:16 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
mattias 2025-02-05 12:46:01 +01:00
parent 7f4df82e7a
commit 4d8c9c9d78
2 changed files with 99 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
packages/pastojs/src/fppas2js.pp
View File

@ -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;"

62
packages/pastojs/tests/tcmodules.pas
View File

@ -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);