From bac5ba153d4e3c4aca45288c3009dcedabe64bb9 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 2 May 2016 12:27:18 +0200 Subject: [PATCH] [multiple changes] 2016-05-02 Hristian Kirtchev * sem_ch3.adb, exp_ch9.adb, einfo.adb, sem_ch4.adb, sem_ch6.adb: Minor reformatting. 2016-05-02 Ed Schonberg * exp_ch4.adb (Expand_N_Allocator): If the designated type is a private derived type with no discriminants, examine its underlying_full_view to determine whether the full view has defaulted discriminants, so their defaults can be used in the call to the initialization procedure for the designated object. From-SVN: r235740 --- gcc/ada/ChangeLog | 13 ++++++ gcc/ada/einfo.adb | 2 +- gcc/ada/exp_ch4.adb | 25 ++++++++--- gcc/ada/exp_ch9.adb | 57 ++++++++++++------------ gcc/ada/sem_ch3.adb | 4 +- gcc/ada/sem_ch4.adb | 7 +-- gcc/ada/sem_ch6.adb | 105 +++++++++++++++++++++++--------------------- 7 files changed, 123 insertions(+), 90 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8acbbb3ec32..51ba99854e9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2016-05-02 Hristian Kirtchev + + * sem_ch3.adb, exp_ch9.adb, einfo.adb, sem_ch4.adb, sem_ch6.adb: Minor + reformatting. + +2016-05-02 Ed Schonberg + + * exp_ch4.adb (Expand_N_Allocator): If the designated type + is a private derived type with no discriminants, examine its + underlying_full_view to determine whether the full view has + defaulted discriminants, so their defaults can be used in the + call to the initialization procedure for the designated object. + 2016-05-02 Hristian Kirtchev * exp_prag.adb, comperr.adb: Minor reformatting. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index e66ca79aa7c..c6a0935b3e6 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -5908,7 +5908,7 @@ package body Einfo is procedure Set_Original_Protected_Subprogram (Id : E; V : N) is begin - pragma Assert (Ekind_In (Id, E_Procedure, E_Function)); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Node41 (Id, V); end Set_Original_Protected_Subprogram; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index ea59e6e73b4..cb1c117b30b 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4503,12 +4503,25 @@ package body Exp_Ch4 is Dis := True; Typ := T; - elsif Is_Private_Type (T) - and then Present (Full_View (T)) - and then Has_Discriminants (Full_View (T)) - then - Dis := True; - Typ := Full_View (T); + -- Type may be a private type with no visible discriminants + -- in which case check full view if in scope, or the + -- underlying_full_view if dealing with a type whose full + -- view may be derived from a private type whose own full + -- view has discriminants. + + elsif Is_Private_Type (T) then + if Present (Full_View (T)) + and then Has_Discriminants (Full_View (T)) + then + Dis := True; + Typ := Full_View (T); + + elsif Present (Underlying_Full_View (T)) + and then Has_Discriminants (Underlying_Full_View (T)) + then + Dis := True; + Typ := Underlying_Full_View (T); + end if; end if; if Dis then diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index e48b9839064..68c6dcb9575 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -2558,9 +2558,9 @@ package body Exp_Ch9 is end if; return - Type_Conformant_Parameters ( - Parameter_Specifications (Iface_Op_Spec), - Parameter_Specifications (Wrapper_Spec)); + Type_Conformant_Parameters + (Parameter_Specifications (Iface_Op_Spec), + Parameter_Specifications (Wrapper_Spec)); end Overriding_Possible; ----------------------- @@ -2609,14 +2609,13 @@ package body Exp_Ch9 is Append_To (New_Formals, Make_Parameter_Specification (Loc, - Defining_Identifier => + Defining_Identifier => Make_Defining_Identifier (Loc, - Chars => Chars - (Defining_Identifier (Formal))), - In_Present => In_Present (Formal), - Out_Present => Out_Present (Formal), - Null_Exclusion_Present => Null_Exclusion_Present (Formal), - Parameter_Type => Param_Type)); + Chars => Chars (Defining_Identifier (Formal))), + In_Present => In_Present (Formal), + Out_Present => Out_Present (Formal), + Null_Exclusion_Present => Null_Exclusion_Present (Formal), + Parameter_Type => Param_Type)); Next (Formal); end loop; @@ -2776,13 +2775,16 @@ package body Exp_Ch9 is else pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id)); + Obj_Param := Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), - In_Present => In_Present (Parent (First_Entity (Subp_Id))), - Out_Present => Ekind (Subp_Id) /= E_Function, - Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); + In_Present => + In_Present (Parent (First_Entity (Subp_Id))), + Out_Present => Ekind (Subp_Id) /= E_Function, + Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); + Prepend_To (New_Formals, Obj_Param); end if; @@ -4195,8 +4197,7 @@ package body Exp_Ch9 is Unprotected_Mode => 'N'); begin - if Ekind (Defining_Unit_Name (Specification (N))) = - E_Subprogram_Body + if Ekind (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body then Decl := Unit_Declaration_Node (Corresponding_Spec (N)); else @@ -4238,7 +4239,7 @@ package body Exp_Ch9 is if Nkind (Specification (Decl)) = N_Procedure_Specification then New_Spec := Make_Procedure_Specification (Loc, - Defining_Unit_Name => New_Id, + Defining_Unit_Name => New_Id, Parameter_Specifications => New_Plist); -- Create a new specification for the anonymous subprogram type @@ -4246,9 +4247,9 @@ package body Exp_Ch9 is else New_Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => New_Id, + Defining_Unit_Name => New_Id, Parameter_Specifications => New_Plist, - Result_Definition => + Result_Definition => Copy_Result_Type (Result_Definition (Specification (Decl)))); Set_Return_Present (Defining_Unit_Name (New_Spec)); @@ -9654,22 +9655,22 @@ package body Exp_Ch9 is Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) then declare + Found : Boolean := False; Prim_Elmt : Elmt_Id; Prim_Op : Node_Id; - Found : Boolean := False; begin Prim_Elmt := First_Elmt (Primitive_Operations - (Corresponding_Record_Type (Prot_Typ))); + (Corresponding_Record_Type (Prot_Typ))); while Present (Prim_Elmt) loop Prim_Op := Node (Prim_Elmt); if Is_Primitive_Wrapper (Prim_Op) - and then (Wrapped_Entity (Prim_Op)) - = Defining_Entity (Specification (Comp)) + and then Wrapped_Entity (Prim_Op) = + Defining_Entity (Specification (Comp)) then Found := True; exit; @@ -9684,6 +9685,7 @@ package body Exp_Ch9 is Specification => Build_Protected_Sub_Specification (Comp, Prot_Typ, Dispatching_Mode)); + Insert_After (Current_Node, Sub); Analyze (Sub); @@ -9740,19 +9742,19 @@ package body Exp_Ch9 is Body_Arr := Make_Object_Declaration (Loc, Defining_Identifier => Body_Id, - Aliased_Present => True, - Object_Definition => + Aliased_Present => True, + Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RE_Protected_Entry_Body_Array), Loc), - Constraint => + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Range (Loc, Make_Integer_Literal (Loc, 1), Make_Integer_Literal (Loc, E_Count))))), - Expression => Entries_Aggr); + Expression => Entries_Aggr); when System_Tasking_Protected_Objects_Single_Entry => Body_Arr := @@ -9761,7 +9763,8 @@ package body Exp_Ch9 is Aliased_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Entry_Body), Loc), - Expression => Remove_Head (Expressions (Entries_Aggr))); + Expression => + Remove_Head (Expressions (Entries_Aggr))); when others => raise Program_Error; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index df0293c8525..18ebc25ab77 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -19828,8 +19828,8 @@ package body Sem_Ch3 is (Subp_Id => Prim, Obj_Typ => Conc_Typ, Formals => - Parameter_Specifications ( - Parent (Prim)))); + Parameter_Specifications + (Parent (Prim)))); Insert_After (Curr_Nod, Wrap_Spec); Curr_Nod := Wrap_Spec; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 73fa52199ca..dd140c165cb 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -9022,9 +9022,10 @@ package body Sem_Ch4 is -- Exp_Ch9.Build_Selected_Name). elsif Is_Protected_Type (Obj_Type) then - return Present (Original_Protected_Subprogram (Prim_Op)) - and then Chars (Original_Protected_Subprogram (Prim_Op)) - = Chars (Subprog); + return + Present (Original_Protected_Subprogram (Prim_Op)) + and then Chars (Original_Protected_Subprogram (Prim_Op)) = + Chars (Subprog); end if; return False; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d7647a3c1bf..244e7a1dbb8 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6491,13 +6491,6 @@ package body Sem_Ch6 is (Prim_Params : List_Id; Iface_Params : List_Id) return Boolean is - Iface_Id : Entity_Id; - Iface_Param : Node_Id; - Iface_Typ : Entity_Id; - Prim_Id : Entity_Id; - Prim_Param : Node_Id; - Prim_Typ : Entity_Id; - function Is_Implemented (Ifaces_List : Elist_Id; Iface : Entity_Id) return Boolean; @@ -6527,6 +6520,15 @@ package body Sem_Ch6 is return False; end Is_Implemented; + -- Local variables + + Iface_Id : Entity_Id; + Iface_Param : Node_Id; + Iface_Typ : Entity_Id; + Prim_Id : Entity_Id; + Prim_Param : Node_Id; + Prim_Typ : Entity_Id; + -- Start of processing for Matches_Prefixed_View_Profile begin @@ -6539,8 +6541,8 @@ package body Sem_Ch6 is Prim_Param := First (Prim_Params); - -- The first parameter of the potentially overridden subprogram - -- must be an interface implemented by Prim. + -- The first parameter of the potentially overridden subprogram must + -- be an interface implemented by Prim. if not Is_Interface (Iface_Typ) or else not Is_Implemented (Ifaces_List, Iface_Typ) @@ -6548,8 +6550,8 @@ package body Sem_Ch6 is return False; end if; - -- The checks on the object parameters are done, move onto the - -- rest of the parameters. + -- The checks on the object parameters are done, move onto the rest + -- of the parameters. if not In_Scope then Prim_Param := Next (Prim_Param); @@ -6568,15 +6570,15 @@ package body Sem_Ch6 is and then Is_Concurrent_Type (Designated_Type (Prim_Typ)) then Iface_Typ := Designated_Type (Iface_Typ); - Prim_Typ := Designated_Type (Prim_Typ); + Prim_Typ := Designated_Type (Prim_Typ); end if; -- Case of multiple interface types inside a parameter profile -- (Obj_Param : in out Iface; ...; Param : Iface) - -- If the interface type is implemented, then the matching type - -- in the primitive should be the implementing record type. + -- If the interface type is implemented, then the matching type in + -- the primitive should be the implementing record type. if Ekind (Iface_Typ) = E_Record_Type and then Is_Interface (Iface_Typ) @@ -6626,9 +6628,9 @@ package body Sem_Ch6 is return; end if; - -- Search for the concurrent declaration since it contains the list - -- of all implemented interfaces. In this case, the subprogram is - -- declared within the scope of a protected or a task type. + -- Search for the concurrent declaration since it contains the list of + -- all implemented interfaces. In this case, the subprogram is declared + -- within the scope of a protected or a task type. if Present (Scope (Def_Id)) and then Is_Concurrent_Type (Scope (Def_Id)) @@ -6658,10 +6660,10 @@ package body Sem_Ch6 is then In_Scope := False; - -- This case occurs when the concurrent type is declared within - -- a generic unit. As a result the corresponding record has been - -- built and used as the type of the first formal, we just have - -- to retrieve the corresponding concurrent type. + -- This case occurs when the concurrent type is declared within a + -- generic unit. As a result the corresponding record has been built + -- and used as the type of the first formal, we just have to retrieve + -- the corresponding concurrent type. elsif Is_Concurrent_Record_Type (Typ) and then not Is_Class_Wide_Type (Typ) @@ -6693,9 +6695,8 @@ package body Sem_Ch6 is Subp : Entity_Id := Empty; begin - -- Traverse the homonym chain, looking for a potentially - -- overridden subprogram that belongs to an implemented - -- interface. + -- Traverse the homonym chain, looking for a potentially overridden + -- subprogram that belongs to an implemented interface. Hom := Current_Entity_In_Scope (Def_Id); while Present (Hom) loop @@ -6710,11 +6711,10 @@ package body Sem_Ch6 is then null; - -- Entries and procedures can override abstract or null - -- interface procedures. + -- Entries and procedures can override abstract or null interface + -- procedures. - elsif (Ekind (Def_Id) = E_Procedure - or else Ekind (Def_Id) = E_Entry) + elsif Ekind_In (Def_Id, E_Entry, E_Procedure) and then Ekind (Subp) = E_Procedure and then Matches_Prefixed_View_Profile (Parameter_Specifications (Parent (Def_Id)), @@ -6723,17 +6723,16 @@ package body Sem_Ch6 is Candidate := Subp; -- For an overridden subprogram Subp, check whether the mode - -- of its first parameter is correct depending on the kind - -- of synchronized type. + -- of its first parameter is correct depending on the kind of + -- synchronized type. declare Formal : constant Node_Id := First_Formal (Candidate); begin -- In order for an entry or a protected procedure to - -- override, the first parameter of the overridden - -- routine must be of mode "out", "in out" or - -- access-to-variable. + -- override, the first parameter of the overridden routine + -- must be of mode "out", "in out" or access-to-variable. if Ekind_In (Candidate, E_Entry, E_Procedure) and then Is_Protected_Type (Typ) @@ -6744,9 +6743,9 @@ package body Sem_Ch6 is then null; - -- All other cases are OK since a task entry or routine - -- does not have a restriction on the mode of the first - -- parameter of the overridden interface routine. + -- All other cases are OK since a task entry or routine does + -- not have a restriction on the mode of the first parameter + -- of the overridden interface routine. else Overridden_Subp := Candidate; @@ -6768,8 +6767,8 @@ package body Sem_Ch6 is -- If an inherited subprogram is implemented by a protected -- function, then the first parameter of the inherited - -- subprogram shall be of mode in, but not an - -- access-to-variable parameter (RM 9.4(11/9) + -- subprogram shall be of mode in, but not an access-to- + -- variable parameter (RM 9.4(11/9) if Present (First_Formal (Subp)) and then Ekind (First_Formal (Subp)) = E_In_Parameter @@ -9692,7 +9691,8 @@ package body Sem_Ch6 is -- Has_Matching_Entry_Or_Subprogram -- -------------------------------------- - function Has_Matching_Entry_Or_Subprogram (E : Entity_Id) return Boolean + function Has_Matching_Entry_Or_Subprogram + (E : Entity_Id) return Boolean is function Check_Conforming_Parameters (E1_Param : Node_Id; @@ -9738,12 +9738,13 @@ package body Sem_Ch6 is begin while Present (Param_E1) and then Present (Param_E2) loop - if Ekind (Defining_Identifier (Param_E1)) - /= Ekind (Defining_Identifier (Param_E2)) + if Ekind (Defining_Identifier (Param_E1)) /= + Ekind (Defining_Identifier (Param_E2)) or else not - Conforming_Types (Find_Parameter_Type (Param_E1), - Find_Parameter_Type (Param_E2), - Subtype_Conformant) + Conforming_Types + (Find_Parameter_Type (Param_E1), + Find_Parameter_Type (Param_E2), + Subtype_Conformant) then return False; end if; @@ -9799,7 +9800,7 @@ package body Sem_Ch6 is begin -- Search for entities in the enclosing scope of this synchonized - -- type + -- type. pragma Assert (Is_Concurrent_Type (Conc_Typ)); Push_Scope (Scope (Conc_Typ)); @@ -9841,7 +9842,7 @@ package body Sem_Ch6 is begin -- Temporarily decorate the first parameter of Subp as controlling - -- formal; required to invoke Subtype_Conformant() + -- formal, required to invoke Subtype_Conformant. Set_Is_Controlling_Formal (First_Entity (Subp)); @@ -9866,6 +9867,7 @@ package body Sem_Ch6 is end loop; Set_Is_Controlling_Formal (First_Entity (Subp), ICF); + return Empty; end Matching_Original_Protected_Subprogram; @@ -9882,8 +9884,8 @@ package body Sem_Ch6 is and then Is_Concurrent_Record_Type (Etype (First_Entity (E))) then if Scope (E) = - Scope (Corresponding_Concurrent_Type ( - Etype (First_Entity (E)))) + Scope (Corresponding_Concurrent_Type + (Etype (First_Entity (E)))) and then Present (Matching_Entry_Or_Subprogram @@ -9913,8 +9915,8 @@ package body Sem_Ch6 is and then Present (Matching_Original_Protected_Subprogram - (Corresponding_Concurrent_Type (Etype (First_Entity (E))), - Subp => E)) + (Corresponding_Concurrent_Type (Etype (First_Entity (E))), + Subp => E)) then Report_Conflict (E, Matching_Original_Protected_Subprogram @@ -9944,8 +9946,8 @@ package body Sem_Ch6 is ---------------------------- function Is_Private_Declaration (E : Entity_Id) return Boolean is - Priv_Decls : List_Id; Decl : constant Node_Id := Unit_Declaration_Node (E); + Priv_Decls : List_Id; begin if Is_Package_Or_Generic_Package (Current_Scope) @@ -9979,6 +9981,7 @@ package body Sem_Ch6 is is AO : constant Entity_Id := Alias (Old_E); AN : constant Entity_Id := Alias (New_E); + begin return Scope (AO) /= Scope (AN) or else No (DTC_Entity (AO)) -- 2.30.2