paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-13 05:29:34 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
mattias 2025-02-05 16:51:46 +01:00
parent 4d8c9c9d78
commit d0b4e8730a
2 changed files with 124 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

@ -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}