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

fcl-passrc: fixed mem leak specialize with param self

Browse Source 
git-svn-id: trunk@47038 -
This commit is contained in:
Mattias Gaertner 2020-10-03 13:05:15 +00:00
parent bb51a2134a
commit fdd3d163ff
2 changed files with 197 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

213
packages/fcl-passrc/src/pastree.pp
View File

@ -571,6 +571,7 @@ type
const Arg: Pointer); override;
procedure AddConstraint(El: TPasElement);
procedure ClearConstraints;
procedure ClearTypeReferences(aType: TPasElement); override;
Public
TypeConstraint: String deprecated; // deprecated in fpc 3.3.1
Constraints: TPasElementArray; // list of TPasExpr or TPasType, can be nil!
@ -597,6 +598,7 @@ type
public
constructor Create(const AName: string; AParent: TPasElement); override;
destructor Destroy; override;
procedure ClearTypeReferences(aType: TPasElement); override;
function ElementTypeName: string; override;
function GetDeclaration(full: boolean) : string; override;
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
@ -611,6 +613,7 @@ type
public
constructor Create(const AName: string; AParent: TPasElement); override;
destructor Destroy; override;
procedure ClearTypeReferences(aType: TPasElement); override;
function ElementTypeName: string; override;
function GetDeclaration(full : Boolean): string; override;
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
@ -650,6 +653,7 @@ type
procedure SetParent(const AValue: TPasElement); override;
public
destructor Destroy; override;
procedure ClearTypeReferences(aType: TPasElement); override;
function ElementTypeName: string; override;
function GetDeclaration(full : boolean) : string; override;
public
@ -667,6 +671,7 @@ type
TPasFileType = class(TPasType)
public
destructor Destroy; override;
procedure ClearTypeReferences(aType: TPasElement); override;
function ElementTypeName: string; override;
function GetDeclaration(full : boolean) : string; override;
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
@ -708,6 +713,7 @@ type
TPasSetType = class(TPasType)
public
destructor Destroy; override;
procedure ClearTypeReferences(aType: TPasElement); override;
function ElementTypeName: string; override;
function GetDeclaration(full : boolean) : string; override;
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
@ -755,6 +761,7 @@ type
public
constructor Create(const AName: string; AParent: TPasElement); override;
destructor Destroy; override;
procedure ClearTypeReferences(aType: TPasElement); override;
function ElementTypeName: string; override;
function GetDeclaration(full : boolean) : string; override;
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
@ -793,6 +800,7 @@ type
public
constructor Create(const AName: string; AParent: TPasElement); override;
destructor Destroy; override;
procedure ClearTypeReferences(aType: TPasElement); override;
function ElementTypeName: string; override;
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer); override;
@ -826,11 +834,11 @@ type
TPasArgument = class(TPasElement)
public
destructor Destroy; override;
procedure ClearTypeReferences(aType: TPasElement); override;
function ElementTypeName: string; override;
function GetDeclaration(full : boolean) : string; override;
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer); override;
procedure ClearTypeReferences(aType: TPasElement); override;
public
Access: TArgumentAccess;
ArgType: TPasType; // can be nil, when Access<>argDefault
@ -853,6 +861,7 @@ type
public
constructor Create(const AName: string; AParent: TPasElement); override;
destructor Destroy; override;
procedure ClearTypeReferences(aType: TPasElement); override;
class function TypeName: string; virtual;
function ElementTypeName: string; override;
function GetDeclaration(full : boolean) : string; override;
@ -1924,7 +1933,7 @@ begin
if (AValue=nil) and (Parent<>nil) then
begin
// parent is cleared
// -> clear all child references to this array (releasing loops)
// -> clear all child references to self (releasing loops)
ForEachCall(@ClearChildReferences,nil);
end;
inherited SetParent(AValue);
@ -2027,6 +2036,7 @@ begin
for i:=0 to length(Constraints)-1 do
begin
aConstraint:=Constraints[i];
if aConstraint=nil then continue;
if aConstraint.Parent=Self then
aConstraint.Parent:=nil;
aConstraint.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
@ -2034,6 +2044,22 @@ begin
Constraints:=nil;
end;
procedure TPasGenericTemplateType.ClearTypeReferences(aType: TPasElement);
var
i: SizeInt;
aConstraint: TPasElement;
begin
for i:=length(Constraints)-1 downto 0 do
begin
aConstraint:=Constraints[i];
if aConstraint=aType then
begin
aConstraint.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
Constraints[i]:=nil;
end;
end;
end;
{$IFDEF HasPTDumpStack}
procedure PTDumpStack;
begin
@ -2133,6 +2159,22 @@ begin
inherited Destroy;
end;
procedure TInlineSpecializeExpr.ClearTypeReferences(aType: TPasElement);
var
i: Integer;
El: TPasElement;
begin
for i:=Params.Count-1 downto 0 do
begin
El:=TPasElement(Params[i]);
if El=aType then
begin
El.Release{$IFDEF CheckPasTreeRefCount}('TInlineSpecializeExpr.Params'){$ENDIF};
Params.Delete(i);
end;
end;
end;
function TInlineSpecializeExpr.ElementTypeName: string;
begin
Result:=SPasTreeSpecializedExpr;
@ -2183,6 +2225,23 @@ begin
inherited Destroy;
end;
procedure TPasSpecializeType.ClearTypeReferences(aType: TPasElement);
var
i: Integer;
El: TPasElement;
begin
inherited ClearTypeReferences(aType);
for i:=Params.Count-1 downto 0 do
begin
El:=TPasElement(Params[i]);
if El=aType then
begin
El.Release{$IFDEF CheckPasTreeRefCount}('TPasSpecializeType.Params'){$ENDIF};
Params.Delete(i);
end;
end;
end;
function TPasSpecializeType.ElementTypeName: string;
begin
Result:=SPasTreeSpecializedType;
@ -3212,7 +3271,7 @@ end;
procedure TPasPointerType.SetParent(const AValue: TPasElement);
begin
if (AValue=nil) and (Parent<>nil) and (DestType<>nil)
and ((DestType.Parent=Parent) or (DestType=Self)) then
and ((DestType.HasParent(Parent)) or (DestType=Self)) then
begin
// DestType in same type section can create a loop
// -> break loop when type section is closed
@ -3231,7 +3290,7 @@ end;
procedure TPasAliasType.SetParent(const AValue: TPasElement);
begin
if (AValue=nil) and (Parent<>nil) and (DestType<>nil)
and ((DestType.Parent=Parent) or (DestType=Self)) then
and ((DestType.HasParent(Parent)) or (DestType=Self)) then
begin
// DestType in same type section can create a loop
// -> break loop when type section is closed
@ -3261,7 +3320,7 @@ begin
begin
if CurArr.ElType=Self then
begin
ReleaseAndNil(TPasElement(CurArr.ElType){$IFDEF CheckPasTreeRefCount},'TPasClassType.AncestorType'{$ENDIF});
ReleaseAndNil(TPasElement(CurArr.ElType){$IFDEF CheckPasTreeRefCount},'TPasArrayType.ElType'{$ENDIF});
break;
end;
CurArr:=TPasArrayType(CurArr.ElType);
@ -3280,12 +3339,25 @@ begin
inherited Destroy;
end;
procedure TPasArrayType.ClearTypeReferences(aType: TPasElement);
begin
inherited ClearTypeReferences(aType);
if ElType=aType then
ReleaseAndNil(TPasElement(ElType){$IFDEF CheckPasTreeRefCount},'TPasArrayType.ElType'{$ENDIF});
end;
destructor TPasFileType.Destroy;
begin
ReleaseAndNil(TPasElement(ElType){$IFDEF CheckPasTreeRefCount},'TPasFileType.ElType'{$ENDIF});
inherited Destroy;
end;
procedure TPasFileType.ClearTypeReferences(aType: TPasElement);
begin
if aType=ElType then
ReleaseAndNil(TPasElement(ElType){$IFDEF CheckPasTreeRefCount},'TPasFileType.ElType'{$ENDIF});
end;
constructor TPasEnumType.Create(const AName: string; AParent: TPasElement);
begin
inherited Create(AName, AParent);
@ -3405,9 +3477,19 @@ begin
inherited Destroy;
end;
procedure TPasRecordType.ClearTypeReferences(aType: TPasElement);
begin
inherited ClearTypeReferences(aType);
if VariantEl=aType then
ReleaseAndNil(TPasElement(VariantEl){$IFDEF CheckPasTreeRefCount},'TPasRecordType.VariantEl'{$ENDIF});
end;
{ TPasClassType }
procedure TPasClassType.SetParent(const AValue: TPasElement);
var
i: Integer;
Intf: TPasElement;
begin
if (AValue=nil) and (Parent<>nil) then
begin
@ -3417,6 +3499,15 @@ begin
ReleaseAndNil(TPasElement(AncestorType){$IFDEF CheckPasTreeRefCount},'TPasClassType.AncestorType'{$ENDIF});
if HelperForType=Self then
ReleaseAndNil(TPasElement(HelperForType){$IFDEF CheckPasTreeRefCount},'TPasClassType.HelperForType'{$ENDIF});
for i := Interfaces.Count - 1 downto 0 do
begin
Intf:=TPasElement(Interfaces[i]);
if Intf=Self then
begin
Intf.Release{$IFDEF CheckPasTreeRefCount}('TPasClassType.Interfaces'){$ENDIF};
Interfaces.Delete(i);
end;
end;
end;
inherited SetParent(AValue);
end;
@ -3443,6 +3534,27 @@ begin
inherited Destroy;
end;
procedure TPasClassType.ClearTypeReferences(aType: TPasElement);
var
i: Integer;
El: TPasElement;
begin
inherited ClearTypeReferences(aType);
if AncestorType=aType then
ReleaseAndNil(TPasElement(AncestorType){$IFDEF CheckPasTreeRefCount},'TPasClassType.AncestorType'{$ENDIF});
if HelperForType=aType then
ReleaseAndNil(TPasElement(HelperForType){$IFDEF CheckPasTreeRefCount},'TPasClassType.HelperForType'{$ENDIF});
for i := Interfaces.Count - 1 downto 0 do
begin
El:=TPasElement(Interfaces[i]);
if El=aType then
begin
El.Release{$IFDEF CheckPasTreeRefCount}('TPasClassType.Interfaces'){$ENDIF};
Interfaces[i]:=nil;
end;
end;
end;
function TPasClassType.ElementTypeName: string;
begin
case ObjKind of
@ -3557,6 +3669,45 @@ begin
inherited Destroy;
end;
procedure TPasArgument.ClearTypeReferences(aType: TPasElement);
begin
if ArgType=aType then
ReleaseAndNil(TPasElement(ArgType){$IFDEF CheckPasTreeRefCount},'TPasArgument.ArgType'{$ENDIF});
end;
function TPasArgument.GetDeclaration (full : boolean) : string;
begin
If Assigned(ArgType) then
begin
If ArgType.Name<>'' then
Result:=ArgType.SafeName
else
Result:=ArgType.GetDeclaration(False);
If Full and (Name<>'') then
Result:=SafeName+': '+Result;
end
else If Full then
Result:=SafeName
else
Result:='';
end;
procedure TPasArgument.ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer);
begin
inherited ForEachCall(aMethodCall, Arg);
ForEachChildCall(aMethodCall,Arg,ArgType,true);
ForEachChildCall(aMethodCall,Arg,ValueExpr,false);
end;
function TPasArgument.Value: String;
begin
If Assigned(ValueExpr) then
Result:=ValueExpr.GetDeclaration(true)
else
Result:='';
end;
{ TPasProcedureType }
// inline
@ -3632,6 +3783,13 @@ begin
inherited Destroy;
end;
procedure TPasProcedureType.ClearTypeReferences(aType: TPasElement);
begin
inherited ClearTypeReferences(aType);
if VarArgsType=aType then
ReleaseAndNil(TPasElement(VarArgsType){$IFDEF CheckPasTreeRefCount},'CreateElement'{$ENDIF});
end;
class function TPasProcedureType.TypeName: string;
begin
Result := 'procedure';
@ -4356,6 +4514,12 @@ begin
inherited Destroy;
end;
procedure TPasSetType.ClearTypeReferences(aType: TPasElement);
begin
if EnumType=aType then
ReleaseAndNil(TPasElement(EnumType){$IFDEF CheckPasTreeRefCount},'TPasSetType.EnumType'{$ENDIF});
end;
function TPasSetType.GetDeclaration (full : boolean) : string;
Var
@ -5105,45 +5269,6 @@ begin
Result:=ptDestructor;
end;
function TPasArgument.GetDeclaration (full : boolean) : string;
begin
If Assigned(ArgType) then
begin
If ArgType.Name<>'' then
Result:=ArgType.SafeName
else
Result:=ArgType.GetDeclaration(False);
If Full and (Name<>'') then
Result:=SafeName+': '+Result;
end
else If Full then
Result:=SafeName
else
Result:='';
end;
procedure TPasArgument.ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer);
begin
inherited ForEachCall(aMethodCall, Arg);
ForEachChildCall(aMethodCall,Arg,ArgType,true);
ForEachChildCall(aMethodCall,Arg,ValueExpr,false);
end;
procedure TPasArgument.ClearTypeReferences(aType: TPasElement);
begin
if ArgType=aType then
ReleaseAndNil(TPasElement(ArgType){$IFDEF CheckPasTreeRefCount},'TPasArgument.ArgType'{$ENDIF});
end;
function TPasArgument.Value: String;
begin
If Assigned(ValueExpr) then
Result:=ValueExpr.GetDeclaration(true)
else
Result:='';
end;
{ TPassTreeVisitor }
procedure TPassTreeVisitor.Visit(obj: TPasElement);

28
packages/fcl-passrc/tests/tcresolvegenerics.pas
View File

@ -95,6 +95,7 @@ type
procedure TestGen_Class_ReferenceTo;
procedure TestGen_Class_TwoSpecsAreNotRelatedWarn;
procedure TestGen_Class_List;
procedure TestGen_Class_Typecast;
// ToDo: different modeswitches at parse time and specialize time
// generic external class
@ -1629,6 +1630,33 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_Class_Typecast;
begin
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TObject = class end;',
' TList<T> = class',
' end;',
' TEagle = class;',
' TBird = class',
' FLegs: TList<TBird>;',
' property Legs: TList<TBird> read FLegs write FLegs;',
' end;',
' TEagle = class(TBird)',
' end;',
'var',
' B: TBird;',
' List: TList<TEagle>;',
'begin',
// ' List:=TList<Eagle>(B.Legs);',
// ' TList<Eagle>(B.Legs):=List;',
'',
'']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_ExtClass_Array;
begin
StartProgram(false);