path: root/gcc/ada/exp_dbug.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             E X P _ D B U G                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision$
--                                                                          --
--          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_Len >= 3 and then
                   Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR")

        or else (Name_Len >= 4 and then
                   (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;