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