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

* Fix Pointer types as arguments

Browse Source 
git-svn-id: trunk@47900 -
This commit is contained in:
michael 2020-12-30 08:52:38 +00:00
parent 8eafcd9490
commit 6dafbfb7ca
2 changed files with 26 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -4943,7 +4943,7 @@ procedure TPasParser.ParseArgList(Parent: TPasElement; Args: TFPList; EndToken:
end;
end;
var
IsUntyped, ok, LastHadDefaultValue: Boolean;
OldForceCaret,IsUntyped, ok, LastHadDefaultValue: Boolean;
Name : String;
Value : TPasExpr;
i, OldArgCount: Integer;
@ -5022,9 +5022,11 @@ begin
if not IsUntyped then
begin
Arg := TPasArgument(Args[OldArgCount]);
ArgType := ParseType(Arg,CurSourcePos);
ArgType:=Nil;
ok:=false;
oldForceCaret:=Scanner.SetForceCaret(True);
try
ArgType := ParseType(Arg,CurSourcePos);
NextToken;
if CurToken = tkEqual then
begin
@ -5048,6 +5050,7 @@ begin
UngetToken;
ok:=true;
finally
Scanner.SetForceCaret(oldForceCaret);
if (not ok) and (ArgType<>nil) then
ArgType.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
end;

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

@ -102,6 +102,8 @@ type
Procedure TestFunctionArrayOfConstArg;
procedure TestProcedureConstArrayOfConstArg;
Procedure TestFunctionConstArrayOfConstArg;
procedure TestProcedureOnePointerArg;
Procedure TestProcedureCdecl;
Procedure TestFunctionCdecl;
Procedure TestProcedureCdeclDeprecated;
@ -354,6 +356,7 @@ procedure TTestProcedureFunction.AssertArg(ProcType: TPasProcedureType;
Var
A : TPasArgument;
T : TPasType;
N : String;
begin
@ -361,11 +364,21 @@ begin
N:='Argument '+IntToStr(AIndex+1)+' : ';
if (TypeName='') then
AssertNull(N+' No argument type',A.ArgType)
else
else if TypeName[1]<>'^' then
begin
AssertNotNull(N+' Have argument type',A.ArgType);
AssertEquals(N+' Correct argument type name',TypeName,A.ArgType.Name);
end
else
begin
AssertNotNull(N+' Have argument type',A.ArgType);
T:=A.ArgType;
AssertEquals(N+' type Is pointer type',TPasPointerType,T.CLassType);
T:=TPasPointerType(T).DestType;
AssertNotNull(N+'Have dest type',T);
AssertEquals(N+' Correct argument dest type name',Copy(TypeName,2,MaxInt),T.Name);
end;
end;
procedure TTestProcedureFunction.AssertArrayArg(ProcType: TPasProcedureType;
@ -481,6 +494,13 @@ begin
AssertArg(ProcType,0,'B',argDefault,'Integer','');
end;
procedure TTestProcedureFunction.TestProcedureOnePointerArg;
begin
ParseProcedure('(B : ^Integer)');
AssertProc([],[],ccDefault,1);
AssertArg(ProcType,0,'B',argDefault,'^Integer','');
end;
procedure TTestProcedureFunction.TestFunctionOneArg;
begin
ParseFunction('(B : Integer)');