diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 6575e41d29..9f143fd150 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -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); diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index e73e25d67b..515876c919 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -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); diff --git a/packages/fcl-passrc/tests/tcuseanalyzer.pas b/packages/fcl-passrc/tests/tcuseanalyzer.pas index 91831fbc3d..451f9edf20 100644 --- a/packages/fcl-passrc/tests/tcuseanalyzer.pas +++ b/packages/fcl-passrc/tests/tcuseanalyzer.pas @@ -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);