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

fcl-passrc: fixed mem leak on error during parsing function type

Browse Source 
(cherry picked from commit 89abeff99a)
This commit is contained in:
mattias 2022-03-20 17:58:23 +01:00 committed by Mattias Gaertner
parent ee3383d3a8
commit d6cf7f5b5c
3 changed files with 43 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
packages/fcl-passrc/src/pasresolver.pp
View File

@ -12082,6 +12082,8 @@ begin
CurName:=''; CurName:='';
p:=El.Parent; p:=El.Parent;
repeat repeat
if p=nil then
RaiseNotYetImplemented(20220320165553,El);
if (p is TPasDeclarations) or (p is TPasMembersType) then if (p is TPasDeclarations) or (p is TPasMembersType) then
begin begin
if CurName='' then if CurName='' then
@ -12563,6 +12565,7 @@ procedure TPasResolver.AddProcedureType(El: TPasProcedureType;
TypeParams: TFPList); TypeParams: TFPList);
var var
Scope: TPasProcTypeScope; Scope: TPasProcTypeScope;
C: TClass;
begin begin
if El.Name<>'' then if El.Name<>'' then
begin begin
@ -12602,6 +12605,11 @@ begin
else else
begin begin
// anonymous procedure type, e.g. "var p: procedure;" // anonymous procedure type, e.g. "var p: procedure;"
C:=El.Parent.ClassType;
if C.InheritsFrom(TPasVariable) then
// ok
else
RaiseMsg(20220320165827,nCannotNestAnonymousX,sCannotNestAnonymousX,[GetElementTypeName(El)],El);
DeanonymizeType(El); DeanonymizeType(El);
end; end;
end; end;
@ -21244,6 +21252,7 @@ begin
RaiseMsg(20171018121900,nCantFindUnitX,sCantFindUnitX,[AName],El) RaiseMsg(20171018121900,nCantFindUnitX,sCantFindUnitX,[AName],El)
else else
RaiseNotYetImplemented(20160922163544,El); RaiseNotYetImplemented(20160922163544,El);
Result:=El; Result:=El;
finally finally
if Result=nil then if Result=nil then

51
packages/fcl-passrc/src/pparser.pp
View File

@ -2330,11 +2330,13 @@ begin
ok:=true; ok:=true;
finally finally
if not ok then if not ok then
begin
if Result<>nil then if Result<>nil then
begin begin
Result.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; Result.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
Result:=nil; Result:=nil;
end; end;
end;
end; end;
end; end;
@ -2358,27 +2360,36 @@ end;
function TPasParser.ParseVarType(Parent : TPasElement = Nil): TPasType; function TPasParser.ParseVarType(Parent : TPasElement = Nil): TPasType;
var var
NamePos: TPasSourcePos; NamePos: TPasSourcePos;
ok: Boolean;
begin begin
NextToken; Result:=nil;
case CurToken of ok:=false;
tkProcedure: try
begin NextToken;
Result := TPasProcedureType(CreateElement(TPasProcedureType, '', Parent)); case CurToken of
ParseProcedureOrFunction(Result, TPasProcedureType(Result), ptProcedure, True); tkProcedure:
if CurToken = tkSemicolon then begin
UngetToken; // Unget semicolon Result := TPasProcedureType(CreateElement(TPasProcedureType, '', Parent));
end; ParseProcedureOrFunction(Result, TPasProcedureType(Result), ptProcedure, True);
tkFunction: if CurToken = tkSemicolon then
begin UngetToken; // Unget semicolon
Result := CreateFunctionType('', 'Result', Parent, False, CurSourcePos); end;
ParseProcedureOrFunction(Result, TPasFunctionType(Result), ptFunction, True); tkFunction:
if CurToken = tkSemicolon then begin
UngetToken; // Unget semicolon Result := CreateFunctionType('', 'Result', Parent, False, CurSourcePos);
end; ParseProcedureOrFunction(Result, TPasFunctionType(Result), ptFunction, True);
else if CurToken = tkSemicolon then
NamePos:=CurSourcePos; UngetToken; // Unget semicolon
UngetToken; end;
Result := ParseType(Parent,NamePos); else
NamePos:=CurSourcePos;
UngetToken;
Result := ParseType(Parent,NamePos);
end;
ok:=true;
finally
if (not ok) and (Result<>nil) then
Result.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
end; end;
end; end;

8
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -891,7 +891,7 @@ type
Procedure TestProcType_PassProcToUntyped; Procedure TestProcType_PassProcToUntyped;
// anonymous procedure type // anonymous procedure type
Procedure TestProcTypeAnonymous_FunctionFunctionFail; // ToDo Procedure TestProcTypeAnonymous_FunctionFunctionFail;
// pointer // pointer
Procedure TestPointer; Procedure TestPointer;
@ -16526,15 +16526,13 @@ end;
procedure TTestResolver.TestProcTypeAnonymous_FunctionFunctionFail; procedure TTestResolver.TestProcTypeAnonymous_FunctionFunctionFail;
begin begin
exit;
StartProgram(false); StartProgram(false);
Add([ Add([
'var', 'var',
' f: function:function:longint;', ' f: function:function:longint;',
'begin']); 'begin']);
CheckParserException('Expected "Identifier or file"', CheckResolverException('Cannot nest anonymous functional type',
nParserExpectTokenError); nCannotNestAnonymousX);
end; end;
procedure TTestResolver.TestPointer; procedure TTestResolver.TestPointer;