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-2009, 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)
 533                    and then E = Base_Type (E))
 534
 535       --  Or if this is a dummy type for a renaming
 536
 537         or else (Name_Len >= 3 and then
 538                    Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR")
 539
 540         or else (Name_Len >= 4 and then
 541                    (Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
 542                       or else
 543                     Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"))
 544
 545       --  For all these cases, just return the name unchanged
 546
 547       then
 548          Name_Buffer (Name_Len + 1) := ASCII.NUL;
 549          return;
 550       end if;
 551
 552       Has_Suffix := True;
 553
 554       --  Fixed-point case
 555
 556       if Is_Fixed_Point_Type (E) then
 557          Get_External_Name_With_Suffix (E, "XF_");
 558          Add_Real_To_Buffer (Delta_Value (E));
 559
 560          if Small_Value (E) /= Delta_Value (E) then
 561             Add_Str_To_Name_Buffer ("_");
 562             Add_Real_To_Buffer (Small_Value (E));
 563          end if;
 564
 565       --  Vax floating-point case
 566
 567       elsif Vax_Float (E) then
 568          if Digits_Value (Base_Type (E)) = 6 then
 569             Get_External_Name_With_Suffix (E, "XFF");
 570
 571          elsif Digits_Value (Base_Type (E)) = 9 then
 572             Get_External_Name_With_Suffix (E, "XFF");
 573
 574          else
 575             pragma Assert (Digits_Value (Base_Type (E)) = 15);
 576             Get_External_Name_With_Suffix (E, "XFG");
 577          end if;
 578
 579       --  Discrete case where bounds do not match size
 580
 581       elsif Is_Discrete_Type (E)
 582         and then not Bounds_Match_Size (E)
 583       then
 584          declare
 585             Lo : constant Node_Id := Type_Low_Bound (E);
 586             Hi : constant Node_Id := Type_High_Bound (E);
 587
 588             Lo_Con : constant Boolean := Compile_Time_Known_Value (Lo);
 589             Hi_Con : constant Boolean := Compile_Time_Known_Value (Hi);
 590
 591             Lo_Discr : constant Boolean :=
 592                          Nkind (Lo) = N_Identifier
 593                            and then
 594                          Ekind (Entity (Lo)) = E_Discriminant;
 595
 596             Hi_Discr : constant Boolean :=
 597                          Nkind (Hi) = N_Identifier
 598                            and then
 599                          Ekind (Entity (Hi)) = E_Discriminant;
 600
 601             Lo_Encode : constant Boolean := Lo_Con or Lo_Discr;
 602             Hi_Encode : constant Boolean := Hi_Con or Hi_Discr;
 603
 604             Biased : constant Boolean := Has_Biased_Representation (E);
 605
 606          begin
 607             if Biased then
 608                Get_External_Name_With_Suffix (E, "XB");
 609             else
 610                Get_External_Name_With_Suffix (E, "XD");
 611             end if;
 612
 613             if Lo_Encode or Hi_Encode then
 614                if Biased then
 615                   Add_Str_To_Name_Buffer ("_");
 616                else
 617                   if Lo_Encode then
 618                      if Hi_Encode then
 619                         Add_Str_To_Name_Buffer ("LU_");
 620                      else
 621                         Add_Str_To_Name_Buffer ("L_");
 622                      end if;
 623                   else
 624                      Add_Str_To_Name_Buffer ("U_");
 625                   end if;
 626                end if;
 627
 628                if Lo_Con then
 629                   Add_Uint_To_Buffer (Expr_Rep_Value (Lo));
 630                elsif Lo_Discr then
 631                   Get_Name_String_And_Append (Chars (Entity (Lo)));
 632                end if;
 633
 634                if Lo_Encode and Hi_Encode then
 635                   Add_Str_To_Name_Buffer ("__");
 636                end if;
 637
 638                if Hi_Con then
 639                   Add_Uint_To_Buffer (Expr_Rep_Value (Hi));
 640                elsif Hi_Discr then
 641                   Get_Name_String_And_Append (Chars (Entity (Hi)));
 642                end if;
 643             end if;
 644          end;
 645
 646       --  For all other cases, the encoded name is the normal type name
 647
 648       else
 649          Has_Suffix := False;
 650          Get_External_Name (E, Has_Suffix);
 651       end if;
 652
 653       if Debug_Flag_B and then Has_Suffix then
 654          Write_Str ("**** type ");
 655          Write_Name (Chars (E));
 656          Write_Str (" is encoded as ");
 657          Write_Str (Name_Buffer (1 .. Name_Len));
 658          Write_Eol;
 659       end if;
 660
 661       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 662    end Get_Encoded_Name;
 663
 664    -----------------------
 665    -- Get_External_Name --
 666    -----------------------
 667
 668    procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean) is
 669       E    : Entity_Id := Entity;
 670       Kind : Entity_Kind;
 671
 672       procedure Get_Qualified_Name_And_Append (Entity : Entity_Id);
 673       --  Appends fully qualified name of given entity to Name_Buffer
 674
 675       -----------------------------------
 676       -- Get_Qualified_Name_And_Append --
 677       -----------------------------------
 678
 679       procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is
 680       begin
 681          --  If the entity is a compilation unit, its scope is Standard,
 682          --  there is no outer scope, and the no further qualification
 683          --  is required.
 684
 685          --  If the front end has already computed a fully qualified name,
 686          --  then it is also the case that no further qualification is
 687          --  required.
 688
 689          if Present (Scope (Scope (Entity)))
 690            and then not Has_Fully_Qualified_Name (Entity)
 691          then
 692             Get_Qualified_Name_And_Append (Scope (Entity));
 693             Add_Str_To_Name_Buffer ("__");
 694             Get_Name_String_And_Append (Chars (Entity));
 695             Append_Homonym_Number (Entity);
 696
 697          else
 698             Get_Name_String_And_Append (Chars (Entity));
 699          end if;
 700       end Get_Qualified_Name_And_Append;
 701
 702    --  Start of processing for Get_External_Name
 703
 704    begin
 705       Name_Len    := 0;
 706       Homonym_Len := 0;
 707
 708       --  If this is a child unit, we want the child
 709
 710       if Nkind (E) = N_Defining_Program_Unit_Name then
 711          E := Defining_Identifier (Entity);
 712       end if;
 713
 714       Kind := Ekind (E);
 715
 716       --  Case of interface name being used
 717
 718       if (Kind = E_Procedure or else
 719           Kind = E_Function  or else
 720           Kind = E_Constant  or else
 721           Kind = E_Variable  or else
 722           Kind = E_Exception)
 723         and then Present (Interface_Name (E))
 724         and then No (Address_Clause (E))
 725         and then not Has_Suffix
 726       then
 727          Add_String_To_Name_Buffer (Strval (Interface_Name (E)));
 728
 729       --  All other cases besides the interface name case
 730
 731       else
 732          --  If this is a library level subprogram (i.e. a subprogram that is a
 733          --  compilation unit other than a subunit), then we prepend _ada_ to
 734          --  ensure distinctions required as described in the spec.
 735
 736          --  Check explicitly for child units, because those are not flagged
 737          --  as Compilation_Units by lib. Should they be ???
 738
 739          if Is_Subprogram (E)
 740            and then (Is_Compilation_Unit (E) or Is_Child_Unit (E))
 741            and then not Has_Suffix
 742          then
 743             Add_Str_To_Name_Buffer ("_ada_");
 744          end if;
 745
 746          --  If the entity is a subprogram instance that is not a compilation
 747          --  unit, generate the name of the original Ada entity, which is the
 748          --  one gdb needs.
 749
 750          if Is_Generic_Instance (E)
 751            and then Is_Subprogram (E)
 752            and then not Is_Compilation_Unit (Scope (E))
 753            and then (Ekind (Scope (E)) = E_Package
 754                       or else
 755                      Ekind (Scope (E)) = E_Package_Body)
 756            and then Present (Related_Instance (Scope (E)))
 757          then
 758             E := Related_Instance (Scope (E));
 759          end if;
 760
 761          Get_Qualified_Name_And_Append (E);
 762       end if;
 763
 764       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 765    end Get_External_Name;
 766
 767    -----------------------------------
 768    -- Get_External_Name_With_Suffix --
 769    -----------------------------------
 770
 771    procedure Get_External_Name_With_Suffix
 772      (Entity : Entity_Id;
 773       Suffix : String)
 774    is
 775       Has_Suffix : constant Boolean := (Suffix /= "");
 776
 777    begin
 778       --  If we are not in code generation mode, this procedure may still be
 779       --  called from Back_End (more specifically - from gigi for doing type
 780       --  representation annotation or some representation-specific checks).
 781       --  But in this mode there is no need to mess with external names.
 782
 783       --  Furthermore, the call causes difficulties in this case because the
 784       --  string representing the homonym number is not correctly reset as a
 785       --  part of the call to Output_Homonym_Numbers_Suffix (which is not
 786       --  called in gigi).
 787
 788       if Operating_Mode /= Generate_Code then
 789          return;
 790       end if;
 791
 792       Get_External_Name (Entity, Has_Suffix);
 793
 794       if Has_Suffix then
 795          Add_Str_To_Name_Buffer ("___");
 796          Add_Str_To_Name_Buffer (Suffix);
 797          Name_Buffer (Name_Len + 1) := ASCII.NUL;
 798       end if;
 799    end Get_External_Name_With_Suffix;
 800
 801    --------------------------
 802    -- Get_Variant_Encoding --
 803    --------------------------
 804
 805    procedure Get_Variant_Encoding (V : Node_Id) is
 806       Choice : Node_Id;
 807
 808       procedure Choice_Val (Typ : Character; Choice : Node_Id);
 809       --  Output encoded value for a single choice value. Typ is the key
 810       --  character ('S', 'F', or 'T') that precedes the choice value.
 811
 812       ----------------
 813       -- Choice_Val --
 814       ----------------
 815
 816       procedure Choice_Val (Typ : Character; Choice : Node_Id) is
 817       begin
 818          if Nkind (Choice) = N_Integer_Literal then
 819             Add_Char_To_Name_Buffer (Typ);
 820             Add_Uint_To_Buffer (Intval (Choice));
 821
 822          --  Character literal with no entity present (this is the case
 823          --  Standard.Character or Standard.Wide_Character as root type)
 824
 825          elsif Nkind (Choice) = N_Character_Literal
 826            and then No (Entity (Choice))
 827          then
 828             Add_Char_To_Name_Buffer (Typ);
 829             Add_Uint_To_Buffer (Char_Literal_Value (Choice));
 830
 831          else
 832             declare
 833                Ent : constant Entity_Id := Entity (Choice);
 834
 835             begin
 836                if Ekind (Ent) = E_Enumeration_Literal then
 837                   Add_Char_To_Name_Buffer (Typ);
 838                   Add_Uint_To_Buffer (Enumeration_Rep (Ent));
 839
 840                else
 841                   pragma Assert (Ekind (Ent) = E_Constant);
 842                   Choice_Val (Typ, Constant_Value (Ent));
 843                end if;
 844             end;
 845          end if;
 846       end Choice_Val;
 847
 848    --  Start of processing for Get_Variant_Encoding
 849
 850    begin
 851       Name_Len := 0;
 852
 853       Choice := First (Discrete_Choices (V));
 854       while Present (Choice) loop
 855          if Nkind (Choice) = N_Others_Choice then
 856             Add_Char_To_Name_Buffer ('O');
 857
 858          elsif Nkind (Choice) = N_Range then
 859             Choice_Val ('R', Low_Bound (Choice));
 860             Choice_Val ('T', High_Bound (Choice));
 861
 862          elsif Is_Entity_Name (Choice)
 863            and then Is_Type (Entity (Choice))
 864          then
 865             Choice_Val ('R', Type_Low_Bound (Entity (Choice)));
 866             Choice_Val ('T', Type_High_Bound (Entity (Choice)));
 867
 868          elsif Nkind (Choice) = N_Subtype_Indication then
 869             declare
 870                Rang : constant Node_Id :=
 871                         Range_Expression (Constraint (Choice));
 872             begin
 873                Choice_Val ('R', Low_Bound (Rang));
 874                Choice_Val ('T', High_Bound (Rang));
 875             end;
 876
 877          else
 878             Choice_Val ('S', Choice);
 879          end if;
 880
 881          Next (Choice);
 882       end loop;
 883
 884       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 885
 886       if Debug_Flag_B then
 887          declare
 888             VP : constant Node_Id := Parent (V);    -- Variant_Part
 889             CL : constant Node_Id := Parent (VP);   -- Component_List
 890             RD : constant Node_Id := Parent (CL);   -- Record_Definition
 891             FT : constant Node_Id := Parent (RD);   -- Full_Type_Declaration
 892
 893          begin
 894             Write_Str ("**** variant for type ");
 895             Write_Name (Chars (Defining_Identifier (FT)));
 896             Write_Str (" is encoded as ");
 897             Write_Str (Name_Buffer (1 .. Name_Len));
 898             Write_Eol;
 899          end;
 900       end if;
 901    end Get_Variant_Encoding;
 902
 903    ------------------------------------
 904    -- Get_Secondary_DT_External_Name --
 905    ------------------------------------
 906
 907    procedure Get_Secondary_DT_External_Name
 908      (Typ          : Entity_Id;
 909       Ancestor_Typ : Entity_Id;
 910       Suffix_Index : Int)
 911    is
 912    begin
 913       Get_External_Name (Typ, Has_Suffix => False);
 914
 915       if Ancestor_Typ /= Typ then
 916          declare
 917             Len      : constant Natural := Name_Len;
 918             Save_Str : constant String (1 .. Name_Len)
 919                          := Name_Buffer (1 .. Name_Len);
 920          begin
 921             Get_External_Name (Ancestor_Typ, Has_Suffix => False);
 922
 923             --  Append the extended name of the ancestor to the
 924             --  extended name of Typ
 925
 926             Name_Buffer (Len + 2 .. Len + Name_Len + 1) :=
 927               Name_Buffer (1 .. Name_Len);
 928             Name_Buffer (1 .. Len) := Save_Str;
 929             Name_Buffer (Len + 1) := '_';
 930             Name_Len := Len + Name_Len + 1;
 931          end;
 932       end if;
 933
 934       Add_Nat_To_Name_Buffer (Suffix_Index);
 935    end Get_Secondary_DT_External_Name;
 936
 937    ---------------------------------
 938    -- Make_Packed_Array_Type_Name --
 939    ---------------------------------
 940
 941    function Make_Packed_Array_Type_Name
 942      (Typ   : Entity_Id;
 943       Csize : Uint)
 944       return  Name_Id
 945    is
 946    begin
 947       Get_Name_String (Chars (Typ));
 948       Add_Str_To_Name_Buffer ("___XP");
 949       Add_Uint_To_Buffer (Csize);
 950       return Name_Find;
 951    end Make_Packed_Array_Type_Name;
 952
 953    -----------------------------------
 954    -- Output_Homonym_Numbers_Suffix --
 955    -----------------------------------
 956
 957    procedure Output_Homonym_Numbers_Suffix is
 958       J : Natural;
 959
 960    begin
 961       if Homonym_Len > 0 then
 962
 963          --  Check for all 1's, in which case we do not output
 964
 965          J := 1;
 966          loop
 967             exit when Homonym_Numbers (J) /= '1';
 968
 969             --  If we reached end of string we do not output
 970
 971             if J = Homonym_Len then
 972                Homonym_Len := 0;
 973                return;
 974             end if;
 975
 976             exit when Homonym_Numbers (J + 1) /= '_';
 977             J := J + 2;
 978          end loop;
 979
 980          --  If we exit the loop then suffix must be output
 981
 982          Add_Str_To_Name_Buffer ("__");
 983          Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len));
 984          Homonym_Len := 0;
 985       end if;
 986    end Output_Homonym_Numbers_Suffix;
 987
 988    ------------------------------
 989    -- Prepend_String_To_Buffer --
 990    ------------------------------
 991
 992    procedure Prepend_String_To_Buffer (S : String) is
 993       N : constant Integer := S'Length;
 994    begin
 995       Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len);
 996       Name_Buffer (1 .. N) := S;
 997       Name_Len := Name_Len + N;
 998    end Prepend_String_To_Buffer;
 999
1000    ----------------------------
1001    -- Prepend_Uint_To_Buffer --
1002    ----------------------------
1003
1004    procedure Prepend_Uint_To_Buffer (U : Uint) is
1005    begin
1006       if U < 0 then
1007          Prepend_String_To_Buffer ("m");
1008          Prepend_Uint_To_Buffer (-U);
1009       else
1010          UI_Image (U, Decimal);
1011          Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
1012       end if;
1013    end Prepend_Uint_To_Buffer;
1014
1015    ------------------------------
1016    -- Qualify_All_Entity_Names --
1017    ------------------------------
1018
1019    procedure Qualify_All_Entity_Names is
1020       E   : Entity_Id;
1021       Ent : Entity_Id;
1022
1023    begin
1024       for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
1025          E := Defining_Entity (Name_Qualify_Units.Table (J));
1026          Qualify_Entity_Name (E);
1027
1028          --  Normally entities in the qualification list are scopes, but in the
1029          --  case of a library-level package renaming there is an associated
1030          --  variable that encodes the debugger name and that variable is
1031          --  entered in the list since it occurs in the Aux_Decls list of the
1032          --  compilation and doesn't have a normal scope.
1033
1034          if Ekind (E) /= E_Variable then
1035             Ent := First_Entity (E);
1036             while Present (Ent) loop
1037                Qualify_Entity_Name (Ent);
1038                Next_Entity (Ent);
1039
1040                --  There are odd cases where Last_Entity (E) = E. This happens
1041                --  in the case of renaming of packages. This test avoids
1042                --  getting stuck in such cases.
1043
1044                exit when Ent = E;
1045             end loop;
1046          end if;
1047       end loop;
1048    end Qualify_All_Entity_Names;
1049
1050    -------------------------
1051    -- Qualify_Entity_Name --
1052    -------------------------
1053
1054    procedure Qualify_Entity_Name (Ent : Entity_Id) is
1055
1056       Full_Qualify_Name : String (1 .. Name_Buffer'Length);
1057       Full_Qualify_Len  : Natural := 0;
1058       --  Used to accumulate fully qualified name of subprogram
1059
1060       procedure Fully_Qualify_Name (E : Entity_Id);
1061       --  Used to qualify a subprogram or type name, where full
1062       --  qualification up to Standard is always used. Name is set
1063       --  in Full_Qualify_Name with the length in Full_Qualify_Len.
1064       --  Note that this routine does not prepend the _ada_ string
1065       --  required for library subprograms (this is done in the back end).
1066
1067       function Is_BNPE (S : Entity_Id) return Boolean;
1068       --  Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
1069       --  is defined to be a package which is immediately nested within a
1070       --  package body.
1071
1072       function Qualify_Needed (S : Entity_Id) return Boolean;
1073       --  Given a scope, determines if the scope is to be included in the
1074       --  fully qualified name, True if so, False if not.
1075
1076       procedure Set_BNPE_Suffix (E : Entity_Id);
1077       --  Recursive routine to append the BNPE qualification suffix. Works
1078       --  from right to left with E being the current entity in the list.
1079       --  The result does NOT have the trailing n's and trailing b stripped.
1080       --  The caller must do this required stripping.
1081
1082       procedure Set_Entity_Name (E : Entity_Id);
1083       --  Internal recursive routine that does most of the work. This routine
1084       --  leaves the result sitting in Name_Buffer and Name_Len.
1085
1086       BNPE_Suffix_Needed : Boolean := False;
1087       --  Set true if a body-nested package entity suffix is required
1088
1089       Save_Chars : constant Name_Id := Chars (Ent);
1090       --  Save original name
1091
1092       ------------------------
1093       -- Fully_Qualify_Name --
1094       ------------------------
1095
1096       procedure Fully_Qualify_Name (E : Entity_Id) is
1097          Discard : Boolean := False;
1098
1099       begin
1100          --  Ignore empty entry (can happen in error cases)
1101
1102          if No (E) then
1103             return;
1104
1105          --  If this we are qualifying entities local to a generic
1106          --  instance, use the name of the original instantiation,
1107          --  not that of the anonymous subprogram in the wrapper
1108          --  package, so that gdb doesn't have to know about these.
1109
1110          elsif Is_Generic_Instance (E)
1111            and then Is_Subprogram (E)
1112            and then not Comes_From_Source (E)
1113            and then not Is_Compilation_Unit (Scope (E))
1114          then
1115             Fully_Qualify_Name (Related_Instance (Scope (E)));
1116             return;
1117          end if;
1118
1119          --  If we reached fully qualified name, then just copy it
1120
1121          if Has_Fully_Qualified_Name (E) then
1122             Get_Name_String (Chars (E));
1123             Strip_Suffixes (Discard);
1124             Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1125             Full_Qualify_Len := Name_Len;
1126             Set_Has_Fully_Qualified_Name (Ent);
1127
1128          --  Case of non-fully qualified name
1129
1130          else
1131             if Scope (E) = Standard_Standard then
1132                Set_Has_Fully_Qualified_Name (Ent);
1133             else
1134                Fully_Qualify_Name (Scope (E));
1135                Full_Qualify_Name (Full_Qualify_Len + 1) := '_';
1136                Full_Qualify_Name (Full_Qualify_Len + 2) := '_';
1137                Full_Qualify_Len := Full_Qualify_Len + 2;
1138             end if;
1139
1140             if Has_Qualified_Name (E) then
1141                Get_Unqualified_Name_String (Chars (E));
1142             else
1143                Get_Name_String (Chars (E));
1144             end if;
1145
1146             --  Here we do one step of the qualification
1147
1148             Full_Qualify_Name
1149               (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) :=
1150                  Name_Buffer (1 .. Name_Len);
1151             Full_Qualify_Len := Full_Qualify_Len + Name_Len;
1152             Append_Homonym_Number (E);
1153          end if;
1154
1155          if Is_BNPE (E) then
1156             BNPE_Suffix_Needed := True;
1157          end if;
1158       end Fully_Qualify_Name;
1159
1160       -------------
1161       -- Is_BNPE --
1162       -------------
1163
1164       function Is_BNPE (S : Entity_Id) return Boolean is
1165       begin
1166          return
1167            Ekind (S) = E_Package
1168              and then Is_Package_Body_Entity (S);
1169       end Is_BNPE;
1170
1171       --------------------
1172       -- Qualify_Needed --
1173       --------------------
1174
1175       function Qualify_Needed (S : Entity_Id) return Boolean is
1176       begin
1177          --  If we got all the way to Standard, then we have certainly
1178          --  fully qualified the name, so set the flag appropriately,
1179          --  and then return False, since we are most certainly done!
1180
1181          if S = Standard_Standard then
1182             Set_Has_Fully_Qualified_Name (Ent, True);
1183             return False;
1184
1185          --  Otherwise figure out if further qualification is required
1186
1187          else
1188             return
1189               Is_Subprogram (Ent)
1190                 or else
1191               Ekind (Ent) = E_Subprogram_Body
1192                 or else
1193                   (Ekind (S) /= E_Block
1194                     and then not Is_Dynamic_Scope (S));
1195          end if;
1196       end Qualify_Needed;
1197
1198       ---------------------
1199       -- Set_BNPE_Suffix --
1200       ---------------------
1201
1202       procedure Set_BNPE_Suffix (E : Entity_Id) is
1203          S : constant Entity_Id := Scope (E);
1204
1205       begin
1206          if Qualify_Needed (S) then
1207             Set_BNPE_Suffix (S);
1208
1209             if Is_BNPE (E) then
1210                Add_Char_To_Name_Buffer ('b');
1211             else
1212                Add_Char_To_Name_Buffer ('n');
1213             end if;
1214
1215          else
1216             Add_Char_To_Name_Buffer ('X');
1217          end if;
1218       end Set_BNPE_Suffix;
1219
1220       ---------------------
1221       -- Set_Entity_Name --
1222       ---------------------
1223
1224       procedure Set_Entity_Name (E : Entity_Id) is
1225          S : constant Entity_Id := Scope (E);
1226
1227       begin
1228          --  If we reach an already qualified name, just take the encoding
1229          --  except that we strip the package body suffixes, since these
1230          --  will be separately put on later.
1231
1232          if Has_Qualified_Name (E) then
1233             Get_Name_String_And_Append (Chars (E));
1234             Strip_Suffixes (BNPE_Suffix_Needed);
1235
1236             --  If the top level name we are adding is itself fully
1237             --  qualified, then that means that the name that we are
1238             --  preparing for the Fully_Qualify_Name call will also
1239             --  generate a fully qualified name.
1240
1241             if Has_Fully_Qualified_Name (E) then
1242                Set_Has_Fully_Qualified_Name (Ent);
1243             end if;
1244
1245          --  Case where upper level name is not encoded yet
1246
1247          else
1248             --  Recurse if further qualification required
1249
1250             if Qualify_Needed (S) then
1251                Set_Entity_Name (S);
1252                Add_Str_To_Name_Buffer ("__");
1253             end if;
1254
1255             --  Otherwise get name and note if it is a BNPE
1256
1257             Get_Name_String_And_Append (Chars (E));
1258
1259             if Is_BNPE (E) then
1260                BNPE_Suffix_Needed := True;
1261             end if;
1262
1263             Append_Homonym_Number (E);
1264          end if;
1265       end Set_Entity_Name;
1266
1267    --  Start of processing for Qualify_Entity_Name
1268
1269    begin
1270       if Has_Qualified_Name (Ent) then
1271          return;
1272
1273       --  If the entity is a variable encoding the debug name for an object
1274       --  renaming, then the qualified name of the entity associated with the
1275       --  renamed object can now be incorporated in the debug name.
1276
1277       elsif Ekind (Ent) = E_Variable
1278         and then Present (Debug_Renaming_Link (Ent))
1279       then
1280          Name_Len := 0;
1281          Qualify_Entity_Name (Debug_Renaming_Link (Ent));
1282          Get_Name_String (Chars (Ent));
1283
1284          --  Retrieve the now-qualified name of the renamed entity and insert
1285          --  it in the middle of the name, just preceding the suffix encoding
1286          --  describing the renamed object.
1287
1288          declare
1289             Renamed_Id : constant String :=
1290                            Get_Name_String (Chars (Debug_Renaming_Link (Ent)));
1291             Insert_Len : constant Integer := Renamed_Id'Length + 1;
1292             Index      : Natural := Name_Len - 3;
1293
1294          begin
1295             --  Loop backwards through the name to find the start of the "___"
1296             --  sequence associated with the suffix.
1297
1298             while Index >= Name_Buffer'First
1299               and then (Name_Buffer (Index + 1) /= '_'
1300                          or else Name_Buffer (Index + 2) /= '_'
1301                          or else Name_Buffer (Index + 3) /= '_')
1302             loop
1303                Index := Index - 1;
1304             end loop;
1305
1306             pragma Assert (Name_Buffer (Index + 1 .. Index + 3) = "___");
1307
1308             --  Insert an underscore separator and the entity name just in
1309             --  front of the suffix.
1310
1311             Name_Buffer (Index + 1 + Insert_Len .. Name_Len + Insert_Len) :=
1312               Name_Buffer (Index + 1 .. Name_Len);
1313             Name_Buffer (Index + 1) := '_';
1314             Name_Buffer (Index + 2 .. Index + Insert_Len) := Renamed_Id;
1315             Name_Len := Name_Len + Insert_Len;
1316          end;
1317
1318          --  Reset the name of the variable to the new name that includes the
1319          --  name of the renamed entity.
1320
1321          Set_Chars (Ent, Name_Enter);
1322
1323          --  If the entity needs qualification by its scope then develop it
1324          --  here, add the variable's name, and again reset the entity name.
1325
1326          if Qualify_Needed (Scope (Ent)) then
1327             Name_Len := 0;
1328             Set_Entity_Name (Scope (Ent));
1329             Add_Str_To_Name_Buffer ("__");
1330
1331             Get_Name_String_And_Append (Chars (Ent));
1332
1333             Set_Chars (Ent, Name_Enter);
1334          end if;
1335
1336          Set_Has_Qualified_Name (Ent);
1337          return;
1338
1339       elsif Is_Subprogram (Ent)
1340         or else Ekind (Ent) = E_Subprogram_Body
1341         or else Is_Type (Ent)
1342       then
1343          Fully_Qualify_Name (Ent);
1344          Name_Len := Full_Qualify_Len;
1345          Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
1346
1347       elsif Qualify_Needed (Scope (Ent)) then
1348          Name_Len := 0;
1349          Set_Entity_Name (Ent);
1350
1351       else
1352          Set_Has_Qualified_Name (Ent);
1353          return;
1354       end if;
1355
1356       --  Fall through with a fully qualified name in Name_Buffer/Name_Len
1357
1358       Output_Homonym_Numbers_Suffix;
1359
1360       --  Add body-nested package suffix if required
1361
1362       if BNPE_Suffix_Needed
1363         and then Ekind (Ent) /= E_Enumeration_Literal
1364       then
1365          Set_BNPE_Suffix (Ent);
1366
1367          --  Strip trailing n's and last trailing b as required. note that
1368          --  we know there is at least one b, or no suffix would be generated.
1369
1370          while Name_Buffer (Name_Len) = 'n' loop
1371             Name_Len := Name_Len - 1;
1372          end loop;
1373
1374          Name_Len := Name_Len - 1;
1375       end if;
1376
1377       Set_Chars (Ent, Name_Enter);
1378       Set_Has_Qualified_Name (Ent);
1379
1380       if Debug_Flag_BB then
1381          Write_Str ("*** ");
1382          Write_Name (Save_Chars);
1383          Write_Str (" qualified as ");
1384          Write_Name (Chars (Ent));
1385          Write_Eol;
1386       end if;
1387    end Qualify_Entity_Name;
1388
1389    --------------------------
1390    -- Qualify_Entity_Names --
1391    --------------------------
1392
1393    procedure Qualify_Entity_Names (N : Node_Id) is
1394    begin
1395       Name_Qualify_Units.Append (N);
1396    end Qualify_Entity_Names;
1397
1398    --------------------
1399    -- Strip_Suffixes --
1400    --------------------
1401
1402    procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is
1403       SL : Natural;
1404
1405       pragma Warnings (Off, BNPE_Suffix_Found);
1406       --  Since this procedure only ever sets the flag
1407
1408    begin
1409       --  Search for and strip BNPE suffix
1410
1411       for J in reverse 2 .. Name_Len loop
1412          if Name_Buffer (J) = 'X' then
1413             Name_Len := J - 1;
1414             BNPE_Suffix_Found := True;
1415             exit;
1416          end if;
1417
1418          exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n';
1419       end loop;
1420
1421       --  Search for and strip homonym numbers suffix
1422
1423       for J in reverse 2 .. Name_Len - 2 loop
1424          if Name_Buffer (J) = '_'
1425            and then Name_Buffer (J + 1) = '_'
1426          then
1427             if Name_Buffer (J + 2) in '0' .. '9' then
1428                if Homonym_Len > 0 then
1429                   Homonym_Len := Homonym_Len + 1;
1430                   Homonym_Numbers (Homonym_Len) := '-';
1431                end if;
1432
1433                SL := Name_Len - (J + 1);
1434
1435                Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) :=
1436                  Name_Buffer (J + 2 .. Name_Len);
1437                Name_Len := J - 1;
1438                Homonym_Len := Homonym_Len + SL;
1439             end if;
1440
1441             exit;
1442          end if;
1443       end loop;
1444    end Strip_Suffixes;
1445
1446 end Exp_Dbug;