From 429438fbb9ed8127d3129ad0bfdec8081afbd05d Mon Sep 17 00:00:00 2001
From: mattias <nc-gaertnma@netcologne.de>
Date: Thu, 21 Oct 2021 20:02:22 +0200
Subject: [PATCH] pastojs: fixed clear com interface reference in class field
on destroy
---
packages/pastojs/src/fppas2js.pp | 37 +++++++++++++++------
packages/pastojs/tests/tcmodules.pas | 48 ++++++++++++++++++++++++----
2 files changed, 69 insertions(+), 16 deletions(-)
diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp
index 2a1752f131..a19880f74e 100644
--- a/packages/pastojs/src/fppas2js.pp
+++ b/packages/pastojs/src/fppas2js.pp
@@ -19175,6 +19175,9 @@ var
Func: TJSFunctionDeclarationStatement;
VarType: TPasType;
AssignSt: TJSSimpleAssignStatement;
+ C: TClass;
+ ElClass: TPasClassType;
+ Call: TJSCallExpression;
begin
// add instance members
AncestorIsExternal:=(Ancestor is TPasClassType) and TPasClassType(Ancestor).IsExternal;
@@ -19204,13 +19207,29 @@ begin
// mfFinalize: clear reference
if vmExternal in TPasVariable(P).VarModifiers then continue;
VarType:=ClassContext.Resolver.ResolveAliasType(TPasVariable(P).VarType);
- if (VarType.ClassType=TPasRecordType)
- or (VarType.ClassType=TPasClassType)
- or (VarType.ClassType=TPasClassOfType)
- or (VarType.ClassType=TPasSetType)
- or (VarType.ClassType=TPasProcedureType)
- or (VarType.ClassType=TPasFunctionType)
- or (VarType.ClassType=TPasArrayType) then
+ C:=VarType.ClassType;
+ if (C=TPasClassType) then
+ begin
+ ElClass:=TPasClassType(VarType);
+ if (ElClass.ObjKind=okInterface) and (ElClass.InterfaceType=citCom) then
+ begin
+ // rtl.setIntfP(this,"FieldName",null)
+ Call:=CreateCallExpression(El);
+ NewEl:=Call;
+ Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnIntfSetIntfP)]);
+ Call.AddArg(CreatePrimitiveDotExpr('this',El));
+ Call.AddArg(CreateLiteralString(El,TransformElToJSName(P,New_FuncContext)));
+ Call.AddArg(CreateLiteralNull(El));
+ end;
+ end;
+ if (NewEl=nil)
+ and ((C=TPasRecordType)
+ or (C=TPasClassType)
+ or (C=TPasClassOfType)
+ or (C=TPasSetType)
+ or (C=TPasProcedureType)
+ or (C=TPasFunctionType)
+ or (C=TPasArrayType)) then
begin
// add 'this.FieldName = undefined;'
AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
@@ -21123,7 +21142,7 @@ begin
Result:=Call;
if LHS is TJSDotMemberExpression then
begin
- // path.name = RHS -> rtl.setIntfP(path,"IntfVar",RHS})
+ // path.name = RHS -> rtl.setIntfP(path,"IntfVar",RHS)
Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnIntfSetIntfP)]);
Call.AddArg(TJSDotMemberExpression(LHS).MExpr);
TJSDotMemberExpression(LHS).MExpr:=nil;
@@ -21136,7 +21155,7 @@ begin
end
else if LHS is TJSBracketMemberExpression then
begin
- // path[index] = RHS -> rtl.setIntfP(path,index,RHS})
+ // path[index] = RHS -> rtl.setIntfP(path,index,RHS)
Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnIntfSetIntfP)]);
Call.AddArg(TJSBracketMemberExpression(LHS).MExpr);
TJSBracketMemberExpression(LHS).MExpr:=nil;
diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas
index 66b51538b6..73e8e8dc84 100644
--- a/packages/pastojs/tests/tcmodules.pas
+++ b/packages/pastojs/tests/tcmodules.pas
@@ -20,7 +20,7 @@
unit TCModules;
{$mode objfpc}{$H+}
-
+{$Optimization }
interface
uses
@@ -910,10 +910,9 @@ type
// Library
Procedure TestLibrary_Empty;
- Procedure TestLibrary_ExportFunc; // ToDo
- // ToDo: export let as let fail
- // ToDo: Procedure TestLibrary_ExportVar;
- // ToDo: Procedure TestLibrary_Export_Index_Fail;
+ Procedure TestLibrary_ExportFunc;
+ Procedure TestLibrary_Export_Index_Fail;
+ Procedure TestLibrary_ExportVar; // ToDo
// ToDo: test delayed specialization init
// ToDo: analyzer
end;
@@ -20885,7 +20884,7 @@ begin
' this.FAnt = null;',
' };',
' this.$final = function () {',
- ' this.FAnt = undefined;',
+ ' rtl.setIntfP(this, "FAnt", null);',
' };',
' rtl.addIntf(this, $mod.IUnknown);',
'});',
@@ -21063,7 +21062,7 @@ begin
' this.FDoveObj = null;',
' };',
' this.$final = function () {',
- ' this.FBirdIntf = undefined;',
+ ' rtl.setIntfP(this, "FBirdIntf", null);',
' this.FDoveObj = undefined;',
' $mod.TObject.$final.call(this);',
' };',
@@ -33821,6 +33820,41 @@ begin
CheckResolverUnexpectedHints();
end;
+procedure TTestModule.TestLibrary_Export_Index_Fail;
+begin
+ StartLibrary(false);
+ Add([
+ 'procedure Run(w: word);',
+ 'begin',
+ 'end;',
+ 'exports',
+ ' Run index 3;',
+ '']);
+ SetExpectedPasResolverError('Not supported: export index',nNotSupportedX);
+ ConvertLibrary;
+end;
+
+procedure TTestModule.TestLibrary_ExportVar;
+begin
+ exit;
+
+ StartLibrary(false);
+ Add([
+ 'var Wing: word;',
+ 'exports',
+ ' Wing;',
+ '']);
+ ConvertLibrary;
+ CheckSource('TestLibrary_ExportVar',
+ LinesToStr([ // statements
+ 'this.Wing = 0;',
+ 'export { this.Wing as Wing };',
+ '']),
+ LinesToStr([
+ '']));
+ CheckResolverUnexpectedHints();
+end;
+
Initialization
RegisterTests([TTestModule]);
end.