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-2005 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 (Char_Literal_Value (Choice));
 797
 798          else
 799             declare
 800                Ent : constant Entity_Id := Entity (Choice);
 801
 802             begin
 803                if Ekind (Ent) = E_Enumeration_Literal then
 804                   Add_Uint_To_Buffer (Enumeration_Rep (Ent));
 805
 806                else
 807                   pragma Assert (Ekind (Ent) = E_Constant);
 808                   Choice_Val (Typ, Constant_Value (Ent));
 809                end if;
 810             end;
 811          end if;
 812       end Choice_Val;
 813
 814    --  Start of processing for Get_Variant_Encoding
 815
 816    begin
 817       Name_Len := 0;
 818
 819       Choice := First (Discrete_Choices (V));
 820       while Present (Choice) loop
 821          if Nkind (Choice) = N_Others_Choice then
 822             Add_Char_To_Name_Buffer ('O');
 823
 824          elsif Nkind (Choice) = N_Range then
 825             Choice_Val ('R', Low_Bound (Choice));
 826             Choice_Val ('T', High_Bound (Choice));
 827
 828          elsif Is_Entity_Name (Choice)
 829            and then Is_Type (Entity (Choice))
 830          then
 831             Choice_Val ('R', Type_Low_Bound (Entity (Choice)));
 832             Choice_Val ('T', Type_High_Bound (Entity (Choice)));
 833
 834          elsif Nkind (Choice) = N_Subtype_Indication then
 835             declare
 836                Rang : constant Node_Id :=
 837                         Range_Expression (Constraint (Choice));
 838             begin
 839                Choice_Val ('R', Low_Bound (Rang));
 840                Choice_Val ('T', High_Bound (Rang));
 841             end;
 842
 843          else
 844             Choice_Val ('S', Choice);
 845          end if;
 846
 847          Next (Choice);
 848       end loop;
 849
 850       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 851
 852       if Debug_Flag_B then
 853          declare
 854             VP : constant Node_Id := Parent (V);    -- Variant_Part
 855             CL : constant Node_Id := Parent (VP);   -- Component_List
 856             RD : constant Node_Id := Parent (CL);   -- Record_Definition
 857             FT : constant Node_Id := Parent (RD);   -- Full_Type_Declaration
 858
 859          begin
 860             Write_Str ("**** variant for type ");
 861             Write_Name (Chars (Defining_Identifier (FT)));
 862             Write_Str (" is encoded as ");
 863             Write_Str (Name_Buffer (1 .. Name_Len));
 864             Write_Eol;
 865          end;
 866       end if;
 867    end Get_Variant_Encoding;
 868
 869    ---------------------------------
 870    -- Make_Packed_Array_Type_Name --
 871    ---------------------------------
 872
 873    function Make_Packed_Array_Type_Name
 874      (Typ   : Entity_Id;
 875       Csize : Uint)
 876       return  Name_Id
 877    is
 878    begin
 879       Get_Name_String (Chars (Typ));
 880       Add_Str_To_Name_Buffer ("___XP");
 881       Add_Uint_To_Buffer (Csize);
 882       return Name_Find;
 883    end Make_Packed_Array_Type_Name;
 884
 885    -----------------------------------
 886    -- Output_Homonym_Numbers_Suffix --
 887    -----------------------------------
 888
 889    procedure Output_Homonym_Numbers_Suffix is
 890       J : Natural;
 891
 892    begin
 893       if Homonym_Len > 0 then
 894
 895          --  Check for all 1's, in which case we do not output
 896
 897          J := 1;
 898          loop
 899             exit when Homonym_Numbers (J) /= '1';
 900
 901             --  If we reached end of string we do not output
 902
 903             if J = Homonym_Len then
 904                Homonym_Len := 0;
 905                return;
 906             end if;
 907
 908             exit when Homonym_Numbers (J + 1) /= '_';
 909             J := J + 2;
 910          end loop;
 911
 912          --  If we exit the loop then suffix must be output
 913
 914          Add_Str_To_Name_Buffer ("__");
 915          Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len));
 916          Homonym_Len := 0;
 917       end if;
 918    end Output_Homonym_Numbers_Suffix;
 919
 920    ------------------------------
 921    -- Prepend_String_To_Buffer --
 922    ------------------------------
 923
 924    procedure Prepend_String_To_Buffer (S : String) is
 925       N : constant Integer := S'Length;
 926    begin
 927       Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len);
 928       Name_Buffer (1 .. N) := S;
 929       Name_Len := Name_Len + N;
 930    end Prepend_String_To_Buffer;
 931
 932    ----------------------------
 933    -- Prepend_Uint_To_Buffer --
 934    ----------------------------
 935
 936    procedure Prepend_Uint_To_Buffer (U : Uint) is
 937    begin
 938       if U < 0 then
 939          Prepend_String_To_Buffer ("m");
 940          Prepend_Uint_To_Buffer (-U);
 941       else
 942          UI_Image (U, Decimal);
 943          Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
 944       end if;
 945    end Prepend_Uint_To_Buffer;
 946
 947    ------------------------------
 948    -- Qualify_All_Entity_Names --
 949    ------------------------------
 950
 951    procedure Qualify_All_Entity_Names is
 952       E   : Entity_Id;
 953       Ent : Entity_Id;
 954
 955    begin
 956       for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
 957          E := Defining_Entity (Name_Qualify_Units.Table (J));
 958          Qualify_Entity_Name (E);
 959
 960          Ent := First_Entity (E);
 961          while Present (Ent) loop
 962             Qualify_Entity_Name (Ent);
 963             Next_Entity (Ent);
 964
 965             --  There are odd cases where Last_Entity (E) = E. This happens
 966             --  in the case of renaming of packages. This test avoids getting
 967             --  stuck in such cases.
 968
 969             exit when Ent = E;
 970          end loop;
 971       end loop;
 972    end Qualify_All_Entity_Names;
 973
 974    -------------------------
 975    -- Qualify_Entity_Name --
 976    -------------------------
 977
 978    procedure Qualify_Entity_Name (Ent : Entity_Id) is
 979
 980       Full_Qualify_Name : String (1 .. Name_Buffer'Length);
 981       Full_Qualify_Len  : Natural := 0;
 982       --  Used to accumulate fully qualified name of subprogram
 983
 984       procedure Fully_Qualify_Name (E : Entity_Id);
 985       --  Used to qualify a subprogram or type name, where full
 986       --  qualification up to Standard is always used. Name is set
 987       --  in Full_Qualify_Name with the length in Full_Qualify_Len.
 988       --  Note that this routine does not prepend the _ada_ string
 989       --  required for library subprograms (this is done in the back end).
 990
 991       function Is_BNPE (S : Entity_Id) return Boolean;
 992       --  Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
 993       --  is defined to be a package which is immediately nested within a
 994       --  package body.
 995
 996       function Qualify_Needed (S : Entity_Id) return Boolean;
 997       --  Given a scope, determines if the scope is to be included in the
 998       --  fully qualified name, True if so, False if not.
 999
1000       procedure Set_BNPE_Suffix (E : Entity_Id);
1001       --  Recursive routine to append the BNPE qualification suffix. Works
1002       --  from right to left with E being the current entity in the list.
1003       --  The result does NOT have the trailing n's and trailing b stripped.
1004       --  The caller must do this required stripping.
1005
1006       procedure Set_Entity_Name (E : Entity_Id);
1007       --  Internal recursive routine that does most of the work. This routine
1008       --  leaves the result sitting in Name_Buffer and Name_Len.
1009
1010       BNPE_Suffix_Needed : Boolean := False;
1011       --  Set true if a body-nested package entity suffix is required
1012
1013       Save_Chars : constant Name_Id := Chars (Ent);
1014       --  Save original name
1015
1016       ------------------------
1017       -- Fully_Qualify_Name --
1018       ------------------------
1019
1020       procedure Fully_Qualify_Name (E : Entity_Id) is
1021          Discard : Boolean := False;
1022
1023       begin
1024          --  Ignore empty entry (can happen in error cases)
1025
1026          if No (E) then
1027             return;
1028
1029          --  If this we are qualifying entities local to a generic
1030          --  instance, use the name of the original instantiation,
1031          --  not that of the anonymous subprogram in the wrapper
1032          --  package, so that gdb doesn't have to know about these.
1033
1034          elsif Is_Generic_Instance (E)
1035            and then Is_Subprogram (E)
1036            and then not Comes_From_Source (E)
1037            and then not Is_Compilation_Unit (Scope (E))
1038          then
1039             Fully_Qualify_Name (Related_Instance (Scope (E)));
1040             return;
1041          end if;
1042
1043          --  If we reached fully qualified name, then just copy it
1044
1045          if Has_Fully_Qualified_Name (E) then
1046             Get_Name_String (Chars (E));
1047             Strip_Suffixes (Discard);
1048             Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1049             Full_Qualify_Len := Name_Len;
1050             Set_Has_Fully_Qualified_Name (Ent);
1051
1052          --  Case of non-fully qualified name
1053
1054          else
1055             if Scope (E) = Standard_Standard then
1056                Set_Has_Fully_Qualified_Name (Ent);
1057             else
1058                Fully_Qualify_Name (Scope (E));
1059                Full_Qualify_Name (Full_Qualify_Len + 1) := '_';
1060                Full_Qualify_Name (Full_Qualify_Len + 2) := '_';
1061                Full_Qualify_Len := Full_Qualify_Len + 2;
1062             end if;
1063
1064             if Has_Qualified_Name (E) then
1065                Get_Unqualified_Name_String (Chars (E));
1066             else
1067                Get_Name_String (Chars (E));
1068             end if;
1069
1070             --  A special check here, we never add internal block or loop
1071             --  names, since they intefere with debugging. We identify these
1072             --  by the fact that they start with an upper case B or L.
1073             --  But do add these if what we are qualifying is a __clean
1074             --  procedure since those need to be made unique.
1075
1076             if (Name_Buffer (1) = 'B' or else Name_Buffer (1) = 'L')
1077                 and then (not Debug_Flag_VV)
1078                 and then Full_Qualify_Len > 2
1079                 and then Chars (Ent) /= Name_uClean
1080             then
1081                Full_Qualify_Len := Full_Qualify_Len - 2;
1082
1083             else
1084                Full_Qualify_Name
1085                  (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) :=
1086                    Name_Buffer (1 .. Name_Len);
1087                Full_Qualify_Len := Full_Qualify_Len + Name_Len;
1088                Append_Homonym_Number (E);
1089             end if;
1090          end if;
1091
1092          if Is_BNPE (E) then
1093             BNPE_Suffix_Needed := True;
1094          end if;
1095       end Fully_Qualify_Name;
1096
1097       -------------
1098       -- Is_BNPE --
1099       -------------
1100
1101       function Is_BNPE (S : Entity_Id) return Boolean is
1102       begin
1103          return
1104            Ekind (S) = E_Package
1105              and then Is_Package_Body_Entity (S);
1106       end Is_BNPE;
1107
1108       --------------------
1109       -- Qualify_Needed --
1110       --------------------
1111
1112       function Qualify_Needed (S : Entity_Id) return Boolean is
1113       begin
1114          --  If we got all the way to Standard, then we have certainly
1115          --  fully qualified the name, so set the flag appropriately,
1116          --  and then return False, since we are most certainly done!
1117
1118          if S = Standard_Standard then
1119             Set_Has_Fully_Qualified_Name (Ent, True);
1120             return False;
1121
1122          --  Otherwise figure out if further qualification is required
1123
1124          else
1125             return
1126               Is_Subprogram (Ent)
1127                 or else
1128               Ekind (Ent) = E_Subprogram_Body
1129                 or else
1130                   (Ekind (S) /= E_Block
1131                     and then not Is_Dynamic_Scope (S));
1132          end if;
1133       end Qualify_Needed;
1134
1135       ---------------------
1136       -- Set_BNPE_Suffix --
1137       ---------------------
1138
1139       procedure Set_BNPE_Suffix (E : Entity_Id) is
1140          S : constant Entity_Id := Scope (E);
1141
1142       begin
1143          if Qualify_Needed (S) then
1144             Set_BNPE_Suffix (S);
1145
1146             if Is_BNPE (E) then
1147                Add_Char_To_Name_Buffer ('b');
1148             else
1149                Add_Char_To_Name_Buffer ('n');
1150             end if;
1151
1152          else
1153             Add_Char_To_Name_Buffer ('X');
1154          end if;
1155
1156       end Set_BNPE_Suffix;
1157
1158       ---------------------
1159       -- Set_Entity_Name --
1160       ---------------------
1161
1162       procedure Set_Entity_Name (E : Entity_Id) is
1163          S : constant Entity_Id := Scope (E);
1164
1165       begin
1166          --  If we reach an already qualified name, just take the encoding
1167          --  except that we strip the package body suffixes, since these
1168          --  will be separately put on later.
1169
1170          if Has_Qualified_Name (E) then
1171             Get_Name_String_And_Append (Chars (E));
1172             Strip_Suffixes (BNPE_Suffix_Needed);
1173
1174             --  If the top level name we are adding is itself fully
1175             --  qualified, then that means that the name that we are
1176             --  preparing for the Fully_Qualify_Name call will also
1177             --  generate a fully qualified name.
1178
1179             if Has_Fully_Qualified_Name (E) then
1180                Set_Has_Fully_Qualified_Name (Ent);
1181             end if;
1182
1183          --  Case where upper level name is not encoded yet
1184
1185          else
1186             --  Recurse if further qualification required
1187
1188             if Qualify_Needed (S) then
1189                Set_Entity_Name (S);
1190                Add_Str_To_Name_Buffer ("__");
1191             end if;
1192
1193             --  Otherwise get name and note if it is a NPBE
1194
1195             Get_Name_String_And_Append (Chars (E));
1196
1197             if Is_BNPE (E) then
1198                BNPE_Suffix_Needed := True;
1199             end if;
1200
1201             Append_Homonym_Number (E);
1202          end if;
1203       end Set_Entity_Name;
1204
1205    --  Start of processing for Qualify_Entity_Name
1206
1207    begin
1208       if Has_Qualified_Name (Ent) then
1209          return;
1210
1211       --  Here is where we create the proper link for renaming
1212
1213       elsif Ekind (Ent) = E_Enumeration_Literal
1214         and then Present (Debug_Renaming_Link (Ent))
1215       then
1216          Name_Len := 0;
1217          Qualify_Entity_Name (Debug_Renaming_Link (Ent));
1218          Get_Name_String (Chars (Ent));
1219          Prepend_String_To_Buffer
1220            (Get_Name_String (Chars (Debug_Renaming_Link (Ent))));
1221          Set_Chars (Ent, Name_Enter);
1222          Set_Has_Qualified_Name (Ent);
1223          return;
1224
1225       elsif Is_Subprogram (Ent)
1226         or else Ekind (Ent) = E_Subprogram_Body
1227         or else Is_Type (Ent)
1228       then
1229          Fully_Qualify_Name (Ent);
1230          Name_Len := Full_Qualify_Len;
1231          Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
1232
1233       elsif Qualify_Needed (Scope (Ent)) then
1234          Name_Len := 0;
1235          Set_Entity_Name (Ent);
1236
1237       else
1238          Set_Has_Qualified_Name (Ent);
1239          return;
1240       end if;
1241
1242       --  Fall through with a fully qualified name in Name_Buffer/Name_Len
1243
1244       Output_Homonym_Numbers_Suffix;
1245
1246       --  Add body-nested package suffix if required
1247
1248       if BNPE_Suffix_Needed
1249         and then Ekind (Ent) /= E_Enumeration_Literal
1250       then
1251          Set_BNPE_Suffix (Ent);
1252
1253          --  Strip trailing n's and last trailing b as required. note that
1254          --  we know there is at least one b, or no suffix would be generated.
1255
1256          while Name_Buffer (Name_Len) = 'n' loop
1257             Name_Len := Name_Len - 1;
1258          end loop;
1259
1260          Name_Len := Name_Len - 1;
1261       end if;
1262
1263       Set_Chars (Ent, Name_Enter);
1264       Set_Has_Qualified_Name (Ent);
1265
1266       if Debug_Flag_BB then
1267          Write_Str ("*** ");
1268          Write_Name (Save_Chars);
1269          Write_Str (" qualified as ");
1270          Write_Name (Chars (Ent));
1271          Write_Eol;
1272       end if;
1273    end Qualify_Entity_Name;
1274
1275    --------------------------
1276    -- Qualify_Entity_Names --
1277    --------------------------
1278
1279    procedure Qualify_Entity_Names (N : Node_Id) is
1280    begin
1281       Name_Qualify_Units.Append (N);
1282    end Qualify_Entity_Names;
1283
1284    --------------------
1285    -- Strip_Suffixes --
1286    --------------------
1287
1288    procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is
1289       SL : Natural;
1290
1291    begin
1292       --  Search for and strip BNPE suffix
1293
1294       for J in reverse 2 .. Name_Len loop
1295          if Name_Buffer (J) = 'X' then
1296             Name_Len := J - 1;
1297             BNPE_Suffix_Found := True;
1298             exit;
1299          end if;
1300
1301          exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n';
1302       end loop;
1303
1304       --  Search for and strip homonym numbers suffix
1305
1306       for J in reverse 2 .. Name_Len - 2 loop
1307          if Name_Buffer (J) = '_'
1308            and then Name_Buffer (J + 1) = '_'
1309          then
1310             if Name_Buffer (J + 2) in '0' .. '9' then
1311                if Homonym_Len > 0 then
1312                   Homonym_Len := Homonym_Len + 1;
1313                   Homonym_Numbers (Homonym_Len) := '-';
1314                end if;
1315
1316                SL := Name_Len - (J + 1);
1317
1318                Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) :=
1319                  Name_Buffer (J + 2 .. Name_Len);
1320                Name_Len := J - 1;
1321                Homonym_Len := Homonym_Len + SL;
1322             end if;
1323
1324             exit;
1325          end if;
1326       end loop;
1327
1328    end Strip_Suffixes;
1329
1330 end Exp_Dbug;