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