New Language: Ada

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45954 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 1753 insertions, 0 deletions

diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb
new file mode 100644
index 00000000000..871b0c56c64
--- /dev/null
+++ b/gcc/ada/exp_dbug.adb
@@ -0,0 +1,1753 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             E X P _ D B U G                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.56 $
+--                                                                          --
+--          Copyright (C) 1996-2001 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- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Alloc;    use Alloc;
+with Atree;    use Atree;
+with Debug;    use Debug;
+with Einfo;    use Einfo;
+with Exp_Util; use Exp_Util;
+with Freeze;   use Freeze;
+with Lib;      use Lib;
+with Hostparm; use Hostparm;
+with Namet;    use Namet;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Output;   use Output;
+with Sem_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sinput;   use Sinput;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Stringt;  use Stringt;
+with Table;
+with Urealp;   use Urealp;
+
+with GNAT.HTable;
+
+package body Exp_Dbug is
+
+   --  The following table is used to queue up the entities passed as
+   --  arguments to Qualify_Entity_Names for later processing when
+   --  Qualify_All_Entity_Names is called.
+
+   package Name_Qualify_Units is new Table.Table (
+     Table_Component_Type => Node_Id,
+     Table_Index_Type     => Nat,
+     Table_Low_Bound      => 1,
+     Table_Initial        => Alloc.Name_Qualify_Units_Initial,
+     Table_Increment      => Alloc.Name_Qualify_Units_Increment,
+     Table_Name           => "Name_Qualify_Units");
+
+   --  Define hash table for compressed debug names
+
+   --  This hash table keeps track of qualification prefix strings
+   --  that have been compressed. The element is the corresponding
+   --  hash value used in the compressed symbol.
+
+   type Hindex is range 0 .. 4096;
+   --  Type to define range of headers
+
+   function SHash (S : String_Ptr) return Hindex;
+   --  Hash function for this table
+
+   function SEq (F1, F2 : String_Ptr) return Boolean;
+   --  Equality function for this table
+
+   type Elmt is record
+      W : Word;
+      S : String_Ptr;
+   end record;
+
+   No_Elmt : Elmt := (0, null);
+
+   package CDN is new GNAT.HTable.Simple_HTable (
+     Header_Num => Hindex,
+     Element    => Elmt,
+     No_Element => No_Elmt,
+     Key        => String_Ptr,
+     Hash       => SHash,
+     Equal      => SEq);
+
+   --------------------------------
+   -- Use of Qualification Flags --
+   --------------------------------
+
+   --  There are two flags used to keep track of qualification of entities
+
+   --    Has_Fully_Qualified_Name
+   --    Has_Qualified_Name
+
+   --  The difference between these is as follows. Has_Qualified_Name is
+   --  set to indicate that the name has been qualified as required by the
+   --  spec of this package. As described there, this may involve the full
+   --  qualification for the name, but for some entities, notably procedure
+   --  local variables, this full qualification is not required.
+
+   --  The flag Has_Fully_Qualified_Name is set if indeed the name has been
+   --  fully qualified in the Ada sense. If Has_Fully_Qualified_Name is set,
+   --  then Has_Qualified_Name is also set, but the other way round is not
+   --  the case.
+
+   --  Consider the following example:
+
+   --     with ...
+   --     procedure X is
+   --       B : Ddd.Ttt;
+   --       procedure Y is ..
+
+   --  Here B is a procedure local variable, so it does not need fully
+   --  qualification. The flag Has_Qualified_Name will be set on the
+   --  first attempt to qualify B, to indicate that the job is done
+   --  and need not be redone.
+
+   --  But Y is qualified as x__y, since procedures are always fully
+   --  qualified, so the first time that an attempt is made to qualify
+   --  the name y, it will be replaced by x__y, and both flags are set.
+
+   --  Why the two flags? Well there are cases where we derive type names
+   --  from object names. As noted in the spec, type names are always
+   --  fully qualified. Suppose for example that the backend has to build
+   --  a padded type for variable B. then it will construct the PAD name
+   --  from B, but it requires full qualification, so the fully qualified
+   --  type name will be x__b___PAD. The two flags allow the circuit for
+   --  building this name to realize efficiently that b needs further
+   --  qualification.
+
+   ----------------------
+   -- Local Procedures --
+   ----------------------
+
+   procedure Add_Uint_To_Buffer (U : Uint);
+   --  Add image of universal integer to Name_Buffer, updating Name_Len
+
+   procedure Add_Real_To_Buffer (U : Ureal);
+   --  Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of
+   --  the normalized numerator and denominator of the given real value.
+
+   function Bounds_Match_Size (E : Entity_Id) return  Boolean;
+   --  Determine whether the bounds of E match the size of the type. This is
+   --  used to determine whether encoding is required for a discrete type.
+
+   function CDN_Hash (S : String) return Word;
+   --  This is the hash function used to compress debug symbols. The string
+   --  S is the prefix which is a list of qualified names separated by double
+   --  underscore (no trailing double underscore). The returned value is the
+   --  hash value used in the compressed names. It is also used for the hash
+   --  table used to keep track of what prefixes have been compressed so far.
+
+   procedure Compress_Debug_Name (E : Entity_Id);
+   --  If the name of the entity E is too long, or compression is to be
+   --  attempted on all names (Compress_Debug_Names set), then an attempt
+   --  is made to compress the name of the entity.
+
+   function Double_Underscore (S : String; J : Natural) return Boolean;
+   --  Returns True if J is the start of a double underscore
+   --  sequence in the string S (defined as two underscores
+   --  which are preceded and followed by a non-underscore)
+
+   procedure Prepend_String_To_Buffer (S : String);
+   --  Prepend given string to the contents of the string buffer, updating
+   --  the value in Name_Len (i.e. string is added at start of buffer).
+
+   procedure Prepend_Uint_To_Buffer (U : Uint);
+   --  Prepend image of universal integer to Name_Buffer, updating Name_Len
+
+   procedure Put_Hex (W : Word; N : Natural);
+   --  Output W as 8 hex digits (0-9, a-f) in Name_Buffer (N .. N + 7)
+
+   procedure Qualify_Entity_Name (Ent : Entity_Id);
+   --  If not already done, replaces the Chars field of the given entity
+   --  with the appropriate fully qualified name.
+
+   procedure Strip_BNPE_Suffix (Suffix_Found : in out Boolean);
+   --  Given an qualified entity name in Name_Buffer, remove any plain X or
+   --  X{nb} qualification suffix. The contents of Name_Buffer is not changed
+   --  but Name_Len may be adjusted on return to remove the suffix. If a
+   --  suffix is found and stripped, then Suffix_Found is set to True. If
+   --  no suffix is found, then Suffix_Found is not modified.
+
+   ------------------------
+   -- Add_Real_To_Buffer --
+   ------------------------
+
+   procedure Add_Real_To_Buffer (U : Ureal) is
+   begin
+      Add_Uint_To_Buffer (Norm_Num (U));
+      Add_Str_To_Name_Buffer ("_");
+      Add_Uint_To_Buffer (Norm_Den (U));
+   end Add_Real_To_Buffer;
+
+   ------------------------
+   -- Add_Uint_To_Buffer --
+   ------------------------
+
+   procedure Add_Uint_To_Buffer (U : Uint) is
+   begin
+      if U < 0 then
+         Add_Uint_To_Buffer (-U);
+         Add_Char_To_Name_Buffer ('m');
+      else
+         UI_Image (U, Decimal);
+         Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
+      end if;
+   end Add_Uint_To_Buffer;
+
+   -----------------------
+   -- Bounds_Match_Size --
+   -----------------------
+
+   function Bounds_Match_Size (E : Entity_Id) return Boolean is
+      Siz : Uint;
+
+   begin
+      if not Is_OK_Static_Subtype (E) then
+         return False;
+
+      elsif Is_Integer_Type (E)
+        and then Subtypes_Statically_Match (E, Base_Type (E))
+      then
+         return True;
+
+      --  Here we check if the static bounds match the natural size, which
+      --  is the size passed through with the debugging information. This
+      --  is the Esize rounded up to 8, 16, 32 or 64 as appropriate.
+
+      else
+         declare
+            Umark  : constant Uintp.Save_Mark := Uintp.Mark;
+            Result : Boolean;
+
+         begin
+            if Esize (E) <= 8 then
+               Siz := Uint_8;
+            elsif Esize (E) <= 16 then
+               Siz := Uint_16;
+            elsif Esize (E) <= 32 then
+               Siz := Uint_32;
+            else
+               Siz := Uint_64;
+            end if;
+
+            if Is_Modular_Integer_Type (E) or else Is_Enumeration_Type (E) then
+               Result :=
+                 Expr_Rep_Value (Type_Low_Bound (E)) = 0
+                   and then
+                 2 ** Siz - Expr_Rep_Value (Type_High_Bound (E)) = 1;
+
+            else
+               Result :=
+                 Expr_Rep_Value (Type_Low_Bound (E)) + 2 ** (Siz - 1) = 0
+                   and then
+                 2 ** (Siz - 1) - Expr_Rep_Value (Type_High_Bound (E)) = 1;
+            end if;
+
+            Release (Umark);
+            return Result;
+         end;
+      end if;
+   end Bounds_Match_Size;
+
+   --------------
+   -- CDN_Hash --
+   --------------
+
+   function CDN_Hash (S : String) return Word is
+      H : Word;
+
+      function Rotate_Left (Value : Word; Amount : Natural) return Word;
+      pragma Import (Intrinsic, Rotate_Left);
+
+   begin
+      H := 0;
+      for J in S'Range loop
+         H := Rotate_Left (H, 3) + Character'Pos (S (J));
+      end loop;
+
+      return H;
+   end CDN_Hash;
+
+   -------------------------
+   -- Compress_Debug_Name --
+   -------------------------
+
+   procedure Compress_Debug_Name (E : Entity_Id) is
+      Ptr  : Natural;
+      Sptr : String_Ptr;
+      Cod  : Word;
+
+   begin
+      if not Compress_Debug_Names
+        and then Length_Of_Name (Chars (E)) <= Max_Debug_Name_Length
+      then
+         return;
+      end if;
+
+      Get_Name_String (Chars (E));
+
+      --  Find rightmost double underscore
+
+      Ptr := Name_Len - 2;
+      loop
+         exit when Double_Underscore (Name_Buffer, Ptr);
+
+         --  Cannot compress if no double underscore anywhere
+
+         if Ptr < 2 then
+            return;
+         end if;
+
+         Ptr := Ptr  - 1;
+      end loop;
+
+      --  At this stage we have
+
+      --    Name_Buffer (1 .. Ptr - 1)         string to compress
+      --    Name_Buffer (Ptr)                  underscore
+      --    Name_Buffer (Ptr + 1)              underscore
+      --    Name_Buffer (Ptr + 2 .. Name_Len)  simple name to retain
+
+      --  See if we already have an entry for the compression string
+
+      --  No point in compressing if it does not make things shorter
+
+      if Name_Len <= (2 + 8 + 1) + (Name_Len - (Ptr + 1)) then
+         return;
+      end if;
+
+      --  Do not compress any reference to entity in internal file
+
+      if Name_Buffer (1 .. 5) = "ada__"
+           or else
+         Name_Buffer (1 .. 8) = "system__"
+           or else
+         Name_Buffer (1 .. 6) = "gnat__"
+           or else
+         Name_Buffer (1 .. 12) = "interfaces__"
+           or else
+             (OpenVMS and then Name_Buffer (1 .. 5) = "dec__")
+      then
+         return;
+      end if;
+
+      Sptr := Name_Buffer (1 .. Ptr - 1)'Unrestricted_Access;
+      Cod := CDN.Get (Sptr).W;
+
+      if Cod = 0 then
+         Cod := CDN_Hash (Sptr.all);
+         Sptr := new String'(Sptr.all);
+         CDN.Set (Sptr, (Cod, Sptr));
+      end if;
+
+      Name_Buffer (1) := 'X';
+      Name_Buffer (2) := 'C';
+      Put_Hex (Cod, 3);
+      Name_Buffer (11) := '_';
+      Name_Buffer (12 .. Name_Len - Ptr + 10) :=
+        Name_Buffer (Ptr + 2 .. Name_Len);
+      Name_Len := Name_Len - Ptr + 10;
+
+      Set_Chars (E, Name_Enter);
+   end Compress_Debug_Name;
+
+   --------------------------------
+   -- Debug_Renaming_Declaration --
+   --------------------------------
+
+   function Debug_Renaming_Declaration (N : Node_Id) return Node_Id 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;
+      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 known value with value nnn) or as ?e (subscript is local
+      --  constant with name e), where S supplies the proper string to
+      --  use for ?. Returns False if the subscript is not of an appropriate
+      --  type to output in one of these two forms. The result is prepended
+      --  to the name stored in Name_Buffer.
+
+      ----------------------
+      -- Output_Subscript --
+      ----------------------
+
+      function Output_Subscript (N : Node_Id; S : String) return Boolean is
+      begin
+         if Compile_Time_Known_Value (N) then
+            Prepend_Uint_To_Buffer (Expr_Value (N));
+
+         elsif Nkind (N) = N_Identifier
+           and then Scope (Entity (N)) = Scope (Ent)
+           and then Ekind (Entity (N)) = E_Constant
+         then
+            Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N))));
+
+         else
+            return False;
+         end if;
+
+         Prepend_String_To_Buffer (S);
+         return True;
+      end Output_Subscript;
+
+   --  Start of processing for Debug_Renaming_Declaration
+
+   begin
+      if not Comes_From_Source (N) then
+         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");
+
+         when others =>
+            return Empty;
+      end case;
+
+      Rnm := Name_Find;
+
+      --  Get renamed entity and compute suffix
+
+      Name_Len := 0;
+      Ren := Nam;
+      loop
+         case Nkind (Ren) is
+
+            when N_Identifier =>
+               exit;
+
+            when N_Expanded_Name =>
+
+               --  The entity field for an N_Expanded_Name is on the
+               --  expanded name node itself, so we are done here too.
+
+               exit;
+
+            when N_Selected_Component =>
+               Prepend_String_To_Buffer
+                 (Get_Name_String (Chars (Selector_Name (Ren))));
+               Prepend_String_To_Buffer ("XR");
+               Ren := Prefix (Ren);
+
+            when N_Indexed_Component =>
+               declare
+                  X : Node_Id := Last (Expressions (Ren));
+
+               begin
+                  while Present (X) loop
+                     if not Output_Subscript (X, "XS") then
+                        Set_Materialize_Entity (Ent);
+                        return Empty;
+                     end if;
+
+                     Prev (X);
+                  end loop;
+               end;
+
+               Ren := Prefix (Ren);
+
+            when N_Slice =>
+
+               Typ := Etype (First_Index (Etype (Nam)));
+
+               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;
+
+               Ren := Prefix (Ren);
+
+            when N_Explicit_Dereference =>
+               Prepend_String_To_Buffer ("XA");
+               Ren := Prefix (Ren);
+
+            --  For now, anything else simply results in no translation
+
+            when others =>
+               Set_Materialize_Entity (Ent);
+               return Empty;
+         end case;
+      end loop;
+
+      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
+      --  Qualify_Entity_Name procedure uses this link to create the proper
+      --  fully qualified name.
+
+      --  The reason we do things this way is that we really need to copy the
+      --  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);
+      Res :=
+        Make_Full_Type_Declaration (Loc,
+          Defining_Identifier => Def,
+          Type_Definition =>
+            Make_Enumeration_Type_Definition (Loc,
+              Literals => New_List (Lit)));
+
+      Set_Needs_Debug_Info (Def);
+      Set_Needs_Debug_Info (Lit);
+
+      Set_Discard_Names (Defining_Identifier (Res));
+      return Res;
+
+   --  If we get an exception, just figure it is a case that we cannot
+   --  successfully handle using our current approach, since this is
+   --  only for debugging, no need to take the compilation with us!
+
+   exception
+      when others =>
+         return Make_Null_Statement (Loc);
+   end Debug_Renaming_Declaration;
+
+   -----------------------
+   -- Double_Underscore --
+   -----------------------
+
+   function Double_Underscore (S : String; J : Natural) return Boolean is
+   begin
+      if J = S'First or else J > S'Last - 2 then
+         return False;
+
+      else
+         return S (J) = '_'
+           and then S (J + 1) = '_'
+           and then S (J - 1) /= '_'
+           and then S (J + 2) /= '_';
+      end if;
+   end Double_Underscore;
+
+   ------------------------------
+   -- Generate_Auxiliary_Types --
+   ------------------------------
+
+   --  Note: right now there is only one auxiliary type to be generated,
+   --  namely the enumeration type for the compression sequences if used.
+
+   procedure Generate_Auxiliary_Types is
+      Loc     : constant Source_Ptr := Sloc (Cunit (Current_Sem_Unit));
+      E       : Elmt;
+      Code    : Entity_Id;
+      Lit     : Entity_Id;
+      Start   : Natural;
+      Ptr     : Natural;
+      Discard : List_Id;
+
+      Literal_List : List_Id := New_List;
+      --  Gathers the list of literals for the declaration
+
+      procedure Output_Literal;
+      --  Adds suffix of form Xnnn to name in Name_Buffer, where nnn is
+      --  a serial number that is one greater on each call, and then
+      --  builds an enumeration literal and adds it to the literal list.
+
+      Serial : Nat := 0;
+      --  Current serial number
+
+      procedure Output_Literal is
+      begin
+         Serial := Serial + 1;
+         Add_Char_To_Name_Buffer ('X');
+         Add_Nat_To_Name_Buffer (Serial);
+
+         Lit :=
+           Make_Defining_Identifier (Loc,
+             Chars => Name_Find);
+         Set_Has_Qualified_Name (Lit, True);
+         Append (Lit, Literal_List);
+      end Output_Literal;
+
+   --  Start of processing for Auxiliary_Types
+
+   begin
+      E := CDN.Get_First;
+      if E.S /= null then
+         while E.S /= null loop
+
+            --  We have E.S a String_Ptr that contains a string of the form:
+
+            --    b__c__d
+
+            --  In E.W is a 32-bit word representing the hash value
+
+            --  Our mission is to construct a type
+
+            --     type XChhhhhhhh is (b,c,d);
+
+            --  where hhhhhhhh is the 8 hex digits of the E.W value.
+            --  and append this type declaration to the result list
+
+            Name_Buffer (1) := 'X';
+            Name_Buffer (2) := 'C';
+            Put_Hex (E.W, 3);
+            Name_Len := 10;
+            Output_Literal;
+
+            Start := E.S'First;
+            Ptr   := E.S'First;
+            while Ptr <= E.S'Last loop
+               if Ptr = E.S'Last
+                 or else Double_Underscore (E.S.all, Ptr + 1)
+               then
+                  Name_Len := Ptr - Start + 1;
+                  Name_Buffer (1 .. Name_Len) := E.S (Start .. Ptr);
+                  Output_Literal;
+                  Start := Ptr + 3;
+                  Ptr := Start;
+               else
+                  Ptr := Ptr + 1;
+               end if;
+            end loop;
+
+            E := CDN.Get_Next;
+         end loop;
+
+         Name_Buffer (1) := 'X';
+         Name_Buffer (2) := 'C';
+         Name_Len := 2;
+
+         Code :=
+           Make_Defining_Identifier (Loc,
+             Chars => Name_Find);
+         Set_Has_Qualified_Name (Code, True);
+
+         Insert_Library_Level_Action (
+           Make_Full_Type_Declaration (Loc,
+             Defining_Identifier => Code,
+             Type_Definition =>
+               Make_Enumeration_Type_Definition (Loc,
+                 Literals => Literal_List)));
+
+         --  We have to manually freeze this entity, since it is inserted
+         --  very late on into the tree, and otherwise will not be frozen.
+         --  No freeze actions are generated, so we can discard the result.
+
+         Discard := Freeze_Entity (Code,  Loc);
+      end if;
+   end Generate_Auxiliary_Types;
+
+   ----------------------
+   -- Get_Encoded_Name --
+   ----------------------
+
+   --  Note: see spec for details on encodings
+
+   procedure Get_Encoded_Name (E : Entity_Id) is
+      Has_Suffix : Boolean;
+
+   begin
+      Get_Name_String (Chars (E));
+
+      --  Nothing to do if we do not have a type
+
+      if not Is_Type (E)
+
+      --  Or if this is an enumeration base type
+
+        or else (Is_Enumeration_Type (E)
+                   and then E = Base_Type (E))
+
+      --  Or if this is a dummy type for a renaming
+
+        or else Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR"
+        or else Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
+        or else Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"
+
+      --  For all these cases, just return the name unchanged
+
+      then
+         Name_Buffer (Name_Len + 1) := ASCII.Nul;
+         return;
+      end if;
+
+      Has_Suffix := True;
+
+      --  Fixed-point case
+
+      if Is_Fixed_Point_Type (E) then
+         Get_External_Name_With_Suffix (E, "XF_");
+         Add_Real_To_Buffer (Delta_Value (E));
+
+         if Small_Value (E) /= Delta_Value (E) then
+            Add_Str_To_Name_Buffer ("_");
+            Add_Real_To_Buffer (Small_Value (E));
+         end if;
+
+      --  Vax floating-point case
+
+      elsif Vax_Float (E) then
+
+         if Digits_Value (Base_Type (E)) = 6 then
+            Get_External_Name_With_Suffix (E, "XFF");
+
+         elsif Digits_Value (Base_Type (E)) = 9 then
+            Get_External_Name_With_Suffix (E, "XFF");
+
+         else
+            pragma Assert (Digits_Value (Base_Type (E)) = 15);
+            Get_External_Name_With_Suffix (E, "XFG");
+         end if;
+
+      --  Discrete case where bounds do not match size
+
+      elsif Is_Discrete_Type (E)
+        and then not Bounds_Match_Size (E)
+      then
+         if Has_Biased_Representation (E) then
+            Get_External_Name_With_Suffix (E, "XB");
+         else
+            Get_External_Name_With_Suffix (E, "XD");
+         end if;
+
+         declare
+            Lo : constant Node_Id := Type_Low_Bound (E);
+            Hi : constant Node_Id := Type_High_Bound (E);
+
+            Lo_Stat : constant Boolean := Is_OK_Static_Expression (Lo);
+            Hi_Stat : constant Boolean := Is_OK_Static_Expression (Hi);
+
+            Lo_Discr : constant Boolean :=
+                         Nkind (Lo) = N_Identifier
+                           and then
+                         Ekind (Entity (Lo)) = E_Discriminant;
+
+            Hi_Discr : constant Boolean :=
+                         Nkind (Hi) = N_Identifier
+                           and then
+                         Ekind (Entity (Hi)) = E_Discriminant;
+
+            Lo_Encode : constant Boolean := Lo_Stat or Lo_Discr;
+            Hi_Encode : constant Boolean := Hi_Stat or Hi_Discr;
+
+         begin
+            if Lo_Encode or Hi_Encode then
+               if Lo_Encode then
+                  if Hi_Encode then
+                     Add_Str_To_Name_Buffer ("LU_");
+                  else
+                     Add_Str_To_Name_Buffer ("L_");
+                  end if;
+               else
+                  Add_Str_To_Name_Buffer ("U_");
+               end if;
+
+               if Lo_Stat then
+                  Add_Uint_To_Buffer (Expr_Rep_Value (Lo));
+               elsif Lo_Discr then
+                  Get_Name_String_And_Append (Chars (Entity (Lo)));
+               end if;
+
+               if Lo_Encode and Hi_Encode then
+                  Add_Str_To_Name_Buffer ("__");
+               end if;
+
+               if Hi_Stat then
+                  Add_Uint_To_Buffer (Expr_Rep_Value (Hi));
+               elsif Hi_Discr then
+                  Get_Name_String_And_Append (Chars (Entity (Hi)));
+               end if;
+            end if;
+         end;
+
+      --  For all other cases, the encoded name is the normal type name
+
+      else
+         Has_Suffix := False;
+         Get_External_Name (E, Has_Suffix);
+      end if;
+
+      if Debug_Flag_B and then Has_Suffix then
+         Write_Str ("**** type ");
+         Write_Name (Chars (E));
+         Write_Str (" is encoded as ");
+         Write_Str (Name_Buffer (1 .. Name_Len));
+         Write_Eol;
+      end if;
+
+      Name_Buffer (Name_Len + 1) := ASCII.NUL;
+   end Get_Encoded_Name;
+
+   -------------------
+   -- Get_Entity_Id --
+   -------------------
+
+   function Get_Entity_Id (External_Name : String) return Entity_Id is
+   begin
+      return Empty;
+   end Get_Entity_Id;
+
+   -----------------------
+   -- Get_External_Name --
+   -----------------------
+
+   procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean)
+   is
+      E    : Entity_Id := Entity;
+      Kind : Entity_Kind;
+
+      procedure Get_Qualified_Name_And_Append (Entity : Entity_Id);
+      --  Appends fully qualified name of given entity to Name_Buffer
+
+      -----------------------------------
+      -- Get_Qualified_Name_And_Append --
+      -----------------------------------
+
+      procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is
+      begin
+         --  If the entity is a compilation unit, its scope is Standard,
+         --  there is no outer scope, and the no further qualification
+         --  is required.
+
+         --  If the front end has already computed a fully qualified name,
+         --  then it is also the case that no further qualification is
+         --  required
+
+         if Present (Scope (Scope (Entity)))
+           and then not Has_Fully_Qualified_Name (Entity)
+         then
+            Get_Qualified_Name_And_Append (Scope (Entity));
+            Add_Str_To_Name_Buffer ("__");
+         end if;
+
+         Get_Name_String_And_Append (Chars (Entity));
+      end Get_Qualified_Name_And_Append;
+
+   --  Start of processing for Get_External_Name
+
+   begin
+      Name_Len := 0;
+
+      --  If this is a child unit, we want the child
+
+      if Nkind (E) = N_Defining_Program_Unit_Name then
+         E := Defining_Identifier (Entity);
+      end if;
+
+      Kind := Ekind (E);
+
+      --  Case of interface name being used
+
+      if (Kind = E_Procedure or else
+          Kind = E_Function  or else
+          Kind = E_Constant  or else
+          Kind = E_Variable  or else
+          Kind = E_Exception)
+        and then Present (Interface_Name (E))
+        and then No (Address_Clause (E))
+        and then not Has_Suffix
+      then
+         --  The following code needs explanation ???
+
+         if Convention (E) = Convention_Stdcall
+            and then Ekind (E) = E_Variable
+         then
+            Add_Str_To_Name_Buffer ("_imp__");
+         end if;
+
+         Add_String_To_Name_Buffer (Strval (Interface_Name (E)));
+
+      --  All other cases besides the interface name case
+
+      else
+         --  If this is a library level subprogram (i.e. a subprogram that is a
+         --  compilation unit other than a subunit), then we prepend _ada_ to
+         --  ensure distinctions required as described in the spec.
+         --  Check explicitly for child units, because those are not flagged
+         --  as Compilation_Units by lib. Should they be ???
+
+         if Is_Subprogram (E)
+           and then (Is_Compilation_Unit (E) or Is_Child_Unit (E))
+           and then not Has_Suffix
+         then
+            Add_Str_To_Name_Buffer ("_ada_");
+         end if;
+
+         --  If the entity is a subprogram instance that is not a compilation
+         --  unit, generate the name of the original Ada entity, which is the
+         --  one gdb needs.
+
+         if Is_Generic_Instance (E)
+           and then Is_Subprogram (E)
+           and then not Is_Compilation_Unit (Scope (E))
+         then
+            E := Related_Instance (Scope (E));
+         end if;
+
+         Get_Qualified_Name_And_Append (E);
+
+         if Has_Homonym (E) then
+            declare
+               H  : Entity_Id := Homonym (E);
+               Nr : Nat := 1;
+
+            begin
+               while Present (H) loop
+                  if (Scope (H) = Scope (E)) then
+                     Nr := Nr + 1;
+                  end if;
+
+                  H := Homonym (H);
+               end loop;
+
+               if Nr > 1 then
+                  if No_Dollar_In_Label then
+                     Add_Str_To_Name_Buffer ("__");
+                  else
+                     Add_Char_To_Name_Buffer ('$');
+                  end if;
+
+                  Add_Nat_To_Name_Buffer (Nr);
+               end if;
+            end;
+         end if;
+      end if;
+
+      Name_Buffer (Name_Len + 1) := ASCII.Nul;
+   end Get_External_Name;
+
+   -----------------------------------
+   -- Get_External_Name_With_Suffix --
+   -----------------------------------
+
+   procedure Get_External_Name_With_Suffix
+     (Entity : Entity_Id;
+      Suffix : String)
+   is
+      Has_Suffix : constant Boolean := (Suffix /= "");
+   begin
+      Get_External_Name (Entity, Has_Suffix);
+
+      if Has_Suffix then
+         Add_Str_To_Name_Buffer ("___");
+         Add_Str_To_Name_Buffer (Suffix);
+
+         Name_Buffer (Name_Len + 1) := ASCII.Nul;
+      end if;
+   end Get_External_Name_With_Suffix;
+
+   --------------------------
+   -- Get_Variant_Encoding --
+   --------------------------
+
+   procedure Get_Variant_Encoding (V : Node_Id) is
+      Choice : Node_Id;
+
+      procedure Choice_Val (Typ : Character; Choice : Node_Id);
+      --  Output encoded value for a single choice value. Typ is the key
+      --  character ('S', 'F', or 'T') that precedes the choice value.
+
+      ----------------
+      -- Choice_Val --
+      ----------------
+
+      procedure Choice_Val (Typ : Character; Choice : Node_Id) is
+      begin
+         Add_Char_To_Name_Buffer (Typ);
+
+         if Nkind (Choice) = N_Integer_Literal then
+            Add_Uint_To_Buffer (Intval (Choice));
+
+         --  Character literal with no entity present (this is the case
+         --  Standard.Character or Standard.Wide_Character as root type)
+
+         elsif Nkind (Choice) = N_Character_Literal
+           and then No (Entity (Choice))
+         then
+            Add_Uint_To_Buffer
+              (UI_From_Int (Int (Char_Literal_Value (Choice))));
+
+         else
+            declare
+               Ent : constant Entity_Id := Entity (Choice);
+
+            begin
+               if Ekind (Ent) = E_Enumeration_Literal then
+                  Add_Uint_To_Buffer (Enumeration_Rep (Ent));
+
+               else
+                  pragma Assert (Ekind (Ent) = E_Constant);
+                  Choice_Val (Typ, Constant_Value (Ent));
+               end if;
+            end;
+         end if;
+      end Choice_Val;
+
+   --  Start of processing for Get_Variant_Encoding
+
+   begin
+      Name_Len := 0;
+
+      Choice := First (Discrete_Choices (V));
+      while Present (Choice) loop
+         if Nkind (Choice) = N_Others_Choice then
+            Add_Char_To_Name_Buffer ('O');
+
+         elsif Nkind (Choice) = N_Range then
+            Choice_Val ('R', Low_Bound (Choice));
+            Choice_Val ('T', High_Bound (Choice));
+
+         elsif Is_Entity_Name (Choice)
+           and then Is_Type (Entity (Choice))
+         then
+            Choice_Val ('R', Type_Low_Bound (Entity (Choice)));
+            Choice_Val ('T', Type_High_Bound (Entity (Choice)));
+
+         elsif Nkind (Choice) = N_Subtype_Indication then
+            declare
+               Rang : constant Node_Id :=
+                        Range_Expression (Constraint (Choice));
+            begin
+               Choice_Val ('R', Low_Bound (Rang));
+               Choice_Val ('T', High_Bound (Rang));
+            end;
+
+         else
+            Choice_Val ('S', Choice);
+         end if;
+
+         Next (Choice);
+      end loop;
+
+      Name_Buffer (Name_Len + 1) := ASCII.NUL;
+
+      if Debug_Flag_B then
+         declare
+            VP : constant Node_Id := Parent (V);    -- Variant_Part
+            CL : constant Node_Id := Parent (VP);   -- Component_List
+            RD : constant Node_Id := Parent (CL);   -- Record_Definition
+            FT : constant Node_Id := Parent (RD);   -- Full_Type_Declaration
+
+         begin
+            Write_Str ("**** variant for type ");
+            Write_Name (Chars (Defining_Identifier (FT)));
+            Write_Str (" is encoded as ");
+            Write_Str (Name_Buffer (1 .. Name_Len));
+            Write_Eol;
+         end;
+      end if;
+   end Get_Variant_Encoding;
+
+   ---------------------------------
+   -- Make_Packed_Array_Type_Name --
+   ---------------------------------
+
+   function Make_Packed_Array_Type_Name
+     (Typ   : Entity_Id;
+      Csize : Uint)
+      return  Name_Id
+   is
+   begin
+      Get_Name_String (Chars (Typ));
+      Add_Str_To_Name_Buffer ("___XP");
+      Add_Uint_To_Buffer (Csize);
+      return Name_Find;
+   end Make_Packed_Array_Type_Name;
+
+   ------------------------------
+   -- Prepend_String_To_Buffer --
+   ------------------------------
+
+   procedure Prepend_String_To_Buffer (S : String) is
+      N : constant Integer := S'Length;
+
+   begin
+      Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len);
+      Name_Buffer (1 .. N) := S;
+      Name_Len := Name_Len + N;
+   end Prepend_String_To_Buffer;
+
+   ----------------------------
+   -- Prepend_Uint_To_Buffer --
+   ----------------------------
+
+   procedure Prepend_Uint_To_Buffer (U : Uint) is
+   begin
+      if U < 0 then
+         Prepend_String_To_Buffer ("m");
+         Prepend_Uint_To_Buffer (-U);
+      else
+         UI_Image (U, Decimal);
+         Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
+      end if;
+   end Prepend_Uint_To_Buffer;
+
+   -------------
+   -- Put_Hex --
+   -------------
+
+   procedure Put_Hex (W : Word; N : Natural) is
+      Hex : constant array (Word range 0 .. 15) of Character :=
+              "0123456789abcdef";
+
+      Cod : Word;
+
+   begin
+      Cod := W;
+      for J in reverse N .. N + 7 loop
+         Name_Buffer (J) := Hex (Cod and 16#F#);
+         Cod := Cod / 16;
+      end loop;
+   end Put_Hex;
+
+   ------------------------------
+   -- Qualify_All_Entity_Names --
+   ------------------------------
+
+   procedure Qualify_All_Entity_Names is
+      E   : Entity_Id;
+      Ent : Entity_Id;
+
+   begin
+      for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
+         E := Defining_Entity (Name_Qualify_Units.Table (J));
+         Qualify_Entity_Name (E);
+
+         Ent := First_Entity (E);
+         while Present (Ent) loop
+            Qualify_Entity_Name (Ent);
+            Next_Entity (Ent);
+
+            --  There are odd cases where Last_Entity (E) = E. This happens
+            --  in the case of renaming of packages. This test avoids getting
+            --  stuck in such cases.
+
+            exit when Ent = E;
+         end loop;
+      end loop;
+
+      --  Second loop compresses any names that need compressing
+
+      for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
+         E := Defining_Entity (Name_Qualify_Units.Table (J));
+         Compress_Debug_Name (E);
+
+         Ent := First_Entity (E);
+         while Present (Ent) loop
+            Compress_Debug_Name (Ent);
+            Next_Entity (Ent);
+            exit when Ent = E;
+         end loop;
+      end loop;
+   end Qualify_All_Entity_Names;
+
+   -------------------------
+   -- Qualify_Entity_Name --
+   -------------------------
+
+   procedure Qualify_Entity_Name (Ent : Entity_Id) is
+
+      Full_Qualify_Name : String (1 .. Name_Buffer'Length);
+      Full_Qualify_Len  : Natural := 0;
+      --  Used to accumulate fully qualified name of subprogram
+
+      procedure Fully_Qualify_Name (E : Entity_Id);
+      --  Used to qualify a subprogram or type name, where full
+      --  qualification up to Standard is always used. Name is set
+      --  in Full_Qualify_Name with the length in Full_Qualify_Len.
+      --  Note that this routine does not prepend the _ada_ string
+      --  required for library subprograms (this is done in the back end).
+
+      function Is_BNPE (S : Entity_Id) return Boolean;
+      --  Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
+      --  is defined to be a package which is immediately nested within a
+      --  package body.
+
+      function Qualify_Needed (S : Entity_Id) return Boolean;
+      --  Given a scope, determines if the scope is to be included in the
+      --  fully qualified name, True if so, False if not.
+
+      procedure Set_BNPE_Suffix (E : Entity_Id);
+      --  Recursive routine to append the BNPE qualification suffix. Works
+      --  from right to left with E being the current entity in the list.
+      --  The result does NOT have the trailing n's and trailing b stripped.
+      --  The caller must do this required stripping.
+
+      procedure Set_Entity_Name (E : Entity_Id);
+      --  Internal recursive routine that does most of the work. This routine
+      --  leaves the result sitting in Name_Buffer and Name_Len.
+
+      BNPE_Suffix_Needed : Boolean := False;
+      --  Set true if a body-nested package entity suffix is required
+
+      Save_Chars : constant Name_Id := Chars (Ent);
+      --  Save original name
+
+      ------------------------
+      -- Fully_Qualify_Name --
+      ------------------------
+
+      procedure Fully_Qualify_Name (E : Entity_Id) is
+         Discard : Boolean := False;
+
+      begin
+         --  If this we are qualifying entities local to a generic
+         --  instance, use the name of the original instantiation,
+         --  not that of the anonymous subprogram in the wrapper
+         --  package, so that gdb doesn't have to know about these.
+
+         if Is_Generic_Instance (E)
+           and then Is_Subprogram (E)
+           and then not Comes_From_Source (E)
+           and then not Is_Compilation_Unit (Scope (E))
+         then
+            Fully_Qualify_Name (Related_Instance (Scope (E)));
+            return;
+         end if;
+
+         --  If we reached fully qualified name, then just copy it
+
+         if Has_Fully_Qualified_Name (E) then
+            Get_Name_String (Chars (E));
+            Strip_BNPE_Suffix (Discard);
+            Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+            Full_Qualify_Len := Name_Len;
+            Set_Has_Fully_Qualified_Name (Ent);
+
+         --  Case of non-fully qualified name
+
+         else
+            if Scope (E) = Standard_Standard then
+               Set_Has_Fully_Qualified_Name (Ent);
+            else
+               Fully_Qualify_Name (Scope (E));
+               Full_Qualify_Name (Full_Qualify_Len + 1) := '_';
+               Full_Qualify_Name (Full_Qualify_Len + 2) := '_';
+               Full_Qualify_Len := Full_Qualify_Len + 2;
+            end if;
+
+            if Has_Qualified_Name (E) then
+               Get_Unqualified_Name_String (Chars (E));
+            else
+               Get_Name_String (Chars (E));
+            end if;
+
+            Full_Qualify_Name
+              (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) :=
+                Name_Buffer (1 .. Name_Len);
+            Full_Qualify_Len := Full_Qualify_Len + Name_Len;
+         end if;
+
+         if Is_BNPE (E) then
+            BNPE_Suffix_Needed := True;
+         end if;
+      end Fully_Qualify_Name;
+
+      -------------
+      -- Is_BNPE --
+      -------------
+
+      function Is_BNPE (S : Entity_Id) return Boolean is
+      begin
+         return
+           Ekind (S) = E_Package
+             and then Is_Package_Body_Entity (S);
+      end Is_BNPE;
+
+      --------------------
+      -- Qualify_Needed --
+      --------------------
+
+      function Qualify_Needed (S : Entity_Id) return Boolean is
+      begin
+         --  If we got all the way to Standard, then we have certainly
+         --  fully qualified the name, so set the flag appropriately,
+         --  and then return False, since we are most certainly done!
+
+         if S = Standard_Standard then
+            Set_Has_Fully_Qualified_Name (Ent, True);
+            return False;
+
+         --  Otherwise figure out if further qualification is required
+
+         else
+            return
+              Is_Subprogram (Ent)
+                or else
+              Ekind (Ent) = E_Subprogram_Body
+                or else
+                  (Ekind (S) /= E_Block
+                    and then not Is_Dynamic_Scope (S));
+         end if;
+      end Qualify_Needed;
+
+      ---------------------
+      -- Set_BNPE_Suffix --
+      ---------------------
+
+      procedure Set_BNPE_Suffix (E : Entity_Id) is
+         S : constant Entity_Id := Scope (E);
+
+      begin
+         if Qualify_Needed (S) then
+            Set_BNPE_Suffix (S);
+
+            if Is_BNPE (E) then
+               Add_Char_To_Name_Buffer ('b');
+            else
+               Add_Char_To_Name_Buffer ('n');
+            end if;
+
+         else
+            Add_Char_To_Name_Buffer ('X');
+         end if;
+
+      end Set_BNPE_Suffix;
+
+      ---------------------
+      -- Set_Entity_Name --
+      ---------------------
+
+      procedure Set_Entity_Name (E : Entity_Id) is
+         S : constant Entity_Id := Scope (E);
+
+      begin
+         --  If we reach an already qualified name, just take the encoding
+         --  except that we strip the package body suffixes, since these
+         --  will be separately put on later.
+
+         if Has_Qualified_Name (E) then
+            Get_Name_String_And_Append (Chars (E));
+            Strip_BNPE_Suffix (BNPE_Suffix_Needed);
+
+            --  If the top level name we are adding is itself fully
+            --  qualified, then that means that the name that we are
+            --  preparing for the Fully_Qualify_Name call will also
+            --  generate a fully qualified name.
+
+            if Has_Fully_Qualified_Name (E) then
+               Set_Has_Fully_Qualified_Name (Ent);
+            end if;
+
+         --  Case where upper level name is not encoded yet
+
+         else
+            --  Recurse if further qualification required
+
+            if Qualify_Needed (S) then
+               Set_Entity_Name (S);
+               Add_Str_To_Name_Buffer ("__");
+            end if;
+
+            --  Otherwise get name and note if it is a NPBE
+
+            Get_Name_String_And_Append (Chars (E));
+
+            if Is_BNPE (E) then
+               BNPE_Suffix_Needed := True;
+            end if;
+         end if;
+      end Set_Entity_Name;
+
+   --  Start of processing for Qualify_Entity_Name
+
+   begin
+      if Has_Qualified_Name (Ent) then
+         return;
+
+      --  Here is where we create the proper link for renaming
+
+      elsif Ekind (Ent) = E_Enumeration_Literal
+        and then Present (Debug_Renaming_Link (Ent))
+      then
+         Set_Entity_Name (Debug_Renaming_Link (Ent));
+         Get_Name_String (Chars (Ent));
+         Prepend_String_To_Buffer
+           (Get_Name_String (Chars (Debug_Renaming_Link (Ent))));
+         Set_Chars (Ent, Name_Enter);
+         Set_Has_Qualified_Name (Ent);
+         return;
+
+      elsif Is_Subprogram (Ent)
+        or else Ekind (Ent) = E_Subprogram_Body
+        or else Is_Type (Ent)
+      then
+         Fully_Qualify_Name (Ent);
+         Name_Len := Full_Qualify_Len;
+         Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
+
+      elsif Qualify_Needed (Scope (Ent)) then
+         Name_Len := 0;
+         Set_Entity_Name (Ent);
+
+      else
+         Set_Has_Qualified_Name (Ent);
+         return;
+      end if;
+
+      --  Fall through with a fully qualified name in Name_Buffer/Name_Len
+
+      --  Add body-nested package suffix if required
+
+      if BNPE_Suffix_Needed
+        and then Ekind (Ent) /= E_Enumeration_Literal
+      then
+         Set_BNPE_Suffix (Ent);
+
+         --  Strip trailing n's and last trailing b as required. note that
+         --  we know there is at least one b, or no suffix would be generated.
+
+         while Name_Buffer (Name_Len) = 'n' loop
+            Name_Len := Name_Len - 1;
+         end loop;
+
+         Name_Len := Name_Len - 1;
+      end if;
+
+      Set_Chars (Ent, Name_Enter);
+      Set_Has_Qualified_Name (Ent);
+
+      if Debug_Flag_BB then
+         Write_Str ("*** ");
+         Write_Name (Save_Chars);
+         Write_Str (" qualified as ");
+         Write_Name (Chars (Ent));
+         Write_Eol;
+      end if;
+   end Qualify_Entity_Name;
+
+   --------------------------
+   -- Qualify_Entity_Names --
+   --------------------------
+
+   procedure Qualify_Entity_Names (N : Node_Id) is
+   begin
+      Name_Qualify_Units.Append (N);
+   end Qualify_Entity_Names;
+
+   --------------------------------
+   -- Save_Unitname_And_Use_List --
+   --------------------------------
+
+   procedure Save_Unitname_And_Use_List
+     (Main_Unit_Node : Node_Id;
+      Main_Kind      : Node_Kind)
+   is
+      INITIAL_NAME_LENGTH : constant := 1024;
+
+      Item       : Node_Id;
+      Pack_Name  : Node_Id;
+
+      Unit_Spec  : Node_Id := 0;
+      Unit_Body  : Node_Id := 0;
+
+      Main_Name : String_Id;
+      --  Fully qualified name of Main Unit
+
+      Unit_Name : String_Id;
+      --  Name of unit specified in a Use clause
+
+      Spec_Unit_Index : Source_File_Index;
+      Spec_File_Name  : File_Name_Type := No_File;
+
+      Body_Unit_Index : Source_File_Index;
+      Body_File_Name : File_Name_Type := No_File;
+
+      type String_Ptr is access all String;
+
+      Spec_File_Name_Str : String_Ptr;
+      Body_File_Name_Str : String_Ptr;
+
+      type Label is record
+        Label_Name  : String_Ptr;
+        Name_Length : Integer;
+        Pos         : Integer;
+      end record;
+
+      Spec_Label : Label;
+      Body_Label : Label;
+
+      procedure Initialize  (L : out Label);
+      --  Initialize label
+
+      procedure Append      (L : in out Label; Ch : Character);
+      --  Append character to label
+
+      procedure Append      (L : in out Label; Str : String);
+      --  Append string to label
+
+      procedure Append_Name (L : in out Label; Unit_Name : String_Id);
+      --  Append name to label
+
+      function  Sufficient_Space
+        (L         : Label;
+         Unit_Name : String_Id)
+         return      Boolean;
+      --  Does sufficient space exist to append another name?
+
+      procedure Append (L : in out Label; Str : String) is
+      begin
+         L.Label_Name (L.Pos + 1 .. L.Pos + Str'Length) := Str;
+         L.Pos := L.Pos + Str'Length;
+      end Append;
+
+      procedure Append (L : in out Label; Ch : Character) is
+      begin
+         L.Pos := L.Pos + 1;
+         L.Label_Name (L.Pos) := Ch;
+      end Append;
+
+      procedure Append_Name (L : in out Label; Unit_Name : String_Id) is
+         Char         : Char_Code;
+         Upper_Offset : constant := Character'Pos ('a') - Character'Pos ('A');
+
+      begin
+         for J in 1 .. String_Length (Unit_Name) loop
+            Char := Get_String_Char (Unit_Name, J);
+
+            if Character'Val (Char) = '.' then
+               Append (L, "__");
+            elsif Character'Val (Char) in 'A' .. 'Z' then
+               Append (L, Character'Val (Char + Upper_Offset));
+            elsif Char /= 0 then
+               Append (L, Character'Val (Char));
+            end if;
+         end loop;
+      end Append_Name;
+
+      procedure Initialize (L : out Label) is
+      begin
+         L.Name_Length := INITIAL_NAME_LENGTH;
+         L.Pos := 0;
+         L.Label_Name := new String (1 .. L.Name_Length);
+      end Initialize;
+
+      function  Sufficient_Space
+        (L         : Label;
+         Unit_Name : String_Id)
+         return      Boolean
+      is
+         Len : Integer := Integer (String_Length (Unit_Name)) + 1;
+
+      begin
+         for J in 1 .. String_Length (Unit_Name) loop
+            if Character'Val (Get_String_Char (Unit_Name, J)) = '.' then
+               Len := Len + 1;
+            end if;
+         end loop;
+
+         return L.Pos + Len < L.Name_Length;
+      end Sufficient_Space;
+
+   --  Start of processing for Save_Unitname_And_Use_List
+
+   begin
+      Initialize (Spec_Label);
+      Initialize (Body_Label);
+
+      case Main_Kind is
+         when N_Package_Declaration =>
+            Main_Name := Full_Qualified_Name
+              (Defining_Unit_Name (Specification (Unit (Main_Unit_Node))));
+            Unit_Spec := Main_Unit_Node;
+            Append (Spec_Label, "_LPS__");
+            Append (Body_Label, "_LPB__");
+
+         when N_Package_Body =>
+            Unit_Spec := Corresponding_Spec (Unit (Main_Unit_Node));
+            Unit_Body := Main_Unit_Node;
+            Main_Name := Full_Qualified_Name (Unit_Spec);
+            Append (Spec_Label, "_LPS__");
+            Append (Body_Label, "_LPB__");
+
+         when N_Subprogram_Body =>
+            Unit_Body := Main_Unit_Node;
+
+            if Present (Corresponding_Spec (Unit (Main_Unit_Node))) then
+               Unit_Spec := Corresponding_Spec (Unit (Main_Unit_Node));
+               Main_Name := Full_Qualified_Name
+                 (Corresponding_Spec (Unit (Main_Unit_Node)));
+            else
+               Main_Name := Full_Qualified_Name
+                 (Defining_Unit_Name (Specification (Unit (Main_Unit_Node))));
+            end if;
+
+            Append (Spec_Label, "_LSS__");
+            Append (Body_Label, "_LSB__");
+
+         when others =>
+            return;
+      end case;
+
+      Append_Name (Spec_Label, Main_Name);
+      Append_Name (Body_Label, Main_Name);
+
+      --  If we have a body, process it first
+
+      if Present (Unit_Body) then
+
+         Item := First (Context_Items (Unit_Body));
+
+         while Present (Item) loop
+            if Nkind (Item) = N_Use_Package_Clause then
+               Pack_Name := First (Names (Item));
+               while Present (Pack_Name) loop
+                  Unit_Name := Full_Qualified_Name (Entity (Pack_Name));
+
+                  if Sufficient_Space (Body_Label, Unit_Name) then
+                     Append (Body_Label, '$');
+                     Append_Name (Body_Label, Unit_Name);
+                  end if;
+
+                  Pack_Name := Next (Pack_Name);
+               end loop;
+            end if;
+
+            Item := Next (Item);
+         end loop;
+      end if;
+
+      while Present (Unit_Spec) and then
+        Nkind (Unit_Spec) /= N_Compilation_Unit
+      loop
+         Unit_Spec := Parent (Unit_Spec);
+      end loop;
+
+      if Present (Unit_Spec) then
+
+         Item := First (Context_Items (Unit_Spec));
+
+         while Present (Item) loop
+            if Nkind (Item) = N_Use_Package_Clause then
+               Pack_Name := First (Names (Item));
+               while Present (Pack_Name) loop
+                  Unit_Name := Full_Qualified_Name (Entity (Pack_Name));
+
+                  if Sufficient_Space (Spec_Label, Unit_Name) then
+                     Append (Spec_Label, '$');
+                     Append_Name (Spec_Label, Unit_Name);
+                  end if;
+
+                  if Sufficient_Space (Body_Label, Unit_Name) then
+                     Append (Body_Label, '$');
+                     Append_Name (Body_Label, Unit_Name);
+                  end if;
+
+                  Pack_Name := Next (Pack_Name);
+               end loop;
+            end if;
+
+            Item := Next (Item);
+         end loop;
+      end if;
+
+      if Present (Unit_Spec) then
+         Append (Spec_Label, Character'Val (0));
+         Spec_Unit_Index := Source_Index (Get_Cunit_Unit_Number (Unit_Spec));
+         Spec_File_Name := Full_File_Name (Spec_Unit_Index);
+         Get_Name_String (Spec_File_Name);
+         Spec_File_Name_Str := new String (1 .. Name_Len + 1);
+         Spec_File_Name_Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+         Spec_File_Name_Str (Name_Len + 1) := Character'Val (0);
+         Spec_Filename := Spec_File_Name_Str (1)'Unrestricted_Access;
+         Spec_Context_List :=
+           Spec_Label.Label_Name.all (1)'Unrestricted_Access;
+      end if;
+
+      if Present (Unit_Body) then
+         Append (Body_Label, Character'Val (0));
+         Body_Unit_Index := Source_Index (Get_Cunit_Unit_Number (Unit_Body));
+         Body_File_Name := Full_File_Name (Body_Unit_Index);
+         Get_Name_String (Body_File_Name);
+         Body_File_Name_Str := new String (1 .. Name_Len + 1);
+         Body_File_Name_Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+         Body_File_Name_Str (Name_Len + 1) := Character'Val (0);
+         Body_Filename := Body_File_Name_Str (1)'Unrestricted_Access;
+         Body_Context_List :=
+           Body_Label.Label_Name.all (1)'Unrestricted_Access;
+      end if;
+
+   end Save_Unitname_And_Use_List;
+
+   ---------
+   -- SEq --
+   ---------
+
+   function SEq (F1, F2 : String_Ptr) return Boolean is
+   begin
+      return F1.all = F2.all;
+   end SEq;
+
+   -----------
+   -- SHash --
+   -----------
+
+   function SHash (S : String_Ptr) return Hindex is
+   begin
+      return Hindex
+        (Hindex'First + Hindex (CDN_Hash (S.all) mod Hindex'Range_Length));
+   end SHash;
+
+   -----------------------
+   -- Strip_BNPE_Suffix --
+   -----------------------
+
+   procedure Strip_BNPE_Suffix (Suffix_Found : in out Boolean) is
+   begin
+      for J in reverse 2 .. Name_Len loop
+         if Name_Buffer (J) = 'X' then
+            Name_Len := J - 1;
+            Suffix_Found := True;
+            exit;
+         end if;
+
+         exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n';
+      end loop;
+   end Strip_BNPE_Suffix;
+
+end Exp_Dbug;