From 5efb89d0e1a8aa19fafd64e7c7bebde46cccdd14 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 6 Sep 2017 14:05:48 +0200 Subject: [PATCH] [multiple changes] 2017-09-06 Eric Botcazou * sem_ch7.adb (Entity_Table_Size): Change to nearest prime number. 2017-09-06 Yannick Moy * sem_warn.adb: Minor refactoring. 2017-09-06 Ed Schonberg * einfo.ads, einfo.adb (Get_Classwwide_Pragma): New utility, to retrieve the inherited classwide precondition/postcondition of a subprogram. * freeze.adb (Freeze_Entity): Use Get_Classwide_Pragma when freezing a subprogram, to complete the generation of the corresponding checking code. 2017-09-06 Eric Botcazou * inline.adb (Analyze_Inlined_Bodies): Remove restriction on loading of parent body with a with clause for the main unit. * gcc-interface/decl.c (defer_limited_with_list): Document new usage. (gnat_to_gnu_entity) : Handle completed Taft Amendment types declared in external units like types from limited with clauses. Adjust final processing of defer_limited_with_list accordingly. 2017-09-06 Hristian Kirtchev * exp_util.adb (Is_Controlled_Indexing): New routine. (Is_Displace_Call): Use routine Strip to remove indirections. (Is_Displacement_Of_Object_Or_Function_Result): Code clean up. Add a missing case of controlled generalized indexing. (Is_Source_Object): Use routine Strip to remove indirections. (Strip): New routine. 2017-09-06 Bob Duff * sysdep.c (__gnat_has_cap_sys_nice): If HAVE_CAPABILITY is defined, we include the proper header. Otherwise, we just declare the necessary things from the capabilities library. This is so we can build on machines without that library, while still enabling that library. At run time, we're using weak symbols, so __gnat_has_cap_sys_nice will simply return 0 if the library is not present, or not included in the link. 2017-09-06 Pierre-Marie de Rodat * exp_dbug.adb (Debug_Renaming_Declaration): Do not create an encoding for renamings that involve function calls in prefix form. 2017-09-06 Bob Duff * sem_ch3.adb (Analyze_Subtype_Declaration): Set Has_Delayed_Freeze on a subtype of an incomplete type. 2017-09-06 Pierre-Marie de Rodat * par_sco.adb (Extend_Statement_Sequence): When the accept statement has no parameter specification and no entry index, use the entry name as the end of the generated SCO statement. From-SVN: r251785 --- gcc/ada/ChangeLog | 63 ++++++++++++++++++++ gcc/ada/einfo.adb | 33 +++++++++++ gcc/ada/einfo.ads | 6 ++ gcc/ada/exp_dbug.adb | 15 ++++- gcc/ada/exp_util.adb | 136 ++++++++++++++++++++++++++----------------- gcc/ada/freeze.adb | 8 +-- gcc/ada/par_sco.adb | 2 + gcc/ada/sem_ch3.adb | 21 +++++++ gcc/ada/sem_ch7.adb | 2 +- gcc/ada/sem_warn.adb | 13 +++-- gcc/ada/sysdep.c | 61 +++++++++++-------- 11 files changed, 271 insertions(+), 89 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b7a86799165..98562ab7b84 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,66 @@ +2017-09-06 Eric Botcazou + + * sem_ch7.adb (Entity_Table_Size): Change to nearest prime number. + +2017-09-06 Yannick Moy + + * sem_warn.adb: Minor refactoring. + +2017-09-06 Ed Schonberg + + * einfo.ads, einfo.adb (Get_Classwwide_Pragma): New utility, + to retrieve the inherited classwide precondition/postcondition + of a subprogram. + * freeze.adb (Freeze_Entity): Use Get_Classwide_Pragma when + freezing a subprogram, to complete the generation of the + corresponding checking code. + +2017-09-06 Eric Botcazou + + * inline.adb (Analyze_Inlined_Bodies): Remove restriction on + loading of parent body with a with clause for the main unit. + * gcc-interface/decl.c (defer_limited_with_list): Document + new usage. + (gnat_to_gnu_entity) : Handle + completed Taft Amendment types declared in external units like + types from limited with clauses. Adjust final processing of + defer_limited_with_list accordingly. + +2017-09-06 Hristian Kirtchev + + * exp_util.adb (Is_Controlled_Indexing): New routine. + (Is_Displace_Call): Use routine Strip to remove indirections. + (Is_Displacement_Of_Object_Or_Function_Result): Code clean up. Add a + missing case of controlled generalized indexing. + (Is_Source_Object): Use routine Strip to remove indirections. + (Strip): New routine. + +2017-09-06 Bob Duff + + * sysdep.c (__gnat_has_cap_sys_nice): If HAVE_CAPABILITY is defined, + we include the proper header. Otherwise, we just declare the necessary + things from the capabilities library. This is so we can build on + machines without that library, while still enabling that library. + At run time, we're using weak symbols, so __gnat_has_cap_sys_nice will + simply return 0 if the library is not present, or not included + in the link. + +2017-09-06 Pierre-Marie de Rodat + + * exp_dbug.adb (Debug_Renaming_Declaration): Do not create an encoding + for renamings that involve function calls in prefix form. + +2017-09-06 Bob Duff + + * sem_ch3.adb (Analyze_Subtype_Declaration): + Set Has_Delayed_Freeze on a subtype of an incomplete type. + +2017-09-06 Pierre-Marie de Rodat + + * par_sco.adb (Extend_Statement_Sequence): When the accept statement + has no parameter specification and no entry index, use the entry name + as the end of the generated SCO statement. + 2017-09-06 Steve Baird * exp_util.adb (Side_Effect_Free): For CodePeer (only) treat diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 6d9ae1da7fe..b7782a9ab9a 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -7481,6 +7481,39 @@ package body Einfo is return Empty; end Get_Pragma; + -------------------------- + -- Get_Classwide_Pragma -- + -------------------------- + + function Get_Classwide_Pragma + (E : Entity_Id; + Id : Pragma_Id) return Node_Id + is + Item : Node_Id; + Items : Node_Id; + + begin + Items := Contract (E); + if No (Items) then + return Empty; + end if; + + Item := Pre_Post_Conditions (Items); + + while Present (Item) loop + if Nkind (Item) = N_Pragma + and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id + and then Class_Present (Item) + then + return Item; + else + Item := Next_Pragma (Item); + end if; + end loop; + + return Empty; + end Get_Classwide_Pragma; + -------------------------------------- -- Get_Record_Representation_Clause -- -------------------------------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index cf472ee53e9..f14b22f826b 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -8295,6 +8295,12 @@ package Einfo is -- Test_Case -- Volatile_Function + function Get_Classwide_Pragma + (E : Entity_Id; + Id : Pragma_Id) return Node_Id; + -- Examine Rep_Item chain to locate a classwide pre- or postcondition + -- of a primitive operation. Returns Empty if not present. + function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id; -- Searches the Rep_Item chain for a given entity E, for a record -- representation clause, and if found, returns it. Returns Empty diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index dc1f884d525..1b51d538e3f 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -426,11 +426,20 @@ package body Exp_Dbug is when N_Selected_Component => declare - First_Bit : constant Uint := - Normalized_First_Bit - (Entity (Selector_Name (Ren))); + Sel_Id : constant Entity_Id := + Entity (Selector_Name (Ren)); + First_Bit : Uint; begin + -- If the renaming involves a call to a primitive function, + -- we are out of the scope of renaming encodings. We will + -- very likely create a variable to hold the renamed value + -- anyway, so the renaming entity will be available in + -- debuggers. + + exit when not Ekind_In (Sel_Id, E_Component, E_Discriminant); + + First_Bit := Normalized_First_Bit (Sel_Id); Enable := Enable or else Is_Packed diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 10d9b1d1c82..c0b6b425ae1 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -7590,22 +7590,28 @@ package body Exp_Util is (Obj_Id : Entity_Id) return Boolean is function Is_Controlled_Function_Call (N : Node_Id) return Boolean; - -- Determine if particular node denotes a controlled function call. The - -- call may have been heavily expanded. + -- Determine whether node N denotes a controlled function call + + function Is_Controlled_Indexing (N : Node_Id) return Boolean; + -- Determine whether node N denotes a generalized indexing form which + -- involves a controlled result. function Is_Displace_Call (N : Node_Id) return Boolean; - -- Determine whether a particular node is a call to Ada.Tags.Displace. - -- The call might be nested within other actions such as conversions. + -- Determine whether node N denotes a call to Ada.Tags.Displace function Is_Source_Object (N : Node_Id) return Boolean; -- Determine whether a particular node denotes a source object + function Strip (N : Node_Id) return Node_Id; + -- Examine arbitrary node N by stripping various indirections and return + -- the "real" node. + --------------------------------- -- Is_Controlled_Function_Call -- --------------------------------- function Is_Controlled_Function_Call (N : Node_Id) return Boolean is - Expr : Node_Id := Original_Node (N); + Expr : Node_Id; begin -- When a function call appears in Object.Operation format, the @@ -7617,6 +7623,7 @@ package body Exp_Util is -- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an -- N_Selected_Component + Expr := Original_Node (N); loop if Nkind (Expr) = N_Function_Call then Expr := Name (Expr); @@ -7643,31 +7650,28 @@ package body Exp_Util is and then Needs_Finalization (Etype (Entity (Expr))); end Is_Controlled_Function_Call; + ---------------------------- + -- Is_Controlled_Indexing -- + ---------------------------- + + function Is_Controlled_Indexing (N : Node_Id) return Boolean is + Expr : constant Node_Id := Original_Node (N); + + begin + return + Nkind (Expr) = N_Indexed_Component + and then Present (Generalized_Indexing (Expr)) + and then Needs_Finalization (Etype (Expr)); + end Is_Controlled_Indexing; + ---------------------- -- Is_Displace_Call -- ---------------------- function Is_Displace_Call (N : Node_Id) return Boolean is - Call : Node_Id; + Call : constant Node_Id := Strip (N); begin - -- Strip various actions which may precede a call to Displace - - Call := N; - loop - if Nkind (Call) = N_Explicit_Dereference then - Call := Prefix (Call); - - elsif Nkind_In (Call, N_Type_Conversion, - N_Unchecked_Type_Conversion) - then - Call := Expression (Call); - - else - exit; - end if; - end loop; - return Present (Call) and then Nkind (Call) = N_Function_Call @@ -7679,38 +7683,48 @@ package body Exp_Util is ---------------------- function Is_Source_Object (N : Node_Id) return Boolean is - Obj : Node_Id; + Obj : constant Node_Id := Strip (N); begin - -- Strip various actions which may be associated with the object + return + Present (Obj) + and then Comes_From_Source (Obj) + and then Nkind (Obj) in N_Has_Entity + and then Is_Object (Entity (Obj)); + end Is_Source_Object; + + ----------- + -- Strip -- + ----------- + + function Strip (N : Node_Id) return Node_Id is + Result : Node_Id; - Obj := N; + begin + Result := N; loop - if Nkind (Obj) = N_Explicit_Dereference then - Obj := Prefix (Obj); + if Nkind (Result) = N_Explicit_Dereference then + Result := Prefix (Result); - elsif Nkind_In (Obj, N_Type_Conversion, - N_Unchecked_Type_Conversion) + elsif Nkind_In (Result, N_Type_Conversion, + N_Unchecked_Type_Conversion) then - Obj := Expression (Obj); + Result := Expression (Result); else exit; end if; end loop; - return - Present (Obj) - and then Nkind (Obj) in N_Has_Entity - and then Is_Object (Entity (Obj)) - and then Comes_From_Source (Obj); - end Is_Source_Object; + return Result; + end Strip; -- Local variables - Decl : constant Node_Id := Parent (Obj_Id); + Obj_Decl : constant Node_Id := Declaration_Node (Obj_Id); Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); - Orig_Decl : constant Node_Id := Original_Node (Decl); + Orig_Decl : constant Node_Id := Original_Node (Obj_Decl); + Orig_Expr : Node_Id; -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result @@ -7719,34 +7733,52 @@ package body Exp_Util is -- Obj : CW_Type := Function_Call (...); - -- rewritten into: + -- is rewritten into: - -- Tmp : ... := Function_Call (...)'reference; - -- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp)); + -- Temp : ... := Function_Call (...)'reference; + -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp)); -- where the return type of the function and the class-wide type require -- dispatch table pointer displacement. -- Case 2: + -- Obj : CW_Type := Container (...); + + -- is rewritten into: + + -- Temp : ... := Function_Call (Container, ...)'reference; + -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp)); + + -- where the container element type and the class-wide type require + -- dispatch table pointer dispacement. + + -- Case 3: + -- Obj : CW_Type := Src_Obj; - -- rewritten into: + -- is rewritten into: -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); -- where the type of the source object and the class-wide type require -- dispatch table pointer displacement. - return - Nkind (Decl) = N_Object_Renaming_Declaration - and then Nkind (Orig_Decl) = N_Object_Declaration - and then Comes_From_Source (Orig_Decl) - and then Is_Class_Wide_Type (Obj_Typ) - and then Is_Displace_Call (Renamed_Object (Obj_Id)) - and then - (Is_Controlled_Function_Call (Expression (Orig_Decl)) - or else Is_Source_Object (Expression (Orig_Decl))); + if Nkind (Obj_Decl) = N_Object_Renaming_Declaration + and then Is_Class_Wide_Type (Obj_Typ) + and then Is_Displace_Call (Renamed_Object (Obj_Id)) + and then Nkind (Orig_Decl) = N_Object_Declaration + and then Comes_From_Source (Orig_Decl) + then + Orig_Expr := Expression (Orig_Decl); + + return + Is_Controlled_Function_Call (Orig_Expr) + or else Is_Controlled_Indexing (Orig_Expr) + or else Is_Source_Object (Orig_Expr); + end if; + + return False; end Is_Displacement_Of_Object_Or_Function_Result; ------------------------------ diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index caccb7e425b..bf76970c0d9 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1418,8 +1418,8 @@ package body Freeze is New_Prag : Node_Id; begin - A_Pre := Get_Pragma (Par_Prim, Pragma_Precondition); - if Present (A_Pre) and then Class_Present (A_Pre) then + A_Pre := Get_Classwide_Pragma (Par_Prim, Pragma_Precondition); + if Present (A_Pre) then New_Prag := New_Copy_Tree (A_Pre); Build_Class_Wide_Expression (Prag => New_Prag, @@ -1436,9 +1436,9 @@ package body Freeze is end if; end if; - A_Post := Get_Pragma (Par_Prim, Pragma_Postcondition); + A_Post := Get_Classwide_Pragma (Par_Prim, Pragma_Postcondition); - if Present (A_Post) and then Class_Present (A_Post) then + if Present (A_Post) then New_Prag := New_Copy_Tree (A_Post); Build_Class_Wide_Expression (Prag => New_Prag, diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index d44b656530d..69be2e6196b 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -1483,6 +1483,8 @@ package body Par_SCO is To_Node := Last (Parameter_Specifications (N)); elsif Present (Entry_Index (N)) then To_Node := Entry_Index (N); + else + To_Node := Entry_Direct_Name (N); end if; when N_Case_Statement => diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 90abf1a8ede..0ec2e846386 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -5707,6 +5707,27 @@ package body Sem_Ch3 is Conditional_Delay (Id, T); end if; + -- If we have a subtype of an incomplete type whose full type is a + -- derived numeric type, we need to have a freeze node for the subtype. + -- Otherwise gigi will complain while computing the (static) bounds of + -- the subtype. + + if Is_Itype (T) + and then Is_Elementary_Type (Id) + and then Etype (Id) /= Id + then + declare + Partial : constant Entity_Id := + Incomplete_Or_Partial_View (First_Subtype (Id)); + begin + if Present (Partial) + and then Ekind (Partial) = E_Incomplete_Type + then + Set_Has_Delayed_Freeze (Id); + end if; + end; + end if; + -- Check that Constraint_Error is raised for a scalar subtype indication -- when the lower or upper bound of a non-null range lies outside the -- range of the type mark. diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index b0f6bd90f1a..f4cd375bcad 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -193,7 +193,7 @@ package body Sem_Ch7 is -- Analyze_Package_Body_Helper Data and Subprograms -- ------------------------------------------------------ - Entity_Table_Size : constant := 4096; + Entity_Table_Size : constant := 4093; -- Number of headers in hash table subtype Entity_Header_Num is Integer range 0 .. Entity_Table_Size - 1; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 9e1b2c3f3c2..c8136b0d7fc 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1388,15 +1388,18 @@ package body Sem_Warn is -- an expression with actions. UR := Original_Node (UR); - while Nkind_In (UR, N_Attribute_Reference, - N_Expression_With_Actions, + loop + if Nkind_In (UR, N_Expression_With_Actions, N_Qualified_Expression, N_Type_Conversion) - loop - if Nkind (UR) = N_Attribute_Reference then + then + UR := Expression (UR); + + elsif Nkind (UR) = N_Attribute_Reference then UR := Prefix (UR); + else - UR := Expression (UR); + exit; end if; end loop; diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 64278fd8f38..455a78a5645 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -921,16 +921,40 @@ __gnat_is_file_not_found_error (int errno_val) { #if defined (__linux__) -/* HAVE_CAPABILITY is defined if sys/capability.h exists on the system where - this is being compiled. +/* Note well: If this code is modified, it should be tested by hand, + because automated testing doesn't exercise it. +*/ + +/* HAVE_CAPABILITY is supposed to be defined if sys/capability.h exists on the + system where this is being compiled. If this macro is defined, we #include + the header. Otherwise we have the relevant declarations textually here. */ #if defined (HAVE_CAPABILITY) #include +#else -/* Note well: If this code is modified, it should be tested by hand, - because automated testing doesn't exercise it. -*/ +/* HAVE_CAPABILITY is not defined, so sys/capability.h does might not exist. */ + +typedef struct _cap_struct *cap_t; +typedef enum { + CAP_CLEAR=0, + CAP_SET=1 +} cap_flag_value_t; +#define CAP_SYS_NICE 23 +typedef enum { + CAP_EFFECTIVE=0, /* Specifies the effective flag */ + CAP_PERMITTED=1, /* Specifies the permitted flag */ + CAP_INHERITABLE=2 /* Specifies the inheritable flag */ +} cap_flag_t; + +typedef int cap_value_t; + +extern cap_t cap_get_proc(void); +extern int cap_get_flag(cap_t, cap_value_t, cap_flag_t, cap_flag_value_t *); +extern int cap_free(void *); + +#endif /* __gnat_has_cap_sys_nice returns 1 if the current process has the CAP_SYS_NICE capability. This capability is necessary to use the @@ -945,9 +969,12 @@ __gnat_is_file_not_found_error (int errno_val) { symbols will be 0, and __gnat_has_cap_sys_nice will return 0. */ -static cap_t cap_get_proc_weak() __attribute__ ((weakref ("cap_get_proc"))); -static int cap_get_flag_weak() __attribute__ ((weakref ("cap_get_flag"))); -static int cap_free_weak() __attribute__ ((weakref ("cap_free"))); +static cap_t cap_get_proc_weak(void) + __attribute__ ((weakref ("cap_get_proc"))); +static int cap_get_flag_weak(cap_t, cap_value_t, cap_flag_t, cap_flag_value_t *) + __attribute__ ((weakref ("cap_get_flag"))); +static int cap_free_weak(void *) + __attribute__ ((weakref ("cap_free"))); int __gnat_has_cap_sys_nice () { @@ -957,11 +984,11 @@ __gnat_has_cap_sys_nice () { return 0; cap_t caps = cap_get_proc_weak(); - cap_flag_value_t value; - if (caps == NULL) return 0; + cap_flag_value_t value; + if (cap_get_flag_weak(caps, CAP_SYS_NICE, CAP_EFFECTIVE, &value) == -1) return 0; @@ -973,20 +1000,6 @@ __gnat_has_cap_sys_nice () { return 0; } - -#else - -/* HAVE_CAPABILITY is not defined, so sys/capability.h does not exist, so - simply indicate that the current process does not have the CAP_SYS_NICE - capability. -*/ - -int -__gnat_has_cap_sys_nice () { - return 0; -} - -#endif #endif #ifdef __ANDROID__ -- 2.30.2