2015-05-25 Javier Miranda <miranda@adacore.com>

	* einfo.ads, einfo.adb (Has_Out_Or_In_Out_Parameter): This attribute
	is now present in subprograms, generic subprograms, entries and
	entry families.
	* sem_ch6.adb (Set_Formal_Mode): Set As_Out_Or_In_Out_Parameter
	on entries, entry families, subprograms and generic subprograms.
	* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration):
	Minor code reorganization to ensure that the Ekind attribute
	of the subprogram entity is set before its formals are
	processed. Required to allow the use of the attribute
	Has_Out_Or_In_Out_Parameter on the subprogram entity.
	* sem_aggr.adb (Resolve_Aggregate, Resolve_Extension_Aggregate):
	Perform the check on writable actuals only if the value of some
	component of the aggregate involves calling a function with
	out-mode parameters.
	(Resolve_Record_Aggregate): Propagate the Check_Actuals flag to the
	internally built aggregate.
	* sem_ch3.adb (Build_Derived_Record_Type, Record_Type_Declaration):
	Perform the check on writable actuals only if the initialization of
	some component involves calling a function with out-mode parameters.
	* sem_ch4.adb (Analyze_Arithmetic_Op, Analyze_Comparison_Op,
	Analyze_Equality_Op, Analyze_Logical_Op, Analyze_Membership_Op,
	Analyze_Range): Check writable actuals only if the
	subtrees have a call to a function with out-mode parameters
	(Analyze_Call.Check_Writable_Actuals): New subprogram. If the call
	has out or in-out parameters then mark its outermost enclosing
	construct as a node on which the writable actuals check must
	be performed.
	(Analyze_Call): Check if the flag must be set and if the outermost
	enclosing construct.
	* sem_util.adb (Check_Function_Writable_Actuals): Code cleanup
	and reorganization. We skip processing aggregate discriminants
	since their precise analysis involves two phases traversal.
	* sem_res.adb (Resolve_Actuals, Resolve_Arithmetic_Op,
	Resolve_Logical_Op, Resolve_Membership_Op): Remove call to
	check_writable_actuals.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@223643 138bc75d-0d04-0410-961f-82ee72b054a4

10 files changed, 329 insertions, 40 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4a6f2775303..5afd2f8f583 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,41 @@
+2015-05-25  Javier Miranda  <miranda@adacore.com>
+
+	* einfo.ads, einfo.adb (Has_Out_Or_In_Out_Parameter): This attribute
+	is now present in subprograms, generic subprograms, entries and
+	entry families.
+	* sem_ch6.adb (Set_Formal_Mode): Set As_Out_Or_In_Out_Parameter
+	on entries, entry families, subprograms and generic subprograms.
+	* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration):
+	Minor code reorganization to ensure that the Ekind attribute
+	of the subprogram entity is set before its formals are
+	processed. Required to allow the use of the attribute
+	Has_Out_Or_In_Out_Parameter on the subprogram entity.
+	* sem_aggr.adb (Resolve_Aggregate, Resolve_Extension_Aggregate):
+	Perform the check on writable actuals only if the value of some
+	component of the aggregate involves calling a function with
+	out-mode parameters.
+	(Resolve_Record_Aggregate): Propagate the Check_Actuals flag to the
+	internally built aggregate.
+	* sem_ch3.adb (Build_Derived_Record_Type, Record_Type_Declaration):
+	Perform the check on writable actuals only if the initialization of
+	some component involves calling a function with out-mode parameters.
+	* sem_ch4.adb (Analyze_Arithmetic_Op, Analyze_Comparison_Op,
+	Analyze_Equality_Op, Analyze_Logical_Op, Analyze_Membership_Op,
+	Analyze_Range): Check writable actuals only if the
+	subtrees have a call to a function with out-mode parameters
+	(Analyze_Call.Check_Writable_Actuals): New subprogram. If the call
+	has out or in-out parameters then mark its outermost enclosing
+	construct as a node on which the writable actuals check must
+	be performed.
+	(Analyze_Call): Check if the flag must be set and if the outermost
+	enclosing construct.
+	* sem_util.adb (Check_Function_Writable_Actuals): Code cleanup
+	and reorganization. We skip processing aggregate discriminants
+	since their precise analysis involves two phases traversal.
+	* sem_res.adb (Resolve_Actuals, Resolve_Arithmetic_Op,
+	Resolve_Logical_Op, Resolve_Membership_Op): Remove call to
+	check_writable_actuals.
+
 2015-05-22  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_ch3.adb (Constrain_Concurrent): If the context is a
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 64426ec3af6..2c9a4bab0f9 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -1611,7 +1611,9 @@ package body Einfo is
 
    function Has_Out_Or_In_Out_Parameter (Id : E) return B is
    begin
-      pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function));
+      pragma Assert
+        (Ekind_In (Id, E_Entry, E_Entry_Family)
+          or else Is_Subprogram_Or_Generic_Subprogram (Id));
       return Flag110 (Id);
    end Has_Out_Or_In_Out_Parameter;
 
@@ -4505,7 +4507,9 @@ package body Einfo is
 
    procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True) is
    begin
-      pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function));
+      pragma Assert
+        (Ekind_In (Id, E_Entry, E_Entry_Family)
+          or else Is_Subprogram_Or_Generic_Subprogram (Id));
       Set_Flag110 (Id, V);
    end Set_Has_Out_Or_In_Out_Parameter;
 
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index fcb37fa54b6..8676713b7b9 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -1756,8 +1756,9 @@ package Einfo is
 --       Object_Size clauses for a given entity.
 
 --    Has_Out_Or_In_Out_Parameter (Flag110)
---       Present in function and generic function entities. Set if the function
---       has at least one OUT or IN OUT parameter (allowed only in Ada 2012).
+--       Present in subprograms, generic subprograms, entries and entry
+--       families. Set if they have at least one OUT or IN OUT parameter
+--       (allowed for functions only in Ada 2012).
 
 --    Has_Per_Object_Constraint (Flag154)
 --       Defined in E_Component entities. Set if the subtype of the component
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index dce37c887fe..d38547d701c 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -1161,7 +1161,9 @@ package body Sem_Aggr is
          Set_Analyzed (N);
       end if;
 
-      Check_Function_Writable_Actuals (N);
+      if Check_Actuals (N) then
+         Check_Function_Writable_Actuals (N);
+      end if;
    end Resolve_Aggregate;
 
    -----------------------------
@@ -2904,7 +2906,9 @@ package body Sem_Aggr is
          Error_Msg_N ("no unique type for this aggregate",  A);
       end if;
 
-      Check_Function_Writable_Actuals (N);
+      if Check_Actuals (N) then
+         Check_Function_Writable_Actuals (N);
+      end if;
    end Resolve_Extension_Aggregate;
 
    ------------------------------
@@ -4677,6 +4681,7 @@ package body Sem_Aggr is
          Set_Expressions            (New_Aggregate, No_List);
          Set_Etype                  (New_Aggregate, Etype (N));
          Set_Component_Associations (New_Aggregate, New_Assoc_List);
+         Set_Check_Actuals          (New_Aggregate, Check_Actuals (N));
 
          Rewrite (N, New_Aggregate);
       end Step_8;
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index b5c8888bb6a..a915a43f33b 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -3366,13 +3366,17 @@ package body Sem_Ch12 is
 
       Formals := Parameter_Specifications (Spec);
 
+      if Nkind (Spec) = N_Function_Specification then
+         Set_Ekind (Id, E_Generic_Function);
+      else
+         Set_Ekind (Id, E_Generic_Procedure);
+      end if;
+
       if Present (Formals) then
          Process_Formals (Formals, Spec);
       end if;
 
       if Nkind (Spec) = N_Function_Specification then
-         Set_Ekind (Id, E_Generic_Function);
-
          if Nkind (Result_Definition (Spec)) = N_Access_Definition then
             Result_Type := Access_Definition (Spec, Result_Definition (Spec));
             Set_Etype (Id, Result_Type);
@@ -3420,7 +3424,6 @@ package body Sem_Ch12 is
          end if;
 
       else
-         Set_Ekind (Id, E_Generic_Procedure);
          Set_Etype (Id, Standard_Void_Type);
       end if;
 
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index f0abad3a950..ecd1639242f 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -8953,7 +8953,9 @@ package body Sem_Ch3 is
            (Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type));
       end if;
 
-      Check_Function_Writable_Actuals (N);
+      if Check_Actuals (N) then
+         Check_Function_Writable_Actuals (N);
+      end if;
    end Build_Derived_Record_Type;
 
    ------------------------
@@ -21116,7 +21118,9 @@ package body Sem_Ch3 is
          Derive_Progenitor_Subprograms (T, T);
       end if;
 
-      Check_Function_Writable_Actuals (N);
+      if Check_Actuals (N) then
+         Check_Function_Writable_Actuals (N);
+      end if;
    end Record_Type_Declaration;
 
    ----------------------------
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index bea6692fc7d..e87af41e5e7 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -830,6 +830,10 @@ package body Sem_Ch4 is
       end if;
 
       Operator_Check (N);
+
+      if Check_Actuals (N) then
+         Check_Function_Writable_Actuals (N);
+      end if;
    end Analyze_Arithmetic_Op;
 
    ------------------
@@ -862,6 +866,11 @@ package body Sem_Ch4 is
       --  Check that parameter and named associations are not mixed. This is
       --  a restriction in SPARK mode.
 
+      procedure Check_Writable_Actuals (N : Node_Id);
+      --  If the call has out or in-out parameters then mark its outermost
+      --  enclosing construct as a node on which the writable actuals check
+      --  must be performed.
+
       function Name_Denotes_Function return Boolean;
       --  If the type of the name is an access to subprogram, this may be the
       --  type of a name, or the return type of the function being called. If
@@ -902,6 +911,140 @@ package body Sem_Ch4 is
          end loop;
       end Check_Mixed_Parameter_And_Named_Associations;
 
+      ----------------------------
+      -- Check_Writable_Actuals --
+      ----------------------------
+
+      --  The identification of conflicts in calls to functions with writable
+      --  actuals is performed in the analysis phase of the frontend to ensure
+      --  that it reports exactly the same errors compiling with and without
+      --  expansion enabled. It is performed in two stages:
+
+      --    1) When a call to a function with out-mode parameters is found
+      --       we climb to the outermost enclosing construct which can be
+      --       evaluated in arbitrary order and we mark it with the flag
+      --       Check_Actuals.
+
+      --    2) When the analysis of the marked node is complete then we
+      --       traverse its decorated subtree searching for conflicts
+      --       (see function Sem_Util.Check_Function_Writable_Actuals).
+
+      --  The unique exception to this general rule are aggregates, since
+      --  their analysis is performed by the frontend in the resolution
+      --  phase. For aggregates we do not climb to its enclosing construct:
+      --  we restrict the analysis to the subexpressions initializing the
+      --  aggregate components.
+
+      --  This implies that the analysis of expressions containing aggregates
+      --  is not complete since there may be conflicts on writable actuals
+      --  involving subexpressions of the enclosing logical or arithmetic
+      --  expressions. However, we cannot wait and perform the analysis when
+      --  the whole subtree is resolved since the subtrees may be transformed
+      --  thus adding extra complexity and computation cost to identify and
+      --  report exactly the same errors compiling with and without expansion
+      --  enabled.
+
+      procedure Check_Writable_Actuals (N : Node_Id) is
+
+         function Is_Arbitrary_Evaluation_Order_Construct
+           (N : Node_Id) return Boolean;
+         --  Return True if N is an Ada construct which may evaluate in
+         --  arbitrary order. This function does not cover all the language
+         --  constructs which can be evaluated in arbitrary order but the
+         --  subset needed for AI05-0144.
+
+         ---------------------------------------------
+         -- Is_Arbitrary_Evaluation_Order_Construct --
+         ---------------------------------------------
+
+         function Is_Arbitrary_Evaluation_Order_Construct
+           (N : Node_Id) return Boolean is
+         begin
+            return Nkind (N) = N_Aggregate
+               or else Nkind (N) = N_Assignment_Statement
+               or else Nkind (N) = N_Full_Type_Declaration
+               or else Nkind (N) = N_Entry_Call_Statement
+               or else Nkind (N) = N_Extension_Aggregate
+               or else Nkind (N) = N_Indexed_Component
+               or else Nkind (N) = N_Object_Declaration
+               or else Nkind (N) = N_Pragma
+               or else Nkind (N) = N_Range
+               or else Nkind (N) = N_Slice
+
+               or else Nkind (N) in N_Array_Type_Definition
+               or else Nkind (N) in N_Membership_Test
+               or else Nkind (N) in N_Op
+               or else Nkind (N) in N_Subprogram_Call;
+         end Is_Arbitrary_Evaluation_Order_Construct;
+
+      --  Start of processing for Check_Writable_Actuals
+
+      begin
+         if Comes_From_Source (N)
+           and then Present (Get_Subprogram_Entity (N))
+           and then Has_Out_Or_In_Out_Parameter (Get_Subprogram_Entity (N))
+         then
+            --  For procedures and entries there is no need to climb since
+            --  we only need to check if the actuals of this call invoke
+            --  functions whose out-mode parameters overlap.
+
+            if Nkind (N) /= N_Function_Call then
+               Set_Check_Actuals (N);
+
+            --  For calls to functions we climb to the outermost enclosing
+            --  construct where the out-mode actuals of this function may
+            --  introduce conflicts.
+
+            else
+               declare
+                  Outermost : Node_Id;
+                  P         : Node_Id := N;
+
+               begin
+                  while Present (P) loop
+
+                     --  For object declarations we can climb to such node from
+                     --  its object definition branch or from its initializing
+                     --  expression. We prefer to mark the child node as the
+                     --  outermost construct to avoid adding further complexity
+                     --  to the routine which will take care later of
+                     --  performing the writable actuals check.
+
+                     if Is_Arbitrary_Evaluation_Order_Construct (P)
+                       and then Nkind (P) /= N_Assignment_Statement
+                       and then Nkind (P) /= N_Object_Declaration
+                     then
+                        Outermost := P;
+                     end if;
+
+                     --  Avoid climbing more than needed!
+
+                     exit when Nkind (P) = N_Aggregate
+                       or else Nkind (P) = N_Assignment_Statement
+                       or else Nkind (P) = N_Entry_Call_Statement
+                       or else Nkind (P) = N_Extended_Return_Statement
+                       or else Nkind (P) = N_Extension_Aggregate
+                       or else Nkind (P) = N_Full_Type_Declaration
+                       or else Nkind (P) = N_Object_Declaration
+                       or else Nkind (P) = N_Object_Renaming_Declaration
+                       or else Nkind (P) = N_Package_Specification
+                       or else Nkind (P) = N_Pragma
+                       or else Nkind (P) = N_Procedure_Call_Statement
+                       or else Nkind (P) = N_Simple_Return_Statement
+                       or else (Nkind (P) = N_Range
+                                 and then not
+                                   Nkind_In (Parent (P), N_In, N_Not_In))
+                       or else Nkind (P) in N_Has_Condition;
+
+                     P := Parent (P);
+                  end loop;
+
+                  Set_Check_Actuals (Outermost);
+               end;
+            end if;
+         end if;
+      end Check_Writable_Actuals;
+
       ---------------------------
       -- Name_Denotes_Function --
       ---------------------------
@@ -1257,6 +1400,21 @@ package body Sem_Ch4 is
 
          End_Interp_List;
       end if;
+
+      if Ada_Version >= Ada_2012 then
+
+         --  Check if the call contains a function with writable actuals
+
+         Check_Writable_Actuals (N);
+
+         --  If found and the outermost construct which can be evaluated in
+         --  arbitrary order is precisely this call then check all its
+         --  actuals.
+
+         if Check_Actuals (N) then
+            Check_Function_Writable_Actuals (N);
+         end if;
+      end if;
    end Analyze_Call;
 
    -----------------------------
@@ -1474,6 +1632,10 @@ package body Sem_Ch4 is
       end if;
 
       Operator_Check (N);
+
+      if Check_Actuals (N) then
+         Check_Function_Writable_Actuals (N);
+      end if;
    end Analyze_Comparison_Op;
 
    ---------------------------
@@ -1721,6 +1883,10 @@ package body Sem_Ch4 is
       end if;
 
       Operator_Check (N);
+
+      if Check_Actuals (N) then
+         Check_Function_Writable_Actuals (N);
+      end if;
    end Analyze_Equality_Op;
 
    ----------------------------------
@@ -2544,6 +2710,10 @@ package body Sem_Ch4 is
       end if;
 
       Operator_Check (N);
+
+      if Check_Actuals (N) then
+         Check_Function_Writable_Actuals (N);
+      end if;
    end Analyze_Logical_Op;
 
    ---------------------------
@@ -2699,6 +2869,11 @@ package body Sem_Ch4 is
 
       if No (R) and then Ada_Version >= Ada_2012 then
          Analyze_Set_Membership;
+
+         if Check_Actuals (N) then
+            Check_Function_Writable_Actuals (N);
+         end if;
+
          return;
       end if;
 
@@ -2770,6 +2945,10 @@ package body Sem_Ch4 is
       then
          Error_Msg_N ("membership test not applicable to cpp-class types", N);
       end if;
+
+      if Check_Actuals (N) then
+         Check_Function_Writable_Actuals (N);
+      end if;
    end Analyze_Membership_Op;
 
    -----------------
@@ -3849,7 +4028,9 @@ package body Sem_Ch4 is
          Check_Universal_Expression (H);
       end if;
 
-      Check_Function_Writable_Actuals (N);
+      if Check_Actuals (N) then
+         Check_Function_Writable_Actuals (N);
+      end if;
    end Analyze_Range;
 
    -----------------------
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index d92e5baceb9..5e3be75ae98 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -10539,6 +10539,7 @@ package body Sem_Ch6 is
 
    procedure Set_Formal_Mode (Formal_Id : Entity_Id) is
       Spec : constant Node_Id := Parent (Formal_Id);
+      Id   : constant Entity_Id := Scope (Formal_Id);
 
    begin
       --  Note: we set Is_Known_Valid for IN parameters and IN OUT parameters
@@ -10546,7 +10547,13 @@ package body Sem_Ch6 is
       --  point of the call.
 
       if Out_Present (Spec) then
-         if Ekind_In (Scope (Formal_Id), E_Function, E_Generic_Function) then
+         if Ekind_In (Id, E_Entry, E_Entry_Family)
+           or else Is_Subprogram_Or_Generic_Subprogram (Id)
+         then
+            Set_Has_Out_Or_In_Out_Parameter (Id, True);
+         end if;
+
+         if Ekind_In (Id, E_Function, E_Generic_Function) then
 
             --  [IN] OUT parameters allowed for functions in Ada 2012
 
@@ -10564,8 +10571,6 @@ package body Sem_Ch6 is
                   Set_Ekind (Formal_Id, E_Out_Parameter);
                end if;
 
-               Set_Has_Out_Or_In_Out_Parameter (Scope (Formal_Id), True);
-
             --  But not in earlier versions of Ada
 
             else
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 9d7ddf4fd32..fe739341b8f 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -3566,7 +3566,6 @@ package body Sem_Res is
 
    begin
       Check_Argument_Order;
-      Check_Function_Writable_Actuals (N);
 
       if Is_Overloadable (Nam)
         and then Is_Inherited_Operation (Nam)
@@ -5508,7 +5507,6 @@ package body Sem_Res is
 
       Check_Unset_Reference (L);
       Check_Unset_Reference (R);
-      Check_Function_Writable_Actuals (N);
    end Resolve_Arithmetic_Op;
 
    ------------------
@@ -8600,8 +8598,6 @@ package body Sem_Res is
             end if;
          end;
       end if;
-
-      Check_Function_Writable_Actuals (N);
    end Resolve_Logical_Op;
 
    ---------------------------
@@ -8793,7 +8789,6 @@ package body Sem_Res is
       <<SM_Exit>>
 
       Eval_Membership_Op (N);
-      Check_Function_Writable_Actuals (N);
    end Resolve_Membership_Op;
 
    ------------------
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 8b9dfca717e..5f6f464c1ff 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -2119,11 +2119,37 @@ package body Sem_Util is
                then
                   return Skip;
 
+               --  For now we skip aggregate discriminants since they require
+               --  performing the analysis in two phases to identify conflicts:
+               --  first one analyzing discriminants and second one analyzing
+               --  the rest of components (since at runtime discriminants are
+               --  evaluated prior to components): too much computation cost
+               --  to identify a corner case???
+
+               elsif Nkind (Parent (N)) = N_Component_Association
+                  and then Nkind_In (Parent (Parent (N)),
+                             N_Aggregate,
+                             N_Extension_Aggregate)
+               then
+                  declare
+                     Choice : constant Node_Id := First (Choices (Parent (N)));
+                  begin
+                     if Ekind (Entity (N)) = E_Discriminant then
+                        return Skip;
+
+                     elsif Expression (Parent (N)) = N
+                        and then Nkind (Choice) = N_Identifier
+                        and then Ekind (Entity (Choice)) = E_Discriminant
+                     then
+                        return Skip;
+                     end if;
+                  end;
+
                --  Analyze if N is a writable actual of a function
 
                elsif Nkind (Parent (N)) = N_Function_Call then
                   declare
-                     Call   : constant Node_Id   := Parent (N);
+                     Call   : constant Node_Id := Parent (N);
                      Actual : Node_Id;
                      Formal : Node_Id;
 
@@ -2136,32 +2162,59 @@ package body Sem_Util is
                         return Abandon;
                      end if;
 
-                     Formal := First_Formal (Id);
-                     Actual := First_Actual (Call);
-                     while Present (Actual) and then Present (Formal) loop
-                        if Actual = N then
-                           if Ekind_In (Formal, E_Out_Parameter,
-                                                E_In_Out_Parameter)
-                           then
-                              Is_Writable_Actual := True;
-                           end if;
+                     if Ekind_In (Id, E_Function, E_Generic_Function)
+                       and then Has_Out_Or_In_Out_Parameter (Id)
+                     then
+                        Formal := First_Formal (Id);
+                        Actual := First_Actual (Call);
+                        while Present (Actual) and then Present (Formal) loop
+                           if Actual = N then
+                              if Ekind_In (Formal, E_Out_Parameter,
+                                                   E_In_Out_Parameter)
+                              then
+                                 Is_Writable_Actual := True;
+                              end if;
 
-                           exit;
-                        end if;
+                              exit;
+                           end if;
 
-                        Next_Formal (Formal);
-                        Next_Actual (Actual);
-                     end loop;
+                           Next_Formal (Formal);
+                           Next_Actual (Actual);
+                        end loop;
+                     end if;
                   end;
                end if;
 
                if Is_Writable_Actual then
                   if Contains (Writable_Actuals_List, N) then
-                     Error_Msg_NE
-                       ("value may be affected by call to& "
-                        & "because order of evaluation is arbitrary", N, Id);
-                     Error_Node := N;
-                     return Abandon;
+
+                     --  Report the error on the second occurrence of the
+                     --  identifier. We cannot assume that N is the second
+                     --  occurrence since traverse_func walks through Field2
+                     --  last (see comment in the body of traverse_func).
+
+                     declare
+                        Elmt : Elmt_Id := First_Elmt (Writable_Actuals_List);
+
+                     begin
+                        while Present (Elmt)
+                           and then Entity (Node (Elmt)) /= Entity (N)
+                        loop
+                           Next_Elmt (Elmt);
+                        end loop;
+
+                        if Sloc (N) > Sloc (Node (Elmt)) then
+                           Error_Node := N;
+                        else
+                           Error_Node := Node (Elmt);
+                        end if;
+
+                        Error_Msg_NE
+                          ("value may be affected by call to& "
+                           & "because order of evaluation is arbitrary",
+                           Error_Node, Id);
+                        return Abandon;
+                     end;
                   end if;
 
                   Append_New_Elmt (N, To => Writable_Actuals_List);