paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2026-02-04 07:54:58 +01:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: resolver: check reference-to when assign ano proc

Browse Source 
git-svn-id: trunk@40533 -
This commit is contained in:
Mattias Gaertner 2018-12-12 12:24:43 +00:00
parent 21c867d3fc
commit d985a016a5
4 changed files with 63 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16320,6 +16320,14 @@ begin
else
; // AnyProc = aRefTo -> ok
end
else if Proc2.Parent is TPasAnonymousProcedure then
begin
if IsAssign then
// NonRefTo := AnonymousProc -> not possible
exit(ModifierError(ptmReferenceTo))
else
; // AnyProc = AnonymousProc -> ok
end
else
begin
// neither Proc1 nor Proc2 is a reference-to -> check isNested and OfObject

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

@ -1988,7 +1988,7 @@ end;
constructor TProcedureExpr.Create(AParent: TPasElement);
begin
inherited Create(AParent,pekProcedure, eopNone);
inherited Create(AParent,pekProcedure,eopNone);
end;
destructor TProcedureExpr.Destroy;
@ -2009,8 +2009,7 @@ procedure TProcedureExpr.ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer);
begin
inherited ForEachCall(aMethodCall, Arg);
if Proc<>nil then
Proc.ForEachCall(aMethodCall,Arg);
ForEachChildCall(aMethodCall,Arg,Proc,false);
end;
{ TPasImplRaise }

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

@ -456,7 +456,7 @@ type
procedure ParseArgList(Parent: TPasElement;
Args: TFPList; // list of TPasArgument
EndToken: TToken);
procedure ParseProcedureOrFunctionHeader(Parent: TPasElement; Element: TPasProcedureType; ProcType: TProcType; OfObjectPossible: Boolean);
procedure ParseProcedureOrFunction(Parent: TPasElement; Element: TPasProcedureType; ProcType: TProcType; OfObjectPossible: Boolean);
procedure ParseProcedureBody(Parent: TPasElement);
function ParseMethodResolution(Parent: TPasElement): TPasMethodResolution;
// Properties for external access
@ -1818,14 +1818,14 @@ begin
tkProcedure:
begin
Result := TPasProcedureType(CreateElement(TPasProcedureType, '', Parent));
ParseProcedureOrFunctionHeader(Result, TPasProcedureType(Result), ptProcedure, True);
ParseProcedureOrFunction(Result, TPasProcedureType(Result), ptProcedure, True);
if CurToken = tkSemicolon then
UngetToken; // Unget semicolon
end;
tkFunction:
begin
Result := CreateFunctionType('', 'Result', Parent, False, CurSourcePos);
ParseProcedureOrFunctionHeader(Result, TPasFunctionType(Result), ptFunction, True);
ParseProcedureOrFunction(Result, TPasFunctionType(Result), ptFunction, True);
if CurToken = tkSemicolon then
UngetToken; // Unget semicolon
end;
@ -2214,6 +2214,7 @@ var
ST: TPasSpecializeType;
SrcPos, ScrPos: TPasSourcePos;
ProcType: TProcType;
ProcExpr: TProcedureExpr;
begin
Result:=nil;
@ -2272,14 +2273,13 @@ begin
ProcType:=ptAnonymousProcedure
else
ProcType:=ptAnonymousFunction;
ok:=false;
try
Result:=TProcedureExpr(CreateElement(TProcedureExpr,'',AParent,visPublic));
TProcedureExpr(Result).Proc:=TPasAnonymousProcedure(ParseProcedureOrFunctionDecl(Result,ProcType));
ok:=true;
ProcExpr:=TProcedureExpr(CreateElement(TProcedureExpr,'',AParent,visPublic));
ProcExpr.Proc:=TPasAnonymousProcedure(ParseProcedureOrFunctionDecl(ProcExpr,ProcType));
Result:=ProcExpr;
finally
if not ok then
Result.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
if Result=nil then
ProcExpr.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
end;
exit; // do not allow postfix operators . ^. [] ()
end;
@ -4144,7 +4144,7 @@ begin
Result := TPasProcedureType(CreateElement(TPasProcedureType, TypeName, Parent, NamePos));
ok:=false;
try
ParseProcedureOrFunctionHeader(Result, TPasProcedureType(Result), PT, True);
ParseProcedureOrFunction(Result, TPasProcedureType(Result), PT, True);
ok:=true;
finally
if not ok then
@ -4837,7 +4837,7 @@ begin
end;
end;
procedure TPasParser.ParseProcedureOrFunctionHeader(Parent: TPasElement;
procedure TPasParser.ParseProcedureOrFunction(Parent: TPasElement;
Element: TPasProcedureType; ProcType: TProcType; OfObjectPossible: Boolean);
Function FindInSection(AName : String;ASection : TPasSection) : Boolean;
@ -4966,10 +4966,10 @@ begin
UnGetToken;
end;
ModTokenCount:=0;
//writeln('TPasParser.ParseProcedureOrFunctionHeader IsProcType=',IsProcType,' IsAnonymous=',IsAnonymous);
//writeln('TPasParser.ParseProcedureOrFunction IsProcType=',IsProcType,' IsAnonymous=',IsAnonymous);
Repeat
inc(ModTokenCount);
//writeln('TPasParser.ParseProcedureOrFunctionHeader ',ModTokenCount,' ',CurToken,' ',CurTokenText);
//writeln('TPasParser.ParseProcedureOrFunction ',ModTokenCount,' ',CurToken,' ',CurTokenText);
LastToken:=CurToken;
NextToken;
if (CurToken = tkEqual) and IsProcType and (ModTokenCount<=3) then
@ -6184,7 +6184,7 @@ begin
else
Result.ProcType := TPasProcedureType(CreateElement(TPasProcedureType, '', Result));
end;
ParseProcedureOrFunctionHeader(Result, Result.ProcType, ProcType, False);
ParseProcedureOrFunction(Result, Result.ProcType, ProcType, False);
Result.Hints:=Result.ProcType.Hints;
Result.HintMessage:=Result.ProcType.HintMessage;
// + is detected as 'positive', but is in fact Add if there are 2 arguments.

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

@ -450,6 +450,8 @@ type
// anonymous procs
Procedure TestAnonymousProc_Assign;
Procedure TestAnonymousProc_AssignSemicolonFail;
Procedure TestAnonymousProc_Assign_ReferenceToMissingFail;
Procedure TestAnonymousProc_Assign_WrongParamListFail;
Procedure TestAnonymousProc_Arg;
Procedure TestAnonymousProc_ArgSemicolonFail;
Procedure TestAnonymousProc_EqualFail;
@ -2231,6 +2233,11 @@ begin
if TParamsExpr(El).Params[i].Parent<>El then
E('TParamsExpr(El).Params[i].Parent='+GetObjName(TParamsExpr(El).Params[i].Parent)+'<>El');
end
else if El is TProcedureExpr then
begin
if (TProcedureExpr(El).Proc<>nil) and (TProcedureExpr(El).Proc.Parent<>El) then
E('TProcedureExpr(El).Proc.Parent='+GetObjName(TProcedureExpr(El).Proc.Parent)+'<>El');
end
else if El is TPasDeclarations then
begin
for i:=0 to TPasDeclarations(El).Declarations.Count-1 do
@ -7195,6 +7202,38 @@ begin
nParserExpectTokenError);
end;
procedure TTestResolver.TestAnonymousProc_Assign_ReferenceToMissingFail;
begin
StartProgram(false);
Add([
'type',
' TProc = procedure;',
'procedure DoIt;',
'var p: TProc;',
'begin',
' p:=procedure(w: word) begin end;',
'end;',
'begin']);
CheckResolverException('procedural type modifier "reference to" mismatch',
nXModifierMismatchY);
end;
procedure TTestResolver.TestAnonymousProc_Assign_WrongParamListFail;
begin
StartProgram(false);
Add([
'type',
' TProc = reference to procedure;',
'procedure DoIt;',
'var p: TProc;',
'begin',
' p:=procedure(w: word) begin end;',
'end;',
'begin']);
CheckResolverException('Incompatible types, got 0 parameters, expected 1',
nIncompatibleTypesGotParametersExpected);
end;
procedure TTestResolver.TestAnonymousProc_Arg;
begin
StartProgram(false);