paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-28 16:20:15 +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;
end; end;
var var
IsUntyped, ok, LastHadDefaultValue: Boolean; OldForceCaret,IsUntyped, ok, LastHadDefaultValue: Boolean;
Name : String; Name : String;
Value : TPasExpr; Value : TPasExpr;
i, OldArgCount: Integer; i, OldArgCount: Integer;
@ -5022,9 +5022,11 @@ begin
if not IsUntyped then if not IsUntyped then
begin begin
Arg := TPasArgument(Args[OldArgCount]); Arg := TPasArgument(Args[OldArgCount]);
ArgType := ParseType(Arg,CurSourcePos); ArgType:=Nil;
ok:=false; ok:=false;
oldForceCaret:=Scanner.SetForceCaret(True);
try try
ArgType := ParseType(Arg,CurSourcePos);
NextToken; NextToken;
if CurToken = tkEqual then if CurToken = tkEqual then
begin begin
@ -5048,6 +5050,7 @@ begin
UngetToken; UngetToken;
ok:=true; ok:=true;
finally finally
Scanner.SetForceCaret(oldForceCaret);
if (not ok) and (ArgType<>nil) then if (not ok) and (ArgType<>nil) then
ArgType.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; ArgType.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
end; end;

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

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