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

fcl-passrc: resolver: function result is writable

Browse Source 
git-svn-id: trunk@40674 -
This commit is contained in:
Mattias Gaertner 2018-12-27 09:37:51 +00:00
parent f0753517b4
commit 2d94d97887
2 changed files with 101 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1890,6 +1890,8 @@ type
function IsNameExpr(El: TPasExpr): boolean; inline; // TSelfExpr or TPrimitiveExpr with Kind=pekIdent
function GetNameExprValue(El: TPasExpr): string; // TSelfExpr or TPrimitiveExpr with Kind=pekIdent
function GetNextDottedExpr(El: TPasExpr): TPasExpr;
function GetLeftMostExpr(El: TPasExpr): TPasExpr;
function GetRightMostExpr(El: TPasExpr): TPasExpr;
function GetUsesUnitInFilename(InFileExpr: TPasExpr): string;
function GetPathStart(El: TPasExpr): TPasExpr;
function GetNewInstanceExpr(El: TPasExpr): TPasExpr;
@ -3865,6 +3867,52 @@ begin
until false;
end;
function TPasResolver.GetLeftMostExpr(El: TPasExpr): TPasExpr;
var
C: TClass;
begin
Result:=El;
while Result<>nil do
begin
El:=Result;
C:=Result.ClassType;
if C=TBinaryExpr then
begin
if TBinaryExpr(Result).OpCode<>eopSubIdent then
exit;
Result:=TBinaryExpr(Result).left;
end
else if C=TParamsExpr then
begin
if not (TParamsExpr(Result).Kind in [pekFuncParams,pekArrayParams]) then
exit;
Result:=TParamsExpr(Result).Value;
end
else
exit;
end;
end;
function TPasResolver.GetRightMostExpr(El: TPasExpr): TPasExpr;
var
C: TClass;
begin
Result:=El;
while Result<>nil do
begin
El:=Result;
C:=Result.ClassType;
if C=TBinaryExpr then
begin
if TBinaryExpr(Result).OpCode<>eopSubIdent then
exit;
Result:=TBinaryExpr(Result).right;
end
else
exit;
end;
end;
function TPasResolver.GetUsesUnitInFilename(InFileExpr: TPasExpr): string;
var
Value: TResEvalValue;
@ -7719,7 +7767,7 @@ begin
{$ENDIF}
// check LHS can be assigned
ComputeElement(El.left,LeftResolved,[rcNoImplicitProc,rcSetReferenceFlags]);
CheckCanBeLHS(LeftResolved,true,El.left);
CheckCanBeLHS(LeftResolved,true,GetRightMostExpr(El.left));
// compute RHS
ResolveExpr(El.right,rraRead);
@ -19923,8 +19971,8 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
writeln('TPasResolver.ComputeElement.ComputeIdentifier "',GetObjName(Expr),'" ',GetResolverResultDbg(ResolvedEl),' Flags=',dbgs(Flags));
{AllowWriteln-}
{$ENDIF}
if (Expr is TPrimitiveExpr) and (Expr.Parent is TParamsExpr) and (TPrimitiveExpr(Expr).Value='FA') then
//RaiseNotYetImplemented(20180621235200,Expr);
//if (Expr is TPrimitiveExpr) and (Expr.Parent is TParamsExpr) and (TPrimitiveExpr(Expr).Value='FA') then
// RaiseNotYetImplemented(20180621235200,Expr);
if not (rcSetReferenceFlags in Flags)
and (rrfNoImplicitCallWithoutParams in Ref.Flags) then
@ -19950,7 +19998,6 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
// function => return result
ComputeElement(TPasFunction(ResolvedEl.IdentEl).FuncType.ResultEl,
ResolvedEl,Flags+[rcType],StartEl);
Exclude(ResolvedEl.Flags,rrfWritable);
end
else if (ResolvedEl.IdentEl.ClassType=TPasConstructor)
and (rrfNewInstance in Ref.Flags) then

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

@ -498,10 +498,11 @@ type
// ToDo: Procedure TestAdvRecord_ClassConstructorParamsFail;
// ToDo: Procedure TestAdvRecord_ClassDestructorParamsFail;
Procedure TestAdvRecord_NestedRecordType;
Procedure TestAdvRecord_NestedArgConstFail;
Procedure TestAdvRecord_Property;
Procedure TestAdvRecord_ClassProperty;
Procedure TestAdvRecord_RecordAsFuncResult;
// ToDo: inheritedexpr fail
Procedure TestAdvRecord_InheritedFail;
// todo: for in record
// class
@ -8029,19 +8030,21 @@ begin
' type',
' TSub = record',
' x: word;',
' class var y: word;',
' procedure DoSub;',
' end;',
' var',
' Sub: TSub;',
' procedure DoIt;',
' procedure DoIt(const r: TRec);',
' end;',
'procedure TRec.TSub.DoSub;',
'begin',
' x:=3;',
'end;',
'procedure TRec.DoIt;',
'procedure TRec.DoIt(const r: TRec);',
'begin',
' Sub.x:=4;',
' r.Sub.y:=Sub.x;', // class var y is writable, even though r.Sub is not
'end;',
'var r: TRec;',
'begin',
@ -8050,6 +8053,30 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestAdvRecord_NestedArgConstFail;
begin
StartProgram(false);
Add([
'{$modeswitch advancedrecords}',
'type',
' TRec = record',
' type',
' TSub = record',
' x: word;',
' end;',
' var',
' Sub: TSub;',
' procedure DoIt(const r: TRec);',
' end;',
'procedure TRec.DoIt(const r: TRec);',
'begin',
' r.Sub.x:=4;',
'end;',
'begin',
'']);
CheckResolverException(sVariableIdentifierExpected,nVariableIdentifierExpected);
end;
procedure TTestResolver.TestAdvRecord_Property;
begin
StartProgram(false);
@ -8149,12 +8176,31 @@ begin
' {@v}v:={@A}TRec.{@A_CreateA}Create;',
' {@v}v:={@A}TRec.{@A_CreateA}Create();',
' {@v}v:={@A}TRec.{@A_CreateB}Create(3);',
' {@A}TRec.{@A_CreateA}Create.{@A_i}i:=4;',
' {@A}TRec.{@A_CreateA}Create . {@A_i}i:=4;',
' {@A}TRec.{@A_CreateA}Create().{@A_i}i:=5;',
' {@A}TRec.{@A_CreateB}Create(3).{@A_i}i:=6;']);
ParseProgram;
end;
procedure TTestResolver.TestAdvRecord_InheritedFail;
begin
StartProgram(false);
Add([
'{$modeswitch advancedrecords}',
'type',
' TRec = record',
' procedure DoIt;',
' end;',
'procedure TRec.DoIt;',
'begin',
' inherited;',
'end;',
'begin',
'']);
CheckResolverException('The use of "inherited" is not allowed in a record',
nTheUseOfXisNotAllowedInARecord);
end;
procedure TTestResolver.TestClass;
begin
StartProgram(false);