From 31e358e1c8a0f896ec189b1fdb28dcb4a21a1e78 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 2 May 2017 10:28:03 +0200 Subject: [PATCH] [multiple changes] 2017-05-02 Hristian Kirtchev * checks.adb, sem_ch3.adb, sem_ch6.adb: Minor reformatting. 2017-05-02 Bob Duff * exp_attr.adb (Callable, Identity, Terminated): Use Find_Prim_Op to find primitive ops, instead of using an Identifier that will later be looked up. This is necessary because these ops are not necessarily visible at all places where we need to call them. * exp_util.ads: Minor comment fix. From-SVN: r247466 --- gcc/ada/ChangeLog | 12 ++++++ gcc/ada/checks.adb | 8 ++-- gcc/ada/exp_attr.adb | 90 +++++++++++++++++++++++++------------------- gcc/ada/exp_util.ads | 8 ++-- gcc/ada/sem_ch3.adb | 44 +++++++++++----------- gcc/ada/sem_ch6.adb | 21 ++++++----- 6 files changed, 104 insertions(+), 79 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5ef8c6d51db..59ee6e5cd95 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,15 @@ +2017-05-02 Hristian Kirtchev + + * checks.adb, sem_ch3.adb, sem_ch6.adb: Minor reformatting. + +2017-05-02 Bob Duff + + * exp_attr.adb (Callable, Identity, Terminated): Use Find_Prim_Op + to find primitive ops, instead of using an Identifier that will + later be looked up. This is necessary because these ops are not + necessarily visible at all places where we need to call them. + * exp_util.ads: Minor comment fix. + 2017-05-02 Ed Schonberg * sem_ch6.adb (Fully_Conformant_Expressions): Two entity diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index a5a57c4e0e9..40f4e65252e 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -4124,7 +4124,7 @@ package body Checks is if Present (Comp) then - -- Specialize the error message to indicate that we are dealing + -- Specialize the warning message to indicate that we are dealing -- with an uninitialized composite object that has a defaulted -- null-excluding component. @@ -4133,9 +4133,11 @@ package body Checks is Apply_Compile_Time_Constraint_Error (N => Expression (N), - Msg => "(Ada 2005) null-excluding component % of object % " & - "must be initialized??", + Msg => + "(Ada 2005) null-excluding component % of object % must be " + & "initialized??", Reason => CE_Null_Not_Allowed); + else Apply_Compile_Time_Constraint_Error (N => Expression (N), diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index b81e26cec18..4d8417afeeb 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1028,7 +1028,7 @@ package body Exp_Attr is Loc : Source_Ptr; Loop_Id : Entity_Id; Loop_Stmt : Node_Id; - Result : Node_Id; + Result : Node_Id := Empty; Scheme : Node_Id; Temp_Decl : Node_Id; Temp_Id : Entity_Id; @@ -1093,8 +1093,6 @@ package body Exp_Attr is Decls := Declarations (Parent (Parent (Loop_Stmt))); end if; - Result := Empty; - -- Transform the loop into a conditional block else @@ -2480,20 +2478,25 @@ package body Exp_Attr is and then Is_Interface (Ptyp) and then Is_Task_Interface (Ptyp) then - Rewrite (N, - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Callable), Loc), - Parameter_Associations => New_List ( - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), - Expression => - Make_Selected_Component (Loc, - Prefix => - New_Copy_Tree (Pref), - Selector_Name => - Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))))); + declare + Id : constant Node_Id := + New_Occurrence_Of + (Find_Prim_Op (Ptyp, Name_uDisp_Get_Task_Id), Loc); + Call : constant Node_Id := + Make_Function_Call (Loc, + Name => Id, + Parameter_Associations => New_List (Pref)); + begin + Rewrite (N, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Callable), Loc), + Parameter_Associations => New_List ( + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), + Expression => Call)))); + end; else Rewrite (N, @@ -3578,13 +3581,17 @@ package body Exp_Attr is and then Is_Interface (Ptyp) and then Is_Task_Interface (Ptyp) then - Rewrite (N, - Unchecked_Convert_To (Id_Kind, - Make_Selected_Component (Loc, - Prefix => - New_Copy_Tree (Pref), - Selector_Name => - Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))); + declare + Id : constant Node_Id := + New_Occurrence_Of + (Find_Prim_Op (Ptyp, Name_uDisp_Get_Task_Id), Loc); + Call : constant Node_Id := + Make_Function_Call (Loc, + Name => Id, + Parameter_Associations => New_List (Pref)); + begin + Rewrite (N, Unchecked_Convert_To (Id_Kind, Call)); + end; else Rewrite (N, @@ -6264,27 +6271,32 @@ package body Exp_Attr is -- The prefix of Terminated is of a task interface class-wide type. -- Generate: - -- terminated (Task_Id (Pref._disp_get_task_id)); + -- terminated (Task_Id (_disp_get_task_id (Pref))); if Ada_Version >= Ada_2005 and then Ekind (Ptyp) = E_Class_Wide_Type and then Is_Interface (Ptyp) and then Is_Task_Interface (Ptyp) then - Rewrite (N, - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Terminated), Loc), - Parameter_Associations => New_List ( - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), - Expression => - Make_Selected_Component (Loc, - Prefix => - New_Copy_Tree (Pref), - Selector_Name => - Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))))); + declare + Id : constant Node_Id := + New_Occurrence_Of + (Find_Prim_Op (Ptyp, Name_uDisp_Get_Task_Id), Loc); + Call : constant Node_Id := + Make_Function_Call (Loc, + Name => Id, + Parameter_Associations => New_List (Pref)); + begin + Rewrite (N, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Terminated), Loc), + Parameter_Associations => New_List ( + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), + Expression => Call)))); + end; elsif Restricted_Profile then Rewrite (N, diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 3f60993b1a3..485374ba0ff 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -592,11 +592,9 @@ package Exp_Util is function Find_Prim_Op (T : Entity_Id; Name : TSS_Name_Type) return Entity_Id; - -- Find the first primitive operation of type T whose name has the form - -- indicated by the name parameter (i.e. is a type support subprogram - -- with the indicated suffix). This function allows use of a primitive - -- operation which is not directly visible. If T is a class wide type, - -- then the reference is to an operation of the corresponding root type. + -- Same as Find_Prim_Op above, except we're searching for an op that has + -- the form indicated by Name (i.e. is a type support subprogram with the + -- indicated suffix). function Find_Optional_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 245601595bb..9ad370facb6 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3583,17 +3583,17 @@ package body Sem_Ch3 is T : Entity_Id; E : Node_Id := Expression (N); - -- E is set to Expression (N) throughout this routine. When - -- Expression (N) is modified, E is changed accordingly. + -- E is set to Expression (N) throughout this routine. When Expression + -- (N) is modified, E is changed accordingly. Prev_Entity : Entity_Id := Empty; procedure Check_For_Null_Excluding_Components (Obj_Typ : Entity_Id; Obj_Decl : Node_Id); - -- Recursively verify that each null-excluding component of an object - -- declaration's type has explicit initialization, and generate - -- compile-time warnings for each one that does not. + -- Verify that each null-excluding component of object declaration + -- Obj_Decl carrying type Obj_Typ has explicit initialization. Emit + -- a compile-time warning if this is not the case. function Count_Tasks (T : Entity_Id) return Uint; -- This function is called when a non-generic library level object of a @@ -3622,12 +3622,12 @@ package body Sem_Ch3 is (Obj_Typ : Entity_Id; Obj_Decl : Node_Id) is - procedure Check_Component (Comp_Typ : Entity_Id; Comp_Decl : Node_Id := Empty); - -- Perform compile-time null-exclusion checks on a given component - -- and all of its subcomponents, if any. + -- Apply a compile-time null-exclusion check on a component denoted + -- by its declaration Comp_Decl and type Comp_Typ, and all of its + -- subcomponents (if any). --------------------- -- Check_Component -- @@ -3641,15 +3641,14 @@ package body Sem_Ch3 is T : Entity_Id; begin - -- Return without further checking if the component has explicit - -- initialization or does not come from source. + -- Do not consider internally-generated components or those that + -- are already initialized. - if Present (Comp_Decl) then - if not Comes_From_Source (Comp_Decl) - or else Present (Expression (Comp_Decl)) - then - return; - end if; + if Present (Comp_Decl) + and then (not Comes_From_Source (Comp_Decl) + or else Present (Expression (Comp_Decl))) + then + return; end if; if Is_Incomplete_Or_Private_Type (Comp_Typ) @@ -3667,9 +3666,10 @@ package body Sem_Ch3 is then Null_Exclusion_Static_Checks (Obj_Decl, Comp_Decl); - -- Check array type components + -- Check array components elsif Is_Array_Type (T) then + -- There is no suitable component when the object is of an -- array type. However, a namable component may appear at some -- point during the recursive inspection, but not at the top @@ -3681,12 +3681,10 @@ package body Sem_Ch3 is Check_Component (Component_Type (T), Comp_Decl); end if; - -- If T allows named components, then iterate through them, - -- recursively verifying all subcomponents. + -- Verify all components of type T - -- NOTE: Due to the complexities involved with checking components - -- of nontrivial types with discriminants (variant records and - -- the like), no static checking is performed on them. ??? + -- Note: No checks are performed on types with discriminants due + -- to complexities involving variants. ??? elsif (Is_Concurrent_Type (T) or else Is_Incomplete_Or_Private_Type (T) @@ -3910,12 +3908,12 @@ package body Sem_Ch3 is -- out some static checks. if Ada_Version >= Ada_2005 then + -- In case of aggregates we must also take care of the correct -- initialization of nested aggregates bug this is done at the -- point of the analysis of the aggregate (see sem_aggr.adb) ??? if Can_Never_Be_Null (T) then - if Present (Expression (N)) and then Nkind (Expression (N)) = N_Aggregate then diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 98c893b684b..5c31c428c2f 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -8763,18 +8763,20 @@ package body Sem_Ch6 is if Present (Entity (E1)) then return Entity (E1) = Entity (E2) - -- One may be a discriminant that has been replaced by - -- the corresponding discriminal. + -- One may be a discriminant that has been replaced by the + -- corresponding discriminal. - or else (Chars (Entity (E1)) = Chars (Entity (E2)) - and then Ekind (Entity (E1)) = E_Discriminant - and then Ekind (Entity (E2)) = E_In_Parameter) + or else + (Chars (Entity (E1)) = Chars (Entity (E2)) + and then Ekind (Entity (E1)) = E_Discriminant + and then Ekind (Entity (E2)) = E_In_Parameter) -- The discriminant of a protected type is transformed into -- a local constant and then into a parameter of a protected -- operation. - or else (Ekind (Entity (E1)) = E_Constant + or else + (Ekind (Entity (E1)) = E_Constant and then Ekind (Entity (E2)) = E_In_Parameter and then Present (Discriminal_Link (Entity (E1))) and then Discriminal_Link (Entity (E1)) = @@ -8784,9 +8786,10 @@ package body Sem_Ch6 is -- match if they have the same identifier, even though they -- are different entities. - or else (Chars (Entity (E1)) = Chars (Entity (E2)) - and then Ekind (Entity (E1)) = E_Loop_Parameter - and then Ekind (Entity (E2)) = E_Loop_Parameter); + or else + (Chars (Entity (E1)) = Chars (Entity (E2)) + and then Ekind (Entity (E1)) = E_Loop_Parameter + and then Ekind (Entity (E2)) = E_Loop_Parameter); elsif Nkind (E1) = N_Expanded_Name and then Nkind (E2) = N_Expanded_Name -- 2.30.2