einfo.ads, einfo.adb (Has_Out_Or_In_Out_Parameter): This attribute is now present in subprograms...

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.

From-SVN: r223643

1 files changed, 73 insertions, 20 deletions

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 8b9dfca..5f6f464 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);