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

git-svn-id: trunk@41714 -

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);

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);

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);