[multiple changes]

2017-04-25  Bob Duff  <duff@adacore.com>

	* 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  <duff@adacore.com>

	* 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  <miranda@adacore.com>

	* 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  <kirtchev@adacore.com>

	* 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  <derodat@adacore.com>

	* 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

+2017-04-25  Bob Duff  <duff@adacore.com>
+
+	* 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  <duff@adacore.com>
+
+	* 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  <miranda@adacore.com>
+
+	* 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  <kirtchev@adacore.com>
+
+	* 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  <derodat@adacore.com>
+
+	* 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  <kirtchev@adacore.com>
 
 	* sem_prag.adb, sem_prag.ads: Minor reformatting.

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

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);
 

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
 

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;
 

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;
 

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;

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