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-2006, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Alloc;    use Alloc;
  28 with Atree;    use Atree;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Namet;    use Namet;
  32 with Nlists;   use Nlists;
  33 with Nmake;    use Nmake;
  34 with Opt;      use Opt;
  35 with Output;   use Output;
  36 with Sem_Eval; use Sem_Eval;
  37 with Sem_Util; use Sem_Util;
  38 with Sinfo;    use Sinfo;
  39 with Snames;   use Snames;
  40 with Stand;    use Stand;
  41 with Stringt;  use Stringt;
  42 with Table;
  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       Rnm : Name_Id;
 301       Ren : Node_Id;
 302       Lit : Entity_Id;
 303       Typ : Entity_Id;
 304       Res : Node_Id;
 305       Def : Entity_Id;
 306
 307       function Output_Subscript (N : Node_Id; S : String) return Boolean;
 308       --  Outputs a single subscript value as ?nnn (subscript is compile time
 309       --  known value with value nnn) or as ?e (subscript is local constant
 310       --  with name e), where S supplies the proper string to use for ?.
 311       --  Returns False if the subscript is not of an appropriate type to
 312       --  output in one of these two forms. The result is prepended to the
 313       --  name stored in Name_Buffer.
 314
 315       ----------------------
 316       -- Output_Subscript --
 317       ----------------------
 318
 319       function Output_Subscript (N : Node_Id; S : String) return Boolean is
 320       begin
 321          if Compile_Time_Known_Value (N) then
 322             Prepend_Uint_To_Buffer (Expr_Value (N));
 323
 324          elsif Nkind (N) = N_Identifier
 325            and then Scope (Entity (N)) = Scope (Ent)
 326            and then Ekind (Entity (N)) = E_Constant
 327          then
 328             Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N))));
 329
 330          else
 331             return False;
 332          end if;
 333
 334          Prepend_String_To_Buffer (S);
 335          return True;
 336       end Output_Subscript;
 337
 338    --  Start of processing for Debug_Renaming_Declaration
 339
 340    begin
 341       if not Comes_From_Source (N)
 342         and then not Needs_Debug_Info (Ent)
 343       then
 344          return Empty;
 345       end if;
 346
 347       --  Prepare entity name for type declaration
 348
 349       Get_Name_String (Chars (Ent));
 350
 351       case Nkind (N) is
 352          when N_Object_Renaming_Declaration =>
 353             Add_Str_To_Name_Buffer ("___XR");
 354
 355          when N_Exception_Renaming_Declaration =>
 356             Add_Str_To_Name_Buffer ("___XRE");
 357
 358          when N_Package_Renaming_Declaration =>
 359             Add_Str_To_Name_Buffer ("___XRP");
 360
 361             --  If it is a child unit create a fully qualified name, to
 362             --  disambiguate multiple child units with the same name and
 363             --  different parents.
 364
 365             if Is_Child_Unit (Ent) then
 366                Prepend_String_To_Buffer ("__");
 367                Prepend_String_To_Buffer
 368                  (Get_Name_String (Chars (Scope (Ent))));
 369             end if;
 370
 371          when others =>
 372             return Empty;
 373       end case;
 374
 375       Rnm := Name_Find;
 376
 377       --  Get renamed entity and compute suffix
 378
 379       Name_Len := 0;
 380       Ren := Nam;
 381       loop
 382          case Nkind (Ren) is
 383
 384             when N_Identifier =>
 385                exit;
 386
 387             when N_Expanded_Name =>
 388
 389                --  The entity field for an N_Expanded_Name is on the expanded
 390                --  name node itself, so we are done here too.
 391
 392                exit;
 393
 394             when N_Selected_Component =>
 395                Prepend_String_To_Buffer
 396                  (Get_Name_String (Chars (Selector_Name (Ren))));
 397                Prepend_String_To_Buffer ("XR");
 398                Ren := Prefix (Ren);
 399
 400             when N_Indexed_Component =>
 401                declare
 402                   X : Node_Id := Last (Expressions (Ren));
 403
 404                begin
 405                   while Present (X) loop
 406                      if not Output_Subscript (X, "XS") then
 407                         Set_Materialize_Entity (Ent);
 408                         return Empty;
 409                      end if;
 410
 411                      Prev (X);
 412                   end loop;
 413                end;
 414
 415                Ren := Prefix (Ren);
 416
 417             when N_Slice =>
 418
 419                Typ := Etype (First_Index (Etype (Nam)));
 420
 421                if not Output_Subscript (Type_High_Bound (Typ), "XS") then
 422                   Set_Materialize_Entity (Ent);
 423                   return Empty;
 424                end if;
 425
 426                if not Output_Subscript (Type_Low_Bound  (Typ), "XL") then
 427                   Set_Materialize_Entity (Ent);
 428                   return Empty;
 429                end if;
 430
 431                Ren := Prefix (Ren);
 432
 433             when N_Explicit_Dereference =>
 434                Set_Materialize_Entity (Ent);
 435                Prepend_String_To_Buffer ("XA");
 436                Ren := Prefix (Ren);
 437
 438             --  For now, anything else simply results in no translation
 439
 440             when others =>
 441                Set_Materialize_Entity (Ent);
 442                return Empty;
 443          end case;
 444       end loop;
 445
 446       Prepend_String_To_Buffer ("___XE");
 447
 448       --  For now, the literal name contains only the suffix. The Entity_Id
 449       --  value for the name is used to create a link from this literal name
 450       --  to the renamed entity using the Debug_Renaming_Link field. Then the
 451       --  Qualify_Entity_Name procedure uses this link to create the proper
 452       --  fully qualified name.
 453
 454       --  The reason we do things this way is that we really need to copy the
 455       --  qualification of the renamed entity, and it is really much easier to
 456       --  do this after the renamed entity has itself been fully qualified.
 457
 458       Lit := Make_Defining_Identifier (Loc, Chars => Name_Enter);
 459       Set_Debug_Renaming_Link (Lit, Entity (Ren));
 460
 461       --  Return the appropriate enumeration type
 462
 463       Def := Make_Defining_Identifier (Loc, Chars => Rnm);
 464       Res :=
 465         Make_Full_Type_Declaration (Loc,
 466           Defining_Identifier => Def,
 467           Type_Definition =>
 468             Make_Enumeration_Type_Definition (Loc,
 469               Literals => New_List (Lit)));
 470
 471       Set_Needs_Debug_Info (Def);
 472       Set_Needs_Debug_Info (Lit);
 473
 474       Set_Discard_Names (Defining_Identifier (Res));
 475       return Res;
 476
 477    --  If we get an exception, just figure it is a case that we cannot
 478    --  successfully handle using our current approach, since this is
 479    --  only for debugging, no need to take the compilation with us!
 480
 481    exception
 482       when others =>
 483          return Make_Null_Statement (Loc);
 484    end Debug_Renaming_Declaration;
 485
 486    ----------------------
 487    -- Get_Encoded_Name --
 488    ----------------------
 489
 490    --  Note: see spec for details on encodings
 491
 492    procedure Get_Encoded_Name (E : Entity_Id) is
 493       Has_Suffix : Boolean;
 494
 495    begin
 496       --  If not generating code, there is no need to create encoded
 497       --  names, and problems when the back-end is called to annotate
 498       --  types without full code generation. See comments at beginning
 499       --  of Get_External_Name_With_Suffix for additional details.
 500
 501       if Operating_Mode /= Generate_Code then
 502          return;
 503       end if;
 504
 505       Get_Name_String (Chars (E));
 506
 507       --  Nothing to do if we do not have a type
 508
 509       if not Is_Type (E)
 510
 511       --  Or if this is an enumeration base type
 512
 513         or else (Is_Enumeration_Type (E)
 514                    and then E = Base_Type (E))
 515
 516       --  Or if this is a dummy type for a renaming
 517
 518         or else (Name_Len >= 3 and then
 519                    Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR")
 520
 521         or else (Name_Len >= 4 and then
 522                    (Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
 523                       or else
 524                     Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"))
 525
 526       --  For all these cases, just return the name unchanged
 527
 528       then
 529          Name_Buffer (Name_Len + 1) := ASCII.Nul;
 530          return;
 531       end if;
 532
 533       Has_Suffix := True;
 534
 535       --  Fixed-point case
 536
 537       if Is_Fixed_Point_Type (E) then
 538          Get_External_Name_With_Suffix (E, "XF_");
 539          Add_Real_To_Buffer (Delta_Value (E));
 540
 541          if Small_Value (E) /= Delta_Value (E) then
 542             Add_Str_To_Name_Buffer ("_");
 543             Add_Real_To_Buffer (Small_Value (E));
 544          end if;
 545
 546       --  Vax floating-point case
 547
 548       elsif Vax_Float (E) then
 549
 550          if Digits_Value (Base_Type (E)) = 6 then
 551             Get_External_Name_With_Suffix (E, "XFF");
 552
 553          elsif Digits_Value (Base_Type (E)) = 9 then
 554             Get_External_Name_With_Suffix (E, "XFF");
 555
 556          else
 557             pragma Assert (Digits_Value (Base_Type (E)) = 15);
 558             Get_External_Name_With_Suffix (E, "XFG");
 559          end if;
 560
 561       --  Discrete case where bounds do not match size
 562
 563       elsif Is_Discrete_Type (E)
 564         and then not Bounds_Match_Size (E)
 565       then
 566          declare
 567             Lo : constant Node_Id := Type_Low_Bound (E);
 568             Hi : constant Node_Id := Type_High_Bound (E);
 569
 570             Lo_Con : constant Boolean := Compile_Time_Known_Value (Lo);
 571             Hi_Con : constant Boolean := Compile_Time_Known_Value (Hi);
 572
 573             Lo_Discr : constant Boolean :=
 574                          Nkind (Lo) = N_Identifier
 575                            and then
 576                          Ekind (Entity (Lo)) = E_Discriminant;
 577
 578             Hi_Discr : constant Boolean :=
 579                          Nkind (Hi) = N_Identifier
 580                            and then
 581                          Ekind (Entity (Hi)) = E_Discriminant;
 582
 583             Lo_Encode : constant Boolean := Lo_Con or Lo_Discr;
 584             Hi_Encode : constant Boolean := Hi_Con or Hi_Discr;
 585
 586             Biased : constant Boolean := Has_Biased_Representation (E);
 587
 588          begin
 589             if Biased then
 590                Get_External_Name_With_Suffix (E, "XB");
 591             else
 592                Get_External_Name_With_Suffix (E, "XD");
 593             end if;
 594
 595             if Lo_Encode or Hi_Encode then
 596                if Biased then
 597                   Add_Str_To_Name_Buffer ("_");
 598                else
 599                   if Lo_Encode then
 600                      if Hi_Encode then
 601                         Add_Str_To_Name_Buffer ("LU_");
 602                      else
 603                         Add_Str_To_Name_Buffer ("L_");
 604                      end if;
 605                   else
 606                      Add_Str_To_Name_Buffer ("U_");
 607                   end if;
 608                end if;
 609
 610                if Lo_Con then
 611                   Add_Uint_To_Buffer (Expr_Rep_Value (Lo));
 612                elsif Lo_Discr then
 613                   Get_Name_String_And_Append (Chars (Entity (Lo)));
 614                end if;
 615
 616                if Lo_Encode and Hi_Encode then
 617                   Add_Str_To_Name_Buffer ("__");
 618                end if;
 619
 620                if Hi_Con then
 621                   Add_Uint_To_Buffer (Expr_Rep_Value (Hi));
 622                elsif Hi_Discr then
 623                   Get_Name_String_And_Append (Chars (Entity (Hi)));
 624                end if;
 625             end if;
 626          end;
 627
 628       --  For all other cases, the encoded name is the normal type name
 629
 630       else
 631          Has_Suffix := False;
 632          Get_External_Name (E, Has_Suffix);
 633       end if;
 634
 635       if Debug_Flag_B and then Has_Suffix then
 636          Write_Str ("**** type ");
 637          Write_Name (Chars (E));
 638          Write_Str (" is encoded as ");
 639          Write_Str (Name_Buffer (1 .. Name_Len));
 640          Write_Eol;
 641       end if;
 642
 643       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 644    end Get_Encoded_Name;
 645
 646    -----------------------
 647    -- Get_External_Name --
 648    -----------------------
 649
 650    procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean) is
 651       E    : Entity_Id := Entity;
 652       Kind : Entity_Kind;
 653
 654       procedure Get_Qualified_Name_And_Append (Entity : Entity_Id);
 655       --  Appends fully qualified name of given entity to Name_Buffer
 656
 657       -----------------------------------
 658       -- Get_Qualified_Name_And_Append --
 659       -----------------------------------
 660
 661       procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is
 662       begin
 663          --  If the entity is a compilation unit, its scope is Standard,
 664          --  there is no outer scope, and the no further qualification
 665          --  is required.
 666
 667          --  If the front end has already computed a fully qualified name,
 668          --  then it is also the case that no further qualification is
 669          --  required
 670
 671          if Present (Scope (Scope (Entity)))
 672            and then not Has_Fully_Qualified_Name (Entity)
 673          then
 674             Get_Qualified_Name_And_Append (Scope (Entity));
 675             Add_Str_To_Name_Buffer ("__");
 676             Get_Name_String_And_Append (Chars (Entity));
 677             Append_Homonym_Number (Entity);
 678
 679          else
 680             Get_Name_String_And_Append (Chars (Entity));
 681          end if;
 682
 683       end Get_Qualified_Name_And_Append;
 684
 685    --  Start of processing for Get_External_Name
 686
 687    begin
 688       Name_Len := 0;
 689
 690       --  If this is a child unit, we want the child
 691
 692       if Nkind (E) = N_Defining_Program_Unit_Name then
 693          E := Defining_Identifier (Entity);
 694       end if;
 695
 696       Kind := Ekind (E);
 697
 698       --  Case of interface name being used
 699
 700       if (Kind = E_Procedure or else
 701           Kind = E_Function  or else
 702           Kind = E_Constant  or else
 703           Kind = E_Variable  or else
 704           Kind = E_Exception)
 705         and then Present (Interface_Name (E))
 706         and then No (Address_Clause (E))
 707         and then not Has_Suffix
 708       then
 709          Add_String_To_Name_Buffer (Strval (Interface_Name (E)));
 710
 711       --  All other cases besides the interface name case
 712
 713       else
 714          --  If this is a library level subprogram (i.e. a subprogram that is a
 715          --  compilation unit other than a subunit), then we prepend _ada_ to
 716          --  ensure distinctions required as described in the spec.
 717
 718          --  Check explicitly for child units, because those are not flagged
 719          --  as Compilation_Units by lib. Should they be ???
 720
 721          if Is_Subprogram (E)
 722            and then (Is_Compilation_Unit (E) or Is_Child_Unit (E))
 723            and then not Has_Suffix
 724          then
 725             Add_Str_To_Name_Buffer ("_ada_");
 726          end if;
 727
 728          --  If the entity is a subprogram instance that is not a compilation
 729          --  unit, generate the name of the original Ada entity, which is the
 730          --  one gdb needs.
 731
 732          if Is_Generic_Instance (E)
 733            and then Is_Subprogram (E)
 734            and then not Is_Compilation_Unit (Scope (E))
 735            and then (Ekind (Scope (E)) = E_Package
 736                       or else
 737                      Ekind (Scope (E)) = E_Package_Body)
 738            and then Present (Related_Instance (Scope (E)))
 739          then
 740             E := Related_Instance (Scope (E));
 741          end if;
 742
 743          Get_Qualified_Name_And_Append (E);
 744       end if;
 745
 746       Name_Buffer (Name_Len + 1) := ASCII.Nul;
 747    end Get_External_Name;
 748
 749    -----------------------------------
 750    -- Get_External_Name_With_Suffix --
 751    -----------------------------------
 752
 753    procedure Get_External_Name_With_Suffix
 754      (Entity : Entity_Id;
 755       Suffix : String)
 756    is
 757       Has_Suffix : constant Boolean := (Suffix /= "");
 758
 759    begin
 760       --  If we are not in code generation mode, this procedure may still be
 761       --  called from Back_End (more specifically - from gigi for doing type
 762       --  representation annotation or some representation-specific checks).
 763       --  But in this mode there is no need to mess with external names.
 764
 765       --  Furthermore, the call causes difficulties in this case because the
 766       --  string representing the homonym number is not correctly reset as a
 767       --  part of the call to Output_Homonym_Numbers_Suffix (which is not
 768       --  called in gigi).
 769
 770       if Operating_Mode /= Generate_Code then
 771          return;
 772       end if;
 773
 774       Get_External_Name (Entity, Has_Suffix);
 775
 776       if Has_Suffix then
 777          Add_Str_To_Name_Buffer ("___");
 778          Add_Str_To_Name_Buffer (Suffix);
 779          Name_Buffer (Name_Len + 1) := ASCII.Nul;
 780       end if;
 781    end Get_External_Name_With_Suffix;
 782
 783    --------------------------
 784    -- Get_Variant_Encoding --
 785    --------------------------
 786
 787    procedure Get_Variant_Encoding (V : Node_Id) is
 788       Choice : Node_Id;
 789
 790       procedure Choice_Val (Typ : Character; Choice : Node_Id);
 791       --  Output encoded value for a single choice value. Typ is the key
 792       --  character ('S', 'F', or 'T') that precedes the choice value.
 793
 794       ----------------
 795       -- Choice_Val --
 796       ----------------
 797
 798       procedure Choice_Val (Typ : Character; Choice : Node_Id) is
 799       begin
 800          if Nkind (Choice) = N_Integer_Literal then
 801             Add_Char_To_Name_Buffer (Typ);
 802             Add_Uint_To_Buffer (Intval (Choice));
 803
 804          --  Character literal with no entity present (this is the case
 805          --  Standard.Character or Standard.Wide_Character as root type)
 806
 807          elsif Nkind (Choice) = N_Character_Literal
 808            and then No (Entity (Choice))
 809          then
 810             Add_Char_To_Name_Buffer (Typ);
 811             Add_Uint_To_Buffer (Char_Literal_Value (Choice));
 812
 813          else
 814             declare
 815                Ent : constant Entity_Id := Entity (Choice);
 816
 817             begin
 818                if Ekind (Ent) = E_Enumeration_Literal then
 819                   Add_Char_To_Name_Buffer (Typ);
 820                   Add_Uint_To_Buffer (Enumeration_Rep (Ent));
 821
 822                else
 823                   pragma Assert (Ekind (Ent) = E_Constant);
 824                   Choice_Val (Typ, Constant_Value (Ent));
 825                end if;
 826             end;
 827          end if;
 828       end Choice_Val;
 829
 830    --  Start of processing for Get_Variant_Encoding
 831
 832    begin
 833       Name_Len := 0;
 834
 835       Choice := First (Discrete_Choices (V));
 836       while Present (Choice) loop
 837          if Nkind (Choice) = N_Others_Choice then
 838             Add_Char_To_Name_Buffer ('O');
 839
 840          elsif Nkind (Choice) = N_Range then
 841             Choice_Val ('R', Low_Bound (Choice));
 842             Choice_Val ('T', High_Bound (Choice));
 843
 844          elsif Is_Entity_Name (Choice)
 845            and then Is_Type (Entity (Choice))
 846          then
 847             Choice_Val ('R', Type_Low_Bound (Entity (Choice)));
 848             Choice_Val ('T', Type_High_Bound (Entity (Choice)));
 849
 850          elsif Nkind (Choice) = N_Subtype_Indication then
 851             declare
 852                Rang : constant Node_Id :=
 853                         Range_Expression (Constraint (Choice));
 854             begin
 855                Choice_Val ('R', Low_Bound (Rang));
 856                Choice_Val ('T', High_Bound (Rang));
 857             end;
 858
 859          else
 860             Choice_Val ('S', Choice);
 861          end if;
 862
 863          Next (Choice);
 864       end loop;
 865
 866       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 867
 868       if Debug_Flag_B then
 869          declare
 870             VP : constant Node_Id := Parent (V);    -- Variant_Part
 871             CL : constant Node_Id := Parent (VP);   -- Component_List
 872             RD : constant Node_Id := Parent (CL);   -- Record_Definition
 873             FT : constant Node_Id := Parent (RD);   -- Full_Type_Declaration
 874
 875          begin
 876             Write_Str ("**** variant for type ");
 877             Write_Name (Chars (Defining_Identifier (FT)));
 878             Write_Str (" is encoded as ");
 879             Write_Str (Name_Buffer (1 .. Name_Len));
 880             Write_Eol;
 881          end;
 882       end if;
 883    end Get_Variant_Encoding;
 884
 885    ------------------------------------
 886    -- Get_Secondary_DT_External_Name --
 887    ------------------------------------
 888
 889    procedure Get_Secondary_DT_External_Name
 890      (Typ             : Entity_Id;
 891       Ancestor_Typ    : Entity_Id;
 892       Suffix_Index    : Int) is
 893    begin
 894       Get_External_Name (Typ, Has_Suffix => False);
 895
 896       if Ancestor_Typ /= Typ then
 897          declare
 898             Len      : constant Natural := Name_Len;
 899             Save_Str : constant String (1 .. Name_Len)
 900                          := Name_Buffer (1 .. Name_Len);
 901          begin
 902             Get_External_Name (Ancestor_Typ, Has_Suffix => False);
 903
 904             --  Append the extended name of the ancestor to the
 905             --  extended name of Typ
 906
 907             Name_Buffer (Len + 2 .. Len + Name_Len + 1) :=
 908               Name_Buffer (1 .. Name_Len);
 909             Name_Buffer (1 .. Len) := Save_Str;
 910             Name_Buffer (Len + 1) := '_';
 911             Name_Len := Len + Name_Len + 1;
 912          end;
 913       end if;
 914
 915       Add_Nat_To_Name_Buffer (Suffix_Index);
 916    end Get_Secondary_DT_External_Name;
 917
 918    ---------------------------------
 919    -- Make_Packed_Array_Type_Name --
 920    ---------------------------------
 921
 922    function Make_Packed_Array_Type_Name
 923      (Typ   : Entity_Id;
 924       Csize : Uint)
 925       return  Name_Id
 926    is
 927    begin
 928       Get_Name_String (Chars (Typ));
 929       Add_Str_To_Name_Buffer ("___XP");
 930       Add_Uint_To_Buffer (Csize);
 931       return Name_Find;
 932    end Make_Packed_Array_Type_Name;
 933
 934    -----------------------------------
 935    -- Output_Homonym_Numbers_Suffix --
 936    -----------------------------------
 937
 938    procedure Output_Homonym_Numbers_Suffix is
 939       J : Natural;
 940
 941    begin
 942       if Homonym_Len > 0 then
 943
 944          --  Check for all 1's, in which case we do not output
 945
 946          J := 1;
 947          loop
 948             exit when Homonym_Numbers (J) /= '1';
 949
 950             --  If we reached end of string we do not output
 951
 952             if J = Homonym_Len then
 953                Homonym_Len := 0;
 954                return;
 955             end if;
 956
 957             exit when Homonym_Numbers (J + 1) /= '_';
 958             J := J + 2;
 959          end loop;
 960
 961          --  If we exit the loop then suffix must be output
 962
 963          Add_Str_To_Name_Buffer ("__");
 964          Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len));
 965          Homonym_Len := 0;
 966       end if;
 967    end Output_Homonym_Numbers_Suffix;
 968
 969    ------------------------------
 970    -- Prepend_String_To_Buffer --
 971    ------------------------------
 972
 973    procedure Prepend_String_To_Buffer (S : String) is
 974       N : constant Integer := S'Length;
 975    begin
 976       Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len);
 977       Name_Buffer (1 .. N) := S;
 978       Name_Len := Name_Len + N;
 979    end Prepend_String_To_Buffer;
 980
 981    ----------------------------
 982    -- Prepend_Uint_To_Buffer --
 983    ----------------------------
 984
 985    procedure Prepend_Uint_To_Buffer (U : Uint) is
 986    begin
 987       if U < 0 then
 988          Prepend_String_To_Buffer ("m");
 989          Prepend_Uint_To_Buffer (-U);
 990       else
 991          UI_Image (U, Decimal);
 992          Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
 993       end if;
 994    end Prepend_Uint_To_Buffer;
 995
 996    ------------------------------
 997    -- Qualify_All_Entity_Names --
 998    ------------------------------
 999
1000    procedure Qualify_All_Entity_Names is
1001       E   : Entity_Id;
1002       Ent : Entity_Id;
1003
1004    begin
1005       for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
1006          E := Defining_Entity (Name_Qualify_Units.Table (J));
1007          Qualify_Entity_Name (E);
1008
1009          Ent := First_Entity (E);
1010          while Present (Ent) loop
1011             Qualify_Entity_Name (Ent);
1012             Next_Entity (Ent);
1013
1014             --  There are odd cases where Last_Entity (E) = E. This happens
1015             --  in the case of renaming of packages. This test avoids getting
1016             --  stuck in such cases.
1017
1018             exit when Ent = E;
1019          end loop;
1020       end loop;
1021    end Qualify_All_Entity_Names;
1022
1023    -------------------------
1024    -- Qualify_Entity_Name --
1025    -------------------------
1026
1027    procedure Qualify_Entity_Name (Ent : Entity_Id) is
1028
1029       Full_Qualify_Name : String (1 .. Name_Buffer'Length);
1030       Full_Qualify_Len  : Natural := 0;
1031       --  Used to accumulate fully qualified name of subprogram
1032
1033       procedure Fully_Qualify_Name (E : Entity_Id);
1034       --  Used to qualify a subprogram or type name, where full
1035       --  qualification up to Standard is always used. Name is set
1036       --  in Full_Qualify_Name with the length in Full_Qualify_Len.
1037       --  Note that this routine does not prepend the _ada_ string
1038       --  required for library subprograms (this is done in the back end).
1039
1040       function Is_BNPE (S : Entity_Id) return Boolean;
1041       --  Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
1042       --  is defined to be a package which is immediately nested within a
1043       --  package body.
1044
1045       function Qualify_Needed (S : Entity_Id) return Boolean;
1046       --  Given a scope, determines if the scope is to be included in the
1047       --  fully qualified name, True if so, False if not.
1048
1049       procedure Set_BNPE_Suffix (E : Entity_Id);
1050       --  Recursive routine to append the BNPE qualification suffix. Works
1051       --  from right to left with E being the current entity in the list.
1052       --  The result does NOT have the trailing n's and trailing b stripped.
1053       --  The caller must do this required stripping.
1054
1055       procedure Set_Entity_Name (E : Entity_Id);
1056       --  Internal recursive routine that does most of the work. This routine
1057       --  leaves the result sitting in Name_Buffer and Name_Len.
1058
1059       BNPE_Suffix_Needed : Boolean := False;
1060       --  Set true if a body-nested package entity suffix is required
1061
1062       Save_Chars : constant Name_Id := Chars (Ent);
1063       --  Save original name
1064
1065       ------------------------
1066       -- Fully_Qualify_Name --
1067       ------------------------
1068
1069       procedure Fully_Qualify_Name (E : Entity_Id) is
1070          Discard : Boolean := False;
1071
1072       begin
1073          --  Ignore empty entry (can happen in error cases)
1074
1075          if No (E) then
1076             return;
1077
1078          --  If this we are qualifying entities local to a generic
1079          --  instance, use the name of the original instantiation,
1080          --  not that of the anonymous subprogram in the wrapper
1081          --  package, so that gdb doesn't have to know about these.
1082
1083          elsif Is_Generic_Instance (E)
1084            and then Is_Subprogram (E)
1085            and then not Comes_From_Source (E)
1086            and then not Is_Compilation_Unit (Scope (E))
1087          then
1088             Fully_Qualify_Name (Related_Instance (Scope (E)));
1089             return;
1090          end if;
1091
1092          --  If we reached fully qualified name, then just copy it
1093
1094          if Has_Fully_Qualified_Name (E) then
1095             Get_Name_String (Chars (E));
1096             Strip_Suffixes (Discard);
1097             Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1098             Full_Qualify_Len := Name_Len;
1099             Set_Has_Fully_Qualified_Name (Ent);
1100
1101          --  Case of non-fully qualified name
1102
1103          else
1104             if Scope (E) = Standard_Standard then
1105                Set_Has_Fully_Qualified_Name (Ent);
1106             else
1107                Fully_Qualify_Name (Scope (E));
1108                Full_Qualify_Name (Full_Qualify_Len + 1) := '_';
1109                Full_Qualify_Name (Full_Qualify_Len + 2) := '_';
1110                Full_Qualify_Len := Full_Qualify_Len + 2;
1111             end if;
1112
1113             if Has_Qualified_Name (E) then
1114                Get_Unqualified_Name_String (Chars (E));
1115             else
1116                Get_Name_String (Chars (E));
1117             end if;
1118
1119             --  A special check here, we never add internal block or loop
1120             --  names, since they intefere with debugging. We identify these
1121             --  by the fact that they start with an upper case B or L.
1122             --  But do add these if what we are qualifying is a __clean
1123             --  procedure since those need to be made unique.
1124
1125             if (Name_Buffer (1) = 'B' or else Name_Buffer (1) = 'L')
1126                 and then (not Debug_Flag_VV)
1127                 and then Full_Qualify_Len > 2
1128                 and then Chars (Ent) /= Name_uClean
1129             then
1130                Full_Qualify_Len := Full_Qualify_Len - 2;
1131
1132             else
1133                Full_Qualify_Name
1134                  (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) :=
1135                    Name_Buffer (1 .. Name_Len);
1136                Full_Qualify_Len := Full_Qualify_Len + Name_Len;
1137                Append_Homonym_Number (E);
1138             end if;
1139          end if;
1140
1141          if Is_BNPE (E) then
1142             BNPE_Suffix_Needed := True;
1143          end if;
1144       end Fully_Qualify_Name;
1145
1146       -------------
1147       -- Is_BNPE --
1148       -------------
1149
1150       function Is_BNPE (S : Entity_Id) return Boolean is
1151       begin
1152          return
1153            Ekind (S) = E_Package
1154              and then Is_Package_Body_Entity (S);
1155       end Is_BNPE;
1156
1157       --------------------
1158       -- Qualify_Needed --
1159       --------------------
1160
1161       function Qualify_Needed (S : Entity_Id) return Boolean is
1162       begin
1163          --  If we got all the way to Standard, then we have certainly
1164          --  fully qualified the name, so set the flag appropriately,
1165          --  and then return False, since we are most certainly done!
1166
1167          if S = Standard_Standard then
1168             Set_Has_Fully_Qualified_Name (Ent, True);
1169             return False;
1170
1171          --  Otherwise figure out if further qualification is required
1172
1173          else
1174             return
1175               Is_Subprogram (Ent)
1176                 or else
1177               Ekind (Ent) = E_Subprogram_Body
1178                 or else
1179                   (Ekind (S) /= E_Block
1180                     and then not Is_Dynamic_Scope (S));
1181          end if;
1182       end Qualify_Needed;
1183
1184       ---------------------
1185       -- Set_BNPE_Suffix --
1186       ---------------------
1187
1188       procedure Set_BNPE_Suffix (E : Entity_Id) is
1189          S : constant Entity_Id := Scope (E);
1190
1191       begin
1192          if Qualify_Needed (S) then
1193             Set_BNPE_Suffix (S);
1194
1195             if Is_BNPE (E) then
1196                Add_Char_To_Name_Buffer ('b');
1197             else
1198                Add_Char_To_Name_Buffer ('n');
1199             end if;
1200
1201          else
1202             Add_Char_To_Name_Buffer ('X');
1203          end if;
1204       end Set_BNPE_Suffix;
1205
1206       ---------------------
1207       -- Set_Entity_Name --
1208       ---------------------
1209
1210       procedure Set_Entity_Name (E : Entity_Id) is
1211          S : constant Entity_Id := Scope (E);
1212
1213       begin
1214          --  If we reach an already qualified name, just take the encoding
1215          --  except that we strip the package body suffixes, since these
1216          --  will be separately put on later.
1217
1218          if Has_Qualified_Name (E) then
1219             Get_Name_String_And_Append (Chars (E));
1220             Strip_Suffixes (BNPE_Suffix_Needed);
1221
1222             --  If the top level name we are adding is itself fully
1223             --  qualified, then that means that the name that we are
1224             --  preparing for the Fully_Qualify_Name call will also
1225             --  generate a fully qualified name.
1226
1227             if Has_Fully_Qualified_Name (E) then
1228                Set_Has_Fully_Qualified_Name (Ent);
1229             end if;
1230
1231          --  Case where upper level name is not encoded yet
1232
1233          else
1234             --  Recurse if further qualification required
1235
1236             if Qualify_Needed (S) then
1237                Set_Entity_Name (S);
1238                Add_Str_To_Name_Buffer ("__");
1239             end if;
1240
1241             --  Otherwise get name and note if it is a NPBE
1242
1243             Get_Name_String_And_Append (Chars (E));
1244
1245             if Is_BNPE (E) then
1246                BNPE_Suffix_Needed := True;
1247             end if;
1248
1249             Append_Homonym_Number (E);
1250          end if;
1251       end Set_Entity_Name;
1252
1253    --  Start of processing for Qualify_Entity_Name
1254
1255    begin
1256       if Has_Qualified_Name (Ent) then
1257          return;
1258
1259       --  Here is where we create the proper link for renaming
1260
1261       elsif Ekind (Ent) = E_Enumeration_Literal
1262         and then Present (Debug_Renaming_Link (Ent))
1263       then
1264          Name_Len := 0;
1265          Qualify_Entity_Name (Debug_Renaming_Link (Ent));
1266          Get_Name_String (Chars (Ent));
1267          Prepend_String_To_Buffer
1268            (Get_Name_String (Chars (Debug_Renaming_Link (Ent))));
1269          Set_Chars (Ent, Name_Enter);
1270          Set_Has_Qualified_Name (Ent);
1271          return;
1272
1273       elsif Is_Subprogram (Ent)
1274         or else Ekind (Ent) = E_Subprogram_Body
1275         or else Is_Type (Ent)
1276       then
1277          Fully_Qualify_Name (Ent);
1278          Name_Len := Full_Qualify_Len;
1279          Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
1280
1281       elsif Qualify_Needed (Scope (Ent)) then
1282          Name_Len := 0;
1283          Set_Entity_Name (Ent);
1284
1285       else
1286          Set_Has_Qualified_Name (Ent);
1287          return;
1288       end if;
1289
1290       --  Fall through with a fully qualified name in Name_Buffer/Name_Len
1291
1292       Output_Homonym_Numbers_Suffix;
1293
1294       --  Add body-nested package suffix if required
1295
1296       if BNPE_Suffix_Needed
1297         and then Ekind (Ent) /= E_Enumeration_Literal
1298       then
1299          Set_BNPE_Suffix (Ent);
1300
1301          --  Strip trailing n's and last trailing b as required. note that
1302          --  we know there is at least one b, or no suffix would be generated.
1303
1304          while Name_Buffer (Name_Len) = 'n' loop
1305             Name_Len := Name_Len - 1;
1306          end loop;
1307
1308          Name_Len := Name_Len - 1;
1309       end if;
1310
1311       Set_Chars (Ent, Name_Enter);
1312       Set_Has_Qualified_Name (Ent);
1313
1314       if Debug_Flag_BB then
1315          Write_Str ("*** ");
1316          Write_Name (Save_Chars);
1317          Write_Str (" qualified as ");
1318          Write_Name (Chars (Ent));
1319          Write_Eol;
1320       end if;
1321    end Qualify_Entity_Name;
1322
1323    --------------------------
1324    -- Qualify_Entity_Names --
1325    --------------------------
1326
1327    procedure Qualify_Entity_Names (N : Node_Id) is
1328    begin
1329       Name_Qualify_Units.Append (N);
1330    end Qualify_Entity_Names;
1331
1332    --------------------
1333    -- Strip_Suffixes --
1334    --------------------
1335
1336    procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is
1337       SL : Natural;
1338
1339    begin
1340       --  Search for and strip BNPE suffix
1341
1342       for J in reverse 2 .. Name_Len loop
1343          if Name_Buffer (J) = 'X' then
1344             Name_Len := J - 1;
1345             BNPE_Suffix_Found := True;
1346             exit;
1347          end if;
1348
1349          exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n';
1350       end loop;
1351
1352       --  Search for and strip homonym numbers suffix
1353
1354       for J in reverse 2 .. Name_Len - 2 loop
1355          if Name_Buffer (J) = '_'
1356            and then Name_Buffer (J + 1) = '_'
1357          then
1358             if Name_Buffer (J + 2) in '0' .. '9' then
1359                if Homonym_Len > 0 then
1360                   Homonym_Len := Homonym_Len + 1;
1361                   Homonym_Numbers (Homonym_Len) := '-';
1362                end if;
1363
1364                SL := Name_Len - (J + 1);
1365
1366                Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) :=
1367                  Name_Buffer (J + 2 .. Name_Len);
1368                Name_Len := J - 1;
1369                Homonym_Len := Homonym_Len + SL;
1370             end if;
1371
1372             exit;
1373          end if;
1374       end loop;
1375    end Strip_Suffixes;
1376
1377 end Exp_Dbug;