From d9049849d0052ba4c7ab5585d896c7e746add39f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 11:40:48 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Bob Duff * s-secsta.adb (SS_Info): Add a comment explaining why we don't need to walk all the chunks in order to compute the total size. 2017-04-25 Bob Duff * namet.ads, namet.adb (Global_Name_Buffer): Increase the length of the global name buffer to 4*Max_Line_Length. 2017-04-25 Javier Miranda * exp_ch8.adb (Expand_N_Object_Renaming_Declaration): When creating a renaming entity for debug information, mark the entity as needing debug info if it comes from sources. 2017-04-25 Hristian Kirtchev * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Remove the restriction converning the use of 'Address where the prefix is of a controlled type. 2017-04-25 Pierre-Marie de Rodat * exp_dbug.adb: In Debug_Renaming_Declaration, skip slices that are made redundant by an indexed component access. * atree.h: New definition for Original_Node. From-SVN: r247166 --- gcc/ada/ChangeLog | 30 ++++++++++++++++++++++++ gcc/ada/atree.h | 3 +++ gcc/ada/exp_ch8.adb | 8 ++++++- gcc/ada/exp_dbug.adb | 55 ++++++++++++++++++++++++++++++++------------ gcc/ada/namet.adb | 3 +++ gcc/ada/namet.ads | 3 ++- gcc/ada/s-secsta.adb | 22 ++++++++---------- gcc/ada/sem_ch13.adb | 38 +++--------------------------- 8 files changed, 98 insertions(+), 64 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 084b900fa99..4e0d87301cc 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,33 @@ +2017-04-25 Bob Duff + + * s-secsta.adb (SS_Info): Add a comment + explaining why we don't need to walk all the chunks in order to + compute the total size. + +2017-04-25 Bob Duff + + * namet.ads, namet.adb (Global_Name_Buffer): Increase the length + of the global name buffer to 4*Max_Line_Length. + +2017-04-25 Javier Miranda + + * exp_ch8.adb (Expand_N_Object_Renaming_Declaration): When creating a + renaming entity for debug information, mark the entity as needing debug + info if it comes from sources. + +2017-04-25 Hristian Kirtchev + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Remove the + restriction converning the use of 'Address where the prefix is + of a controlled type. + +2017-04-25 Pierre-Marie de Rodat + + * exp_dbug.adb: In Debug_Renaming_Declaration, + skip slices that are made redundant by an indexed component + access. + * atree.h: New definition for Original_Node. + 2017-04-25 Hristian Kirtchev * sem_prag.adb, sem_prag.ads: Minor reformatting. diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index e09f7e2c9fe..bad07652c68 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -359,6 +359,9 @@ extern struct Node *Nodes_Ptr; #define Parent atree__parent extern Node_Id Parent (Node_Id); +#define Original_Node atree__original_node +extern Node_Id Original_Node (Node_Id); + /* The auxiliary flags array which is allocated in parallel to Nodes */ struct Flags diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index 9a4e5e53d1b..7af33b36168 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -187,7 +187,13 @@ package body Exp_Ch8 is Make_Build_In_Place_Call_In_Anonymous_Context (Nam); end if; - -- Create renaming entry for debug information + -- Create renaming entry for debug information. Mark the entity as + -- needing debug info if it comes from sources because the current + -- setting in Freeze_Entity occurs too late. ??? + + if Comes_From_Source (Defining_Identifier (N)) then + Set_Debug_Info_Needed (Defining_Identifier (N)); + end if; Decl := Debug_Renaming_Declaration (N); diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index c617e88d5bd..3d0ccbde67e 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -317,6 +317,9 @@ package body Exp_Dbug is -- - when the renaming involves a packed array, -- - when the renaming involves a packed record. + Last_Is_Indexed_Comp : Boolean := False; + -- Whether the last subscript value was an indexed component access (XS) + procedure Enable_If_Packed_Array (N : Node_Id); -- Enable encoding generation if N is a packed array @@ -378,16 +381,24 @@ package body Exp_Dbug is Name_Len := 0; Ren := Nam; loop + -- The expression that designates the renamed object is sometimes + -- expanded into bit-wise operations. We want to work instead on + -- array/record components accesses, so try to analyze the unexpanded + -- forms. + + Ren := Original_Node (Ren); + case Nkind (Ren) is - when N_Identifier => - exit; + when N_Identifier | N_Expanded_Name => - when N_Expanded_Name => + if not Present (Renamed_Object (Entity (Ren))) then + exit; + end if; - -- The entity field for an N_Expanded_Name is on the expanded - -- name node itself, so we are done here too. + -- This is a renaming of a renaming: traverse until the + -- final renaming to see if anything is packed on the way. - exit; + Ren := Renamed_Object (Entity (Ren)); when N_Selected_Component => declare @@ -408,6 +419,7 @@ package body Exp_Dbug is (Get_Name_String (Chars (Selector_Name (Ren)))); Prepend_String_To_Buffer ("XR"); Ren := Prefix (Ren); + Last_Is_Indexed_Comp := False; when N_Indexed_Component => declare @@ -424,23 +436,35 @@ package body Exp_Dbug is end if; Prev (X); + Last_Is_Indexed_Comp := True; end loop; end; Ren := Prefix (Ren); when N_Slice => - Enable_If_Packed_Array (Prefix (Ren)); - Typ := Etype (First_Index (Etype (Nam))); + -- Assuming X is an array: + -- X (Y1 .. Y2) (Y3) + -- is equivalent to: + -- X (Y3) + -- GDB cannot handle packed array slices, so avoid to describe + -- the slice if we can avoid it. + + if not Last_Is_Indexed_Comp then + Enable_If_Packed_Array (Prefix (Ren)); + Typ := Etype (First_Index (Etype (Ren))); - if not Output_Subscript (Type_High_Bound (Typ), "XS") then - Set_Materialize_Entity (Ent); - return Empty; - end if; + if not Output_Subscript (Type_High_Bound (Typ), "XS") then + Set_Materialize_Entity (Ent); + return Empty; + end if; + + if not Output_Subscript (Type_Low_Bound (Typ), "XL") then + Set_Materialize_Entity (Ent); + return Empty; + end if; - if not Output_Subscript (Type_Low_Bound (Typ), "XL") then - Set_Materialize_Entity (Ent); - return Empty; + Last_Is_Indexed_Comp := False; end if; Ren := Prefix (Ren); @@ -448,6 +472,7 @@ package body Exp_Dbug is when N_Explicit_Dereference => Prepend_String_To_Buffer ("XA"); Ren := Prefix (Ren); + Last_Is_Indexed_Comp := False; -- For now, anything else simply results in no translation diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 5bea77d93e2..6e599095771 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -116,6 +116,9 @@ package body Namet is procedure Append (Buf : in out Bounded_String; C : Character) is begin if Buf.Length >= Buf.Chars'Last then + Write_Str ("Name buffer overflow; Max_Length = "); + Write_Int (Int (Buf.Max_Length)); + Write_Line (""); raise Program_Error; end if; diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 8c1f124991b..0778ebecbfd 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -30,6 +30,7 @@ ------------------------------------------------------------------------------ with Alloc; +with Hostparm; use Hostparm; with Table; with System; use System; with Types; use Types; @@ -165,7 +166,7 @@ package Namet is -- which is used by most of the code via the renamings. New code ought -- to avoid the global. - Global_Name_Buffer : Bounded_String; + Global_Name_Buffer : Bounded_String (Max_Length => 4 * Max_Line_Length); Name_Buffer : String renames Global_Name_Buffer.Chars; Name_Len : Natural renames Global_Name_Buffer.Length; diff --git a/gcc/ada/s-secsta.adb b/gcc/ada/s-secsta.adb index b55556f73ed..1cb1b1b9782 100644 --- a/gcc/ada/s-secsta.adb +++ b/gcc/ada/s-secsta.adb @@ -368,13 +368,11 @@ package body System.Secondary_Stack is To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); begin - Put_Line ( - " Total size : " + Put_Line (" Total size : " & SS_Ptr'Image (Fixed_Stack.Last) & " bytes"); - Put_Line ( - " Current allocated space : " + Put_Line (" Current allocated space : " & SS_Ptr'Image (Fixed_Stack.Top) & " bytes"); end; @@ -400,22 +398,22 @@ package body System.Secondary_Stack is -- Current Chunk information - Put_Line ( - " Total size : " + -- Note that First of each chunk is one more than Last of the + -- previous one, so Chunk.Last is the total size of all chunks; we + -- don't need to walk all the chunks to compute the total size. + + Put_Line (" Total size : " & SS_Ptr'Image (Chunk.Last) & " bytes"); - Put_Line ( - " Current allocated space : " + Put_Line (" Current allocated space : " & SS_Ptr'Image (Stack.Top - 1) & " bytes"); - Put_Line ( - " Number of Chunks : " + Put_Line (" Number of Chunks : " & Integer'Image (Nb_Chunks)); - Put_Line ( - " Default size of Chunks : " + Put_Line (" Default size of Chunks : " & SSE.Storage_Count'Image (Stack.Default_Size)); end; end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index fdc39291ff6..5be65af3d8f 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4887,21 +4887,6 @@ package body Sem_Ch13 is ("\?j?use interrupt procedure instead", N); end if; - -- Case of an address clause for a controlled object, which we - -- consider to be erroneous. - - elsif Is_Controlled (Etype (U_Ent)) - or else Has_Controlled_Component (Etype (U_Ent)) - then - Error_Msg_NE - ("??controlled object & must not be overlaid", Nam, U_Ent); - Error_Msg_N - ("\??Program_Error will be raised at run time", Nam); - Insert_Action (Declaration_Node (U_Ent), - Make_Raise_Program_Error (Loc, - Reason => PE_Overlaid_Controlled_Object)); - return; - -- Case of an address clause for a class-wide object, which is -- considered erroneous. @@ -4915,9 +4900,9 @@ package body Sem_Ch13 is Reason => PE_Overlaid_Controlled_Object)); return; - -- Case of address clause for a (non-controlled) object + -- Case of address clause for an object - elsif Ekind_In (U_Ent, E_Variable, E_Constant) then + elsif Ekind_In (U_Ent, E_Constant, E_Variable) then declare Expr : constant Node_Id := Expression (N); O_Ent : Entity_Id; @@ -5006,28 +4991,11 @@ package body Sem_Ch13 is end; end if; - -- Overlaying controlled objects is erroneous. Emit warning - -- but continue analysis because program is itself legal, - -- and back end must see address clause. - - if Present (O_Ent) - and then (Has_Controlled_Component (Etype (O_Ent)) - or else Is_Controlled (Etype (O_Ent))) - and then not Inside_A_Generic - then - Error_Msg_N - ("??cannot use overlays with controlled objects", Expr); - Error_Msg_N - ("\??Program_Error will be raised at run time", Expr); - Insert_Action (Declaration_Node (U_Ent), - Make_Raise_Program_Error (Loc, - Reason => PE_Overlaid_Controlled_Object)); - -- Issue an unconditional warning for a constant overlaying -- a variable. For the reverse case, we will issue it only -- if the variable is modified. - elsif Ekind (U_Ent) = E_Constant + if Ekind (U_Ent) = E_Constant and then Present (O_Ent) and then not Overlays_Constant (U_Ent) and then Address_Clause_Overlay_Warnings -- 2.30.2