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

fcl-passrc: parser: forbid anonymous/local types in proc args and result types

Browse Source
This commit is contained in:
mattias 2024-12-30 15:00:34 +01:00
parent 4e5be1337c
commit 80c59d2474
3 changed files with 17 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2153,7 +2153,7 @@ Const
NoHintTokens = [tkProcedure,tkFunction]; NoHintTokens = [tkProcedure,tkFunction];
InterfaceKindTypes : Array[Boolean] of TPasObjKind = (okInterface,okObjcProtocol); InterfaceKindTypes : Array[Boolean] of TPasObjKind = (okInterface,okObjcProtocol);
ClassKindTypes : Array[TLocalClassType] of TPasObjKind = (okClass,okObjCClass,okObjcCategory,okClassHelper); ClassKindTypes : Array[TLocalClassType] of TPasObjKind = (okClass,okObjCClass,okObjcCategory,okClassHelper);
ArgTypeTokens = [tkIdentifier,tkarray,tkSpecialize,tkCaret]; FuncArgResultTypeTokens = [tkIdentifier,tkarray,tkSpecialize];
var var
PM: TPackMode; PM: TPackMode;
@ -2173,7 +2173,8 @@ begin
ParseExc(nParserTypeNotAllowedHere,SParserTypeNotAllowedHere,[CurtokenText]); ParseExc(nParserTypeNotAllowedHere,SParserTypeNotAllowedHere,[CurtokenText]);
end; end;
if (Parent is TPasArgument) and not (CurToken in ArgTypeTokens) then if (not (CurToken in FuncArgResultTypeTokens))
and ((Parent is TPasArgument) or (Parent is TPasResultElement)) then
ParseExc(nParserParamsOrResultTypesNoLocalTypeDefs,SParserParamsOrResultTypesNoLocalTypeDefs); ParseExc(nParserParamsOrResultTypesNoLocalTypeDefs,SParserParamsOrResultTypesNoLocalTypeDefs);
case CurToken of case CurToken of

17
packages/fcl-passrc/tests/tcprocfunc.pas
View File

@ -104,8 +104,6 @@ type
Procedure TestFunctionArrayOfConstArg; Procedure TestFunctionArrayOfConstArg;
procedure TestProcedureConstArrayOfConstArg; procedure TestProcedureConstArrayOfConstArg;
Procedure TestFunctionConstArrayOfConstArg; Procedure TestFunctionConstArrayOfConstArg;
procedure TestProcedureOnePointerArg;
procedure TestFUnctionPointerResult;
Procedure TestProcedureCdecl; Procedure TestProcedureCdecl;
Procedure TestFunctionCdecl; Procedure TestFunctionCdecl;
@ -501,8 +499,6 @@ begin
AssertFunc([],[],ccDefault,0); AssertFunc([],[],ccDefault,0);
end; end;
procedure TTestProcedureFunction.TestProcedureOneArg; procedure TTestProcedureFunction.TestProcedureOneArg;
begin begin
ParseProcedure('(B : Integer)'); ParseProcedure('(B : Integer)');
@ -510,19 +506,6 @@ begin
AssertArg(ProcType,0,'B',argDefault,'Integer',''); AssertArg(ProcType,0,'B',argDefault,'Integer','');
end; end;
procedure TTestProcedureFunction.TestProcedureOnePointerArg;
begin
ParseProcedure('(B : ^Integer)');
AssertProc([],[],ccDefault,1);
AssertArg(ProcType,0,'B',argDefault,'^Integer','');
end;
procedure TTestProcedureFunction.TestFUnctionPointerResult;
begin
ParseFunction('()','^LongInt');
AssertFunc([],[],ccDefault,0);
end;
procedure TTestProcedureFunction.TestFunctionOneArg; procedure TTestProcedureFunction.TestFunctionOneArg;
begin begin
ParseFunction('(B : Integer)'); ParseFunction('(B : Integer)');

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

@ -404,6 +404,7 @@ type
Procedure TestProc_ArgAnonymouseRangeTypeFail; Procedure TestProc_ArgAnonymouseRangeTypeFail;
Procedure TestProc_ArgAnonymouseEnumTypeFail; Procedure TestProc_ArgAnonymouseEnumTypeFail;
Procedure TestProc_ArgAnonymouseSetTypeFail; Procedure TestProc_ArgAnonymouseSetTypeFail;
Procedure TestProc_ArgAnonymousePointerTypeFail;
Procedure TestProc_ArgMissingSemicolonFail; Procedure TestProc_ArgMissingSemicolonFail;
Procedure TestProcOverload; Procedure TestProcOverload;
Procedure TestProcOverloadImplDuplicateFail; Procedure TestProcOverloadImplDuplicateFail;
@ -6516,6 +6517,16 @@ begin
CheckParserException('Parameters or result types cannot contain local type definitions. Use a separate type definition in a type block.',nParserParamsOrResultTypesNoLocalTypeDefs); CheckParserException('Parameters or result types cannot contain local type definitions. Use a separate type definition in a type block.',nParserParamsOrResultTypesNoLocalTypeDefs);
end; end;
procedure TTestResolver.TestProc_ArgAnonymousePointerTypeFail;
begin
StartProgram(false);
Add([
'procedure Fly(Speed: ^word);',
'begin end;',
'begin']);
CheckParserException('Parameters or result types cannot contain local type definitions. Use a separate type definition in a type block.',nParserParamsOrResultTypesNoLocalTypeDefs);
end;
procedure TTestResolver.TestProc_ArgMissingSemicolonFail; procedure TTestResolver.TestProc_ArgMissingSemicolonFail;
begin begin
StartProgram(false); StartProgram(false);
@ -9265,7 +9276,7 @@ begin
'end;', 'end;',
'begin', 'begin',
'']); '']);
CheckResolverException('Cannot nest anonymous record',nCannotNestAnonymousX); CheckParserException('Parameters or result types cannot contain local type definitions. Use a separate type definition in a type block.',nParserParamsOrResultTypesNoLocalTypeDefs);
end; end;
procedure TTestResolver.TestRecordAnonym_ArgumentFail; procedure TTestResolver.TestRecordAnonym_ArgumentFail;
@ -16919,8 +16930,7 @@ begin
'var', 'var',
' f: function:function:longint;', ' f: function:function:longint;',
'begin']); 'begin']);
CheckResolverException('Cannot nest anonymous functional type', CheckParserException('Parameters or result types cannot contain local type definitions. Use a separate type definition in a type block.',nParserParamsOrResultTypesNoLocalTypeDefs);
nCannotNestAnonymousX);
end; end;
procedure TTestResolver.TestProcTypeAnonymous_ResultTypeFail; procedure TTestResolver.TestProcTypeAnonymous_ResultTypeFail;
@ -16931,8 +16941,7 @@ begin
'begin', 'begin',
'end;', 'end;',
'begin']); 'begin']);
CheckResolverException('Cannot nest anonymous procedural type', CheckParserException('Parameters or result types cannot contain local type definitions. Use a separate type definition in a type block.',nParserParamsOrResultTypesNoLocalTypeDefs);
nCannotNestAnonymousX);
end; end;
procedure TTestResolver.TestProcTypeAnonymous_ArgumentFail; procedure TTestResolver.TestProcTypeAnonymous_ArgumentFail;