From 780d73d73d39e83d6034d1d7b06c27091e9a9cdc Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 8 Sep 2017 11:19:34 +0200 Subject: [PATCH] [multiple changes] 2017-09-08 Arnaud Charlet * 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 * 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 * 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 * sem_res.adb (Resolve_Equality_Op): Do not warn on comparisons that may be intentional. 2017-09-08 Tristan Gingold * sem_warn.adb (Check_Unused_Withs): Remove test that disabled warnings on internal units in configurable run time mode. From-SVN: r251871 --- gcc/ada/ChangeLog | 44 ++++++++++++++++ gcc/ada/exp_ch6.adb | 80 ++++++++++++++++++++-------- gcc/ada/freeze.adb | 34 +++++++----- gcc/ada/sem_ch3.adb | 1 + gcc/ada/sem_ch8.adb | 21 +++++++- gcc/ada/sem_prag.adb | 121 ++++++++++++------------------------------- gcc/ada/sem_res.adb | 9 ++++ gcc/ada/sem_util.adb | 48 ++++++++++++++++- gcc/ada/sem_util.ads | 8 +++ gcc/ada/sem_warn.adb | 9 ---- 10 files changed, 241 insertions(+), 134 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2631caf70ee..8f5ef1bc989 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,47 @@ +2017-09-08 Arnaud Charlet + + * 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 + + * 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 + + * 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 + + * sem_res.adb (Resolve_Equality_Op): Do not warn on comparisons that + may be intentional. + +2017-09-08 Tristan Gingold + + * sem_warn.adb (Check_Unused_Withs): Remove test that disabled + warnings on internal units in configurable run time mode. + 2017-09-08 Bob Duff * sem_ch3.adb (Build_Derived_Private_Type): Inherit diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 908338fd28e..28227653d44 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 8a3bf36fac2..437951c82e3 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 158aa674597..188a0d39799 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 621de0315ec..51947035007 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 dc0f8308482..ed4622e357f 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 ed96c533f6c..fc997539925 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 9deee3bc98f..8fe3e1ada79 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 a7b3487ac26..1477dcdf5f4 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 c8136b0d7fc..f6adb7c7bfa 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 -- 2.30.2