paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-18 12:39:36 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: fixed makring array[]:= as read

Browse Source 
git-svn-id: trunk@41714 -
This commit is contained in:
Mattias Gaertner 2019-03-16 15:44:52 +00:00
parent 7ab75c1194
commit 721d20fb8f
3 changed files with 69 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -9696,7 +9696,8 @@ begin
if DeclEl is TPasProcedure then
begin
Proc:=TPasProcedure(DeclEl);
if (Access=rraAssign) and (Proc.ProcType is TPasFunctionType)
if (Access=rraAssign)
and (Proc.ProcType is TPasFunctionType)
and (Params.Parent.ClassType=TPasImplAssign)
and (TPasImplAssign(Params.Parent).left=Params) then
begin
@ -9712,6 +9713,7 @@ begin
end;
end;
end;
ComputeElement(NameExpr,ResolvedEl,[rcSetReferenceFlags]);
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.ResolveArrayParamsExprName NameExp=',GetObjName(NameExpr),' ',GetResolverResultDbg(ResolvedEl));
@ -9722,11 +9724,33 @@ end;
procedure TPasResolver.ResolveArrayParamsArgs(Params: TParamsExpr;
const ResolvedValue: TPasResolverResult; Access: TResolvedRefAccess);
procedure ReadAccessParamValue;
var
Left: TPasExpr;
Ref: TResolvedReference;
begin
if Access=rraAssign then
begin
// ArrayStringPointer[]:=
// -> writing the element needs reading the value
Left:=Params.Value;
if (Left is TBinaryExpr) and (TBinaryExpr(Left).OpCode=eopSubIdent) then
Left:=TBinaryExpr(Left).right;
if Left.CustomData is TResolvedReference then
begin
Ref:=TResolvedReference(Left.CustomData);
if Ref.Access=rraAssign then
Ref.Access:=rraReadAndAssign;
end;
end;
end;
function CheckStringOrPointerIndex(IsStringIndex: boolean): boolean;
var
ArgExp: TPasExpr;
ResolvedArg: TPasResolverResult;
begin
ReadAccessParamValue;
if not IsStringIndex then
begin
// pointer
@ -9795,6 +9819,7 @@ begin
if ResolvedValue.IdentEl is TPasType then
RaiseMsg(20170216152215,nIllegalQualifierAfter,sIllegalQualifierAfter,
['[',ResolvedValue.IdentEl.ElementTypeName],Params);
ReadAccessParamValue;
CheckCallArrayCompatibility(TPasArrayType(TypeEl),Params,true,true);
for i:=0 to length(Params.Params)-1 do
AccessExpr(Params.Params[i],rraRead);

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

@ -557,7 +557,6 @@ type
Procedure TestClass_MethodOverloadUnit;
Procedure TestClass_HintMethodHidesNonVirtualMethod;
Procedure TestClass_HintMethodHidesNonVirtualMethodWithoutBody_NoHint;
Procedure TestClass_HintMethodHidesNonVirtualMethodExact;
Procedure TestClass_NoHintMethodHidesPrivateMethod;
Procedure TestClass_MethodReintroduce;
Procedure TestClass_MethodOverloadArrayOfTClass;
@ -640,6 +639,7 @@ type
// external class
Procedure TestExternalClass;
Procedure TestExternalClass_Descendant;
Procedure TestExternalClass_HintMethodHidesNonVirtualMethodExact;
// class of
Procedure TestClassOf;
@ -9510,31 +9510,6 @@ begin
CheckResolverUnexpectedHints(true);
end;
procedure TTestResolver.TestClass_HintMethodHidesNonVirtualMethodExact;
begin
StartProgram(false);
Add([
'{$modeswitch externalclass}',
'type',
' TJSObject = class external name ''JSObject''',
' procedure DoIt(p: pointer);',
' end;',
' TBird = class external name ''Bird''(TJSObject)',
' procedure DoIt(p: pointer);',
' end;',
'procedure TJSObject.DoIt(p: pointer);',
'begin',
' if p=nil then ;',
'end;',
'procedure TBird.DoIt(p: pointer); begin end;',
'var b: TBird;',
'begin',
' b.DoIt(nil);']);
ParseProgram;
CheckResolverHint(mtHint,nMethodHidesNonVirtualMethodExactly,
'method hides identifier at "afile.pp(5,19)". Use reintroduce');
end;
procedure TTestResolver.TestClass_NoHintMethodHidesPrivateMethod;
begin
AddModuleWithIntfImplSrc('unit2.pas',
@ -11422,6 +11397,31 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestExternalClass_HintMethodHidesNonVirtualMethodExact;
begin
StartProgram(false);
Add([
'{$modeswitch externalclass}',
'type',
' TJSObject = class external name ''JSObject''',
' procedure DoIt(p: pointer);',
' end;',
' TBird = class external name ''Bird''(TJSObject)',
' procedure DoIt(p: pointer);',
' end;',
'procedure TJSObject.DoIt(p: pointer);',
'begin',
' if p=nil then ;',
'end;',
'procedure TBird.DoIt(p: pointer); begin end;',
'var b: TBird;',
'begin',
' b.DoIt(nil);']);
ParseProgram;
CheckResolverHint(mtHint,nMethodHidesNonVirtualMethodExactly,
'method hides identifier at "afile.pp(5,19)". Use reintroduce');
end;
procedure TTestResolver.TestClassOf;
begin
StartProgram(false);

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

@ -101,6 +101,7 @@ type
procedure TestM_Hint_ParameterNotUsedTypecast;
procedure TestM_Hint_OutParam_No_AssignedButNeverUsed;
procedure TestM_Hint_ArgPassed_No_ParameterNotUsed;
procedure TestM_Hint_ArrayArg_No_ParameterNotUsed;
procedure TestM_Hint_InheritedWithoutParams;
procedure TestM_Hint_LocalVariableNotUsed;
procedure TestM_HintsOff_LocalVariableNotUsed;
@ -1607,6 +1608,22 @@ begin
CheckUseAnalyzerUnexpectedHints;
end;
procedure TTestUseAnalyzer.TestM_Hint_ArrayArg_No_ParameterNotUsed;
begin
StartProgram(false);
Add([
'type TArr = array of boolean;',
'procedure Fly(a: TArr);',
'begin',
' a[1]:=true;',
'end;',
'begin',
' Fly(nil);',
'']);
AnalyzeProgram;
CheckUseAnalyzerUnexpectedHints;
end;
procedure TTestUseAnalyzer.TestM_Hint_InheritedWithoutParams;
begin
StartProgram(false);