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-2008, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Alloc;    use Alloc;
  27 with Atree;    use Atree;
  28 with Debug;    use Debug;
  29 with Einfo;    use Einfo;
  30 with Nlists;   use Nlists;
  31 with Nmake;    use Nmake;
  32 with Opt;      use Opt;
  33 with Output;   use Output;
  34 with Sem_Aux;  use Sem_Aux;
  35 with Sem_Eval; use Sem_Eval;
  36 with Sem_Util; use Sem_Util;
  37 with Sinfo;    use Sinfo;
  38 with Stand;    use Stand;
  39 with Stringt;  use Stringt;
  40 with Table;
  41 with Tbuild;   use Tbuild;
  42 with Urealp;   use Urealp;
  43
  44 package body Exp_Dbug is
  45
  46    --  The following table is used to queue up the entities passed as
  47    --  arguments to Qualify_Entity_Names for later processing when
  48    --  Qualify_All_Entity_Names is called.
  49
  50    package Name_Qualify_Units is new Table.Table (
  51      Table_Component_Type => Node_Id,
  52      Table_Index_Type     => Nat,
  53      Table_Low_Bound      => 1,
  54      Table_Initial        => Alloc.Name_Qualify_Units_Initial,
  55      Table_Increment      => Alloc.Name_Qualify_Units_Increment,
  56      Table_Name           => "Name_Qualify_Units");
  57
  58    --------------------------------
  59    -- Use of Qualification Flags --
  60    --------------------------------
  61
  62    --  There are two flags used to keep track of qualification of entities
  63
  64    --    Has_Fully_Qualified_Name
  65    --    Has_Qualified_Name
  66
  67    --  The difference between these is as follows. Has_Qualified_Name is
  68    --  set to indicate that the name has been qualified as required by the
  69    --  spec of this package. As described there, this may involve the full
  70    --  qualification for the name, but for some entities, notably procedure
  71    --  local variables, this full qualification is not required.
  72
  73    --  The flag Has_Fully_Qualified_Name is set if indeed the name has been
  74    --  fully qualified in the Ada sense. If Has_Fully_Qualified_Name is set,
  75    --  then Has_Qualified_Name is also set, but the other way round is not
  76    --  the case.
  77
  78    --  Consider the following example:
  79
  80    --     with ...
  81    --     procedure X is
  82    --       B : Ddd.Ttt;
  83    --       procedure Y is ..
  84
  85    --  Here B is a procedure local variable, so it does not need fully
  86    --  qualification. The flag Has_Qualified_Name will be set on the
  87    --  first attempt to qualify B, to indicate that the job is done
  88    --  and need not be redone.
  89
  90    --  But Y is qualified as x__y, since procedures are always fully
  91    --  qualified, so the first time that an attempt is made to qualify
  92    --  the name y, it will be replaced by x__y, and both flags are set.
  93
  94    --  Why the two flags? Well there are cases where we derive type names
  95    --  from object names. As noted in the spec, type names are always
  96    --  fully qualified. Suppose for example that the backend has to build
  97    --  a padded type for variable B. then it will construct the PAD name
  98    --  from B, but it requires full qualification, so the fully qualified
  99    --  type name will be x__b___PAD. The two flags allow the circuit for
 100    --  building this name to realize efficiently that b needs further
 101    --  qualification.
 102
 103    --------------------
 104    -- Homonym_Suffix --
 105    --------------------
 106
 107    --  The string defined here (and its associated length) is used to
 108    --  gather the homonym string that will be appended to Name_Buffer
 109    --  when the name is complete. Strip_Suffixes appends to this string
 110    --  as does Append_Homonym_Number, and Output_Homonym_Numbers_Suffix
 111    --  appends the string to the end of Name_Buffer.
 112
 113    Homonym_Numbers : String (1 .. 256);
 114    Homonym_Len     : Natural := 0;
 115
 116    ----------------------
 117    -- Local Procedures --
 118    ----------------------
 119
 120    procedure Add_Uint_To_Buffer (U : Uint);
 121    --  Add image of universal integer to Name_Buffer, updating Name_Len
 122
 123    procedure Add_Real_To_Buffer (U : Ureal);
 124    --  Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of
 125    --  the normalized numerator and denominator of the given real value.
 126
 127    procedure Append_Homonym_Number (E : Entity_Id);
 128    --  If the entity E has homonyms in the same scope, then make an entry
 129    --  in the Homonym_Numbers array, bumping Homonym_Count accordingly.
 130
 131    function Bounds_Match_Size (E : Entity_Id) return  Boolean;
 132    --  Determine whether the bounds of E match the size of the type. This is
 133    --  used to determine whether encoding is required for a discrete type.
 134
 135    procedure Output_Homonym_Numbers_Suffix;
 136    --  If homonym numbers are stored, then output them into Name_Buffer
 137
 138    procedure Prepend_String_To_Buffer (S : String);
 139    --  Prepend given string to the contents of the string buffer, updating
 140    --  the value in Name_Len (i.e. string is added at start of buffer).
 141
 142    procedure Prepend_Uint_To_Buffer (U : Uint);
 143    --  Prepend image of universal integer to Name_Buffer, updating Name_Len
 144
 145    procedure Qualify_Entity_Name (Ent : Entity_Id);
 146    --  If not already done, replaces the Chars field of the given entity
 147    --  with the appropriate fully qualified name.
 148
 149    procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean);
 150    --  Given an qualified entity name in Name_Buffer, remove any plain X or
 151    --  X{nb} qualification suffix. The contents of Name_Buffer is not changed
 152    --  but Name_Len may be adjusted on return to remove the suffix. If a
 153    --  BNPE suffix is found and stripped, then BNPE_Suffix_Found is set to
 154    --  True. If no suffix is found, then BNPE_Suffix_Found is not modified.
 155    --  This routine also searches for a homonym suffix, and if one is found
 156    --  it is also stripped, and the entries are added to the global homonym
 157    --  list (Homonym_Numbers) so that they can later be put back.
 158
 159    ------------------------
 160    -- Add_Real_To_Buffer --
 161    ------------------------
 162
 163    procedure Add_Real_To_Buffer (U : Ureal) is
 164    begin
 165       Add_Uint_To_Buffer (Norm_Num (U));
 166       Add_Str_To_Name_Buffer ("_");
 167       Add_Uint_To_Buffer (Norm_Den (U));
 168    end Add_Real_To_Buffer;
 169
 170    ------------------------
 171    -- Add_Uint_To_Buffer --
 172    ------------------------
 173
 174    procedure Add_Uint_To_Buffer (U : Uint) is
 175    begin
 176       if U < 0 then
 177          Add_Uint_To_Buffer (-U);
 178          Add_Char_To_Name_Buffer ('m');
 179       else
 180          UI_Image (U, Decimal);
 181          Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
 182       end if;
 183    end Add_Uint_To_Buffer;
 184
 185    ---------------------------
 186    -- Append_Homonym_Number --
 187    ---------------------------
 188
 189    procedure Append_Homonym_Number (E : Entity_Id) is
 190
 191       procedure Add_Nat_To_H (Nr : Nat);
 192       --  Little procedure to append Nr to Homonym_Numbers
 193
 194       ------------------
 195       -- Add_Nat_To_H --
 196       ------------------
 197
 198       procedure Add_Nat_To_H (Nr : Nat) is
 199       begin
 200          if Nr >= 10 then
 201             Add_Nat_To_H (Nr / 10);
 202          end if;
 203
 204          Homonym_Len := Homonym_Len + 1;
 205          Homonym_Numbers (Homonym_Len) :=
 206            Character'Val (Nr mod 10 + Character'Pos ('0'));
 207       end Add_Nat_To_H;
 208
 209    --  Start of processing for Append_Homonym_Number
 210
 211    begin
 212       if Has_Homonym (E) then
 213          declare
 214             H  : Entity_Id := Homonym (E);
 215             Nr : Nat := 1;
 216
 217          begin
 218             while Present (H) loop
 219                if Scope (H) = Scope (E) then
 220                   Nr := Nr + 1;
 221                end if;
 222
 223                H := Homonym (H);
 224             end loop;
 225
 226             if Homonym_Len > 0 then
 227                Homonym_Len := Homonym_Len + 1;
 228                Homonym_Numbers (Homonym_Len) := '_';
 229             end if;
 230
 231             Add_Nat_To_H (Nr);
 232          end;
 233       end if;
 234    end Append_Homonym_Number;
 235
 236    -----------------------
 237    -- Bounds_Match_Size --
 238    -----------------------
 239
 240    function Bounds_Match_Size (E : Entity_Id) return Boolean is
 241       Siz : Uint;
 242
 243    begin
 244       if not Is_OK_Static_Subtype (E) then
 245          return False;
 246
 247       elsif Is_Integer_Type (E)
 248         and then Subtypes_Statically_Match (E, Base_Type (E))
 249       then
 250          return True;
 251
 252       --  Here we check if the static bounds match the natural size, which is
 253       --  the size passed through with the debugging information. This is the
 254       --  Esize rounded up to 8, 16, 32 or 64 as appropriate.
 255
 256       else
 257          declare
 258             Umark  : constant Uintp.Save_Mark := Uintp.Mark;
 259             Result : Boolean;
 260
 261          begin
 262             if Esize (E) <= 8 then
 263                Siz := Uint_8;
 264             elsif Esize (E) <= 16 then
 265                Siz := Uint_16;
 266             elsif Esize (E) <= 32 then
 267                Siz := Uint_32;
 268             else
 269                Siz := Uint_64;
 270             end if;
 271
 272             if Is_Modular_Integer_Type (E) or else Is_Enumeration_Type (E) then
 273                Result :=
 274                  Expr_Rep_Value (Type_Low_Bound (E)) = 0
 275                    and then
 276                  2 ** Siz - Expr_Rep_Value (Type_High_Bound (E)) = 1;
 277
 278             else
 279                Result :=
 280                  Expr_Rep_Value (Type_Low_Bound (E)) + 2 ** (Siz - 1) = 0
 281                    and then
 282                  2 ** (Siz - 1) - Expr_Rep_Value (Type_High_Bound (E)) = 1;
 283             end if;
 284
 285             Release (Umark);
 286             return Result;
 287          end;
 288       end if;
 289    end Bounds_Match_Size;
 290
 291    --------------------------------
 292    -- Debug_Renaming_Declaration --
 293    --------------------------------
 294
 295    function Debug_Renaming_Declaration (N : Node_Id) return Node_Id is
 296       Loc : constant Source_Ptr := Sloc (N);
 297       Ent : constant Node_Id    := Defining_Entity (N);
 298       Nam : constant Node_Id    := Name (N);
 299       Ren : Node_Id;
 300       Typ : Entity_Id;
 301       Obj : Entity_Id;
 302       Res : Node_Id;
 303
 304       function Output_Subscript (N : Node_Id; S : String) return Boolean;
 305       --  Outputs a single subscript value as ?nnn (subscript is compile time
 306       --  known value with value nnn) or as ?e (subscript is local constant
 307       --  with name e), where S supplies the proper string to use for ?.
 308       --  Returns False if the subscript is not of an appropriate type to
 309       --  output in one of these two forms. The result is prepended to the
 310       --  name stored in Name_Buffer.
 311
 312       ----------------------
 313       -- Output_Subscript --
 314       ----------------------
 315
 316       function Output_Subscript (N : Node_Id; S : String) return Boolean is
 317       begin
 318          if Compile_Time_Known_Value (N) then
 319             Prepend_Uint_To_Buffer (Expr_Value (N));
 320
 321          elsif Nkind (N) = N_Identifier
 322            and then Scope (Entity (N)) = Scope (Ent)
 323            and then Ekind (Entity (N)) = E_Constant
 324          then
 325             Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N))));
 326
 327          else
 328             return False;
 329          end if;
 330
 331          Prepend_String_To_Buffer (S);
 332          return True;
 333       end Output_Subscript;
 334
 335    --  Start of processing for Debug_Renaming_Declaration
 336
 337    begin
 338       if not Comes_From_Source (N)
 339         and then not Needs_Debug_Info (Ent)
 340       then
 341          return Empty;
 342       end if;
 343
 344       --  Get renamed entity and compute suffix
 345
 346       Name_Len := 0;
 347       Ren := Nam;
 348       loop
 349          case Nkind (Ren) is
 350
 351             when N_Identifier =>
 352                exit;
 353
 354             when N_Expanded_Name =>
 355
 356                --  The entity field for an N_Expanded_Name is on the expanded
 357                --  name node itself, so we are done here too.
 358
 359                exit;
 360
 361             when N_Selected_Component =>
 362                Prepend_String_To_Buffer
 363                  (Get_Name_String (Chars (Selector_Name (Ren))));
 364                Prepend_String_To_Buffer ("XR");
 365                Ren := Prefix (Ren);
 366
 367             when N_Indexed_Component =>
 368                declare
 369                   X : Node_Id := Last (Expressions (Ren));
 370
 371                begin
 372                   while Present (X) loop
 373                      if not Output_Subscript (X, "XS") then
 374                         Set_Materialize_Entity (Ent);
 375                         return Empty;
 376                      end if;
 377
 378                      Prev (X);
 379                   end loop;
 380                end;
 381
 382                Ren := Prefix (Ren);
 383
 384             when N_Slice =>
 385
 386                Typ := Etype (First_Index (Etype (Nam)));
 387
 388                if not Output_Subscript (Type_High_Bound (Typ), "XS") then
 389                   Set_Materialize_Entity (Ent);
 390                   return Empty;
 391                end if;
 392
 393                if not Output_Subscript (Type_Low_Bound  (Typ), "XL") then
 394                   Set_Materialize_Entity (Ent);
 395                   return Empty;
 396                end if;
 397
 398                Ren := Prefix (Ren);
 399
 400             when N_Explicit_Dereference =>
 401                Set_Materialize_Entity (Ent);
 402                Prepend_String_To_Buffer ("XA");
 403                Ren := Prefix (Ren);
 404
 405             --  For now, anything else simply results in no translation
 406
 407             when others =>
 408                Set_Materialize_Entity (Ent);
 409                return Empty;
 410          end case;
 411       end loop;
 412
 413       Prepend_String_To_Buffer ("___XE");
 414
 415       --  Include the designation of the form of renaming
 416
 417       case Nkind (N) is
 418          when N_Object_Renaming_Declaration =>
 419             Prepend_String_To_Buffer ("___XR");
 420
 421          when N_Exception_Renaming_Declaration =>
 422             Prepend_String_To_Buffer ("___XRE");
 423
 424          when N_Package_Renaming_Declaration =>
 425             Prepend_String_To_Buffer ("___XRP");
 426
 427          when others =>
 428             return Empty;
 429       end case;
 430
 431       --  Add the name of the renaming entity to the front
 432
 433       Prepend_String_To_Buffer (Get_Name_String (Chars (Ent)));
 434
 435       --  If it is a child unit create a fully qualified name, to disambiguate
 436       --  multiple child units with the same name and different parents.
 437
 438       if Nkind (N) = N_Package_Renaming_Declaration
 439         and then Is_Child_Unit (Ent)
 440       then
 441          Prepend_String_To_Buffer ("__");
 442          Prepend_String_To_Buffer
 443            (Get_Name_String (Chars (Scope (Ent))));
 444       end if;
 445
 446       --  Create the special object whose name is the debug encoding for the
 447       --  renaming declaration.
 448
 449       --  For now, the object name contains the suffix encoding for the renamed
 450       --  object, but not the name of the leading entity. The object is linked
 451       --  the renamed entity using the Debug_Renaming_Link field. Then the
 452       --  Qualify_Entity_Name procedure uses this link to create the proper
 453       --  fully qualified name.
 454
 455       --  The reason we do things this way is that we really need to copy the
 456       --  qualification of the renamed entity, and it is really much easier to
 457       --  do this after the renamed entity has itself been fully qualified.
 458
 459       Obj := Make_Defining_Identifier (Loc, Chars => Name_Enter);
 460       Res :=
 461         Make_Object_Declaration (Loc,
 462           Defining_Identifier => Obj,
 463           Object_Definition   => New_Reference_To
 464                                    (Standard_Debug_Renaming_Type, Loc));
 465
 466       Set_Debug_Renaming_Link (Obj, Entity (Ren));
 467
 468       Set_Debug_Info_Needed (Obj);
 469
 470       --  Mark the object as internal so that it won't be initialized when
 471       --  pragma Initialize_Scalars or Normalize_Scalars is in use.
 472
 473       Set_Is_Internal (Obj);
 474
 475       return Res;
 476
 477    --  If we get an exception, just figure it is a case that we cannot
 478    --  successfully handle using our current approach, since this is
 479    --  only for debugging, no need to take the compilation with us!
 480
 481    exception
 482       when others =>
 483          return Make_Null_Statement (Loc);
 484    end Debug_Renaming_Declaration;
 485
 486    ----------------------
 487    -- Get_Encoded_Name --
 488    ----------------------
 489
 490    --  Note: see spec for details on encodings
 491
 492    procedure Get_Encoded_Name (E : Entity_Id) is
 493       Has_Suffix : Boolean;
 494
 495    begin
 496       --  If not generating code, there is no need to create encoded names, and
 497       --  problems when the back-end is called to annotate types without full
 498       --  code generation. See comments in Get_External_Name_With_Suffix for
 499       --  additional details.
 500
 501       --  However we do create encoded names if the back end is active, even
 502       --  if Operating_Mode got reset. Otherwise any serious error reported
 503       --  by the backend calling Error_Msg changes the Compilation_Mode to
 504       --  Check_Semantics, which disables the functionality of this routine,
 505       --  causing the generation of spurious additional errors.
 506
 507       --  Couldn't we just test Original_Operating_Mode here? ???
 508
 509       if Operating_Mode /= Generate_Code
 510         and then not Generating_Code
 511       then
 512          return;
 513       end if;
 514
 515       Get_Name_String (Chars (E));
 516
 517       --  Nothing to do if we do not have a type
 518
 519       if not Is_Type (E)
 520
 521       --  Or if this is an enumeration base type
 522
 523         or else (Is_Enumeration_Type (E)
 524                    and then E = Base_Type (E))
 525
 526       --  Or if this is a dummy type for a renaming
 527
 528         or else (Name_Len >= 3 and then
 529                    Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR")
 530
 531         or else (Name_Len >= 4 and then
 532                    (Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
 533                       or else
 534                     Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"))
 535
 536       --  For all these cases, just return the name unchanged
 537
 538       then
 539          Name_Buffer (Name_Len + 1) := ASCII.NUL;
 540          return;
 541       end if;
 542
 543       Has_Suffix := True;
 544
 545       --  Fixed-point case
 546
 547       if Is_Fixed_Point_Type (E) then
 548          Get_External_Name_With_Suffix (E, "XF_");
 549          Add_Real_To_Buffer (Delta_Value (E));
 550
 551          if Small_Value (E) /= Delta_Value (E) then
 552             Add_Str_To_Name_Buffer ("_");
 553             Add_Real_To_Buffer (Small_Value (E));
 554          end if;
 555
 556       --  Vax floating-point case
 557
 558       elsif Vax_Float (E) then
 559          if Digits_Value (Base_Type (E)) = 6 then
 560             Get_External_Name_With_Suffix (E, "XFF");
 561
 562          elsif Digits_Value (Base_Type (E)) = 9 then
 563             Get_External_Name_With_Suffix (E, "XFF");
 564
 565          else
 566             pragma Assert (Digits_Value (Base_Type (E)) = 15);
 567             Get_External_Name_With_Suffix (E, "XFG");
 568          end if;
 569
 570       --  Discrete case where bounds do not match size
 571
 572       elsif Is_Discrete_Type (E)
 573         and then not Bounds_Match_Size (E)
 574       then
 575          declare
 576             Lo : constant Node_Id := Type_Low_Bound (E);
 577             Hi : constant Node_Id := Type_High_Bound (E);
 578
 579             Lo_Con : constant Boolean := Compile_Time_Known_Value (Lo);
 580             Hi_Con : constant Boolean := Compile_Time_Known_Value (Hi);
 581
 582             Lo_Discr : constant Boolean :=
 583                          Nkind (Lo) = N_Identifier
 584                            and then
 585                          Ekind (Entity (Lo)) = E_Discriminant;
 586
 587             Hi_Discr : constant Boolean :=
 588                          Nkind (Hi) = N_Identifier
 589                            and then
 590                          Ekind (Entity (Hi)) = E_Discriminant;
 591
 592             Lo_Encode : constant Boolean := Lo_Con or Lo_Discr;
 593             Hi_Encode : constant Boolean := Hi_Con or Hi_Discr;
 594
 595             Biased : constant Boolean := Has_Biased_Representation (E);
 596
 597          begin
 598             if Biased then
 599                Get_External_Name_With_Suffix (E, "XB");
 600             else
 601                Get_External_Name_With_Suffix (E, "XD");
 602             end if;
 603
 604             if Lo_Encode or Hi_Encode then
 605                if Biased then
 606                   Add_Str_To_Name_Buffer ("_");
 607                else
 608                   if Lo_Encode then
 609                      if Hi_Encode then
 610                         Add_Str_To_Name_Buffer ("LU_");
 611                      else
 612                         Add_Str_To_Name_Buffer ("L_");
 613                      end if;
 614                   else
 615                      Add_Str_To_Name_Buffer ("U_");
 616                   end if;
 617                end if;
 618
 619                if Lo_Con then
 620                   Add_Uint_To_Buffer (Expr_Rep_Value (Lo));
 621                elsif Lo_Discr then
 622                   Get_Name_String_And_Append (Chars (Entity (Lo)));
 623                end if;
 624
 625                if Lo_Encode and Hi_Encode then
 626                   Add_Str_To_Name_Buffer ("__");
 627                end if;
 628
 629                if Hi_Con then
 630                   Add_Uint_To_Buffer (Expr_Rep_Value (Hi));
 631                elsif Hi_Discr then
 632                   Get_Name_String_And_Append (Chars (Entity (Hi)));
 633                end if;
 634             end if;
 635          end;
 636
 637       --  For all other cases, the encoded name is the normal type name
 638
 639       else
 640          Has_Suffix := False;
 641          Get_External_Name (E, Has_Suffix);
 642       end if;
 643
 644       if Debug_Flag_B and then Has_Suffix then
 645          Write_Str ("**** type ");
 646          Write_Name (Chars (E));
 647          Write_Str (" is encoded as ");
 648          Write_Str (Name_Buffer (1 .. Name_Len));
 649          Write_Eol;
 650       end if;
 651
 652       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 653    end Get_Encoded_Name;
 654
 655    -----------------------
 656    -- Get_External_Name --
 657    -----------------------
 658
 659    procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean) is
 660       E    : Entity_Id := Entity;
 661       Kind : Entity_Kind;
 662
 663       procedure Get_Qualified_Name_And_Append (Entity : Entity_Id);
 664       --  Appends fully qualified name of given entity to Name_Buffer
 665
 666       -----------------------------------
 667       -- Get_Qualified_Name_And_Append --
 668       -----------------------------------
 669
 670       procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is
 671       begin
 672          --  If the entity is a compilation unit, its scope is Standard,
 673          --  there is no outer scope, and the no further qualification
 674          --  is required.
 675
 676          --  If the front end has already computed a fully qualified name,
 677          --  then it is also the case that no further qualification is
 678          --  required.
 679
 680          if Present (Scope (Scope (Entity)))
 681            and then not Has_Fully_Qualified_Name (Entity)
 682          then
 683             Get_Qualified_Name_And_Append (Scope (Entity));
 684             Add_Str_To_Name_Buffer ("__");
 685             Get_Name_String_And_Append (Chars (Entity));
 686             Append_Homonym_Number (Entity);
 687
 688          else
 689             Get_Name_String_And_Append (Chars (Entity));
 690          end if;
 691       end Get_Qualified_Name_And_Append;
 692
 693    --  Start of processing for Get_External_Name
 694
 695    begin
 696       Name_Len    := 0;
 697       Homonym_Len := 0;
 698
 699       --  If this is a child unit, we want the child
 700
 701       if Nkind (E) = N_Defining_Program_Unit_Name then
 702          E := Defining_Identifier (Entity);
 703       end if;
 704
 705       Kind := Ekind (E);
 706
 707       --  Case of interface name being used
 708
 709       if (Kind = E_Procedure or else
 710           Kind = E_Function  or else
 711           Kind = E_Constant  or else
 712           Kind = E_Variable  or else
 713           Kind = E_Exception)
 714         and then Present (Interface_Name (E))
 715         and then No (Address_Clause (E))
 716         and then not Has_Suffix
 717       then
 718          Add_String_To_Name_Buffer (Strval (Interface_Name (E)));
 719
 720       --  All other cases besides the interface name case
 721
 722       else
 723          --  If this is a library level subprogram (i.e. a subprogram that is a
 724          --  compilation unit other than a subunit), then we prepend _ada_ to
 725          --  ensure distinctions required as described in the spec.
 726
 727          --  Check explicitly for child units, because those are not flagged
 728          --  as Compilation_Units by lib. Should they be ???
 729
 730          if Is_Subprogram (E)
 731            and then (Is_Compilation_Unit (E) or Is_Child_Unit (E))
 732            and then not Has_Suffix
 733          then
 734             Add_Str_To_Name_Buffer ("_ada_");
 735          end if;
 736
 737          --  If the entity is a subprogram instance that is not a compilation
 738          --  unit, generate the name of the original Ada entity, which is the
 739          --  one gdb needs.
 740
 741          if Is_Generic_Instance (E)
 742            and then Is_Subprogram (E)
 743            and then not Is_Compilation_Unit (Scope (E))
 744            and then (Ekind (Scope (E)) = E_Package
 745                       or else
 746                      Ekind (Scope (E)) = E_Package_Body)
 747            and then Present (Related_Instance (Scope (E)))
 748          then
 749             E := Related_Instance (Scope (E));
 750          end if;
 751
 752          Get_Qualified_Name_And_Append (E);
 753       end if;
 754
 755       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 756    end Get_External_Name;
 757
 758    -----------------------------------
 759    -- Get_External_Name_With_Suffix --
 760    -----------------------------------
 761
 762    procedure Get_External_Name_With_Suffix
 763      (Entity : Entity_Id;
 764       Suffix : String)
 765    is
 766       Has_Suffix : constant Boolean := (Suffix /= "");
 767
 768    begin
 769       --  If we are not in code generation mode, this procedure may still be
 770       --  called from Back_End (more specifically - from gigi for doing type
 771       --  representation annotation or some representation-specific checks).
 772       --  But in this mode there is no need to mess with external names.
 773
 774       --  Furthermore, the call causes difficulties in this case because the
 775       --  string representing the homonym number is not correctly reset as a
 776       --  part of the call to Output_Homonym_Numbers_Suffix (which is not
 777       --  called in gigi).
 778
 779       if Operating_Mode /= Generate_Code then
 780          return;
 781       end if;
 782
 783       Get_External_Name (Entity, Has_Suffix);
 784
 785       if Has_Suffix then
 786          Add_Str_To_Name_Buffer ("___");
 787          Add_Str_To_Name_Buffer (Suffix);
 788          Name_Buffer (Name_Len + 1) := ASCII.NUL;
 789       end if;
 790    end Get_External_Name_With_Suffix;
 791
 792    --------------------------
 793    -- Get_Variant_Encoding --
 794    --------------------------
 795
 796    procedure Get_Variant_Encoding (V : Node_Id) is
 797       Choice : Node_Id;
 798
 799       procedure Choice_Val (Typ : Character; Choice : Node_Id);
 800       --  Output encoded value for a single choice value. Typ is the key
 801       --  character ('S', 'F', or 'T') that precedes the choice value.
 802
 803       ----------------
 804       -- Choice_Val --
 805       ----------------
 806
 807       procedure Choice_Val (Typ : Character; Choice : Node_Id) is
 808       begin
 809          if Nkind (Choice) = N_Integer_Literal then
 810             Add_Char_To_Name_Buffer (Typ);
 811             Add_Uint_To_Buffer (Intval (Choice));
 812
 813          --  Character literal with no entity present (this is the case
 814          --  Standard.Character or Standard.Wide_Character as root type)
 815
 816          elsif Nkind (Choice) = N_Character_Literal
 817            and then No (Entity (Choice))
 818          then
 819             Add_Char_To_Name_Buffer (Typ);
 820             Add_Uint_To_Buffer (Char_Literal_Value (Choice));
 821
 822          else
 823             declare
 824                Ent : constant Entity_Id := Entity (Choice);
 825
 826             begin
 827                if Ekind (Ent) = E_Enumeration_Literal then
 828                   Add_Char_To_Name_Buffer (Typ);
 829                   Add_Uint_To_Buffer (Enumeration_Rep (Ent));
 830
 831                else
 832                   pragma Assert (Ekind (Ent) = E_Constant);
 833                   Choice_Val (Typ, Constant_Value (Ent));
 834                end if;
 835             end;
 836          end if;
 837       end Choice_Val;
 838
 839    --  Start of processing for Get_Variant_Encoding
 840
 841    begin
 842       Name_Len := 0;
 843
 844       Choice := First (Discrete_Choices (V));
 845       while Present (Choice) loop
 846          if Nkind (Choice) = N_Others_Choice then
 847             Add_Char_To_Name_Buffer ('O');
 848
 849          elsif Nkind (Choice) = N_Range then
 850             Choice_Val ('R', Low_Bound (Choice));
 851             Choice_Val ('T', High_Bound (Choice));
 852
 853          elsif Is_Entity_Name (Choice)
 854            and then Is_Type (Entity (Choice))
 855          then
 856             Choice_Val ('R', Type_Low_Bound (Entity (Choice)));
 857             Choice_Val ('T', Type_High_Bound (Entity (Choice)));
 858
 859          elsif Nkind (Choice) = N_Subtype_Indication then
 860             declare
 861                Rang : constant Node_Id :=
 862                         Range_Expression (Constraint (Choice));
 863             begin
 864                Choice_Val ('R', Low_Bound (Rang));
 865                Choice_Val ('T', High_Bound (Rang));
 866             end;
 867
 868          else
 869             Choice_Val ('S', Choice);
 870          end if;
 871
 872          Next (Choice);
 873       end loop;
 874
 875       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 876
 877       if Debug_Flag_B then
 878          declare
 879             VP : constant Node_Id := Parent (V);    -- Variant_Part
 880             CL : constant Node_Id := Parent (VP);   -- Component_List
 881             RD : constant Node_Id := Parent (CL);   -- Record_Definition
 882             FT : constant Node_Id := Parent (RD);   -- Full_Type_Declaration
 883
 884          begin
 885             Write_Str ("**** variant for type ");
 886             Write_Name (Chars (Defining_Identifier (FT)));
 887             Write_Str (" is encoded as ");
 888             Write_Str (Name_Buffer (1 .. Name_Len));
 889             Write_Eol;
 890          end;
 891       end if;
 892    end Get_Variant_Encoding;
 893
 894    ------------------------------------
 895    -- Get_Secondary_DT_External_Name --
 896    ------------------------------------
 897
 898    procedure Get_Secondary_DT_External_Name
 899      (Typ          : Entity_Id;
 900       Ancestor_Typ : Entity_Id;
 901       Suffix_Index : Int)
 902    is
 903    begin
 904       Get_External_Name (Typ, Has_Suffix => False);
 905
 906       if Ancestor_Typ /= Typ then
 907          declare
 908             Len      : constant Natural := Name_Len;
 909             Save_Str : constant String (1 .. Name_Len)
 910                          := Name_Buffer (1 .. Name_Len);
 911          begin
 912             Get_External_Name (Ancestor_Typ, Has_Suffix => False);
 913
 914             --  Append the extended name of the ancestor to the
 915             --  extended name of Typ
 916
 917             Name_Buffer (Len + 2 .. Len + Name_Len + 1) :=
 918               Name_Buffer (1 .. Name_Len);
 919             Name_Buffer (1 .. Len) := Save_Str;
 920             Name_Buffer (Len + 1) := '_';
 921             Name_Len := Len + Name_Len + 1;
 922          end;
 923       end if;
 924
 925       Add_Nat_To_Name_Buffer (Suffix_Index);
 926    end Get_Secondary_DT_External_Name;
 927
 928    ---------------------------------
 929    -- Make_Packed_Array_Type_Name --
 930    ---------------------------------
 931
 932    function Make_Packed_Array_Type_Name
 933      (Typ   : Entity_Id;
 934       Csize : Uint)
 935       return  Name_Id
 936    is
 937    begin
 938       Get_Name_String (Chars (Typ));
 939       Add_Str_To_Name_Buffer ("___XP");
 940       Add_Uint_To_Buffer (Csize);
 941       return Name_Find;
 942    end Make_Packed_Array_Type_Name;
 943
 944    -----------------------------------
 945    -- Output_Homonym_Numbers_Suffix --
 946    -----------------------------------
 947
 948    procedure Output_Homonym_Numbers_Suffix is
 949       J : Natural;
 950
 951    begin
 952       if Homonym_Len > 0 then
 953
 954          --  Check for all 1's, in which case we do not output
 955
 956          J := 1;
 957          loop
 958             exit when Homonym_Numbers (J) /= '1';
 959
 960             --  If we reached end of string we do not output
 961
 962             if J = Homonym_Len then
 963                Homonym_Len := 0;
 964                return;
 965             end if;
 966
 967             exit when Homonym_Numbers (J + 1) /= '_';
 968             J := J + 2;
 969          end loop;
 970
 971          --  If we exit the loop then suffix must be output
 972
 973          Add_Str_To_Name_Buffer ("__");
 974          Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len));
 975          Homonym_Len := 0;
 976       end if;
 977    end Output_Homonym_Numbers_Suffix;
 978
 979    ------------------------------
 980    -- Prepend_String_To_Buffer --
 981    ------------------------------
 982
 983    procedure Prepend_String_To_Buffer (S : String) is
 984       N : constant Integer := S'Length;
 985    begin
 986       Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len);
 987       Name_Buffer (1 .. N) := S;
 988       Name_Len := Name_Len + N;
 989    end Prepend_String_To_Buffer;
 990
 991    ----------------------------
 992    -- Prepend_Uint_To_Buffer --
 993    ----------------------------
 994
 995    procedure Prepend_Uint_To_Buffer (U : Uint) is
 996    begin
 997       if U < 0 then
 998          Prepend_String_To_Buffer ("m");
 999          Prepend_Uint_To_Buffer (-U);
1000       else
1001          UI_Image (U, Decimal);
1002          Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
1003       end if;
1004    end Prepend_Uint_To_Buffer;
1005
1006    ------------------------------
1007    -- Qualify_All_Entity_Names --
1008    ------------------------------
1009
1010    procedure Qualify_All_Entity_Names is
1011       E   : Entity_Id;
1012       Ent : Entity_Id;
1013
1014    begin
1015       for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
1016          E := Defining_Entity (Name_Qualify_Units.Table (J));
1017          Qualify_Entity_Name (E);
1018
1019          --  Normally entities in the qualification list are scopes, but in the
1020          --  case of a library-level package renaming there is an associated
1021          --  variable that encodes the debugger name and that variable is
1022          --  entered in the list since it occurs in the Aux_Decls list of the
1023          --  compilation and doesn't have a normal scope.
1024
1025          if Ekind (E) /= E_Variable then
1026             Ent := First_Entity (E);
1027             while Present (Ent) loop
1028                Qualify_Entity_Name (Ent);
1029                Next_Entity (Ent);
1030
1031                --  There are odd cases where Last_Entity (E) = E. This happens
1032                --  in the case of renaming of packages. This test avoids
1033                --  getting stuck in such cases.
1034
1035                exit when Ent = E;
1036             end loop;
1037          end if;
1038       end loop;
1039    end Qualify_All_Entity_Names;
1040
1041    -------------------------
1042    -- Qualify_Entity_Name --
1043    -------------------------
1044
1045    procedure Qualify_Entity_Name (Ent : Entity_Id) is
1046
1047       Full_Qualify_Name : String (1 .. Name_Buffer'Length);
1048       Full_Qualify_Len  : Natural := 0;
1049       --  Used to accumulate fully qualified name of subprogram
1050
1051       procedure Fully_Qualify_Name (E : Entity_Id);
1052       --  Used to qualify a subprogram or type name, where full
1053       --  qualification up to Standard is always used. Name is set
1054       --  in Full_Qualify_Name with the length in Full_Qualify_Len.
1055       --  Note that this routine does not prepend the _ada_ string
1056       --  required for library subprograms (this is done in the back end).
1057
1058       function Is_BNPE (S : Entity_Id) return Boolean;
1059       --  Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
1060       --  is defined to be a package which is immediately nested within a
1061       --  package body.
1062
1063       function Qualify_Needed (S : Entity_Id) return Boolean;
1064       --  Given a scope, determines if the scope is to be included in the
1065       --  fully qualified name, True if so, False if not.
1066
1067       procedure Set_BNPE_Suffix (E : Entity_Id);
1068       --  Recursive routine to append the BNPE qualification suffix. Works
1069       --  from right to left with E being the current entity in the list.
1070       --  The result does NOT have the trailing n's and trailing b stripped.
1071       --  The caller must do this required stripping.
1072
1073       procedure Set_Entity_Name (E : Entity_Id);
1074       --  Internal recursive routine that does most of the work. This routine
1075       --  leaves the result sitting in Name_Buffer and Name_Len.
1076
1077       BNPE_Suffix_Needed : Boolean := False;
1078       --  Set true if a body-nested package entity suffix is required
1079
1080       Save_Chars : constant Name_Id := Chars (Ent);
1081       --  Save original name
1082
1083       ------------------------
1084       -- Fully_Qualify_Name --
1085       ------------------------
1086
1087       procedure Fully_Qualify_Name (E : Entity_Id) is
1088          Discard : Boolean := False;
1089
1090       begin
1091          --  Ignore empty entry (can happen in error cases)
1092
1093          if No (E) then
1094             return;
1095
1096          --  If this we are qualifying entities local to a generic
1097          --  instance, use the name of the original instantiation,
1098          --  not that of the anonymous subprogram in the wrapper
1099          --  package, so that gdb doesn't have to know about these.
1100
1101          elsif Is_Generic_Instance (E)
1102            and then Is_Subprogram (E)
1103            and then not Comes_From_Source (E)
1104            and then not Is_Compilation_Unit (Scope (E))
1105          then
1106             Fully_Qualify_Name (Related_Instance (Scope (E)));
1107             return;
1108          end if;
1109
1110          --  If we reached fully qualified name, then just copy it
1111
1112          if Has_Fully_Qualified_Name (E) then
1113             Get_Name_String (Chars (E));
1114             Strip_Suffixes (Discard);
1115             Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1116             Full_Qualify_Len := Name_Len;
1117             Set_Has_Fully_Qualified_Name (Ent);
1118
1119          --  Case of non-fully qualified name
1120
1121          else
1122             if Scope (E) = Standard_Standard then
1123                Set_Has_Fully_Qualified_Name (Ent);
1124             else
1125                Fully_Qualify_Name (Scope (E));
1126                Full_Qualify_Name (Full_Qualify_Len + 1) := '_';
1127                Full_Qualify_Name (Full_Qualify_Len + 2) := '_';
1128                Full_Qualify_Len := Full_Qualify_Len + 2;
1129             end if;
1130
1131             if Has_Qualified_Name (E) then
1132                Get_Unqualified_Name_String (Chars (E));
1133             else
1134                Get_Name_String (Chars (E));
1135             end if;
1136
1137             --  Here we do one step of the qualification
1138
1139             Full_Qualify_Name
1140               (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) :=
1141                  Name_Buffer (1 .. Name_Len);
1142             Full_Qualify_Len := Full_Qualify_Len + Name_Len;
1143             Append_Homonym_Number (E);
1144          end if;
1145
1146          if Is_BNPE (E) then
1147             BNPE_Suffix_Needed := True;
1148          end if;
1149       end Fully_Qualify_Name;
1150
1151       -------------
1152       -- Is_BNPE --
1153       -------------
1154
1155       function Is_BNPE (S : Entity_Id) return Boolean is
1156       begin
1157          return
1158            Ekind (S) = E_Package
1159              and then Is_Package_Body_Entity (S);
1160       end Is_BNPE;
1161
1162       --------------------
1163       -- Qualify_Needed --
1164       --------------------
1165
1166       function Qualify_Needed (S : Entity_Id) return Boolean is
1167       begin
1168          --  If we got all the way to Standard, then we have certainly
1169          --  fully qualified the name, so set the flag appropriately,
1170          --  and then return False, since we are most certainly done!
1171
1172          if S = Standard_Standard then
1173             Set_Has_Fully_Qualified_Name (Ent, True);
1174             return False;
1175
1176          --  Otherwise figure out if further qualification is required
1177
1178          else
1179             return
1180               Is_Subprogram (Ent)
1181                 or else
1182               Ekind (Ent) = E_Subprogram_Body
1183                 or else
1184                   (Ekind (S) /= E_Block
1185                     and then not Is_Dynamic_Scope (S));
1186          end if;
1187       end Qualify_Needed;
1188
1189       ---------------------
1190       -- Set_BNPE_Suffix --
1191       ---------------------
1192
1193       procedure Set_BNPE_Suffix (E : Entity_Id) is
1194          S : constant Entity_Id := Scope (E);
1195
1196       begin
1197          if Qualify_Needed (S) then
1198             Set_BNPE_Suffix (S);
1199
1200             if Is_BNPE (E) then
1201                Add_Char_To_Name_Buffer ('b');
1202             else
1203                Add_Char_To_Name_Buffer ('n');
1204             end if;
1205
1206          else
1207             Add_Char_To_Name_Buffer ('X');
1208          end if;
1209       end Set_BNPE_Suffix;
1210
1211       ---------------------
1212       -- Set_Entity_Name --
1213       ---------------------
1214
1215       procedure Set_Entity_Name (E : Entity_Id) is
1216          S : constant Entity_Id := Scope (E);
1217
1218       begin
1219          --  If we reach an already qualified name, just take the encoding
1220          --  except that we strip the package body suffixes, since these
1221          --  will be separately put on later.
1222
1223          if Has_Qualified_Name (E) then
1224             Get_Name_String_And_Append (Chars (E));
1225             Strip_Suffixes (BNPE_Suffix_Needed);
1226
1227             --  If the top level name we are adding is itself fully
1228             --  qualified, then that means that the name that we are
1229             --  preparing for the Fully_Qualify_Name call will also
1230             --  generate a fully qualified name.
1231
1232             if Has_Fully_Qualified_Name (E) then
1233                Set_Has_Fully_Qualified_Name (Ent);
1234             end if;
1235
1236          --  Case where upper level name is not encoded yet
1237
1238          else
1239             --  Recurse if further qualification required
1240
1241             if Qualify_Needed (S) then
1242                Set_Entity_Name (S);
1243                Add_Str_To_Name_Buffer ("__");
1244             end if;
1245
1246             --  Otherwise get name and note if it is a BNPE
1247
1248             Get_Name_String_And_Append (Chars (E));
1249
1250             if Is_BNPE (E) then
1251                BNPE_Suffix_Needed := True;
1252             end if;
1253
1254             Append_Homonym_Number (E);
1255          end if;
1256       end Set_Entity_Name;
1257
1258    --  Start of processing for Qualify_Entity_Name
1259
1260    begin
1261       if Has_Qualified_Name (Ent) then
1262          return;
1263
1264       --  If the entity is a variable encoding the debug name for an object
1265       --  renaming, then the qualified name of the entity associated with the
1266       --  renamed object can now be incorporated in the debug name.
1267
1268       elsif Ekind (Ent) = E_Variable
1269         and then Present (Debug_Renaming_Link (Ent))
1270       then
1271          Name_Len := 0;
1272          Qualify_Entity_Name (Debug_Renaming_Link (Ent));
1273          Get_Name_String (Chars (Ent));
1274
1275          --  Retrieve the now-qualified name of the renamed entity and insert
1276          --  it in the middle of the name, just preceding the suffix encoding
1277          --  describing the renamed object.
1278
1279          declare
1280             Renamed_Id : constant String :=
1281                            Get_Name_String (Chars (Debug_Renaming_Link (Ent)));
1282             Insert_Len : constant Integer := Renamed_Id'Length + 1;
1283             Index      : Natural := Name_Len - 3;
1284
1285          begin
1286             --  Loop backwards through the name to find the start of the "___"
1287             --  sequence associated with the suffix.
1288
1289             while Index >= Name_Buffer'First
1290               and then (Name_Buffer (Index + 1) /= '_'
1291                          or else Name_Buffer (Index + 2) /= '_'
1292                          or else Name_Buffer (Index + 3) /= '_')
1293             loop
1294                Index := Index - 1;
1295             end loop;
1296
1297             pragma Assert (Name_Buffer (Index + 1 .. Index + 3) = "___");
1298
1299             --  Insert an underscore separator and the entity name just in
1300             --  front of the suffix.
1301
1302             Name_Buffer (Index + 1 + Insert_Len .. Name_Len + Insert_Len) :=
1303               Name_Buffer (Index + 1 .. Name_Len);
1304             Name_Buffer (Index + 1) := '_';
1305             Name_Buffer (Index + 2 .. Index + Insert_Len) := Renamed_Id;
1306             Name_Len := Name_Len + Insert_Len;
1307          end;
1308
1309          --  Reset the name of the variable to the new name that includes the
1310          --  name of the renamed entity.
1311
1312          Set_Chars (Ent, Name_Enter);
1313
1314          --  If the entity needs qualification by its scope then develop it
1315          --  here, add the variable's name, and again reset the entity name.
1316
1317          if Qualify_Needed (Scope (Ent)) then
1318             Name_Len := 0;
1319             Set_Entity_Name (Scope (Ent));
1320             Add_Str_To_Name_Buffer ("__");
1321
1322             Get_Name_String_And_Append (Chars (Ent));
1323
1324             Set_Chars (Ent, Name_Enter);
1325          end if;
1326
1327          Set_Has_Qualified_Name (Ent);
1328          return;
1329
1330       elsif Is_Subprogram (Ent)
1331         or else Ekind (Ent) = E_Subprogram_Body
1332         or else Is_Type (Ent)
1333       then
1334          Fully_Qualify_Name (Ent);
1335          Name_Len := Full_Qualify_Len;
1336          Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
1337
1338       elsif Qualify_Needed (Scope (Ent)) then
1339          Name_Len := 0;
1340          Set_Entity_Name (Ent);
1341
1342       else
1343          Set_Has_Qualified_Name (Ent);
1344          return;
1345       end if;
1346
1347       --  Fall through with a fully qualified name in Name_Buffer/Name_Len
1348
1349       Output_Homonym_Numbers_Suffix;
1350
1351       --  Add body-nested package suffix if required
1352
1353       if BNPE_Suffix_Needed
1354         and then Ekind (Ent) /= E_Enumeration_Literal
1355       then
1356          Set_BNPE_Suffix (Ent);
1357
1358          --  Strip trailing n's and last trailing b as required. note that
1359          --  we know there is at least one b, or no suffix would be generated.
1360
1361          while Name_Buffer (Name_Len) = 'n' loop
1362             Name_Len := Name_Len - 1;
1363          end loop;
1364
1365          Name_Len := Name_Len - 1;
1366       end if;
1367
1368       Set_Chars (Ent, Name_Enter);
1369       Set_Has_Qualified_Name (Ent);
1370
1371       if Debug_Flag_BB then
1372          Write_Str ("*** ");
1373          Write_Name (Save_Chars);
1374          Write_Str (" qualified as ");
1375          Write_Name (Chars (Ent));
1376          Write_Eol;
1377       end if;
1378    end Qualify_Entity_Name;
1379
1380    --------------------------
1381    -- Qualify_Entity_Names --
1382    --------------------------
1383
1384    procedure Qualify_Entity_Names (N : Node_Id) is
1385    begin
1386       Name_Qualify_Units.Append (N);
1387    end Qualify_Entity_Names;
1388
1389    --------------------
1390    -- Strip_Suffixes --
1391    --------------------
1392
1393    procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is
1394       SL : Natural;
1395
1396       pragma Warnings (Off, BNPE_Suffix_Found);
1397       --  Since this procedure only ever sets the flag
1398
1399    begin
1400       --  Search for and strip BNPE suffix
1401
1402       for J in reverse 2 .. Name_Len loop
1403          if Name_Buffer (J) = 'X' then
1404             Name_Len := J - 1;
1405             BNPE_Suffix_Found := True;
1406             exit;
1407          end if;
1408
1409          exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n';
1410       end loop;
1411
1412       --  Search for and strip homonym numbers suffix
1413
1414       for J in reverse 2 .. Name_Len - 2 loop
1415          if Name_Buffer (J) = '_'
1416            and then Name_Buffer (J + 1) = '_'
1417          then
1418             if Name_Buffer (J + 2) in '0' .. '9' then
1419                if Homonym_Len > 0 then
1420                   Homonym_Len := Homonym_Len + 1;
1421                   Homonym_Numbers (Homonym_Len) := '-';
1422                end if;
1423
1424                SL := Name_Len - (J + 1);
1425
1426                Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) :=
1427                  Name_Buffer (J + 2 .. Name_Len);
1428                Name_Len := J - 1;
1429                Homonym_Len := Homonym_Len + SL;
1430             end if;
1431
1432             exit;
1433          end if;
1434       end loop;
1435    end Strip_Suffixes;
1436
1437 end Exp_Dbug;