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