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