From 288cbbbdacf90e3da12df2fd0cffba69f66369ac Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Mon, 25 May 2015 12:37:37 +0000 Subject: [PATCH] einfo.ads, einfo.adb (Has_Out_Or_In_Out_Parameter): This attribute is now present in subprograms... 2015-05-25 Javier Miranda * 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 --- gcc/ada/ChangeLog | 38 +++++++++ gcc/ada/einfo.adb | 8 +- gcc/ada/einfo.ads | 5 +- gcc/ada/sem_aggr.adb | 9 ++- gcc/ada/sem_ch12.adb | 9 ++- gcc/ada/sem_ch3.adb | 8 +- gcc/ada/sem_ch4.adb | 183 ++++++++++++++++++++++++++++++++++++++++++- gcc/ada/sem_ch6.adb | 11 ++- gcc/ada/sem_res.adb | 5 -- gcc/ada/sem_util.adb | 93 +++++++++++++++++----- 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 + + * 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 * 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 <> 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); -- 2.30.2