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