cstand.adb (Create_Standard): Create an entity for a zero-sized type associated with...

2007-08-16  Gary Dismukes  <dismukes@adacore.com>

	* cstand.adb (Create_Standard): Create an entity for a zero-sized type
	associated with Standard_Debug_Renaming_Type, to be used as the type of
	the special variables whose names provide debugger encodings for
	renaming declarations.

	* einfo.ads, einfo.adb (Debug_Renaming_Link): Change to return Node25.
	(Set_Debug_Renaming_Link): Change to set Node25.
	(Write_Field13_Name): Remove case for E_Enumeration_Literal.
	(Write_Field25_Name): Add case for E_Variable to output
	"Debug_Renaming_Link".
	(Write_Field23_Name): Correct the output string for "Limited_View".

	* exp_dbug.adb: Add with and use of Tbuild.
	(Debug_Renaming_Declaration): Replace creation of an enumeration type
	and literal with creation of a variable of type
	Standard_Debug_Renaming_Type whose name encodes both the renamed object
	and the entity of the renaming declaration.
	(Qualify_Entity_Name): Add the delayed qualification of the entity name
	part of the name of a variable that has a Debug_Renaming_Link.

	* stand.ads (Standard_Debug_Renaming_Type): New Entity_Id denoting a
	special type to be associated with variables that provide debugger
	encodings for renaming declarations.

From-SVN: r127537

gcc/ada/cstand.adb

@@ -927,6 +927,28 @@ package body CStand is
       Set_Directly_Designated_Type (Standard_A_Char, Standard_Character);
       Make_Name     (Standard_A_Char, "access_character");
 
+      --  Standard_Debug_Renaming_Type is used for the special objects created
+      --  to encode the names occurring in renaming declarations for use by the
+      --  debugger (see exp_dbug.adb). The type is a zero-sized subtype of
+      --  Standard.Integer.
+
+      Standard_Debug_Renaming_Type := New_Standard_Entity;
+
+      Set_Ekind (Standard_Debug_Renaming_Type, E_Signed_Integer_Subtype);
+      Set_Scope (Standard_Debug_Renaming_Type, Standard_Standard);
+      Set_Etype (Standard_Debug_Renaming_Type, Base_Type (Standard_Integer));
+      Init_Esize         (Standard_Debug_Renaming_Type, 0);
+      Init_RM_Size       (Standard_Debug_Renaming_Type, 0);
+      Set_Size_Known_At_Compile_Time (Standard_Debug_Renaming_Type);
+      Set_Integer_Bounds (Standard_Debug_Renaming_Type,
+        Typ => Base_Type (Standard_Debug_Renaming_Type),
+        Lb  => Uint_1,
+        Hb  => Uint_0);
+      Set_Is_Constrained (Standard_Debug_Renaming_Type);
+      Set_Has_Size_Clause (Standard_Debug_Renaming_Type);
+
+      Make_Name      (Standard_Debug_Renaming_Type, "_renaming_type");
+
       --  Note on type names. The type names for the following special types
       --  are constructed so that they will look reasonable should they ever
       --  appear in error messages etc, although in practice the use of the

gcc/ada/einfo.adb

@@ -106,7 +106,6 @@ package body Einfo is
 
    --    Corresponding_Equality          Node13
    --    Component_Clause                Node13
-   --    Debug_Renaming_Link             Node13
    --    Elaboration_Entity              Node13
    --    Extra_Accessibility             Node13
    --    RM_Size                         Uint13
@@ -214,6 +213,7 @@ package body Einfo is
    --    Abstract_Interface_Alias        Node25
    --    Abstract_Interfaces             Elist25
    --    Current_Use_Clause              Node25
+   --    Debug_Renaming_Link             Node25
    --    DT_Offset_To_Top_Func           Node25
    --    Task_Body_Procedure             Node25
 
@@ -741,7 +741,7 @@ package body Einfo is
 
    function Debug_Renaming_Link (Id : E) return E is
    begin
-      return Node13 (Id);
+      return Node25 (Id);
    end Debug_Renaming_Link;
 
    function Default_Expr_Function (Id : E) return E is
@@ -2997,7 +2997,7 @@ package body Einfo is
 
    procedure Set_Debug_Renaming_Link (Id : E; V : E) is
    begin
-      Set_Node13 (Id, V);
+      Set_Node25 (Id, V);
    end Set_Debug_Renaming_Link;
 
    procedure Set_Default_Expr_Function (Id : E; V : E) is
@@ -7604,9 +7604,6 @@ package body Einfo is
               E_Discriminant                               =>
             Write_Str ("Component_Clause");
 
-         when E_Enumeration_Literal                        =>
-            Write_Str ("Debug_Renaming_Link");
-
          when E_Function                                   =>
             if not Comes_From_Source (Id)
                  and then
@@ -8149,7 +8146,7 @@ package body Einfo is
             if Is_Generic_Instance (Id) then
                Write_Str ("Generic_Renamings");
             else
-               Write_Str ("Limited Views");
+               Write_Str ("Limited_View");
             end if;
 
          --  What about Privals_Chain for protected operations ???
@@ -8198,6 +8195,9 @@ package body Einfo is
          when Task_Kind                                    =>
             Write_Str ("Task_Body_Procedure");
 
+         when E_Variable                                   =>
+            Write_Str ("Debug_Renaming_Link");
+
          when others                                       =>
             Write_Str ("Field25??");
       end case;

gcc/ada/einfo.ads

@@ -665,8 +665,8 @@ package Einfo is
 --       determining if Needs_Debug_Info should be set. The back end should
 --       always test Needs_Debug_Info, it should never test Debug_Info_Off.
 
---    Debug_Renaming_Link (Node13)
---       Used to link the enumeration literal of a debug renaming declaration
+--    Debug_Renaming_Link (Node25)
+--       Used to link the variable associated with a debug renaming declaration
 --       to the renamed entity. See Exp_Dbug.Debug_Renaming_Declaration for
 --       details of the use of this field.
 
@@ -4717,7 +4717,6 @@ package Einfo is
    --  E_Enumeration_Literal
    --    Enumeration_Pos                     (Uint11)
    --    Enumeration_Rep                     (Uint12)
-   --    Debug_Renaming_Link                 (Node13)
    --    Alias                               (Node18)
    --    Enumeration_Rep_Expr                (Node22)
    --    Next_Literal                        (synth)
@@ -5250,6 +5249,7 @@ package Einfo is
    --    Interface_Name                      (Node21)
    --    Shared_Var_Assign_Proc              (Node22)
    --    Extra_Constrained                   (Node23)
+   --    Debug_Renaming_Link                 (Node25)
    --    Has_Alignment_Clause                (Flag46)
    --    Has_Atomic_Components               (Flag86)
    --    Has_Biased_Representation           (Flag139)

gcc/ada/exp_dbug.adb

@@ -38,6 +38,7 @@ with Sinfo;    use Sinfo;
 with Stand;    use Stand;
 with Stringt;  use Stringt;
 with Table;
+with Tbuild;   use Tbuild;
 with Urealp;   use Urealp;
 
 package body Exp_Dbug is
@@ -295,12 +296,10 @@ package body Exp_Dbug is
       Loc : constant Source_Ptr := Sloc (N);
       Ent : constant Node_Id    := Defining_Entity (N);
       Nam : constant Node_Id    := Name (N);
-      Rnm : Name_Id;
       Ren : Node_Id;
-      Lit : Entity_Id;
       Typ : Entity_Id;
+      Obj : Entity_Id;
       Res : Node_Id;
-      Def : Entity_Id;
 
       function Output_Subscript (N : Node_Id; S : String) return Boolean;
       --  Outputs a single subscript value as ?nnn (subscript is compile time
@@ -342,36 +341,6 @@ package body Exp_Dbug is
          return Empty;
       end if;
 
-      --  Prepare entity name for type declaration
-
-      Get_Name_String (Chars (Ent));
-
-      case Nkind (N) is
-         when N_Object_Renaming_Declaration =>
-            Add_Str_To_Name_Buffer ("___XR");
-
-         when N_Exception_Renaming_Declaration =>
-            Add_Str_To_Name_Buffer ("___XRE");
-
-         when N_Package_Renaming_Declaration =>
-            Add_Str_To_Name_Buffer ("___XRP");
-
-            --  If it is a child unit create a fully qualified name, to
-            --  disambiguate multiple child units with the same name and
-            --  different parents.
-
-            if Is_Child_Unit (Ent) then
-               Prepend_String_To_Buffer ("__");
-               Prepend_String_To_Buffer
-                 (Get_Name_String (Chars (Scope (Ent))));
-            end if;
-
-         when others =>
-            return Empty;
-      end case;
-
-      Rnm := Name_Find;
-
       --  Get renamed entity and compute suffix
 
       Name_Len := 0;
@@ -443,9 +412,43 @@ package body Exp_Dbug is
 
       Prepend_String_To_Buffer ("___XE");
 
-      --  For now, the literal name contains only the suffix. The Entity_Id
-      --  value for the name is used to create a link from this literal name
-      --  to the renamed entity using the Debug_Renaming_Link field. Then the
+      --  Include the designation of the form of renaming
+
+      case Nkind (N) is
+         when N_Object_Renaming_Declaration =>
+            Prepend_String_To_Buffer ("___XR");
+
+         when N_Exception_Renaming_Declaration =>
+            Prepend_String_To_Buffer ("___XRE");
+
+         when N_Package_Renaming_Declaration =>
+            Prepend_String_To_Buffer ("___XRP");
+
+         when others =>
+            return Empty;
+      end case;
+
+      --  Add the name of the renaming entity to the front
+
+      Prepend_String_To_Buffer (Get_Name_String (Chars (Ent)));
+
+      --  If it is a child unit create a fully qualified name, to disambiguate
+      --  multiple child units with the same name and different parents.
+
+      if Nkind (N) = N_Package_Renaming_Declaration
+        and then Is_Child_Unit (Ent)
+      then
+         Prepend_String_To_Buffer ("__");
+         Prepend_String_To_Buffer
+           (Get_Name_String (Chars (Scope (Ent))));
+      end if;
+
+      --  Create the special object whose name is the debug encoding for the
+      --  renaming declaration.
+
+      --  For now, the object name contains the suffix encoding for the renamed
+      --  object, but not the name of the leading entity. The object is linked
+      --  the renamed entity using the Debug_Renaming_Link field. Then the
       --  Qualify_Entity_Name procedure uses this link to create the proper
       --  fully qualified name.
 
@@ -453,23 +456,17 @@ package body Exp_Dbug is
       --  qualification of the renamed entity, and it is really much easier to
       --  do this after the renamed entity has itself been fully qualified.
 
-      Lit := Make_Defining_Identifier (Loc, Chars => Name_Enter);
-      Set_Debug_Renaming_Link (Lit, Entity (Ren));
-
-      --  Return the appropriate enumeration type
-
-      Def := Make_Defining_Identifier (Loc, Chars => Rnm);
+      Obj := Make_Defining_Identifier (Loc, Chars => Name_Enter);
       Res :=
-        Make_Full_Type_Declaration (Loc,
-          Defining_Identifier => Def,
-          Type_Definition =>
-            Make_Enumeration_Type_Definition (Loc,
-              Literals => New_List (Lit)));
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => Obj,
+          Object_Definition   => New_Reference_To
+                                   (Standard_Debug_Renaming_Type, Loc));
+
+      Set_Debug_Renaming_Link (Obj, Entity (Ren));
 
-      Set_Needs_Debug_Info (Def);
-      Set_Needs_Debug_Info (Lit);
+      Set_Needs_Debug_Info (Obj);
 
-      Set_Discard_Names (Defining_Identifier (Res));
       return Res;
 
    --  If we get an exception, just figure it is a case that we cannot
@@ -1251,17 +1248,69 @@ package body Exp_Dbug is
       if Has_Qualified_Name (Ent) then
          return;
 
-      --  Here is where we create the proper link for renaming
+      --  If the entity is a variable encoding the debug name for an object
+      --  renaming, then the qualified name of the entity associated with the
+      --  renamed object can now be incorporated in the debug name.
 
-      elsif Ekind (Ent) = E_Enumeration_Literal
+      elsif Ekind (Ent) = E_Variable
         and then Present (Debug_Renaming_Link (Ent))
       then
          Name_Len := 0;
          Qualify_Entity_Name (Debug_Renaming_Link (Ent));
          Get_Name_String (Chars (Ent));
-         Prepend_String_To_Buffer
-           (Get_Name_String (Chars (Debug_Renaming_Link (Ent))));
+
+         --  Retrieve the now-qualified name of the renamed entity and insert
+         --  it in the middle of the name, just preceding the suffix encoding
+         --  describing the renamed object.
+
+         declare
+            Renamed_Id : constant String :=
+                           Get_Name_String (Chars (Debug_Renaming_Link (Ent)));
+            Insert_Len : constant Integer := Renamed_Id'Length + 1;
+            Index      : Natural := Name_Len - 3;
+
+         begin
+            --  Loop backwards through the name to find the start of the "___"
+            --  sequence associated with the suffix.
+
+            while Index >= Name_Buffer'First
+              and then (Name_Buffer (Index + 1) /= '_'
+                         or else Name_Buffer (Index + 2) /= '_'
+                         or else Name_Buffer (Index + 3) /= '_')
+            loop
+               Index := Index - 1;
+            end loop;
+
+            pragma Assert (Name_Buffer (Index + 1 .. Index + 3) = "___");
+
+            --  Insert an underscore separator and the entity name just in
+            --  front of the suffix.
+
+            Name_Buffer (Index + 1 + Insert_Len .. Name_Len + Insert_Len) :=
+              Name_Buffer (Index + 1 .. Name_Len);
+            Name_Buffer (Index + 1) := '_';
+            Name_Buffer (Index + 2 .. Index + Insert_Len) := Renamed_Id;
+            Name_Len := Name_Len + Insert_Len;
+         end;
+
+         --  Reset the name of the variable to the new name that includes the
+         --  name of the renamed entity.
+
          Set_Chars (Ent, Name_Enter);
+
+         --  If the entity needs qualification by its scope then develop it
+         --  here, add the variable's name, and again reset the entity name.
+
+         if Qualify_Needed (Scope (Ent)) then
+            Name_Len := 0;
+            Set_Entity_Name (Scope (Ent));
+            Add_Str_To_Name_Buffer ("__");
+
+            Get_Name_String_And_Append (Chars (Ent));
+
+            Set_Chars (Ent, Name_Enter);
+         end if;
+
          Set_Has_Qualified_Name (Ent);
          return;
 

gcc/ada/stand.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -345,6 +345,10 @@ package Stand is
    --  Access to character, used as a component of the exception type to
    --  denote a thin pointer component.
 
+   Standard_Debug_Renaming_Type : Entity_Id;
+   --  A null record type with zero size, used as the type of variables used
+   --  to provide the debugger with name encodings for renaming declarations.
+
    --  The entities labeled Any_xxx are used in situations where the full
    --  characteristics of an entity are not yet known, e.g. Any_Character
    --  is used to label a character literal before resolution is complete.