diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 44 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 80 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 34 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 21 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 121 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 48 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_warn.adb | 9 |
10 files changed, 241 insertions, 134 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2631caf..8f5ef1b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,47 @@ +2017-09-08 Arnaud Charlet <charlet@adacore.com> + + * sem_util.ads, sem_util.adb (Is_CCT_Instance): moved from + sem_prag.adb to make it available for GNATprove; for concurrent + types replace custom scope climbing with Scope_Same_Or_Within; for + single concurrent objects add scope climbing (with Scope_Within), + which was not there (that's the primary semantic change of this + commit); also, when comparing a single concurrent object with + its corresponding concurrent type rely on equality of types, + not of objects (because that's simpler to code). + * sem_prag.adb (Is_CCT_Instance): lifted to sem_util.ads. + (Analyze_Global_Item): adjust special-casing of references to the + current instance of a concurrent unit in the Global contracts + of task types and single tasks objects; similar for references + in the protected operations and entries of protected types and + single protected objects (in all these cases the current instance + behaves as an implicit parameter and must not be mentioned in + the Global contract). + +2017-09-08 Arnaud Charlet <charlet@adacore.com> + + * exp_ch6.adb (Expand_Call_Helper): Introduce temporary for + function calls returning a record within a subprogram call, + for C generation. + +2017-09-08 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Find_Expanded_Name): Handle properly an expanded + name that designates the current instance of a child unit in its + own body and appears as the prefix of a reference to an entity + local to the child unit. + * exp_ch6.adb, freeze.adb, sem_ch3.adb, sem_prag.adb, sem_util.adb: + Minor reformatting. + +2017-09-08 Yannick Moy <moy@adacore.com> + + * sem_res.adb (Resolve_Equality_Op): Do not warn on comparisons that + may be intentional. + +2017-09-08 Tristan Gingold <gingold@adacore.com> + + * sem_warn.adb (Check_Unused_Withs): Remove test that disabled + warnings on internal units in configurable run time mode. + 2017-09-08 Bob Duff <duff@adacore.com> * sem_ch3.adb (Build_Derived_Private_Type): Inherit diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 908338f..2822765 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2751,32 +2751,70 @@ package body Exp_Ch6 is end; end if; - -- When generating C code, transform a function call that returns a - -- constrained array type into procedure form. - if Modify_Tree_For_C and then Nkind (Call_Node) = N_Function_Call and then Is_Entity_Name (Name (Call_Node)) - and then Rewritten_For_C (Ultimate_Alias (Entity (Name (Call_Node)))) then - -- For internally generated calls ensure that they reference the - -- entity of the spec of the called function (needed since the - -- expander may generate calls using the entity of their body). - -- See for example Expand_Boolean_Operator(). - - if not (Comes_From_Source (Call_Node)) - and then Nkind (Unit_Declaration_Node - (Ultimate_Alias (Entity (Name (Call_Node))))) = - N_Subprogram_Body - then - Set_Entity (Name (Call_Node), - Corresponding_Function - (Corresponding_Procedure - (Ultimate_Alias (Entity (Name (Call_Node)))))); - end if; + declare + Func_Id : constant Entity_Id := + Ultimate_Alias (Entity (Name (Call_Node))); + begin + -- When generating C code, transform a function call that returns + -- a constrained array type into procedure form. - Rewrite_Function_Call_For_C (Call_Node); - return; + if Rewritten_For_C (Func_Id) then + + -- For internally generated calls ensure that they reference + -- the entity of the spec of the called function (needed since + -- the expander may generate calls using the entity of their + -- body). See for example Expand_Boolean_Operator(). + + if not (Comes_From_Source (Call_Node)) + and then Nkind (Unit_Declaration_Node (Func_Id)) = + N_Subprogram_Body + then + Set_Entity (Name (Call_Node), + Corresponding_Function + (Corresponding_Procedure (Func_Id))); + end if; + + Rewrite_Function_Call_For_C (Call_Node); + return; + + -- Also introduce a temporary for functions that return a record + -- called within another procedure or function call, since records + -- are passed by pointer in the generated C code, and we cannot + -- take a pointer from a subprogram call. + + elsif Nkind (Parent (Call_Node)) in N_Subprogram_Call + and then Is_Record_Type (Etype (Func_Id)) + then + declare + Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); + Decl : Node_Id; + + begin + -- Generate: + -- Temp : ... := Func_Call (...); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Object_Definition => + New_Occurrence_Of (Etype (Func_Id), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Func_Id, Loc), + Parameter_Associations => + Parameter_Associations (Call_Node))); + + Insert_Action (Parent (Call_Node), Decl); + Rewrite (Call_Node, New_Occurrence_Of (Temp_Id, Loc)); + return; + end; + end if; + end; end if; -- First step, compute extra actuals, corresponding to any Extra_Formals diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 8a3bf36..437951c 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3423,16 +3423,12 @@ package body Freeze is -------------------- function Freeze_Profile (E : Entity_Id) return Boolean is - F_Type : Entity_Id; - R_Type : Entity_Id; - Warn_Node : Node_Id; - function Has_Incomplete_Component (T : Entity_Id) return Boolean; - -- If a type includes a private component from an enclosing scope - -- it cannot be frozen yet. This can happen in a package nested - -- within another, when freezing an expression function whose - -- profile depends on a type in some outer scope. Those types will - -- be frozen at a later time in the enclosing unit. + -- If a type includes a private component from an enclosing scope it + -- cannot be frozen yet. This can happen in a package nested within + -- another, when freezing an expression function whose profile + -- depends on a type in some outer scope. Those types will be frozen + -- at a later time in the enclosing unit. ------------------------------ -- Has_Incomplete_Component -- @@ -3456,6 +3452,7 @@ package body Freeze is while Present (Comp) loop Comp_Typ := Etype (Comp); + if Ekind_In (Comp, E_Component, E_Discriminant) and then Is_Private_Type (Comp_Typ) and then No (Full_View (Comp_Typ)) @@ -3464,6 +3461,7 @@ package body Freeze is then return True; end if; + Comp := Next_Entity (Comp); end loop; @@ -3471,16 +3469,26 @@ package body Freeze is elsif Is_Array_Type (T) then Comp_Typ := Component_Type (T); - return Is_Private_Type (Comp_Typ) - and then No (Full_View (Comp_Typ)) - and then In_Open_Scopes (Scope (Comp_Typ)) - and then Scope (Comp_Typ) /= Current_Scope; + + return + Is_Private_Type (Comp_Typ) + and then No (Full_View (Comp_Typ)) + and then In_Open_Scopes (Scope (Comp_Typ)) + and then Scope (Comp_Typ) /= Current_Scope; else return False; end if; end Has_Incomplete_Component; + -- Local variables + + F_Type : Entity_Id; + R_Type : Entity_Id; + Warn_Node : Node_Id; + + -- Start of processing for Freeze_Profile + begin -- Loop through formals diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 158aa67..188a0d3 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9580,6 +9580,7 @@ package body Sem_Ch3 is -- type, and from any interfaces. Inherit_Rep_Item_Chain (Derived_Type, Parent_Type); + declare Iface : Node_Id := First (Abstract_Interface_List (Derived_Type)); begin diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 621de03..5194703 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -3437,7 +3437,7 @@ package body Sem_Ch8 is -- addition the renamed entity may depend on the generic formals of -- the enclosing generic. - if Is_Actual and not Inside_A_Generic then + if Is_Actual and then not Inside_A_Generic then Freeze_Before (N, Old_S); Freeze_Actual_Profile; Set_Has_Delayed_Freeze (New_S, False); @@ -6000,6 +6000,21 @@ package body Sem_Ch8 is Candidate := Get_Full_View (Non_Limited_View (Id)); Is_New_Candidate := True; + -- An unusual case arises with a fully qualified name for an + -- entity local to a generic child unit package, within an + -- instantiation of that package. The name of the unit now + -- denotes the renaming created within the instance. This is + -- only relevant in an instance body, see below. + + elsif Is_Generic_Instance (Scope (Id)) + and then In_Open_Scopes (Scope (Id)) + and then In_Instance_Body + and then Ekind (Scope (Id)) = E_Package + and then Ekind (Id) = E_Package + and then Renamed_Entity (Id) = Scope (Id) + then + Is_New_Candidate := True; + else Is_New_Candidate := False; end if; @@ -6246,6 +6261,10 @@ package body Sem_Ch8 is end; else + -- Might be worth specializing the case when the prefix + -- is a limited view. + -- ... not declared in limited view of... + Error_Msg_NE ("& not declared in&", N, Selector); end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index dc0f830..ed4622e 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -259,14 +259,6 @@ package body Sem_Prag is -- Determine whether dependency clause Clause is surrounded by extra -- parentheses. If this is the case, issue an error message. - function Is_CCT_Instance - (Ref_Id : Entity_Id; - Context_Id : Entity_Id) return Boolean; - -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_] - -- Global. Determine whether entity Ref_Id denotes the current instance of - -- a concurrent type. Context_Id denotes the associated context where the - -- pragma appears. - function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean; -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of -- pragma Depends. Determine whether the type of dependency item Item is @@ -2188,24 +2180,28 @@ package body Sem_Prag is -- formal parameter. if Ekind (Item_Id) = E_Protected_Type then - Error_Msg_Name_1 := Chars (Item_Id); - SPARK_Msg_NE - (Fix_Msg (Spec_Id, "global item of subprogram & " - & "cannot reference current instance of protected " - & "type %"), Item, Spec_Id); - return; + if Scope (Spec_Id) = Item_Id then + Error_Msg_Name_1 := Chars (Item_Id); + SPARK_Msg_NE + (Fix_Msg (Spec_Id, "global item of subprogram & " + & "cannot reference current instance of " + & "protected type %"), Item, Spec_Id); + return; + end if; -- Pragma [Refined_]Global associated with a task type -- cannot mention the current instance of a task type -- because the instance behaves as a formal parameter. else pragma Assert (Ekind (Item_Id) = E_Task_Type); - Error_Msg_Name_1 := Chars (Item_Id); - SPARK_Msg_NE - (Fix_Msg (Spec_Id, "global item of subprogram & " - & "cannot reference current instance of task type " - & "%"), Item, Spec_Id); - return; + if Spec_Id = Item_Id then + Error_Msg_Name_1 := Chars (Item_Id); + SPARK_Msg_NE + (Fix_Msg (Spec_Id, "global item of subprogram & " + & "cannot reference current instance of task " + & "type %"), Item, Spec_Id); + return; + end if; end if; -- Otherwise the global item denotes a subtype mark that is @@ -2230,24 +2226,28 @@ package body Sem_Prag is -- parameter. if Is_Single_Protected_Object (Item_Id) then - Error_Msg_Name_1 := Chars (Item_Id); - SPARK_Msg_NE - (Fix_Msg (Spec_Id, "global item of subprogram & cannot " - & "reference current instance of protected type %"), - Item, Spec_Id); - return; + if Scope (Spec_Id) = Etype (Item_Id) then + Error_Msg_Name_1 := Chars (Item_Id); + SPARK_Msg_NE + (Fix_Msg (Spec_Id, "global item of subprogram & " + & "cannot reference current instance of protected " + & "type %"), Item, Spec_Id); + return; + end if; -- Pragma [Refined_]Global associated with a task type -- cannot mention the current instance of a task type -- because the instance behaves as a formal parameter. else pragma Assert (Is_Single_Task_Object (Item_Id)); - Error_Msg_Name_1 := Chars (Item_Id); - SPARK_Msg_NE - (Fix_Msg (Spec_Id, "global item of subprogram & cannot " - & "reference current instance of task type %"), - Item, Spec_Id); - return; + if Spec_Id = Item_Id then + Error_Msg_Name_1 := Chars (Item_Id); + SPARK_Msg_NE + (Fix_Msg (Spec_Id, "global item of subprogram & " + & "cannot reference current instance of task " + & "type %"), Item, Spec_Id); + return; + end if; end if; -- A formal object may act as a global item inside a generic @@ -29243,63 +29243,6 @@ package body Sem_Prag is return Add_Config_Static_String (Arg); end Is_Config_Static_String; - --------------------- - -- Is_CCT_Instance -- - --------------------- - - function Is_CCT_Instance - (Ref_Id : Entity_Id; - Context_Id : Entity_Id) return Boolean - is - S : Entity_Id; - Typ : Entity_Id; - - begin - -- When the reference denotes a single protected type, the context is - -- either a protected subprogram or its body. - - if Is_Single_Protected_Object (Ref_Id) then - Typ := Scope (Context_Id); - - return - Ekind (Typ) = E_Protected_Type - and then Present (Anonymous_Object (Typ)) - and then Anonymous_Object (Typ) = Ref_Id; - - -- When the reference denotes a single task type, the context is either - -- the same type or if inside the body, the anonymous task type. - - elsif Is_Single_Task_Object (Ref_Id) then - if Ekind (Context_Id) = E_Task_Type then - return - Present (Anonymous_Object (Context_Id)) - and then Anonymous_Object (Context_Id) = Ref_Id; - else - return Ref_Id = Context_Id; - end if; - - -- Otherwise the reference denotes a protected or a task type. Climb the - -- scope chain looking for an enclosing concurrent type that matches the - -- referenced entity. - - else - pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type)); - - S := Current_Scope; - while Present (S) and then S /= Standard_Standard loop - if Ekind_In (S, E_Protected_Type, E_Task_Type) - and then S = Ref_Id - then - return True; - end if; - - S := Scope (S); - end loop; - end if; - - return False; - end Is_CCT_Instance; - ------------------------------- -- Is_Elaboration_SPARK_Mode -- ------------------------------- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ed96c53..fc99753 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -7997,11 +7997,20 @@ package body Sem_Res is Check_Restriction (No_Dispatching_Calls, N); end if; + -- Only warn for redundant equality comparison to True for objects + -- (e.g. "X = True") and operations (e.g. "(X < Y) = True"). For + -- other expressions, it may be a matter of preference to write + -- "Expr = True" or "Expr". + if Warn_On_Redundant_Constructs and then Comes_From_Source (N) and then Comes_From_Source (R) and then Is_Entity_Name (R) and then Entity (R) = Standard_True + and then + ((Is_Entity_Name (L) and then Is_Object (Entity (L))) + or else + Nkind (L) in N_Op) then Error_Msg_N -- CODEFIX ("?r?comparison with True is redundant!", N); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 9deee3b..8fe3e1a 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -205,7 +205,7 @@ package body Sem_Util is Nod := Type_Definition (Parent (Typ)); end if; - -- It's not the kind of type that can implement interfaces + -- Otherwise the type is of a kind which does not implement interfaces else return Empty_List; @@ -12382,6 +12382,52 @@ package body Sem_Util is Is_RTE (Root_Type (Under), RO_WW_Super_String)); end Is_Bounded_String; + --------------------- + -- Is_CCT_Instance -- + --------------------- + + function Is_CCT_Instance + (Ref_Id : Entity_Id; + Context_Id : Entity_Id) return Boolean + is + begin + pragma Assert + (Is_Entry (Context_Id) + or else + Ekind_In (Context_Id, E_Function, + E_Procedure, + E_Protected_Type, + E_Task_Type) + or else + Is_Single_Concurrent_Object (Context_Id)); + + -- When the reference denotes a single protected type, the context is + -- either a protected subprogram or its body. + + if Is_Single_Protected_Object (Ref_Id) then + return Scope_Within (Context_Id, Etype (Ref_Id)); + + -- When the reference denotes a single task type, the context is either + -- the same type or if inside the body, the anonymous task object. + + elsif Is_Single_Task_Object (Ref_Id) then + if Is_Single_Task_Object (Context_Id) then + return Context_Id = Ref_Id; + + elsif Ekind (Context_Id) = E_Task_Type then + return Context_Id = Etype (Ref_Id); + + else + return Scope_Within_Or_Same (Context_Id, Etype (Ref_Id)); + end if; + + else + pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type)); + + return Scope_Within_Or_Same (Context_Id, Ref_Id); + end if; + end Is_CCT_Instance; + ------------------------- -- Is_Child_Or_Sibling -- ------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index a7b3487..1477dcd 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1476,6 +1476,14 @@ package Sem_Util is function Is_CPP_Constructor_Call (N : Node_Id) return Boolean; -- Returns True if N is a call to a CPP constructor + function Is_CCT_Instance + (Ref_Id : Entity_Id; + Context_Id : Entity_Id) return Boolean; + -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_] + -- Global. Determine whether entity Ref_Id denotes the current instance of + -- a concurrent type. Context_Id denotes the associated context where the + -- pragma appears. + function Is_Child_Or_Sibling (Pack_1 : Entity_Id; Pack_2 : Entity_Id) return Boolean; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index c8136b0..f6adb7c 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -2383,15 +2383,6 @@ package body Sem_Warn is if not In_Extended_Main_Source_Unit (Cnode) then return; - - -- In configurable run time mode, we remove the bodies of non-inlined - -- subprograms, which may lead to spurious warnings, which are - -- clearly undesirable. - - elsif Configurable_Run_Time_Mode - and then Is_Predefined_Unit (Unit) - then - return; end if; -- Loop through context items in this unit |