gcc/ada/exp_dbug.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ D B U G                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1996-2006, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Alloc;    use Alloc;
  28 with Atree;    use Atree;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Namet;    use Namet;
  32 with Nlists;   use Nlists;
  33 with Nmake;    use Nmake;
  34 with Opt;      use Opt;
  35 with Output;   use Output;
  36 with Sem_Eval; use Sem_Eval;
  37 with Sem_Util; use Sem_Util;
  38 with Sinfo;    use Sinfo;
  39 with Stand;    use Stand;
  40 with Stringt;  use Stringt;
  41 with Table;
  42 with Urealp;   use Urealp;
  43
  44 package body Exp_Dbug is
  45
  46    --  The following table is used to queue up the entities passed as
  47    --  arguments to Qualify_Entity_Names for later processing when
  48    --  Qualify_All_Entity_Names is called.
  49
  50    package Name_Qualify_Units is new Table.Table (
  51      Table_Component_Type => Node_Id,
  52      Table_Index_Type     => Nat,
  53      Table_Low_Bound      => 1,
  54      Table_Initial        => Alloc.Name_Qualify_Units_Initial,
  55      Table_Increment      => Alloc.Name_Qualify_Units_Increment,
  56      Table_Name           => "Name_Qualify_Units");
  57
  58    --------------------------------
  59    -- Use of Qualification Flags --
  60    --------------------------------
  61
  62    --  There are two flags used to keep track of qualification of entities
  63
  64    --    Has_Fully_Qualified_Name
  65    --    Has_Qualified_Name
  66
  67    --  The difference between these is as follows. Has_Qualified_Name is
  68    --  set to indicate that the name has been qualified as required by the
  69    --  spec of this package. As described there, this may involve the full
  70    --  qualification for the name, but for some entities, notably procedure
  71    --  local variables, this full qualification is not required.
  72
  73    --  The flag Has_Fully_Qualified_Name is set if indeed the name has been
  74    --  fully qualified in the Ada sense. If Has_Fully_Qualified_Name is set,
  75    --  then Has_Qualified_Name is also set, but the other way round is not
  76    --  the case.
  77
  78    --  Consider the following example:
  79
  80    --     with ...
  81    --     procedure X is
  82    --       B : Ddd.Ttt;
  83    --       procedure Y is ..
  84
  85    --  Here B is a procedure local variable, so it does not need fully
  86    --  qualification. The flag Has_Qualified_Name will be set on the
  87    --  first attempt to qualify B, to indicate that the job is done
  88    --  and need not be redone.
  89
  90    --  But Y is qualified as x__y, since procedures are always fully
  91    --  qualified, so the first time that an attempt is made to qualify
  92    --  the name y, it will be replaced by x__y, and both flags are set.
  93
  94    --  Why the two flags? Well there are cases where we derive type names
  95    --  from object names. As noted in the spec, type names are always
  96    --  fully qualified. Suppose for example that the backend has to build
  97    --  a padded type for variable B. then it will construct the PAD name
  98    --  from B, but it requires full qualification, so the fully qualified
  99    --  type name will be x__b___PAD. The two flags allow the circuit for
 100    --  building this name to realize efficiently that b needs further
 101    --  qualification.
 102
 103    --------------------
 104    -- Homonym_Suffix --
 105    --------------------
 106
 107    --  The string defined here (and its associated length) is used to
 108    --  gather the homonym string that will be appended to Name_Buffer
 109    --  when the name is complete. Strip_Suffixes appends to this string
 110    --  as does Append_Homonym_Number, and Output_Homonym_Numbers_Suffix
 111    --  appends the string to the end of Name_Buffer.
 112
 113    Homonym_Numbers : String (1 .. 256);
 114    Homonym_Len     : Natural := 0;
 115
 116    ----------------------
 117    -- Local Procedures --
 118    ----------------------
 119
 120    procedure Add_Uint_To_Buffer (U : Uint);
 121    --  Add image of universal integer to Name_Buffer, updating Name_Len
 122
 123    procedure Add_Real_To_Buffer (U : Ureal);
 124    --  Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of
 125    --  the normalized numerator and denominator of the given real value.
 126
 127    procedure Append_Homonym_Number (E : Entity_Id);
 128    --  If the entity E has homonyms in the same scope, then make an entry
 129    --  in the Homonym_Numbers array, bumping Homonym_Count accordingly.
 130
 131    function Bounds_Match_Size (E : Entity_Id) return  Boolean;
 132    --  Determine whether the bounds of E match the size of the type. This is
 133    --  used to determine whether encoding is required for a discrete type.
 134
 135    procedure Output_Homonym_Numbers_Suffix;
 136    --  If homonym numbers are stored, then output them into Name_Buffer
 137
 138    procedure Prepend_String_To_Buffer (S : String);
 139    --  Prepend given string to the contents of the string buffer, updating
 140    --  the value in Name_Len (i.e. string is added at start of buffer).
 141
 142    procedure Prepend_Uint_To_Buffer (U : Uint);
 143    --  Prepend image of universal integer to Name_Buffer, updating Name_Len
 144
 145    procedure Qualify_Entity_Name (Ent : Entity_Id);
 146    --  If not already done, replaces the Chars field of the given entity
 147    --  with the appropriate fully qualified name.
 148
 149    procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean);
 150    --  Given an qualified entity name in Name_Buffer, remove any plain X or
 151    --  X{nb} qualification suffix. The contents of Name_Buffer is not changed
 152    --  but Name_Len may be adjusted on return to remove the suffix. If a
 153    --  BNPE suffix is found and stripped, then BNPE_Suffix_Found is set to
 154    --  True. If no suffix is found, then BNPE_Suffix_Found is not modified.
 155    --  This routine also searches for a homonym suffix, and if one is found
 156    --  it is also stripped, and the entries are added to the global homonym
 157    --  list (Homonym_Numbers) so that they can later be put back.
 158
 159    ------------------------
 160    -- Add_Real_To_Buffer --
 161    ------------------------
 162
 163    procedure Add_Real_To_Buffer (U : Ureal) is
 164    begin
 165       Add_Uint_To_Buffer (Norm_Num (U));
 166       Add_Str_To_Name_Buffer ("_");
 167       Add_Uint_To_Buffer (Norm_Den (U));
 168    end Add_Real_To_Buffer;
 169
 170    ------------------------
 171    -- Add_Uint_To_Buffer --
 172    ------------------------
 173
 174    procedure Add_Uint_To_Buffer (U : Uint) is
 175    begin
 176       if U < 0 then
 177          Add_Uint_To_Buffer (-U);
 178          Add_Char_To_Name_Buffer ('m');
 179       else
 180          UI_Image (U, Decimal);
 181          Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
 182       end if;
 183    end Add_Uint_To_Buffer;
 184
 185    ---------------------------
 186    -- Append_Homonym_Number --
 187    ---------------------------
 188
 189    procedure Append_Homonym_Number (E : Entity_Id) is
 190
 191       procedure Add_Nat_To_H (Nr : Nat);
 192       --  Little procedure to append Nr to Homonym_Numbers
 193
 194       ------------------
 195       -- Add_Nat_To_H --
 196       ------------------
 197
 198       procedure Add_Nat_To_H (Nr : Nat) is
 199       begin
 200          if Nr >= 10 then
 201             Add_Nat_To_H (Nr / 10);
 202          end if;
 203
 204          Homonym_Len := Homonym_Len + 1;
 205          Homonym_Numbers (Homonym_Len) :=
 206            Character'Val (Nr mod 10 + Character'Pos ('0'));
 207       end Add_Nat_To_H;
 208
 209    --  Start of processing for Append_Homonym_Number
 210
 211    begin
 212       if Has_Homonym (E) then
 213          declare
 214             H  : Entity_Id := Homonym (E);
 215             Nr : Nat := 1;
 216
 217          begin
 218             while Present (H) loop
 219                if Scope (H) = Scope (E) then
 220                   Nr := Nr + 1;
 221                end if;
 222
 223                H := Homonym (H);
 224             end loop;
 225
 226             if Homonym_Len > 0 then
 227                Homonym_Len := Homonym_Len + 1;
 228                Homonym_Numbers (Homonym_Len) := '_';
 229             end if;
 230
 231             Add_Nat_To_H (Nr);
 232          end;
 233       end if;
 234    end Append_Homonym_Number;
 235
 236    -----------------------
 237    -- Bounds_Match_Size --
 238    -----------------------
 239
 240    function Bounds_Match_Size (E : Entity_Id) return Boolean is
 241       Siz : Uint;
 242
 243    begin
 244       if not Is_OK_Static_Subtype (E) then
 245          return False;
 246
 247       elsif Is_Integer_Type (E)
 248         and then Subtypes_Statically_Match (E, Base_Type (E))
 249       then
 250          return True;
 251
 252       --  Here we check if the static bounds match the natural size, which is
 253       --  the size passed through with the debugging information. This is the
 254       --  Esize rounded up to 8, 16, 32 or 64 as appropriate.
 255
 256       else
 257          declare
 258             Umark  : constant Uintp.Save_Mark := Uintp.Mark;
 259             Result : Boolean;
 260
 261          begin
 262             if Esize (E) <= 8 then
 263                Siz := Uint_8;
 264             elsif Esize (E) <= 16 then
 265                Siz := Uint_16;
 266             elsif Esize (E) <= 32 then
 267                Siz := Uint_32;
 268             else
 269                Siz := Uint_64;
 270             end if;
 271
 272             if Is_Modular_Integer_Type (E) or else Is_Enumeration_Type (E) then
 273                Result :=
 274                  Expr_Rep_Value (Type_Low_Bound (E)) = 0
 275                    and then
 276                  2 ** Siz - Expr_Rep_Value (Type_High_Bound (E)) = 1;
 277
 278             else
 279                Result :=
 280                  Expr_Rep_Value (Type_Low_Bound (E)) + 2 ** (Siz - 1) = 0
 281                    and then
 282                  2 ** (Siz - 1) - Expr_Rep_Value (Type_High_Bound (E)) = 1;
 283             end if;
 284
 285             Release (Umark);
 286             return Result;
 287          end;
 288       end if;
 289    end Bounds_Match_Size;
 290
 291    --------------------------------
 292    -- Debug_Renaming_Declaration --
 293    --------------------------------
 294
 295    function Debug_Renaming_Declaration (N : Node_Id) return Node_Id is
 296       Loc : constant Source_Ptr := Sloc (N);
 297       Ent : constant Node_Id    := Defining_Entity (N);
 298       Nam : constant Node_Id    := Name (N);
 299       Rnm : Name_Id;
 300       Ren : Node_Id;
 301       Lit : Entity_Id;
 302       Typ : Entity_Id;
 303       Res : Node_Id;
 304       Def : Entity_Id;
 305
 306       function Output_Subscript (N : Node_Id; S : String) return Boolean;
 307       --  Outputs a single subscript value as ?nnn (subscript is compile time
 308       --  known value with value nnn) or as ?e (subscript is local constant
 309       --  with name e), where S supplies the proper string to use for ?.
 310       --  Returns False if the subscript is not of an appropriate type to
 311       --  output in one of these two forms. The result is prepended to the
 312       --  name stored in Name_Buffer.
 313
 314       ----------------------
 315       -- Output_Subscript --
 316       ----------------------
 317
 318       function Output_Subscript (N : Node_Id; S : String) return Boolean is
 319       begin
 320          if Compile_Time_Known_Value (N) then
 321             Prepend_Uint_To_Buffer (Expr_Value (N));
 322
 323          elsif Nkind (N) = N_Identifier
 324            and then Scope (Entity (N)) = Scope (Ent)
 325            and then Ekind (Entity (N)) = E_Constant
 326          then
 327             Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N))));
 328
 329          else
 330             return False;
 331          end if;
 332
 333          Prepend_String_To_Buffer (S);
 334          return True;
 335       end Output_Subscript;
 336
 337    --  Start of processing for Debug_Renaming_Declaration
 338
 339    begin
 340       if not Comes_From_Source (N)
 341         and then not Needs_Debug_Info (Ent)
 342       then
 343          return Empty;
 344       end if;
 345
 346       --  Prepare entity name for type declaration
 347
 348       Get_Name_String (Chars (Ent));
 349
 350       case Nkind (N) is
 351          when N_Object_Renaming_Declaration =>
 352             Add_Str_To_Name_Buffer ("___XR");
 353
 354          when N_Exception_Renaming_Declaration =>
 355             Add_Str_To_Name_Buffer ("___XRE");
 356
 357          when N_Package_Renaming_Declaration =>
 358             Add_Str_To_Name_Buffer ("___XRP");
 359
 360             --  If it is a child unit create a fully qualified name, to
 361             --  disambiguate multiple child units with the same name and
 362             --  different parents.
 363
 364             if Is_Child_Unit (Ent) then
 365                Prepend_String_To_Buffer ("__");
 366                Prepend_String_To_Buffer
 367                  (Get_Name_String (Chars (Scope (Ent))));
 368             end if;
 369
 370          when others =>
 371             return Empty;
 372       end case;
 373
 374       Rnm := Name_Find;
 375
 376       --  Get renamed entity and compute suffix
 377
 378       Name_Len := 0;
 379       Ren := Nam;
 380       loop
 381          case Nkind (Ren) is
 382
 383             when N_Identifier =>
 384                exit;
 385
 386             when N_Expanded_Name =>
 387
 388                --  The entity field for an N_Expanded_Name is on the expanded
 389                --  name node itself, so we are done here too.
 390
 391                exit;
 392
 393             when N_Selected_Component =>
 394                Prepend_String_To_Buffer
 395                  (Get_Name_String (Chars (Selector_Name (Ren))));
 396                Prepend_String_To_Buffer ("XR");
 397                Ren := Prefix (Ren);
 398
 399             when N_Indexed_Component =>
 400                declare
 401                   X : Node_Id := Last (Expressions (Ren));
 402
 403                begin
 404                   while Present (X) loop
 405                      if not Output_Subscript (X, "XS") then
 406                         Set_Materialize_Entity (Ent);
 407                         return Empty;
 408                      end if;
 409
 410                      Prev (X);
 411                   end loop;
 412                end;
 413
 414                Ren := Prefix (Ren);
 415
 416             when N_Slice =>
 417
 418                Typ := Etype (First_Index (Etype (Nam)));
 419
 420                if not Output_Subscript (Type_High_Bound (Typ), "XS") then
 421                   Set_Materialize_Entity (Ent);
 422                   return Empty;
 423                end if;
 424
 425                if not Output_Subscript (Type_Low_Bound  (Typ), "XL") then
 426                   Set_Materialize_Entity (Ent);
 427                   return Empty;
 428                end if;
 429
 430                Ren := Prefix (Ren);
 431
 432             when N_Explicit_Dereference =>
 433                Set_Materialize_Entity (Ent);
 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       --  If not generating code, there is no need to create encoded
 496       --  names, and problems when the back-end is called to annotate
 497       --  types without full code generation. See comments at beginning
 498       --  of Get_External_Name_With_Suffix for additional details.
 499
 500       if Operating_Mode /= Generate_Code then
 501          return;
 502       end if;
 503
 504       Get_Name_String (Chars (E));
 505
 506       --  Nothing to do if we do not have a type
 507
 508       if not Is_Type (E)
 509
 510       --  Or if this is an enumeration base type
 511
 512         or else (Is_Enumeration_Type (E)
 513                    and then E = Base_Type (E))
 514
 515       --  Or if this is a dummy type for a renaming
 516
 517         or else (Name_Len >= 3 and then
 518                    Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR")
 519
 520         or else (Name_Len >= 4 and then
 521                    (Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
 522                       or else
 523                     Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"))
 524
 525       --  For all these cases, just return the name unchanged
 526
 527       then
 528          Name_Buffer (Name_Len + 1) := ASCII.Nul;
 529          return;
 530       end if;
 531
 532       Has_Suffix := True;
 533
 534       --  Fixed-point case
 535
 536       if Is_Fixed_Point_Type (E) then
 537          Get_External_Name_With_Suffix (E, "XF_");
 538          Add_Real_To_Buffer (Delta_Value (E));
 539
 540          if Small_Value (E) /= Delta_Value (E) then
 541             Add_Str_To_Name_Buffer ("_");
 542             Add_Real_To_Buffer (Small_Value (E));
 543          end if;
 544
 545       --  Vax floating-point case
 546
 547       elsif Vax_Float (E) then
 548          if Digits_Value (Base_Type (E)) = 6 then
 549             Get_External_Name_With_Suffix (E, "XFF");
 550
 551          elsif Digits_Value (Base_Type (E)) = 9 then
 552             Get_External_Name_With_Suffix (E, "XFF");
 553
 554          else
 555             pragma Assert (Digits_Value (Base_Type (E)) = 15);
 556             Get_External_Name_With_Suffix (E, "XFG");
 557          end if;
 558
 559       --  Discrete case where bounds do not match size
 560
 561       elsif Is_Discrete_Type (E)
 562         and then not Bounds_Match_Size (E)
 563       then
 564          declare
 565             Lo : constant Node_Id := Type_Low_Bound (E);
 566             Hi : constant Node_Id := Type_High_Bound (E);
 567
 568             Lo_Con : constant Boolean := Compile_Time_Known_Value (Lo);
 569             Hi_Con : constant Boolean := Compile_Time_Known_Value (Hi);
 570
 571             Lo_Discr : constant Boolean :=
 572                          Nkind (Lo) = N_Identifier
 573                            and then
 574                          Ekind (Entity (Lo)) = E_Discriminant;
 575
 576             Hi_Discr : constant Boolean :=
 577                          Nkind (Hi) = N_Identifier
 578                            and then
 579                          Ekind (Entity (Hi)) = E_Discriminant;
 580
 581             Lo_Encode : constant Boolean := Lo_Con or Lo_Discr;
 582             Hi_Encode : constant Boolean := Hi_Con or Hi_Discr;
 583
 584             Biased : constant Boolean := Has_Biased_Representation (E);
 585
 586          begin
 587             if Biased then
 588                Get_External_Name_With_Suffix (E, "XB");
 589             else
 590                Get_External_Name_With_Suffix (E, "XD");
 591             end if;
 592
 593             if Lo_Encode or Hi_Encode then
 594                if Biased then
 595                   Add_Str_To_Name_Buffer ("_");
 596                else
 597                   if Lo_Encode then
 598                      if Hi_Encode then
 599                         Add_Str_To_Name_Buffer ("LU_");
 600                      else
 601                         Add_Str_To_Name_Buffer ("L_");
 602                      end if;
 603                   else
 604                      Add_Str_To_Name_Buffer ("U_");
 605                   end if;
 606                end if;
 607
 608                if Lo_Con then
 609                   Add_Uint_To_Buffer (Expr_Rep_Value (Lo));
 610                elsif Lo_Discr then
 611                   Get_Name_String_And_Append (Chars (Entity (Lo)));
 612                end if;
 613
 614                if Lo_Encode and Hi_Encode then
 615                   Add_Str_To_Name_Buffer ("__");
 616                end if;
 617
 618                if Hi_Con then
 619                   Add_Uint_To_Buffer (Expr_Rep_Value (Hi));
 620                elsif Hi_Discr then
 621                   Get_Name_String_And_Append (Chars (Entity (Hi)));
 622                end if;
 623             end if;
 624          end;
 625
 626       --  For all other cases, the encoded name is the normal type name
 627
 628       else
 629          Has_Suffix := False;
 630          Get_External_Name (E, Has_Suffix);
 631       end if;
 632
 633       if Debug_Flag_B and then Has_Suffix then
 634          Write_Str ("**** type ");
 635          Write_Name (Chars (E));
 636          Write_Str (" is encoded as ");
 637          Write_Str (Name_Buffer (1 .. Name_Len));
 638          Write_Eol;
 639       end if;
 640
 641       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 642    end Get_Encoded_Name;
 643
 644    -----------------------
 645    -- Get_External_Name --
 646    -----------------------
 647
 648    procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean) is
 649       E    : Entity_Id := Entity;
 650       Kind : Entity_Kind;
 651
 652       procedure Get_Qualified_Name_And_Append (Entity : Entity_Id);
 653       --  Appends fully qualified name of given entity to Name_Buffer
 654
 655       -----------------------------------
 656       -- Get_Qualified_Name_And_Append --
 657       -----------------------------------
 658
 659       procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is
 660       begin
 661          --  If the entity is a compilation unit, its scope is Standard,
 662          --  there is no outer scope, and the no further qualification
 663          --  is required.
 664
 665          --  If the front end has already computed a fully qualified name,
 666          --  then it is also the case that no further qualification is
 667          --  required
 668
 669          if Present (Scope (Scope (Entity)))
 670            and then not Has_Fully_Qualified_Name (Entity)
 671          then
 672             Get_Qualified_Name_And_Append (Scope (Entity));
 673             Add_Str_To_Name_Buffer ("__");
 674             Get_Name_String_And_Append (Chars (Entity));
 675             Append_Homonym_Number (Entity);
 676
 677          else
 678             Get_Name_String_And_Append (Chars (Entity));
 679          end if;
 680       end Get_Qualified_Name_And_Append;
 681
 682    --  Start of processing for Get_External_Name
 683
 684    begin
 685       Name_Len    := 0;
 686       Homonym_Len := 0;
 687
 688       --  If this is a child unit, we want the child
 689
 690       if Nkind (E) = N_Defining_Program_Unit_Name then
 691          E := Defining_Identifier (Entity);
 692       end if;
 693
 694       Kind := Ekind (E);
 695
 696       --  Case of interface name being used
 697
 698       if (Kind = E_Procedure or else
 699           Kind = E_Function  or else
 700           Kind = E_Constant  or else
 701           Kind = E_Variable  or else
 702           Kind = E_Exception)
 703         and then Present (Interface_Name (E))
 704         and then No (Address_Clause (E))
 705         and then not Has_Suffix
 706       then
 707          Add_String_To_Name_Buffer (Strval (Interface_Name (E)));
 708
 709       --  All other cases besides the interface name case
 710
 711       else
 712          --  If this is a library level subprogram (i.e. a subprogram that is a
 713          --  compilation unit other than a subunit), then we prepend _ada_ to
 714          --  ensure distinctions required as described in the spec.
 715
 716          --  Check explicitly for child units, because those are not flagged
 717          --  as Compilation_Units by lib. Should they be ???
 718
 719          if Is_Subprogram (E)
 720            and then (Is_Compilation_Unit (E) or Is_Child_Unit (E))
 721            and then not Has_Suffix
 722          then
 723             Add_Str_To_Name_Buffer ("_ada_");
 724          end if;
 725
 726          --  If the entity is a subprogram instance that is not a compilation
 727          --  unit, generate the name of the original Ada entity, which is the
 728          --  one gdb needs.
 729
 730          if Is_Generic_Instance (E)
 731            and then Is_Subprogram (E)
 732            and then not Is_Compilation_Unit (Scope (E))
 733            and then (Ekind (Scope (E)) = E_Package
 734                       or else
 735                      Ekind (Scope (E)) = E_Package_Body)
 736            and then Present (Related_Instance (Scope (E)))
 737          then
 738             E := Related_Instance (Scope (E));
 739          end if;
 740
 741          Get_Qualified_Name_And_Append (E);
 742       end if;
 743
 744       Name_Buffer (Name_Len + 1) := ASCII.Nul;
 745    end Get_External_Name;
 746
 747    -----------------------------------
 748    -- Get_External_Name_With_Suffix --
 749    -----------------------------------
 750
 751    procedure Get_External_Name_With_Suffix
 752      (Entity : Entity_Id;
 753       Suffix : String)
 754    is
 755       Has_Suffix : constant Boolean := (Suffix /= "");
 756
 757    begin
 758       --  If we are not in code generation mode, this procedure may still be
 759       --  called from Back_End (more specifically - from gigi for doing type
 760       --  representation annotation or some representation-specific checks).
 761       --  But in this mode there is no need to mess with external names.
 762
 763       --  Furthermore, the call causes difficulties in this case because the
 764       --  string representing the homonym number is not correctly reset as a
 765       --  part of the call to Output_Homonym_Numbers_Suffix (which is not
 766       --  called in gigi).
 767
 768       if Operating_Mode /= Generate_Code then
 769          return;
 770       end if;
 771
 772       Get_External_Name (Entity, Has_Suffix);
 773
 774       if Has_Suffix then
 775          Add_Str_To_Name_Buffer ("___");
 776          Add_Str_To_Name_Buffer (Suffix);
 777          Name_Buffer (Name_Len + 1) := ASCII.Nul;
 778       end if;
 779    end Get_External_Name_With_Suffix;
 780
 781    --------------------------
 782    -- Get_Variant_Encoding --
 783    --------------------------
 784
 785    procedure Get_Variant_Encoding (V : Node_Id) is
 786       Choice : Node_Id;
 787
 788       procedure Choice_Val (Typ : Character; Choice : Node_Id);
 789       --  Output encoded value for a single choice value. Typ is the key
 790       --  character ('S', 'F', or 'T') that precedes the choice value.
 791
 792       ----------------
 793       -- Choice_Val --
 794       ----------------
 795
 796       procedure Choice_Val (Typ : Character; Choice : Node_Id) is
 797       begin
 798          if Nkind (Choice) = N_Integer_Literal then
 799             Add_Char_To_Name_Buffer (Typ);
 800             Add_Uint_To_Buffer (Intval (Choice));
 801
 802          --  Character literal with no entity present (this is the case
 803          --  Standard.Character or Standard.Wide_Character as root type)
 804
 805          elsif Nkind (Choice) = N_Character_Literal
 806            and then No (Entity (Choice))
 807          then
 808             Add_Char_To_Name_Buffer (Typ);
 809             Add_Uint_To_Buffer (Char_Literal_Value (Choice));
 810
 811          else
 812             declare
 813                Ent : constant Entity_Id := Entity (Choice);
 814
 815             begin
 816                if Ekind (Ent) = E_Enumeration_Literal then
 817                   Add_Char_To_Name_Buffer (Typ);
 818                   Add_Uint_To_Buffer (Enumeration_Rep (Ent));
 819
 820                else
 821                   pragma Assert (Ekind (Ent) = E_Constant);
 822                   Choice_Val (Typ, Constant_Value (Ent));
 823                end if;
 824             end;
 825          end if;
 826       end Choice_Val;
 827
 828    --  Start of processing for Get_Variant_Encoding
 829
 830    begin
 831       Name_Len := 0;
 832
 833       Choice := First (Discrete_Choices (V));
 834       while Present (Choice) loop
 835          if Nkind (Choice) = N_Others_Choice then
 836             Add_Char_To_Name_Buffer ('O');
 837
 838          elsif Nkind (Choice) = N_Range then
 839             Choice_Val ('R', Low_Bound (Choice));
 840             Choice_Val ('T', High_Bound (Choice));
 841
 842          elsif Is_Entity_Name (Choice)
 843            and then Is_Type (Entity (Choice))
 844          then
 845             Choice_Val ('R', Type_Low_Bound (Entity (Choice)));
 846             Choice_Val ('T', Type_High_Bound (Entity (Choice)));
 847
 848          elsif Nkind (Choice) = N_Subtype_Indication then
 849             declare
 850                Rang : constant Node_Id :=
 851                         Range_Expression (Constraint (Choice));
 852             begin
 853                Choice_Val ('R', Low_Bound (Rang));
 854                Choice_Val ('T', High_Bound (Rang));
 855             end;
 856
 857          else
 858             Choice_Val ('S', Choice);
 859          end if;
 860
 861          Next (Choice);
 862       end loop;
 863
 864       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 865
 866       if Debug_Flag_B then
 867          declare
 868             VP : constant Node_Id := Parent (V);    -- Variant_Part
 869             CL : constant Node_Id := Parent (VP);   -- Component_List
 870             RD : constant Node_Id := Parent (CL);   -- Record_Definition
 871             FT : constant Node_Id := Parent (RD);   -- Full_Type_Declaration
 872
 873          begin
 874             Write_Str ("**** variant for type ");
 875             Write_Name (Chars (Defining_Identifier (FT)));
 876             Write_Str (" is encoded as ");
 877             Write_Str (Name_Buffer (1 .. Name_Len));
 878             Write_Eol;
 879          end;
 880       end if;
 881    end Get_Variant_Encoding;
 882
 883    ------------------------------------
 884    -- Get_Secondary_DT_External_Name --
 885    ------------------------------------
 886
 887    procedure Get_Secondary_DT_External_Name
 888      (Typ          : Entity_Id;
 889       Ancestor_Typ : Entity_Id;
 890       Suffix_Index : Int)
 891    is
 892    begin
 893       Get_External_Name (Typ, Has_Suffix => False);
 894
 895       if Ancestor_Typ /= Typ then
 896          declare
 897             Len      : constant Natural := Name_Len;
 898             Save_Str : constant String (1 .. Name_Len)
 899                          := Name_Buffer (1 .. Name_Len);
 900          begin
 901             Get_External_Name (Ancestor_Typ, Has_Suffix => False);
 902
 903             --  Append the extended name of the ancestor to the
 904             --  extended name of Typ
 905
 906             Name_Buffer (Len + 2 .. Len + Name_Len + 1) :=
 907               Name_Buffer (1 .. Name_Len);
 908             Name_Buffer (1 .. Len) := Save_Str;
 909             Name_Buffer (Len + 1) := '_';
 910             Name_Len := Len + Name_Len + 1;
 911          end;
 912       end if;
 913
 914       Add_Nat_To_Name_Buffer (Suffix_Index);
 915    end Get_Secondary_DT_External_Name;
 916
 917    ---------------------------------
 918    -- Make_Packed_Array_Type_Name --
 919    ---------------------------------
 920
 921    function Make_Packed_Array_Type_Name
 922      (Typ   : Entity_Id;
 923       Csize : Uint)
 924       return  Name_Id
 925    is
 926    begin
 927       Get_Name_String (Chars (Typ));
 928       Add_Str_To_Name_Buffer ("___XP");
 929       Add_Uint_To_Buffer (Csize);
 930       return Name_Find;
 931    end Make_Packed_Array_Type_Name;
 932
 933    -----------------------------------
 934    -- Output_Homonym_Numbers_Suffix --
 935    -----------------------------------
 936
 937    procedure Output_Homonym_Numbers_Suffix is
 938       J : Natural;
 939
 940    begin
 941       if Homonym_Len > 0 then
 942
 943          --  Check for all 1's, in which case we do not output
 944
 945          J := 1;
 946          loop
 947             exit when Homonym_Numbers (J) /= '1';
 948
 949             --  If we reached end of string we do not output
 950
 951             if J = Homonym_Len then
 952                Homonym_Len := 0;
 953                return;
 954             end if;
 955
 956             exit when Homonym_Numbers (J + 1) /= '_';
 957             J := J + 2;
 958          end loop;
 959
 960          --  If we exit the loop then suffix must be output
 961
 962          Add_Str_To_Name_Buffer ("__");
 963          Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len));
 964          Homonym_Len := 0;
 965       end if;
 966    end Output_Homonym_Numbers_Suffix;
 967
 968    ------------------------------
 969    -- Prepend_String_To_Buffer --
 970    ------------------------------
 971
 972    procedure Prepend_String_To_Buffer (S : String) is
 973       N : constant Integer := S'Length;
 974    begin
 975       Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len);
 976       Name_Buffer (1 .. N) := S;
 977       Name_Len := Name_Len + N;
 978    end Prepend_String_To_Buffer;
 979
 980    ----------------------------
 981    -- Prepend_Uint_To_Buffer --
 982    ----------------------------
 983
 984    procedure Prepend_Uint_To_Buffer (U : Uint) is
 985    begin
 986       if U < 0 then
 987          Prepend_String_To_Buffer ("m");
 988          Prepend_Uint_To_Buffer (-U);
 989       else
 990          UI_Image (U, Decimal);
 991          Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
 992       end if;
 993    end Prepend_Uint_To_Buffer;
 994
 995    ------------------------------
 996    -- Qualify_All_Entity_Names --
 997    ------------------------------
 998
 999    procedure Qualify_All_Entity_Names is
1000       E   : Entity_Id;
1001       Ent : Entity_Id;
1002
1003    begin
1004       for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
1005          E := Defining_Entity (Name_Qualify_Units.Table (J));
1006          Qualify_Entity_Name (E);
1007
1008          Ent := First_Entity (E);
1009          while Present (Ent) loop
1010             Qualify_Entity_Name (Ent);
1011             Next_Entity (Ent);
1012
1013             --  There are odd cases where Last_Entity (E) = E. This happens
1014             --  in the case of renaming of packages. This test avoids getting
1015             --  stuck in such cases.
1016
1017             exit when Ent = E;
1018          end loop;
1019       end loop;
1020    end Qualify_All_Entity_Names;
1021
1022    -------------------------
1023    -- Qualify_Entity_Name --
1024    -------------------------
1025
1026    procedure Qualify_Entity_Name (Ent : Entity_Id) is
1027
1028       Full_Qualify_Name : String (1 .. Name_Buffer'Length);
1029       Full_Qualify_Len  : Natural := 0;
1030       --  Used to accumulate fully qualified name of subprogram
1031
1032       procedure Fully_Qualify_Name (E : Entity_Id);
1033       --  Used to qualify a subprogram or type name, where full
1034       --  qualification up to Standard is always used. Name is set
1035       --  in Full_Qualify_Name with the length in Full_Qualify_Len.
1036       --  Note that this routine does not prepend the _ada_ string
1037       --  required for library subprograms (this is done in the back end).
1038
1039       function Is_BNPE (S : Entity_Id) return Boolean;
1040       --  Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
1041       --  is defined to be a package which is immediately nested within a
1042       --  package body.
1043
1044       function Qualify_Needed (S : Entity_Id) return Boolean;
1045       --  Given a scope, determines if the scope is to be included in the
1046       --  fully qualified name, True if so, False if not.
1047
1048       procedure Set_BNPE_Suffix (E : Entity_Id);
1049       --  Recursive routine to append the BNPE qualification suffix. Works
1050       --  from right to left with E being the current entity in the list.
1051       --  The result does NOT have the trailing n's and trailing b stripped.
1052       --  The caller must do this required stripping.
1053
1054       procedure Set_Entity_Name (E : Entity_Id);
1055       --  Internal recursive routine that does most of the work. This routine
1056       --  leaves the result sitting in Name_Buffer and Name_Len.
1057
1058       BNPE_Suffix_Needed : Boolean := False;
1059       --  Set true if a body-nested package entity suffix is required
1060
1061       Save_Chars : constant Name_Id := Chars (Ent);
1062       --  Save original name
1063
1064       ------------------------
1065       -- Fully_Qualify_Name --
1066       ------------------------
1067
1068       procedure Fully_Qualify_Name (E : Entity_Id) is
1069          Discard : Boolean := False;
1070
1071       begin
1072          --  Ignore empty entry (can happen in error cases)
1073
1074          if No (E) then
1075             return;
1076
1077          --  If this we are qualifying entities local to a generic
1078          --  instance, use the name of the original instantiation,
1079          --  not that of the anonymous subprogram in the wrapper
1080          --  package, so that gdb doesn't have to know about these.
1081
1082          elsif Is_Generic_Instance (E)
1083            and then Is_Subprogram (E)
1084            and then not Comes_From_Source (E)
1085            and then not Is_Compilation_Unit (Scope (E))
1086          then
1087             Fully_Qualify_Name (Related_Instance (Scope (E)));
1088             return;
1089          end if;
1090
1091          --  If we reached fully qualified name, then just copy it
1092
1093          if Has_Fully_Qualified_Name (E) then
1094             Get_Name_String (Chars (E));
1095             Strip_Suffixes (Discard);
1096             Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1097             Full_Qualify_Len := Name_Len;
1098             Set_Has_Fully_Qualified_Name (Ent);
1099
1100          --  Case of non-fully qualified name
1101
1102          else
1103             if Scope (E) = Standard_Standard then
1104                Set_Has_Fully_Qualified_Name (Ent);
1105             else
1106                Fully_Qualify_Name (Scope (E));
1107                Full_Qualify_Name (Full_Qualify_Len + 1) := '_';
1108                Full_Qualify_Name (Full_Qualify_Len + 2) := '_';
1109                Full_Qualify_Len := Full_Qualify_Len + 2;
1110             end if;
1111
1112             if Has_Qualified_Name (E) then
1113                Get_Unqualified_Name_String (Chars (E));
1114             else
1115                Get_Name_String (Chars (E));
1116             end if;
1117
1118             --  Here we do one step of the qualification
1119
1120             Full_Qualify_Name
1121               (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) :=
1122                  Name_Buffer (1 .. Name_Len);
1123             Full_Qualify_Len := Full_Qualify_Len + Name_Len;
1124             Append_Homonym_Number (E);
1125          end if;
1126
1127          if Is_BNPE (E) then
1128             BNPE_Suffix_Needed := True;
1129          end if;
1130       end Fully_Qualify_Name;
1131
1132       -------------
1133       -- Is_BNPE --
1134       -------------
1135
1136       function Is_BNPE (S : Entity_Id) return Boolean is
1137       begin
1138          return
1139            Ekind (S) = E_Package
1140              and then Is_Package_Body_Entity (S);
1141       end Is_BNPE;
1142
1143       --------------------
1144       -- Qualify_Needed --
1145       --------------------
1146
1147       function Qualify_Needed (S : Entity_Id) return Boolean is
1148       begin
1149          --  If we got all the way to Standard, then we have certainly
1150          --  fully qualified the name, so set the flag appropriately,
1151          --  and then return False, since we are most certainly done!
1152
1153          if S = Standard_Standard then
1154             Set_Has_Fully_Qualified_Name (Ent, True);
1155             return False;
1156
1157          --  Otherwise figure out if further qualification is required
1158
1159          else
1160             return
1161               Is_Subprogram (Ent)
1162                 or else
1163               Ekind (Ent) = E_Subprogram_Body
1164                 or else
1165                   (Ekind (S) /= E_Block
1166                     and then not Is_Dynamic_Scope (S));
1167          end if;
1168       end Qualify_Needed;
1169
1170       ---------------------
1171       -- Set_BNPE_Suffix --
1172       ---------------------
1173
1174       procedure Set_BNPE_Suffix (E : Entity_Id) is
1175          S : constant Entity_Id := Scope (E);
1176
1177       begin
1178          if Qualify_Needed (S) then
1179             Set_BNPE_Suffix (S);
1180
1181             if Is_BNPE (E) then
1182                Add_Char_To_Name_Buffer ('b');
1183             else
1184                Add_Char_To_Name_Buffer ('n');
1185             end if;
1186
1187          else
1188             Add_Char_To_Name_Buffer ('X');
1189          end if;
1190       end Set_BNPE_Suffix;
1191
1192       ---------------------
1193       -- Set_Entity_Name --
1194       ---------------------
1195
1196       procedure Set_Entity_Name (E : Entity_Id) is
1197          S : constant Entity_Id := Scope (E);
1198
1199       begin
1200          --  If we reach an already qualified name, just take the encoding
1201          --  except that we strip the package body suffixes, since these
1202          --  will be separately put on later.
1203
1204          if Has_Qualified_Name (E) then
1205             Get_Name_String_And_Append (Chars (E));
1206             Strip_Suffixes (BNPE_Suffix_Needed);
1207
1208             --  If the top level name we are adding is itself fully
1209             --  qualified, then that means that the name that we are
1210             --  preparing for the Fully_Qualify_Name call will also
1211             --  generate a fully qualified name.
1212
1213             if Has_Fully_Qualified_Name (E) then
1214                Set_Has_Fully_Qualified_Name (Ent);
1215             end if;
1216
1217          --  Case where upper level name is not encoded yet
1218
1219          else
1220             --  Recurse if further qualification required
1221
1222             if Qualify_Needed (S) then
1223                Set_Entity_Name (S);
1224                Add_Str_To_Name_Buffer ("__");
1225             end if;
1226
1227             --  Otherwise get name and note if it is a NPBE
1228
1229             Get_Name_String_And_Append (Chars (E));
1230
1231             if Is_BNPE (E) then
1232                BNPE_Suffix_Needed := True;
1233             end if;
1234
1235             Append_Homonym_Number (E);
1236          end if;
1237       end Set_Entity_Name;
1238
1239    --  Start of processing for Qualify_Entity_Name
1240
1241    begin
1242       if Has_Qualified_Name (Ent) then
1243          return;
1244
1245       --  Here is where we create the proper link for renaming
1246
1247       elsif Ekind (Ent) = E_Enumeration_Literal
1248         and then Present (Debug_Renaming_Link (Ent))
1249       then
1250          Name_Len := 0;
1251          Qualify_Entity_Name (Debug_Renaming_Link (Ent));
1252          Get_Name_String (Chars (Ent));
1253          Prepend_String_To_Buffer
1254            (Get_Name_String (Chars (Debug_Renaming_Link (Ent))));
1255          Set_Chars (Ent, Name_Enter);
1256          Set_Has_Qualified_Name (Ent);
1257          return;
1258
1259       elsif Is_Subprogram (Ent)
1260         or else Ekind (Ent) = E_Subprogram_Body
1261         or else Is_Type (Ent)
1262       then
1263          Fully_Qualify_Name (Ent);
1264          Name_Len := Full_Qualify_Len;
1265          Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
1266
1267       elsif Qualify_Needed (Scope (Ent)) then
1268          Name_Len := 0;
1269          Set_Entity_Name (Ent);
1270
1271       else
1272          Set_Has_Qualified_Name (Ent);
1273          return;
1274       end if;
1275
1276       --  Fall through with a fully qualified name in Name_Buffer/Name_Len
1277
1278       Output_Homonym_Numbers_Suffix;
1279
1280       --  Add body-nested package suffix if required
1281
1282       if BNPE_Suffix_Needed
1283         and then Ekind (Ent) /= E_Enumeration_Literal
1284       then
1285          Set_BNPE_Suffix (Ent);
1286
1287          --  Strip trailing n's and last trailing b as required. note that
1288          --  we know there is at least one b, or no suffix would be generated.
1289
1290          while Name_Buffer (Name_Len) = 'n' loop
1291             Name_Len := Name_Len - 1;
1292          end loop;
1293
1294          Name_Len := Name_Len - 1;
1295       end if;
1296
1297       Set_Chars (Ent, Name_Enter);
1298       Set_Has_Qualified_Name (Ent);
1299
1300       if Debug_Flag_BB then
1301          Write_Str ("*** ");
1302          Write_Name (Save_Chars);
1303          Write_Str (" qualified as ");
1304          Write_Name (Chars (Ent));
1305          Write_Eol;
1306       end if;
1307    end Qualify_Entity_Name;
1308
1309    --------------------------
1310    -- Qualify_Entity_Names --
1311    --------------------------
1312
1313    procedure Qualify_Entity_Names (N : Node_Id) is
1314    begin
1315       Name_Qualify_Units.Append (N);
1316    end Qualify_Entity_Names;
1317
1318    --------------------
1319    -- Strip_Suffixes --
1320    --------------------
1321
1322    procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is
1323       SL : Natural;
1324
1325    begin
1326       --  Search for and strip BNPE suffix
1327
1328       for J in reverse 2 .. Name_Len loop
1329          if Name_Buffer (J) = 'X' then
1330             Name_Len := J - 1;
1331             BNPE_Suffix_Found := True;
1332             exit;
1333          end if;
1334
1335          exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n';
1336       end loop;
1337
1338       --  Search for and strip homonym numbers suffix
1339
1340       for J in reverse 2 .. Name_Len - 2 loop
1341          if Name_Buffer (J) = '_'
1342            and then Name_Buffer (J + 1) = '_'
1343          then
1344             if Name_Buffer (J + 2) in '0' .. '9' then
1345                if Homonym_Len > 0 then
1346                   Homonym_Len := Homonym_Len + 1;
1347                   Homonym_Numbers (Homonym_Len) := '-';
1348                end if;
1349
1350                SL := Name_Len - (J + 1);
1351
1352                Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) :=
1353                  Name_Buffer (J + 2 .. Name_Len);
1354                Name_Len := J - 1;
1355                Homonym_Len := Homonym_Len + SL;
1356             end if;
1357
1358             exit;
1359          end if;
1360       end loop;
1361    end Strip_Suffixes;
1362
1363 end Exp_Dbug;