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