gcc/ada/exp_dbug.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ D B U G                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1996-2002 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Alloc;    use Alloc;
  28 with Atree;    use Atree;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Exp_Util; use Exp_Util;
  32 with Freeze;   use Freeze;
  33 with Lib;      use Lib;
  34 with Hostparm; use Hostparm;
  35 with Namet;    use Namet;
  36 with Nlists;   use Nlists;
  37 with Nmake;    use Nmake;
  38 with Opt;      use Opt;
  39 with Output;   use Output;
  40 with Sem_Eval; use Sem_Eval;
  41 with Sem_Util; use Sem_Util;
  42 with Sinfo;    use Sinfo;
  43 with Snames;   use Snames;
  44 with Stand;    use Stand;
  45 with Stringt;  use Stringt;
  46 with Table;
  47 with Urealp;   use Urealp;
  48
  49 with GNAT.HTable;
  50
  51 package body Exp_Dbug is
  52
  53    --  The following table is used to queue up the entities passed as
  54    --  arguments to Qualify_Entity_Names for later processing when
  55    --  Qualify_All_Entity_Names is called.
  56
  57    package Name_Qualify_Units is new Table.Table (
  58      Table_Component_Type => Node_Id,
  59      Table_Index_Type     => Nat,
  60      Table_Low_Bound      => 1,
  61      Table_Initial        => Alloc.Name_Qualify_Units_Initial,
  62      Table_Increment      => Alloc.Name_Qualify_Units_Increment,
  63      Table_Name           => "Name_Qualify_Units");
  64
  65    --  Define hash table for compressed debug names
  66
  67    --  This hash table keeps track of qualification prefix strings
  68    --  that have been compressed. The element is the corresponding
  69    --  hash value used in the compressed symbol.
  70
  71    type Hindex is range 0 .. 4096;
  72    --  Type to define range of headers
  73
  74    function SHash (S : String_Ptr) return Hindex;
  75    --  Hash function for this table
  76
  77    function SEq (F1, F2 : String_Ptr) return Boolean;
  78    --  Equality function for this table
  79
  80    type Elmt is record
  81       W : Word;
  82       S : String_Ptr;
  83    end record;
  84
  85    No_Elmt : Elmt := (0, null);
  86
  87    package CDN is new GNAT.HTable.Simple_HTable (
  88      Header_Num => Hindex,
  89      Element    => Elmt,
  90      No_Element => No_Elmt,
  91      Key        => String_Ptr,
  92      Hash       => SHash,
  93      Equal      => SEq);
  94
  95    --------------------------------
  96    -- Use of Qualification Flags --
  97    --------------------------------
  98
  99    --  There are two flags used to keep track of qualification of entities
 100
 101    --    Has_Fully_Qualified_Name
 102    --    Has_Qualified_Name
 103
 104    --  The difference between these is as follows. Has_Qualified_Name is
 105    --  set to indicate that the name has been qualified as required by the
 106    --  spec of this package. As described there, this may involve the full
 107    --  qualification for the name, but for some entities, notably procedure
 108    --  local variables, this full qualification is not required.
 109
 110    --  The flag Has_Fully_Qualified_Name is set if indeed the name has been
 111    --  fully qualified in the Ada sense. If Has_Fully_Qualified_Name is set,
 112    --  then Has_Qualified_Name is also set, but the other way round is not
 113    --  the case.
 114
 115    --  Consider the following example:
 116
 117    --     with ...
 118    --     procedure X is
 119    --       B : Ddd.Ttt;
 120    --       procedure Y is ..
 121
 122    --  Here B is a procedure local variable, so it does not need fully
 123    --  qualification. The flag Has_Qualified_Name will be set on the
 124    --  first attempt to qualify B, to indicate that the job is done
 125    --  and need not be redone.
 126
 127    --  But Y is qualified as x__y, since procedures are always fully
 128    --  qualified, so the first time that an attempt is made to qualify
 129    --  the name y, it will be replaced by x__y, and both flags are set.
 130
 131    --  Why the two flags? Well there are cases where we derive type names
 132    --  from object names. As noted in the spec, type names are always
 133    --  fully qualified. Suppose for example that the backend has to build
 134    --  a padded type for variable B. then it will construct the PAD name
 135    --  from B, but it requires full qualification, so the fully qualified
 136    --  type name will be x__b___PAD. The two flags allow the circuit for
 137    --  building this name to realize efficiently that b needs further
 138    --  qualification.
 139
 140    --------------------
 141    -- Homonym_Suffix --
 142    --------------------
 143
 144    --  The string defined here (and its associated length) is used to
 145    --  gather the homonym string that will be appended to Name_Buffer
 146    --  when the name is complete. Strip_Suffixes appends to this string
 147    --  as does Append_Homonym_Number, and Output_Homonym_Numbers_Suffix
 148    --  appends the string to the end of Name_Buffer.
 149
 150    Homonym_Numbers : String (1 .. 256);
 151    Homonym_Len     : Natural := 0;
 152
 153    ----------------------
 154    -- Local Procedures --
 155    ----------------------
 156
 157    procedure Add_Uint_To_Buffer (U : Uint);
 158    --  Add image of universal integer to Name_Buffer, updating Name_Len
 159
 160    procedure Add_Real_To_Buffer (U : Ureal);
 161    --  Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of
 162    --  the normalized numerator and denominator of the given real value.
 163
 164    procedure Append_Homonym_Number (E : Entity_Id);
 165    --  If the entity E has homonyms in the same scope, then make an entry
 166    --  in the Homonym_Numbers array, bumping Homonym_Count accordingly.
 167
 168    function Bounds_Match_Size (E : Entity_Id) return  Boolean;
 169    --  Determine whether the bounds of E match the size of the type. This is
 170    --  used to determine whether encoding is required for a discrete type.
 171
 172    function CDN_Hash (S : String) return Word;
 173    --  This is the hash function used to compress debug symbols. The string
 174    --  S is the prefix which is a list of qualified names separated by double
 175    --  underscore (no trailing double underscore). The returned value is the
 176    --  hash value used in the compressed names. It is also used for the hash
 177    --  table used to keep track of what prefixes have been compressed so far.
 178
 179    procedure Compress_Debug_Name (E : Entity_Id);
 180    --  If the name of the entity E is too long, or compression is to be
 181    --  attempted on all names (Compress_Debug_Names set), then an attempt
 182    --  is made to compress the name of the entity.
 183
 184    function Double_Underscore (S : String; J : Natural) return Boolean;
 185    --  Returns True if J is the start of a double underscore
 186    --  sequence in the string S (defined as two underscores
 187    --  which are preceded and followed by a non-underscore)
 188
 189    procedure Output_Homonym_Numbers_Suffix;
 190    --  If homonym numbers are stored, then output them into Name_Buffer.
 191
 192    procedure Prepend_String_To_Buffer (S : String);
 193    --  Prepend given string to the contents of the string buffer, updating
 194    --  the value in Name_Len (i.e. string is added at start of buffer).
 195
 196    procedure Prepend_Uint_To_Buffer (U : Uint);
 197    --  Prepend image of universal integer to Name_Buffer, updating Name_Len
 198
 199    procedure Put_Hex (W : Word; N : Natural);
 200    --  Output W as 8 hex digits (0-9, a-f) in Name_Buffer (N .. N + 7)
 201
 202    procedure Qualify_Entity_Name (Ent : Entity_Id);
 203    --  If not already done, replaces the Chars field of the given entity
 204    --  with the appropriate fully qualified name.
 205
 206    procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean);
 207    --  Given an qualified entity name in Name_Buffer, remove any plain X or
 208    --  X{nb} qualification suffix. The contents of Name_Buffer is not changed
 209    --  but Name_Len may be adjusted on return to remove the suffix. If a
 210    --  BNPE suffix is found and stripped, then BNPE_Suffix_Found is set to
 211    --  True. If no suffix is found, then BNPE_Suffix_Found is not modified.
 212    --  This routine also searches for a homonym suffix, and if one is found
 213    --  it is also stripped, and the entries are added to the global homonym
 214    --  list (Homonym_Numbers) so that they can later be put back.
 215
 216    ------------------------
 217    -- Add_Real_To_Buffer --
 218    ------------------------
 219
 220    procedure Add_Real_To_Buffer (U : Ureal) is
 221    begin
 222       Add_Uint_To_Buffer (Norm_Num (U));
 223       Add_Str_To_Name_Buffer ("_");
 224       Add_Uint_To_Buffer (Norm_Den (U));
 225    end Add_Real_To_Buffer;
 226
 227    ------------------------
 228    -- Add_Uint_To_Buffer --
 229    ------------------------
 230
 231    procedure Add_Uint_To_Buffer (U : Uint) is
 232    begin
 233       if U < 0 then
 234          Add_Uint_To_Buffer (-U);
 235          Add_Char_To_Name_Buffer ('m');
 236       else
 237          UI_Image (U, Decimal);
 238          Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
 239       end if;
 240    end Add_Uint_To_Buffer;
 241
 242    ---------------------------
 243    -- Append_Homonym_Number --
 244    ---------------------------
 245
 246    procedure Append_Homonym_Number (E : Entity_Id) is
 247
 248       procedure Add_Nat_To_H (Nr : Nat);
 249       --  Little procedure to append Nr to Homonym_Numbers
 250
 251       ------------------
 252       -- Add_Nat_To_H --
 253       ------------------
 254
 255       procedure Add_Nat_To_H (Nr : Nat) is
 256       begin
 257          if Nr >= 10 then
 258             Add_Nat_To_H (Nr / 10);
 259          end if;
 260
 261          Homonym_Len := Homonym_Len + 1;
 262          Homonym_Numbers (Homonym_Len) :=
 263            Character'Val (Nr mod 10 + Character'Pos ('0'));
 264       end Add_Nat_To_H;
 265
 266    --  Start of processing for Append_Homonym_Number
 267
 268    begin
 269       if Has_Homonym (E) then
 270          declare
 271             H  : Entity_Id := Homonym (E);
 272             Nr : Nat := 1;
 273
 274          begin
 275             while Present (H) loop
 276                if (Scope (H) = Scope (E)) then
 277                   Nr := Nr + 1;
 278                end if;
 279
 280                H := Homonym (H);
 281             end loop;
 282
 283             if Homonym_Len > 0 then
 284                Homonym_Len := Homonym_Len + 1;
 285                Homonym_Numbers (Homonym_Len) := '_';
 286             end if;
 287
 288             Add_Nat_To_H (Nr);
 289          end;
 290       end if;
 291    end Append_Homonym_Number;
 292
 293    -----------------------
 294    -- Bounds_Match_Size --
 295    -----------------------
 296
 297    function Bounds_Match_Size (E : Entity_Id) return Boolean is
 298       Siz : Uint;
 299
 300    begin
 301       if not Is_OK_Static_Subtype (E) then
 302          return False;
 303
 304       elsif Is_Integer_Type (E)
 305         and then Subtypes_Statically_Match (E, Base_Type (E))
 306       then
 307          return True;
 308
 309       --  Here we check if the static bounds match the natural size, which
 310       --  is the size passed through with the debugging information. This
 311       --  is the Esize rounded up to 8, 16, 32 or 64 as appropriate.
 312
 313       else
 314          declare
 315             Umark  : constant Uintp.Save_Mark := Uintp.Mark;
 316             Result : Boolean;
 317
 318          begin
 319             if Esize (E) <= 8 then
 320                Siz := Uint_8;
 321             elsif Esize (E) <= 16 then
 322                Siz := Uint_16;
 323             elsif Esize (E) <= 32 then
 324                Siz := Uint_32;
 325             else
 326                Siz := Uint_64;
 327             end if;
 328
 329             if Is_Modular_Integer_Type (E) or else Is_Enumeration_Type (E) then
 330                Result :=
 331                  Expr_Rep_Value (Type_Low_Bound (E)) = 0
 332                    and then
 333                  2 ** Siz - Expr_Rep_Value (Type_High_Bound (E)) = 1;
 334
 335             else
 336                Result :=
 337                  Expr_Rep_Value (Type_Low_Bound (E)) + 2 ** (Siz - 1) = 0
 338                    and then
 339                  2 ** (Siz - 1) - Expr_Rep_Value (Type_High_Bound (E)) = 1;
 340             end if;
 341
 342             Release (Umark);
 343             return Result;
 344          end;
 345       end if;
 346    end Bounds_Match_Size;
 347
 348    --------------
 349    -- CDN_Hash --
 350    --------------
 351
 352    function CDN_Hash (S : String) return Word is
 353       H : Word;
 354
 355       function Rotate_Left (Value : Word; Amount : Natural) return Word;
 356       pragma Import (Intrinsic, Rotate_Left);
 357
 358    begin
 359       H := 0;
 360       for J in S'Range loop
 361          H := Rotate_Left (H, 3) + Character'Pos (S (J));
 362       end loop;
 363
 364       return H;
 365    end CDN_Hash;
 366
 367    -------------------------
 368    -- Compress_Debug_Name --
 369    -------------------------
 370
 371    procedure Compress_Debug_Name (E : Entity_Id) is
 372       Ptr  : Natural;
 373       Sptr : String_Ptr;
 374       Cod  : Word;
 375
 376    begin
 377       if not Compress_Debug_Names
 378         and then Length_Of_Name (Chars (E)) <= Max_Debug_Name_Length
 379       then
 380          return;
 381       end if;
 382
 383       Get_Name_String (Chars (E));
 384
 385       --  Find rightmost double underscore
 386
 387       Ptr := Name_Len - 2;
 388       loop
 389          exit when Double_Underscore (Name_Buffer, Ptr);
 390
 391          --  Cannot compress if no double underscore anywhere
 392
 393          if Ptr < 2 then
 394             return;
 395          end if;
 396
 397          Ptr := Ptr  - 1;
 398       end loop;
 399
 400       --  At this stage we have
 401
 402       --    Name_Buffer (1 .. Ptr - 1)         string to compress
 403       --    Name_Buffer (Ptr)                  underscore
 404       --    Name_Buffer (Ptr + 1)              underscore
 405       --    Name_Buffer (Ptr + 2 .. Name_Len)  simple name to retain
 406
 407       --  See if we already have an entry for the compression string
 408
 409       --  No point in compressing if it does not make things shorter
 410
 411       if Name_Len <= (2 + 8 + 1) + (Name_Len - (Ptr + 1)) then
 412          return;
 413       end if;
 414
 415       --  Do not compress any reference to entity in internal file
 416
 417       if Name_Buffer (1 .. 5) = "ada__"
 418            or else
 419          Name_Buffer (1 .. 8) = "system__"
 420            or else
 421          Name_Buffer (1 .. 6) = "gnat__"
 422            or else
 423          Name_Buffer (1 .. 12) = "interfaces__"
 424            or else
 425              (OpenVMS and then Name_Buffer (1 .. 5) = "dec__")
 426       then
 427          return;
 428       end if;
 429
 430       Sptr := Name_Buffer (1 .. Ptr - 1)'Unrestricted_Access;
 431       Cod := CDN.Get (Sptr).W;
 432
 433       if Cod = 0 then
 434          Cod := CDN_Hash (Sptr.all);
 435          Sptr := new String'(Sptr.all);
 436          CDN.Set (Sptr, (Cod, Sptr));
 437       end if;
 438
 439       Name_Buffer (1) := 'X';
 440       Name_Buffer (2) := 'C';
 441       Put_Hex (Cod, 3);
 442       Name_Buffer (11) := '_';
 443       Name_Buffer (12 .. Name_Len - Ptr + 10) :=
 444         Name_Buffer (Ptr + 2 .. Name_Len);
 445       Name_Len := Name_Len - Ptr + 10;
 446
 447       Set_Chars (E, Name_Enter);
 448    end Compress_Debug_Name;
 449
 450    --------------------------------
 451    -- Debug_Renaming_Declaration --
 452    --------------------------------
 453
 454    function Debug_Renaming_Declaration (N : Node_Id) return Node_Id is
 455       Loc : constant Source_Ptr := Sloc (N);
 456       Ent : constant Node_Id    := Defining_Entity (N);
 457       Nam : constant Node_Id    := Name (N);
 458       Rnm : Name_Id;
 459       Ren : Node_Id;
 460       Lit : Entity_Id;
 461       Typ : Entity_Id;
 462       Res : Node_Id;
 463       Def : Entity_Id;
 464
 465       function Output_Subscript (N : Node_Id; S : String) return Boolean;
 466       --  Outputs a single subscript value as ?nnn (subscript is compile
 467       --  time known value with value nnn) or as ?e (subscript is local
 468       --  constant with name e), where S supplies the proper string to
 469       --  use for ?. Returns False if the subscript is not of an appropriate
 470       --  type to output in one of these two forms. The result is prepended
 471       --  to the name stored in Name_Buffer.
 472
 473       ----------------------
 474       -- Output_Subscript --
 475       ----------------------
 476
 477       function Output_Subscript (N : Node_Id; S : String) return Boolean is
 478       begin
 479          if Compile_Time_Known_Value (N) then
 480             Prepend_Uint_To_Buffer (Expr_Value (N));
 481
 482          elsif Nkind (N) = N_Identifier
 483            and then Scope (Entity (N)) = Scope (Ent)
 484            and then Ekind (Entity (N)) = E_Constant
 485          then
 486             Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N))));
 487
 488          else
 489             return False;
 490          end if;
 491
 492          Prepend_String_To_Buffer (S);
 493          return True;
 494       end Output_Subscript;
 495
 496    --  Start of processing for Debug_Renaming_Declaration
 497
 498    begin
 499       if not Comes_From_Source (N) then
 500          return Empty;
 501       end if;
 502
 503       --  Prepare entity name for type declaration
 504
 505       Get_Name_String (Chars (Ent));
 506
 507       case Nkind (N) is
 508          when N_Object_Renaming_Declaration =>
 509             Add_Str_To_Name_Buffer ("___XR");
 510
 511          when N_Exception_Renaming_Declaration =>
 512             Add_Str_To_Name_Buffer ("___XRE");
 513
 514          when N_Package_Renaming_Declaration =>
 515             Add_Str_To_Name_Buffer ("___XRP");
 516
 517          when others =>
 518             return Empty;
 519       end case;
 520
 521       Rnm := Name_Find;
 522
 523       --  Get renamed entity and compute suffix
 524
 525       Name_Len := 0;
 526       Ren := Nam;
 527       loop
 528          case Nkind (Ren) is
 529
 530             when N_Identifier =>
 531                exit;
 532
 533             when N_Expanded_Name =>
 534
 535                --  The entity field for an N_Expanded_Name is on the
 536                --  expanded name node itself, so we are done here too.
 537
 538                exit;
 539
 540             when N_Selected_Component =>
 541                Prepend_String_To_Buffer
 542                  (Get_Name_String (Chars (Selector_Name (Ren))));
 543                Prepend_String_To_Buffer ("XR");
 544                Ren := Prefix (Ren);
 545
 546             when N_Indexed_Component =>
 547                declare
 548                   X : Node_Id := Last (Expressions (Ren));
 549
 550                begin
 551                   while Present (X) loop
 552                      if not Output_Subscript (X, "XS") then
 553                         Set_Materialize_Entity (Ent);
 554                         return Empty;
 555                      end if;
 556
 557                      Prev (X);
 558                   end loop;
 559                end;
 560
 561                Ren := Prefix (Ren);
 562
 563             when N_Slice =>
 564
 565                Typ := Etype (First_Index (Etype (Nam)));
 566
 567                if not Output_Subscript (Type_High_Bound (Typ), "XS") then
 568                   Set_Materialize_Entity (Ent);
 569                   return Empty;
 570                end if;
 571
 572                if not Output_Subscript (Type_Low_Bound  (Typ), "XL") then
 573                   Set_Materialize_Entity (Ent);
 574                   return Empty;
 575                end if;
 576
 577                Ren := Prefix (Ren);
 578
 579             when N_Explicit_Dereference =>
 580                Prepend_String_To_Buffer ("XA");
 581                Ren := Prefix (Ren);
 582
 583             --  For now, anything else simply results in no translation
 584
 585             when others =>
 586                Set_Materialize_Entity (Ent);
 587                return Empty;
 588          end case;
 589       end loop;
 590
 591       Prepend_String_To_Buffer ("___XE");
 592
 593       --  For now, the literal name contains only the suffix. The Entity_Id
 594       --  value for the name is used to create a link from this literal name
 595       --  to the renamed entity using the Debug_Renaming_Link field. Then the
 596       --  Qualify_Entity_Name procedure uses this link to create the proper
 597       --  fully qualified name.
 598
 599       --  The reason we do things this way is that we really need to copy the
 600       --  qualification of the renamed entity, and it is really much easier to
 601       --  do this after the renamed entity has itself been fully qualified.
 602
 603       Lit := Make_Defining_Identifier (Loc, Chars => Name_Enter);
 604       Set_Debug_Renaming_Link (Lit, Entity (Ren));
 605
 606       --  Return the appropriate enumeration type
 607
 608       Def := Make_Defining_Identifier (Loc, Chars => Rnm);
 609       Res :=
 610         Make_Full_Type_Declaration (Loc,
 611           Defining_Identifier => Def,
 612           Type_Definition =>
 613             Make_Enumeration_Type_Definition (Loc,
 614               Literals => New_List (Lit)));
 615
 616       Set_Needs_Debug_Info (Def);
 617       Set_Needs_Debug_Info (Lit);
 618
 619       Set_Discard_Names (Defining_Identifier (Res));
 620       return Res;
 621
 622    --  If we get an exception, just figure it is a case that we cannot
 623    --  successfully handle using our current approach, since this is
 624    --  only for debugging, no need to take the compilation with us!
 625
 626    exception
 627       when others =>
 628          return Make_Null_Statement (Loc);
 629    end Debug_Renaming_Declaration;
 630
 631    -----------------------
 632    -- Double_Underscore --
 633    -----------------------
 634
 635    function Double_Underscore (S : String; J : Natural) return Boolean is
 636    begin
 637       if J = S'First or else J > S'Last - 2 then
 638          return False;
 639
 640       else
 641          return S (J) = '_'
 642            and then S (J + 1) = '_'
 643            and then S (J - 1) /= '_'
 644            and then S (J + 2) /= '_';
 645       end if;
 646    end Double_Underscore;
 647
 648    ------------------------------
 649    -- Generate_Auxiliary_Types --
 650    ------------------------------
 651
 652    --  Note: right now there is only one auxiliary type to be generated,
 653    --  namely the enumeration type for the compression sequences if used.
 654
 655    procedure Generate_Auxiliary_Types is
 656       Loc     : constant Source_Ptr := Sloc (Cunit (Current_Sem_Unit));
 657       E       : Elmt;
 658       Code    : Entity_Id;
 659       Lit     : Entity_Id;
 660       Start   : Natural;
 661       Ptr     : Natural;
 662       Discard : List_Id;
 663
 664       Literal_List : List_Id := New_List;
 665       --  Gathers the list of literals for the declaration
 666
 667       procedure Output_Literal;
 668       --  Adds suffix of form Xnnn to name in Name_Buffer, where nnn is
 669       --  a serial number that is one greater on each call, and then
 670       --  builds an enumeration literal and adds it to the literal list.
 671
 672       Serial : Nat := 0;
 673       --  Current serial number
 674
 675       procedure Output_Literal is
 676       begin
 677          Serial := Serial + 1;
 678          Add_Char_To_Name_Buffer ('X');
 679          Add_Nat_To_Name_Buffer (Serial);
 680
 681          Lit :=
 682            Make_Defining_Identifier (Loc,
 683              Chars => Name_Find);
 684          Set_Has_Qualified_Name (Lit, True);
 685          Append (Lit, Literal_List);
 686       end Output_Literal;
 687
 688    --  Start of processing for Auxiliary_Types
 689
 690    begin
 691       E := CDN.Get_First;
 692       if E.S /= null then
 693          while E.S /= null loop
 694
 695             --  We have E.S a String_Ptr that contains a string of the form:
 696
 697             --    b__c__d
 698
 699             --  In E.W is a 32-bit word representing the hash value
 700
 701             --  Our mission is to construct a type
 702
 703             --     type XChhhhhhhh is (b,c,d);
 704
 705             --  where hhhhhhhh is the 8 hex digits of the E.W value.
 706             --  and append this type declaration to the result list
 707
 708             Name_Buffer (1) := 'X';
 709             Name_Buffer (2) := 'C';
 710             Put_Hex (E.W, 3);
 711             Name_Len := 10;
 712             Output_Literal;
 713
 714             Start := E.S'First;
 715             Ptr   := E.S'First;
 716             while Ptr <= E.S'Last loop
 717                if Ptr = E.S'Last
 718                  or else Double_Underscore (E.S.all, Ptr + 1)
 719                then
 720                   Name_Len := Ptr - Start + 1;
 721                   Name_Buffer (1 .. Name_Len) := E.S (Start .. Ptr);
 722                   Output_Literal;
 723                   Start := Ptr + 3;
 724                   Ptr := Start;
 725                else
 726                   Ptr := Ptr + 1;
 727                end if;
 728             end loop;
 729
 730             E := CDN.Get_Next;
 731          end loop;
 732
 733          Name_Buffer (1) := 'X';
 734          Name_Buffer (2) := 'C';
 735          Name_Len := 2;
 736
 737          Code :=
 738            Make_Defining_Identifier (Loc,
 739              Chars => Name_Find);
 740          Set_Has_Qualified_Name (Code, True);
 741
 742          Insert_Library_Level_Action (
 743            Make_Full_Type_Declaration (Loc,
 744              Defining_Identifier => Code,
 745              Type_Definition =>
 746                Make_Enumeration_Type_Definition (Loc,
 747                  Literals => Literal_List)));
 748
 749          --  We have to manually freeze this entity, since it is inserted
 750          --  very late on into the tree, and otherwise will not be frozen.
 751          --  No freeze actions are generated, so we can discard the result.
 752
 753          Discard := Freeze_Entity (Code,  Loc);
 754       end if;
 755    end Generate_Auxiliary_Types;
 756
 757    ----------------------
 758    -- Get_Encoded_Name --
 759    ----------------------
 760
 761    --  Note: see spec for details on encodings
 762
 763    procedure Get_Encoded_Name (E : Entity_Id) is
 764       Has_Suffix : Boolean;
 765
 766    begin
 767       Get_Name_String (Chars (E));
 768
 769       --  Nothing to do if we do not have a type
 770
 771       if not Is_Type (E)
 772
 773       --  Or if this is an enumeration base type
 774
 775         or else (Is_Enumeration_Type (E)
 776                    and then E = Base_Type (E))
 777
 778       --  Or if this is a dummy type for a renaming
 779
 780         or else (Name_Len >= 3 and then
 781                    Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR")
 782
 783         or else (Name_Len >= 4 and then
 784                    (Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
 785                       or else
 786                     Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"))
 787
 788       --  For all these cases, just return the name unchanged
 789
 790       then
 791          Name_Buffer (Name_Len + 1) := ASCII.Nul;
 792          return;
 793       end if;
 794
 795       Has_Suffix := True;
 796
 797       --  Fixed-point case
 798
 799       if Is_Fixed_Point_Type (E) then
 800          Get_External_Name_With_Suffix (E, "XF_");
 801          Add_Real_To_Buffer (Delta_Value (E));
 802
 803          if Small_Value (E) /= Delta_Value (E) then
 804             Add_Str_To_Name_Buffer ("_");
 805             Add_Real_To_Buffer (Small_Value (E));
 806          end if;
 807
 808       --  Vax floating-point case
 809
 810       elsif Vax_Float (E) then
 811
 812          if Digits_Value (Base_Type (E)) = 6 then
 813             Get_External_Name_With_Suffix (E, "XFF");
 814
 815          elsif Digits_Value (Base_Type (E)) = 9 then
 816             Get_External_Name_With_Suffix (E, "XFF");
 817
 818          else
 819             pragma Assert (Digits_Value (Base_Type (E)) = 15);
 820             Get_External_Name_With_Suffix (E, "XFG");
 821          end if;
 822
 823       --  Discrete case where bounds do not match size
 824
 825       elsif Is_Discrete_Type (E)
 826         and then not Bounds_Match_Size (E)
 827       then
 828          if Has_Biased_Representation (E) then
 829             Get_External_Name_With_Suffix (E, "XB");
 830          else
 831             Get_External_Name_With_Suffix (E, "XD");
 832          end if;
 833
 834          declare
 835             Lo : constant Node_Id := Type_Low_Bound (E);
 836             Hi : constant Node_Id := Type_High_Bound (E);
 837
 838             Lo_Stat : constant Boolean := Is_OK_Static_Expression (Lo);
 839             Hi_Stat : constant Boolean := Is_OK_Static_Expression (Hi);
 840
 841             Lo_Discr : constant Boolean :=
 842                          Nkind (Lo) = N_Identifier
 843                            and then
 844                          Ekind (Entity (Lo)) = E_Discriminant;
 845
 846             Hi_Discr : constant Boolean :=
 847                          Nkind (Hi) = N_Identifier
 848                            and then
 849                          Ekind (Entity (Hi)) = E_Discriminant;
 850
 851             Lo_Encode : constant Boolean := Lo_Stat or Lo_Discr;
 852             Hi_Encode : constant Boolean := Hi_Stat or Hi_Discr;
 853
 854          begin
 855             if Lo_Encode or Hi_Encode then
 856                if Lo_Encode then
 857                   if Hi_Encode then
 858                      Add_Str_To_Name_Buffer ("LU_");
 859                   else
 860                      Add_Str_To_Name_Buffer ("L_");
 861                   end if;
 862                else
 863                   Add_Str_To_Name_Buffer ("U_");
 864                end if;
 865
 866                if Lo_Stat then
 867                   Add_Uint_To_Buffer (Expr_Rep_Value (Lo));
 868                elsif Lo_Discr then
 869                   Get_Name_String_And_Append (Chars (Entity (Lo)));
 870                end if;
 871
 872                if Lo_Encode and Hi_Encode then
 873                   Add_Str_To_Name_Buffer ("__");
 874                end if;
 875
 876                if Hi_Stat then
 877                   Add_Uint_To_Buffer (Expr_Rep_Value (Hi));
 878                elsif Hi_Discr then
 879                   Get_Name_String_And_Append (Chars (Entity (Hi)));
 880                end if;
 881             end if;
 882          end;
 883
 884       --  For all other cases, the encoded name is the normal type name
 885
 886       else
 887          Has_Suffix := False;
 888          Get_External_Name (E, Has_Suffix);
 889       end if;
 890
 891       if Debug_Flag_B and then Has_Suffix then
 892          Write_Str ("**** type ");
 893          Write_Name (Chars (E));
 894          Write_Str (" is encoded as ");
 895          Write_Str (Name_Buffer (1 .. Name_Len));
 896          Write_Eol;
 897       end if;
 898
 899       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 900    end Get_Encoded_Name;
 901
 902    -----------------------
 903    -- Get_External_Name --
 904    -----------------------
 905
 906    procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean)
 907    is
 908       E    : Entity_Id := Entity;
 909       Kind : Entity_Kind;
 910
 911       procedure Get_Qualified_Name_And_Append (Entity : Entity_Id);
 912       --  Appends fully qualified name of given entity to Name_Buffer
 913
 914       -----------------------------------
 915       -- Get_Qualified_Name_And_Append --
 916       -----------------------------------
 917
 918       procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is
 919       begin
 920          --  If the entity is a compilation unit, its scope is Standard,
 921          --  there is no outer scope, and the no further qualification
 922          --  is required.
 923
 924          --  If the front end has already computed a fully qualified name,
 925          --  then it is also the case that no further qualification is
 926          --  required
 927
 928          if Present (Scope (Scope (Entity)))
 929            and then not Has_Fully_Qualified_Name (Entity)
 930          then
 931             Get_Qualified_Name_And_Append (Scope (Entity));
 932             Add_Str_To_Name_Buffer ("__");
 933             Get_Name_String_And_Append (Chars (Entity));
 934             Append_Homonym_Number (Entity);
 935
 936          else
 937             Get_Name_String_And_Append (Chars (Entity));
 938          end if;
 939
 940       end Get_Qualified_Name_And_Append;
 941
 942    --  Start of processing for Get_External_Name
 943
 944    begin
 945       Name_Len := 0;
 946
 947       --  If this is a child unit, we want the child
 948
 949       if Nkind (E) = N_Defining_Program_Unit_Name then
 950          E := Defining_Identifier (Entity);
 951       end if;
 952
 953       Kind := Ekind (E);
 954
 955       --  Case of interface name being used
 956
 957       if (Kind = E_Procedure or else
 958           Kind = E_Function  or else
 959           Kind = E_Constant  or else
 960           Kind = E_Variable  or else
 961           Kind = E_Exception)
 962         and then Present (Interface_Name (E))
 963         and then No (Address_Clause (E))
 964         and then not Has_Suffix
 965       then
 966          --  The following code needs explanation ???
 967
 968          if Convention (E) = Convention_Stdcall
 969             and then Ekind (E) = E_Variable
 970          then
 971             Add_Str_To_Name_Buffer ("_imp__");
 972          end if;
 973
 974          Add_String_To_Name_Buffer (Strval (Interface_Name (E)));
 975
 976       --  All other cases besides the interface name case
 977
 978       else
 979          --  If this is a library level subprogram (i.e. a subprogram that is a
 980          --  compilation unit other than a subunit), then we prepend _ada_ to
 981          --  ensure distinctions required as described in the spec.
 982          --  Check explicitly for child units, because those are not flagged
 983          --  as Compilation_Units by lib. Should they be ???
 984
 985          if Is_Subprogram (E)
 986            and then (Is_Compilation_Unit (E) or Is_Child_Unit (E))
 987            and then not Has_Suffix
 988          then
 989             Add_Str_To_Name_Buffer ("_ada_");
 990          end if;
 991
 992          --  If the entity is a subprogram instance that is not a compilation
 993          --  unit, generate the name of the original Ada entity, which is the
 994          --  one gdb needs.
 995
 996          if Is_Generic_Instance (E)
 997            and then Is_Subprogram (E)
 998            and then not Is_Compilation_Unit (Scope (E))
 999          then
1000             E := Related_Instance (Scope (E));
1001          end if;
1002
1003          Get_Qualified_Name_And_Append (E);
1004       end if;
1005
1006       Name_Buffer (Name_Len + 1) := ASCII.Nul;
1007    end Get_External_Name;
1008
1009    -----------------------------------
1010    -- Get_External_Name_With_Suffix --
1011    -----------------------------------
1012
1013    procedure Get_External_Name_With_Suffix
1014      (Entity : Entity_Id;
1015       Suffix : String)
1016    is
1017       Has_Suffix : constant Boolean := (Suffix /= "");
1018    begin
1019       Get_External_Name (Entity, Has_Suffix);
1020
1021       if Has_Suffix then
1022          Add_Str_To_Name_Buffer ("___");
1023          Add_Str_To_Name_Buffer (Suffix);
1024
1025          Name_Buffer (Name_Len + 1) := ASCII.Nul;
1026       end if;
1027    end Get_External_Name_With_Suffix;
1028
1029    --------------------------
1030    -- Get_Variant_Encoding --
1031    --------------------------
1032
1033    procedure Get_Variant_Encoding (V : Node_Id) is
1034       Choice : Node_Id;
1035
1036       procedure Choice_Val (Typ : Character; Choice : Node_Id);
1037       --  Output encoded value for a single choice value. Typ is the key
1038       --  character ('S', 'F', or 'T') that precedes the choice value.
1039
1040       ----------------
1041       -- Choice_Val --
1042       ----------------
1043
1044       procedure Choice_Val (Typ : Character; Choice : Node_Id) is
1045       begin
1046          Add_Char_To_Name_Buffer (Typ);
1047
1048          if Nkind (Choice) = N_Integer_Literal then
1049             Add_Uint_To_Buffer (Intval (Choice));
1050
1051          --  Character literal with no entity present (this is the case
1052          --  Standard.Character or Standard.Wide_Character as root type)
1053
1054          elsif Nkind (Choice) = N_Character_Literal
1055            and then No (Entity (Choice))
1056          then
1057             Add_Uint_To_Buffer
1058               (UI_From_Int (Int (Char_Literal_Value (Choice))));
1059
1060          else
1061             declare
1062                Ent : constant Entity_Id := Entity (Choice);
1063
1064             begin
1065                if Ekind (Ent) = E_Enumeration_Literal then
1066                   Add_Uint_To_Buffer (Enumeration_Rep (Ent));
1067
1068                else
1069                   pragma Assert (Ekind (Ent) = E_Constant);
1070                   Choice_Val (Typ, Constant_Value (Ent));
1071                end if;
1072             end;
1073          end if;
1074       end Choice_Val;
1075
1076    --  Start of processing for Get_Variant_Encoding
1077
1078    begin
1079       Name_Len := 0;
1080
1081       Choice := First (Discrete_Choices (V));
1082       while Present (Choice) loop
1083          if Nkind (Choice) = N_Others_Choice then
1084             Add_Char_To_Name_Buffer ('O');
1085
1086          elsif Nkind (Choice) = N_Range then
1087             Choice_Val ('R', Low_Bound (Choice));
1088             Choice_Val ('T', High_Bound (Choice));
1089
1090          elsif Is_Entity_Name (Choice)
1091            and then Is_Type (Entity (Choice))
1092          then
1093             Choice_Val ('R', Type_Low_Bound (Entity (Choice)));
1094             Choice_Val ('T', Type_High_Bound (Entity (Choice)));
1095
1096          elsif Nkind (Choice) = N_Subtype_Indication then
1097             declare
1098                Rang : constant Node_Id :=
1099                         Range_Expression (Constraint (Choice));
1100             begin
1101                Choice_Val ('R', Low_Bound (Rang));
1102                Choice_Val ('T', High_Bound (Rang));
1103             end;
1104
1105          else
1106             Choice_Val ('S', Choice);
1107          end if;
1108
1109          Next (Choice);
1110       end loop;
1111
1112       Name_Buffer (Name_Len + 1) := ASCII.NUL;
1113
1114       if Debug_Flag_B then
1115          declare
1116             VP : constant Node_Id := Parent (V);    -- Variant_Part
1117             CL : constant Node_Id := Parent (VP);   -- Component_List
1118             RD : constant Node_Id := Parent (CL);   -- Record_Definition
1119             FT : constant Node_Id := Parent (RD);   -- Full_Type_Declaration
1120
1121          begin
1122             Write_Str ("**** variant for type ");
1123             Write_Name (Chars (Defining_Identifier (FT)));
1124             Write_Str (" is encoded as ");
1125             Write_Str (Name_Buffer (1 .. Name_Len));
1126             Write_Eol;
1127          end;
1128       end if;
1129    end Get_Variant_Encoding;
1130
1131    ---------------------------------
1132    -- Make_Packed_Array_Type_Name --
1133    ---------------------------------
1134
1135    function Make_Packed_Array_Type_Name
1136      (Typ   : Entity_Id;
1137       Csize : Uint)
1138       return  Name_Id
1139    is
1140    begin
1141       Get_Name_String (Chars (Typ));
1142       Add_Str_To_Name_Buffer ("___XP");
1143       Add_Uint_To_Buffer (Csize);
1144       return Name_Find;
1145    end Make_Packed_Array_Type_Name;
1146
1147    -----------------------------------
1148    -- Output_Homonym_Numbers_Suffix --
1149    -----------------------------------
1150
1151    procedure Output_Homonym_Numbers_Suffix is
1152       J : Natural;
1153
1154    begin
1155       if Homonym_Len > 0 then
1156
1157          --  Check for all 1's, in which case we do not output
1158
1159          J := 1;
1160          loop
1161             exit when Homonym_Numbers (J) /= '1';
1162
1163             --  If we reached end of string we do not output
1164
1165             if J = Homonym_Len then
1166                Homonym_Len := 0;
1167                return;
1168             end if;
1169
1170             exit when Homonym_Numbers (J + 1) /= '_';
1171             J := J + 2;
1172          end loop;
1173
1174          --  If we exit the loop then suffix must be output
1175
1176          if No_Dollar_In_Label then
1177             Add_Str_To_Name_Buffer ("__");
1178          else
1179             Add_Char_To_Name_Buffer ('$');
1180          end if;
1181
1182          Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len));
1183          Homonym_Len := 0;
1184       end if;
1185    end Output_Homonym_Numbers_Suffix;
1186
1187    ------------------------------
1188    -- Prepend_String_To_Buffer --
1189    ------------------------------
1190
1191    procedure Prepend_String_To_Buffer (S : String) is
1192       N : constant Integer := S'Length;
1193
1194    begin
1195       Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len);
1196       Name_Buffer (1 .. N) := S;
1197       Name_Len := Name_Len + N;
1198    end Prepend_String_To_Buffer;
1199
1200    ----------------------------
1201    -- Prepend_Uint_To_Buffer --
1202    ----------------------------
1203
1204    procedure Prepend_Uint_To_Buffer (U : Uint) is
1205    begin
1206       if U < 0 then
1207          Prepend_String_To_Buffer ("m");
1208          Prepend_Uint_To_Buffer (-U);
1209       else
1210          UI_Image (U, Decimal);
1211          Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
1212       end if;
1213    end Prepend_Uint_To_Buffer;
1214
1215    -------------
1216    -- Put_Hex --
1217    -------------
1218
1219    procedure Put_Hex (W : Word; N : Natural) is
1220       Hex : constant array (Word range 0 .. 15) of Character :=
1221               "0123456789abcdef";
1222
1223       Cod : Word;
1224
1225    begin
1226       Cod := W;
1227       for J in reverse N .. N + 7 loop
1228          Name_Buffer (J) := Hex (Cod and 16#F#);
1229          Cod := Cod / 16;
1230       end loop;
1231    end Put_Hex;
1232
1233    ------------------------------
1234    -- Qualify_All_Entity_Names --
1235    ------------------------------
1236
1237    procedure Qualify_All_Entity_Names is
1238       E   : Entity_Id;
1239       Ent : Entity_Id;
1240
1241    begin
1242       for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
1243          E := Defining_Entity (Name_Qualify_Units.Table (J));
1244          Qualify_Entity_Name (E);
1245
1246          Ent := First_Entity (E);
1247          while Present (Ent) loop
1248             Qualify_Entity_Name (Ent);
1249             Next_Entity (Ent);
1250
1251             --  There are odd cases where Last_Entity (E) = E. This happens
1252             --  in the case of renaming of packages. This test avoids getting
1253             --  stuck in such cases.
1254
1255             exit when Ent = E;
1256          end loop;
1257       end loop;
1258
1259       --  Second loop compresses any names that need compressing
1260
1261       for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
1262          E := Defining_Entity (Name_Qualify_Units.Table (J));
1263          Compress_Debug_Name (E);
1264
1265          Ent := First_Entity (E);
1266          while Present (Ent) loop
1267             Compress_Debug_Name (Ent);
1268             Next_Entity (Ent);
1269             exit when Ent = E;
1270          end loop;
1271       end loop;
1272    end Qualify_All_Entity_Names;
1273
1274    -------------------------
1275    -- Qualify_Entity_Name --
1276    -------------------------
1277
1278    procedure Qualify_Entity_Name (Ent : Entity_Id) is
1279
1280       Full_Qualify_Name : String (1 .. Name_Buffer'Length);
1281       Full_Qualify_Len  : Natural := 0;
1282       --  Used to accumulate fully qualified name of subprogram
1283
1284       procedure Fully_Qualify_Name (E : Entity_Id);
1285       --  Used to qualify a subprogram or type name, where full
1286       --  qualification up to Standard is always used. Name is set
1287       --  in Full_Qualify_Name with the length in Full_Qualify_Len.
1288       --  Note that this routine does not prepend the _ada_ string
1289       --  required for library subprograms (this is done in the back end).
1290
1291       function Is_BNPE (S : Entity_Id) return Boolean;
1292       --  Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
1293       --  is defined to be a package which is immediately nested within a
1294       --  package body.
1295
1296       function Qualify_Needed (S : Entity_Id) return Boolean;
1297       --  Given a scope, determines if the scope is to be included in the
1298       --  fully qualified name, True if so, False if not.
1299
1300       procedure Set_BNPE_Suffix (E : Entity_Id);
1301       --  Recursive routine to append the BNPE qualification suffix. Works
1302       --  from right to left with E being the current entity in the list.
1303       --  The result does NOT have the trailing n's and trailing b stripped.
1304       --  The caller must do this required stripping.
1305
1306       procedure Set_Entity_Name (E : Entity_Id);
1307       --  Internal recursive routine that does most of the work. This routine
1308       --  leaves the result sitting in Name_Buffer and Name_Len.
1309
1310       BNPE_Suffix_Needed : Boolean := False;
1311       --  Set true if a body-nested package entity suffix is required
1312
1313       Save_Chars : constant Name_Id := Chars (Ent);
1314       --  Save original name
1315
1316       ------------------------
1317       -- Fully_Qualify_Name --
1318       ------------------------
1319
1320       procedure Fully_Qualify_Name (E : Entity_Id) is
1321          Discard : Boolean := False;
1322
1323       begin
1324          --  Ignore empty entry (can happen in error cases)
1325
1326          if No (E) then
1327             return;
1328
1329          --  If this we are qualifying entities local to a generic
1330          --  instance, use the name of the original instantiation,
1331          --  not that of the anonymous subprogram in the wrapper
1332          --  package, so that gdb doesn't have to know about these.
1333
1334          elsif Is_Generic_Instance (E)
1335            and then Is_Subprogram (E)
1336            and then not Comes_From_Source (E)
1337            and then not Is_Compilation_Unit (Scope (E))
1338          then
1339             Fully_Qualify_Name (Related_Instance (Scope (E)));
1340             return;
1341          end if;
1342
1343          --  If we reached fully qualified name, then just copy it
1344
1345          if Has_Fully_Qualified_Name (E) then
1346             Get_Name_String (Chars (E));
1347             Strip_Suffixes (Discard);
1348             Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1349             Full_Qualify_Len := Name_Len;
1350             Set_Has_Fully_Qualified_Name (Ent);
1351
1352          --  Case of non-fully qualified name
1353
1354          else
1355             if Scope (E) = Standard_Standard then
1356                Set_Has_Fully_Qualified_Name (Ent);
1357             else
1358                Fully_Qualify_Name (Scope (E));
1359                Full_Qualify_Name (Full_Qualify_Len + 1) := '_';
1360                Full_Qualify_Name (Full_Qualify_Len + 2) := '_';
1361                Full_Qualify_Len := Full_Qualify_Len + 2;
1362             end if;
1363
1364             if Has_Qualified_Name (E) then
1365                Get_Unqualified_Name_String (Chars (E));
1366             else
1367                Get_Name_String (Chars (E));
1368             end if;
1369
1370             Full_Qualify_Name
1371               (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) :=
1372                 Name_Buffer (1 .. Name_Len);
1373             Full_Qualify_Len := Full_Qualify_Len + Name_Len;
1374             Append_Homonym_Number (E);
1375          end if;
1376
1377          if Is_BNPE (E) then
1378             BNPE_Suffix_Needed := True;
1379          end if;
1380       end Fully_Qualify_Name;
1381
1382       -------------
1383       -- Is_BNPE --
1384       -------------
1385
1386       function Is_BNPE (S : Entity_Id) return Boolean is
1387       begin
1388          return
1389            Ekind (S) = E_Package
1390              and then Is_Package_Body_Entity (S);
1391       end Is_BNPE;
1392
1393       --------------------
1394       -- Qualify_Needed --
1395       --------------------
1396
1397       function Qualify_Needed (S : Entity_Id) return Boolean is
1398       begin
1399          --  If we got all the way to Standard, then we have certainly
1400          --  fully qualified the name, so set the flag appropriately,
1401          --  and then return False, since we are most certainly done!
1402
1403          if S = Standard_Standard then
1404             Set_Has_Fully_Qualified_Name (Ent, True);
1405             return False;
1406
1407          --  Otherwise figure out if further qualification is required
1408
1409          else
1410             return
1411               Is_Subprogram (Ent)
1412                 or else
1413               Ekind (Ent) = E_Subprogram_Body
1414                 or else
1415                   (Ekind (S) /= E_Block
1416                     and then not Is_Dynamic_Scope (S));
1417          end if;
1418       end Qualify_Needed;
1419
1420       ---------------------
1421       -- Set_BNPE_Suffix --
1422       ---------------------
1423
1424       procedure Set_BNPE_Suffix (E : Entity_Id) is
1425          S : constant Entity_Id := Scope (E);
1426
1427       begin
1428          if Qualify_Needed (S) then
1429             Set_BNPE_Suffix (S);
1430
1431             if Is_BNPE (E) then
1432                Add_Char_To_Name_Buffer ('b');
1433             else
1434                Add_Char_To_Name_Buffer ('n');
1435             end if;
1436
1437          else
1438             Add_Char_To_Name_Buffer ('X');
1439          end if;
1440
1441       end Set_BNPE_Suffix;
1442
1443       ---------------------
1444       -- Set_Entity_Name --
1445       ---------------------
1446
1447       procedure Set_Entity_Name (E : Entity_Id) is
1448          S : constant Entity_Id := Scope (E);
1449
1450       begin
1451          --  If we reach an already qualified name, just take the encoding
1452          --  except that we strip the package body suffixes, since these
1453          --  will be separately put on later.
1454
1455          if Has_Qualified_Name (E) then
1456             Get_Name_String_And_Append (Chars (E));
1457             Strip_Suffixes (BNPE_Suffix_Needed);
1458
1459             --  If the top level name we are adding is itself fully
1460             --  qualified, then that means that the name that we are
1461             --  preparing for the Fully_Qualify_Name call will also
1462             --  generate a fully qualified name.
1463
1464             if Has_Fully_Qualified_Name (E) then
1465                Set_Has_Fully_Qualified_Name (Ent);
1466             end if;
1467
1468          --  Case where upper level name is not encoded yet
1469
1470          else
1471             --  Recurse if further qualification required
1472
1473             if Qualify_Needed (S) then
1474                Set_Entity_Name (S);
1475                Add_Str_To_Name_Buffer ("__");
1476             end if;
1477
1478             --  Otherwise get name and note if it is a NPBE
1479
1480             Get_Name_String_And_Append (Chars (E));
1481
1482             if Is_BNPE (E) then
1483                BNPE_Suffix_Needed := True;
1484             end if;
1485
1486             Append_Homonym_Number (E);
1487          end if;
1488       end Set_Entity_Name;
1489
1490    --  Start of processing for Qualify_Entity_Name
1491
1492    begin
1493       if Has_Qualified_Name (Ent) then
1494          return;
1495
1496       --  Here is where we create the proper link for renaming
1497
1498       elsif Ekind (Ent) = E_Enumeration_Literal
1499         and then Present (Debug_Renaming_Link (Ent))
1500       then
1501          Name_Len := 0;
1502          Set_Entity_Name (Debug_Renaming_Link (Ent));
1503          Get_Name_String (Chars (Ent));
1504          Prepend_String_To_Buffer
1505            (Get_Name_String (Chars (Debug_Renaming_Link (Ent))));
1506          Set_Chars (Ent, Name_Enter);
1507          Set_Has_Qualified_Name (Ent);
1508          return;
1509
1510       elsif Is_Subprogram (Ent)
1511         or else Ekind (Ent) = E_Subprogram_Body
1512         or else Is_Type (Ent)
1513       then
1514          Fully_Qualify_Name (Ent);
1515          Name_Len := Full_Qualify_Len;
1516          Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
1517
1518       elsif Qualify_Needed (Scope (Ent)) then
1519          Name_Len := 0;
1520          Set_Entity_Name (Ent);
1521
1522       else
1523          Set_Has_Qualified_Name (Ent);
1524          return;
1525       end if;
1526
1527       --  Fall through with a fully qualified name in Name_Buffer/Name_Len
1528
1529       Output_Homonym_Numbers_Suffix;
1530
1531       --  Add body-nested package suffix if required
1532
1533       if BNPE_Suffix_Needed
1534         and then Ekind (Ent) /= E_Enumeration_Literal
1535       then
1536          Set_BNPE_Suffix (Ent);
1537
1538          --  Strip trailing n's and last trailing b as required. note that
1539          --  we know there is at least one b, or no suffix would be generated.
1540
1541          while Name_Buffer (Name_Len) = 'n' loop
1542             Name_Len := Name_Len - 1;
1543          end loop;
1544
1545          Name_Len := Name_Len - 1;
1546       end if;
1547
1548       Set_Chars (Ent, Name_Enter);
1549       Set_Has_Qualified_Name (Ent);
1550
1551       if Debug_Flag_BB then
1552          Write_Str ("*** ");
1553          Write_Name (Save_Chars);
1554          Write_Str (" qualified as ");
1555          Write_Name (Chars (Ent));
1556          Write_Eol;
1557       end if;
1558    end Qualify_Entity_Name;
1559
1560    --------------------------
1561    -- Qualify_Entity_Names --
1562    --------------------------
1563
1564    procedure Qualify_Entity_Names (N : Node_Id) is
1565    begin
1566       Name_Qualify_Units.Append (N);
1567    end Qualify_Entity_Names;
1568
1569    ---------
1570    -- SEq --
1571    ---------
1572
1573    function SEq (F1, F2 : String_Ptr) return Boolean is
1574    begin
1575       return F1.all = F2.all;
1576    end SEq;
1577
1578    -----------
1579    -- SHash --
1580    -----------
1581
1582    function SHash (S : String_Ptr) return Hindex is
1583    begin
1584       return Hindex
1585         (Hindex'First + Hindex (CDN_Hash (S.all) mod Hindex'Range_Length));
1586    end SHash;
1587
1588    --------------------
1589    -- Strip_Suffixes --
1590    --------------------
1591
1592    procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is
1593       SL : Natural;
1594
1595    begin
1596       --  Search for and strip BNPE suffix
1597
1598       for J in reverse 2 .. Name_Len loop
1599          if Name_Buffer (J) = 'X' then
1600             Name_Len := J - 1;
1601             BNPE_Suffix_Found := True;
1602             exit;
1603          end if;
1604
1605          exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n';
1606       end loop;
1607
1608       --  Search for and strip homonym numbers suffix
1609
1610       --  Case of __ used for homonym numbers suffix
1611
1612       if No_Dollar_In_Label then
1613          for J in reverse 2 .. Name_Len - 2 loop
1614             if Name_Buffer (J) = '_'
1615               and then Name_Buffer (J + 1) = '_'
1616             then
1617                if Name_Buffer (J + 2) in '0' .. '9' then
1618                   if Homonym_Len > 0 then
1619                      Homonym_Len := Homonym_Len + 1;
1620                      Homonym_Numbers (Homonym_Len) := '-';
1621                   end if;
1622
1623                   SL := Name_Len - (J + 1);
1624
1625                   Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) :=
1626                     Name_Buffer (J + 2 .. Name_Len);
1627                   Name_Len := J - 1;
1628                   Homonym_Len := Homonym_Len + SL;
1629                end if;
1630
1631                exit;
1632             end if;
1633          end loop;
1634
1635       --  Case of $ used for homonym numbers suffix
1636
1637       else
1638          for J in reverse 2 .. Name_Len - 1 loop
1639             if Name_Buffer (J) = '$' then
1640                if Name_Buffer (J + 1) in '0' .. '9' then
1641                   if Homonym_Len > 0 then
1642                      Homonym_Len := Homonym_Len + 1;
1643                      Homonym_Numbers (Homonym_Len) := '-';
1644                   end if;
1645
1646                   SL := Name_Len - J;
1647
1648                   Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) :=
1649                     Name_Buffer (J + 1 .. Name_Len);
1650                   Name_Len := J - 1;
1651                   Homonym_Len := Homonym_Len + SL;
1652                end if;
1653
1654                exit;
1655             end if;
1656          end loop;
1657       end if;
1658    end Strip_Suffixes;
1659
1660 end Exp_Dbug;