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 --                            $Revision$
  10 --                                                                          --
  11 --          Copyright (C) 1996-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Alloc;    use Alloc;
  30 with Atree;    use Atree;
  31 with Debug;    use Debug;
  32 with Einfo;    use Einfo;
  33 with Exp_Util; use Exp_Util;
  34 with Freeze;   use Freeze;
  35 with Lib;      use Lib;
  36 with Hostparm; use Hostparm;
  37 with Namet;    use Namet;
  38 with Nlists;   use Nlists;
  39 with Nmake;    use Nmake;
  40 with Opt;      use Opt;
  41 with Output;   use Output;
  42 with Sem_Eval; use Sem_Eval;
  43 with Sem_Util; use Sem_Util;
  44 with Sinput;   use Sinput;
  45 with Snames;   use Snames;
  46 with Stand;    use Stand;
  47 with Stringt;  use Stringt;
  48 with Table;
  49 with Urealp;   use Urealp;
  50
  51 with GNAT.HTable;
  52
  53 package body Exp_Dbug is
  54
  55    --  The following table is used to queue up the entities passed as
  56    --  arguments to Qualify_Entity_Names for later processing when
  57    --  Qualify_All_Entity_Names is called.
  58
  59    package Name_Qualify_Units is new Table.Table (
  60      Table_Component_Type => Node_Id,
  61      Table_Index_Type     => Nat,
  62      Table_Low_Bound      => 1,
  63      Table_Initial        => Alloc.Name_Qualify_Units_Initial,
  64      Table_Increment      => Alloc.Name_Qualify_Units_Increment,
  65      Table_Name           => "Name_Qualify_Units");
  66
  67    --  Define hash table for compressed debug names
  68
  69    --  This hash table keeps track of qualification prefix strings
  70    --  that have been compressed. The element is the corresponding
  71    --  hash value used in the compressed symbol.
  72
  73    type Hindex is range 0 .. 4096;
  74    --  Type to define range of headers
  75
  76    function SHash (S : String_Ptr) return Hindex;
  77    --  Hash function for this table
  78
  79    function SEq (F1, F2 : String_Ptr) return Boolean;
  80    --  Equality function for this table
  81
  82    type Elmt is record
  83       W : Word;
  84       S : String_Ptr;
  85    end record;
  86
  87    No_Elmt : Elmt := (0, null);
  88
  89    package CDN is new GNAT.HTable.Simple_HTable (
  90      Header_Num => Hindex,
  91      Element    => Elmt,
  92      No_Element => No_Elmt,
  93      Key        => String_Ptr,
  94      Hash       => SHash,
  95      Equal      => SEq);
  96
  97    --------------------------------
  98    -- Use of Qualification Flags --
  99    --------------------------------
 100
 101    --  There are two flags used to keep track of qualification of entities
 102
 103    --    Has_Fully_Qualified_Name
 104    --    Has_Qualified_Name
 105
 106    --  The difference between these is as follows. Has_Qualified_Name is
 107    --  set to indicate that the name has been qualified as required by the
 108    --  spec of this package. As described there, this may involve the full
 109    --  qualification for the name, but for some entities, notably procedure
 110    --  local variables, this full qualification is not required.
 111
 112    --  The flag Has_Fully_Qualified_Name is set if indeed the name has been
 113    --  fully qualified in the Ada sense. If Has_Fully_Qualified_Name is set,
 114    --  then Has_Qualified_Name is also set, but the other way round is not
 115    --  the case.
 116
 117    --  Consider the following example:
 118
 119    --     with ...
 120    --     procedure X is
 121    --       B : Ddd.Ttt;
 122    --       procedure Y is ..
 123
 124    --  Here B is a procedure local variable, so it does not need fully
 125    --  qualification. The flag Has_Qualified_Name will be set on the
 126    --  first attempt to qualify B, to indicate that the job is done
 127    --  and need not be redone.
 128
 129    --  But Y is qualified as x__y, since procedures are always fully
 130    --  qualified, so the first time that an attempt is made to qualify
 131    --  the name y, it will be replaced by x__y, and both flags are set.
 132
 133    --  Why the two flags? Well there are cases where we derive type names
 134    --  from object names. As noted in the spec, type names are always
 135    --  fully qualified. Suppose for example that the backend has to build
 136    --  a padded type for variable B. then it will construct the PAD name
 137    --  from B, but it requires full qualification, so the fully qualified
 138    --  type name will be x__b___PAD. The two flags allow the circuit for
 139    --  building this name to realize efficiently that b needs further
 140    --  qualification.
 141
 142    ----------------------
 143    -- Local Procedures --
 144    ----------------------
 145
 146    procedure Add_Uint_To_Buffer (U : Uint);
 147    --  Add image of universal integer to Name_Buffer, updating Name_Len
 148
 149    procedure Add_Real_To_Buffer (U : Ureal);
 150    --  Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of
 151    --  the normalized numerator and denominator of the given real value.
 152
 153    function Bounds_Match_Size (E : Entity_Id) return  Boolean;
 154    --  Determine whether the bounds of E match the size of the type. This is
 155    --  used to determine whether encoding is required for a discrete type.
 156
 157    function CDN_Hash (S : String) return Word;
 158    --  This is the hash function used to compress debug symbols. The string
 159    --  S is the prefix which is a list of qualified names separated by double
 160    --  underscore (no trailing double underscore). The returned value is the
 161    --  hash value used in the compressed names. It is also used for the hash
 162    --  table used to keep track of what prefixes have been compressed so far.
 163
 164    procedure Compress_Debug_Name (E : Entity_Id);
 165    --  If the name of the entity E is too long, or compression is to be
 166    --  attempted on all names (Compress_Debug_Names set), then an attempt
 167    --  is made to compress the name of the entity.
 168
 169    function Double_Underscore (S : String; J : Natural) return Boolean;
 170    --  Returns True if J is the start of a double underscore
 171    --  sequence in the string S (defined as two underscores
 172    --  which are preceded and followed by a non-underscore)
 173
 174    procedure Prepend_String_To_Buffer (S : String);
 175    --  Prepend given string to the contents of the string buffer, updating
 176    --  the value in Name_Len (i.e. string is added at start of buffer).
 177
 178    procedure Prepend_Uint_To_Buffer (U : Uint);
 179    --  Prepend image of universal integer to Name_Buffer, updating Name_Len
 180
 181    procedure Put_Hex (W : Word; N : Natural);
 182    --  Output W as 8 hex digits (0-9, a-f) in Name_Buffer (N .. N + 7)
 183
 184    procedure Qualify_Entity_Name (Ent : Entity_Id);
 185    --  If not already done, replaces the Chars field of the given entity
 186    --  with the appropriate fully qualified name.
 187
 188    procedure Strip_BNPE_Suffix (Suffix_Found : in out Boolean);
 189    --  Given an qualified entity name in Name_Buffer, remove any plain X or
 190    --  X{nb} qualification suffix. The contents of Name_Buffer is not changed
 191    --  but Name_Len may be adjusted on return to remove the suffix. If a
 192    --  suffix is found and stripped, then Suffix_Found is set to True. If
 193    --  no suffix is found, then Suffix_Found is not modified.
 194
 195    ------------------------
 196    -- Add_Real_To_Buffer --
 197    ------------------------
 198
 199    procedure Add_Real_To_Buffer (U : Ureal) is
 200    begin
 201       Add_Uint_To_Buffer (Norm_Num (U));
 202       Add_Str_To_Name_Buffer ("_");
 203       Add_Uint_To_Buffer (Norm_Den (U));
 204    end Add_Real_To_Buffer;
 205
 206    ------------------------
 207    -- Add_Uint_To_Buffer --
 208    ------------------------
 209
 210    procedure Add_Uint_To_Buffer (U : Uint) is
 211    begin
 212       if U < 0 then
 213          Add_Uint_To_Buffer (-U);
 214          Add_Char_To_Name_Buffer ('m');
 215       else
 216          UI_Image (U, Decimal);
 217          Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
 218       end if;
 219    end Add_Uint_To_Buffer;
 220
 221    -----------------------
 222    -- Bounds_Match_Size --
 223    -----------------------
 224
 225    function Bounds_Match_Size (E : Entity_Id) return Boolean is
 226       Siz : Uint;
 227
 228    begin
 229       if not Is_OK_Static_Subtype (E) then
 230          return False;
 231
 232       elsif Is_Integer_Type (E)
 233         and then Subtypes_Statically_Match (E, Base_Type (E))
 234       then
 235          return True;
 236
 237       --  Here we check if the static bounds match the natural size, which
 238       --  is the size passed through with the debugging information. This
 239       --  is the Esize rounded up to 8, 16, 32 or 64 as appropriate.
 240
 241       else
 242          declare
 243             Umark  : constant Uintp.Save_Mark := Uintp.Mark;
 244             Result : Boolean;
 245
 246          begin
 247             if Esize (E) <= 8 then
 248                Siz := Uint_8;
 249             elsif Esize (E) <= 16 then
 250                Siz := Uint_16;
 251             elsif Esize (E) <= 32 then
 252                Siz := Uint_32;
 253             else
 254                Siz := Uint_64;
 255             end if;
 256
 257             if Is_Modular_Integer_Type (E) or else Is_Enumeration_Type (E) then
 258                Result :=
 259                  Expr_Rep_Value (Type_Low_Bound (E)) = 0
 260                    and then
 261                  2 ** Siz - Expr_Rep_Value (Type_High_Bound (E)) = 1;
 262
 263             else
 264                Result :=
 265                  Expr_Rep_Value (Type_Low_Bound (E)) + 2 ** (Siz - 1) = 0
 266                    and then
 267                  2 ** (Siz - 1) - Expr_Rep_Value (Type_High_Bound (E)) = 1;
 268             end if;
 269
 270             Release (Umark);
 271             return Result;
 272          end;
 273       end if;
 274    end Bounds_Match_Size;
 275
 276    --------------
 277    -- CDN_Hash --
 278    --------------
 279
 280    function CDN_Hash (S : String) return Word is
 281       H : Word;
 282
 283       function Rotate_Left (Value : Word; Amount : Natural) return Word;
 284       pragma Import (Intrinsic, Rotate_Left);
 285
 286    begin
 287       H := 0;
 288       for J in S'Range loop
 289          H := Rotate_Left (H, 3) + Character'Pos (S (J));
 290       end loop;
 291
 292       return H;
 293    end CDN_Hash;
 294
 295    -------------------------
 296    -- Compress_Debug_Name --
 297    -------------------------
 298
 299    procedure Compress_Debug_Name (E : Entity_Id) is
 300       Ptr  : Natural;
 301       Sptr : String_Ptr;
 302       Cod  : Word;
 303
 304    begin
 305       if not Compress_Debug_Names
 306         and then Length_Of_Name (Chars (E)) <= Max_Debug_Name_Length
 307       then
 308          return;
 309       end if;
 310
 311       Get_Name_String (Chars (E));
 312
 313       --  Find rightmost double underscore
 314
 315       Ptr := Name_Len - 2;
 316       loop
 317          exit when Double_Underscore (Name_Buffer, Ptr);
 318
 319          --  Cannot compress if no double underscore anywhere
 320
 321          if Ptr < 2 then
 322             return;
 323          end if;
 324
 325          Ptr := Ptr  - 1;
 326       end loop;
 327
 328       --  At this stage we have
 329
 330       --    Name_Buffer (1 .. Ptr - 1)         string to compress
 331       --    Name_Buffer (Ptr)                  underscore
 332       --    Name_Buffer (Ptr + 1)              underscore
 333       --    Name_Buffer (Ptr + 2 .. Name_Len)  simple name to retain
 334
 335       --  See if we already have an entry for the compression string
 336
 337       --  No point in compressing if it does not make things shorter
 338
 339       if Name_Len <= (2 + 8 + 1) + (Name_Len - (Ptr + 1)) then
 340          return;
 341       end if;
 342
 343       --  Do not compress any reference to entity in internal file
 344
 345       if Name_Buffer (1 .. 5) = "ada__"
 346            or else
 347          Name_Buffer (1 .. 8) = "system__"
 348            or else
 349          Name_Buffer (1 .. 6) = "gnat__"
 350            or else
 351          Name_Buffer (1 .. 12) = "interfaces__"
 352            or else
 353              (OpenVMS and then Name_Buffer (1 .. 5) = "dec__")
 354       then
 355          return;
 356       end if;
 357
 358       Sptr := Name_Buffer (1 .. Ptr - 1)'Unrestricted_Access;
 359       Cod := CDN.Get (Sptr).W;
 360
 361       if Cod = 0 then
 362          Cod := CDN_Hash (Sptr.all);
 363          Sptr := new String'(Sptr.all);
 364          CDN.Set (Sptr, (Cod, Sptr));
 365       end if;
 366
 367       Name_Buffer (1) := 'X';
 368       Name_Buffer (2) := 'C';
 369       Put_Hex (Cod, 3);
 370       Name_Buffer (11) := '_';
 371       Name_Buffer (12 .. Name_Len - Ptr + 10) :=
 372         Name_Buffer (Ptr + 2 .. Name_Len);
 373       Name_Len := Name_Len - Ptr + 10;
 374
 375       Set_Chars (E, Name_Enter);
 376    end Compress_Debug_Name;
 377
 378    --------------------------------
 379    -- Debug_Renaming_Declaration --
 380    --------------------------------
 381
 382    function Debug_Renaming_Declaration (N : Node_Id) return Node_Id is
 383       Loc : constant Source_Ptr := Sloc (N);
 384       Ent : constant Node_Id    := Defining_Entity (N);
 385       Nam : constant Node_Id    := Name (N);
 386       Rnm : Name_Id;
 387       Ren : Node_Id;
 388       Lit : Entity_Id;
 389       Typ : Entity_Id;
 390       Res : Node_Id;
 391       Def : Entity_Id;
 392
 393       function Output_Subscript (N : Node_Id; S : String) return Boolean;
 394       --  Outputs a single subscript value as ?nnn (subscript is compile
 395       --  time known value with value nnn) or as ?e (subscript is local
 396       --  constant with name e), where S supplies the proper string to
 397       --  use for ?. Returns False if the subscript is not of an appropriate
 398       --  type to output in one of these two forms. The result is prepended
 399       --  to the name stored in Name_Buffer.
 400
 401       ----------------------
 402       -- Output_Subscript --
 403       ----------------------
 404
 405       function Output_Subscript (N : Node_Id; S : String) return Boolean is
 406       begin
 407          if Compile_Time_Known_Value (N) then
 408             Prepend_Uint_To_Buffer (Expr_Value (N));
 409
 410          elsif Nkind (N) = N_Identifier
 411            and then Scope (Entity (N)) = Scope (Ent)
 412            and then Ekind (Entity (N)) = E_Constant
 413          then
 414             Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N))));
 415
 416          else
 417             return False;
 418          end if;
 419
 420          Prepend_String_To_Buffer (S);
 421          return True;
 422       end Output_Subscript;
 423
 424    --  Start of processing for Debug_Renaming_Declaration
 425
 426    begin
 427       if not Comes_From_Source (N) then
 428          return Empty;
 429       end if;
 430
 431       --  Prepare entity name for type declaration
 432
 433       Get_Name_String (Chars (Ent));
 434
 435       case Nkind (N) is
 436          when N_Object_Renaming_Declaration =>
 437             Add_Str_To_Name_Buffer ("___XR");
 438
 439          when N_Exception_Renaming_Declaration =>
 440             Add_Str_To_Name_Buffer ("___XRE");
 441
 442          when N_Package_Renaming_Declaration =>
 443             Add_Str_To_Name_Buffer ("___XRP");
 444
 445          when others =>
 446             return Empty;
 447       end case;
 448
 449       Rnm := Name_Find;
 450
 451       --  Get renamed entity and compute suffix
 452
 453       Name_Len := 0;
 454       Ren := Nam;
 455       loop
 456          case Nkind (Ren) is
 457
 458             when N_Identifier =>
 459                exit;
 460
 461             when N_Expanded_Name =>
 462
 463                --  The entity field for an N_Expanded_Name is on the
 464                --  expanded name node itself, so we are done here too.
 465
 466                exit;
 467
 468             when N_Selected_Component =>
 469                Prepend_String_To_Buffer
 470                  (Get_Name_String (Chars (Selector_Name (Ren))));
 471                Prepend_String_To_Buffer ("XR");
 472                Ren := Prefix (Ren);
 473
 474             when N_Indexed_Component =>
 475                declare
 476                   X : Node_Id := Last (Expressions (Ren));
 477
 478                begin
 479                   while Present (X) loop
 480                      if not Output_Subscript (X, "XS") then
 481                         Set_Materialize_Entity (Ent);
 482                         return Empty;
 483                      end if;
 484
 485                      Prev (X);
 486                   end loop;
 487                end;
 488
 489                Ren := Prefix (Ren);
 490
 491             when N_Slice =>
 492
 493                Typ := Etype (First_Index (Etype (Nam)));
 494
 495                if not Output_Subscript (Type_High_Bound (Typ), "XS") then
 496                   Set_Materialize_Entity (Ent);
 497                   return Empty;
 498                end if;
 499
 500                if not Output_Subscript (Type_Low_Bound  (Typ), "XL") then
 501                   Set_Materialize_Entity (Ent);
 502                   return Empty;
 503                end if;
 504
 505                Ren := Prefix (Ren);
 506
 507             when N_Explicit_Dereference =>
 508                Prepend_String_To_Buffer ("XA");
 509                Ren := Prefix (Ren);
 510
 511             --  For now, anything else simply results in no translation
 512
 513             when others =>
 514                Set_Materialize_Entity (Ent);
 515                return Empty;
 516          end case;
 517       end loop;
 518
 519       Prepend_String_To_Buffer ("___XE");
 520
 521       --  For now, the literal name contains only the suffix. The Entity_Id
 522       --  value for the name is used to create a link from this literal name
 523       --  to the renamed entity using the Debug_Renaming_Link field. Then the
 524       --  Qualify_Entity_Name procedure uses this link to create the proper
 525       --  fully qualified name.
 526
 527       --  The reason we do things this way is that we really need to copy the
 528       --  qualification of the renamed entity, and it is really much easier to
 529       --  do this after the renamed entity has itself been fully qualified.
 530
 531       Lit := Make_Defining_Identifier (Loc, Chars => Name_Enter);
 532       Set_Debug_Renaming_Link (Lit, Entity (Ren));
 533
 534       --  Return the appropriate enumeration type
 535
 536       Def := Make_Defining_Identifier (Loc, Chars => Rnm);
 537       Res :=
 538         Make_Full_Type_Declaration (Loc,
 539           Defining_Identifier => Def,
 540           Type_Definition =>
 541             Make_Enumeration_Type_Definition (Loc,
 542               Literals => New_List (Lit)));
 543
 544       Set_Needs_Debug_Info (Def);
 545       Set_Needs_Debug_Info (Lit);
 546
 547       Set_Discard_Names (Defining_Identifier (Res));
 548       return Res;
 549
 550    --  If we get an exception, just figure it is a case that we cannot
 551    --  successfully handle using our current approach, since this is
 552    --  only for debugging, no need to take the compilation with us!
 553
 554    exception
 555       when others =>
 556          return Make_Null_Statement (Loc);
 557    end Debug_Renaming_Declaration;
 558
 559    -----------------------
 560    -- Double_Underscore --
 561    -----------------------
 562
 563    function Double_Underscore (S : String; J : Natural) return Boolean is
 564    begin
 565       if J = S'First or else J > S'Last - 2 then
 566          return False;
 567
 568       else
 569          return S (J) = '_'
 570            and then S (J + 1) = '_'
 571            and then S (J - 1) /= '_'
 572            and then S (J + 2) /= '_';
 573       end if;
 574    end Double_Underscore;
 575
 576    ------------------------------
 577    -- Generate_Auxiliary_Types --
 578    ------------------------------
 579
 580    --  Note: right now there is only one auxiliary type to be generated,
 581    --  namely the enumeration type for the compression sequences if used.
 582
 583    procedure Generate_Auxiliary_Types is
 584       Loc     : constant Source_Ptr := Sloc (Cunit (Current_Sem_Unit));
 585       E       : Elmt;
 586       Code    : Entity_Id;
 587       Lit     : Entity_Id;
 588       Start   : Natural;
 589       Ptr     : Natural;
 590       Discard : List_Id;
 591
 592       Literal_List : List_Id := New_List;
 593       --  Gathers the list of literals for the declaration
 594
 595       procedure Output_Literal;
 596       --  Adds suffix of form Xnnn to name in Name_Buffer, where nnn is
 597       --  a serial number that is one greater on each call, and then
 598       --  builds an enumeration literal and adds it to the literal list.
 599
 600       Serial : Nat := 0;
 601       --  Current serial number
 602
 603       procedure Output_Literal is
 604       begin
 605          Serial := Serial + 1;
 606          Add_Char_To_Name_Buffer ('X');
 607          Add_Nat_To_Name_Buffer (Serial);
 608
 609          Lit :=
 610            Make_Defining_Identifier (Loc,
 611              Chars => Name_Find);
 612          Set_Has_Qualified_Name (Lit, True);
 613          Append (Lit, Literal_List);
 614       end Output_Literal;
 615
 616    --  Start of processing for Auxiliary_Types
 617
 618    begin
 619       E := CDN.Get_First;
 620       if E.S /= null then
 621          while E.S /= null loop
 622
 623             --  We have E.S a String_Ptr that contains a string of the form:
 624
 625             --    b__c__d
 626
 627             --  In E.W is a 32-bit word representing the hash value
 628
 629             --  Our mission is to construct a type
 630
 631             --     type XChhhhhhhh is (b,c,d);
 632
 633             --  where hhhhhhhh is the 8 hex digits of the E.W value.
 634             --  and append this type declaration to the result list
 635
 636             Name_Buffer (1) := 'X';
 637             Name_Buffer (2) := 'C';
 638             Put_Hex (E.W, 3);
 639             Name_Len := 10;
 640             Output_Literal;
 641
 642             Start := E.S'First;
 643             Ptr   := E.S'First;
 644             while Ptr <= E.S'Last loop
 645                if Ptr = E.S'Last
 646                  or else Double_Underscore (E.S.all, Ptr + 1)
 647                then
 648                   Name_Len := Ptr - Start + 1;
 649                   Name_Buffer (1 .. Name_Len) := E.S (Start .. Ptr);
 650                   Output_Literal;
 651                   Start := Ptr + 3;
 652                   Ptr := Start;
 653                else
 654                   Ptr := Ptr + 1;
 655                end if;
 656             end loop;
 657
 658             E := CDN.Get_Next;
 659          end loop;
 660
 661          Name_Buffer (1) := 'X';
 662          Name_Buffer (2) := 'C';
 663          Name_Len := 2;
 664
 665          Code :=
 666            Make_Defining_Identifier (Loc,
 667              Chars => Name_Find);
 668          Set_Has_Qualified_Name (Code, True);
 669
 670          Insert_Library_Level_Action (
 671            Make_Full_Type_Declaration (Loc,
 672              Defining_Identifier => Code,
 673              Type_Definition =>
 674                Make_Enumeration_Type_Definition (Loc,
 675                  Literals => Literal_List)));
 676
 677          --  We have to manually freeze this entity, since it is inserted
 678          --  very late on into the tree, and otherwise will not be frozen.
 679          --  No freeze actions are generated, so we can discard the result.
 680
 681          Discard := Freeze_Entity (Code,  Loc);
 682       end if;
 683    end Generate_Auxiliary_Types;
 684
 685    ----------------------
 686    -- Get_Encoded_Name --
 687    ----------------------
 688
 689    --  Note: see spec for details on encodings
 690
 691    procedure Get_Encoded_Name (E : Entity_Id) is
 692       Has_Suffix : Boolean;
 693
 694    begin
 695       Get_Name_String (Chars (E));
 696
 697       --  Nothing to do if we do not have a type
 698
 699       if not Is_Type (E)
 700
 701       --  Or if this is an enumeration base type
 702
 703         or else (Is_Enumeration_Type (E)
 704                    and then E = Base_Type (E))
 705
 706       --  Or if this is a dummy type for a renaming
 707
 708         or else (Name_Len >= 3 and then
 709                    Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR")
 710
 711         or else (Name_Len >= 4 and then
 712                    (Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
 713                       or else
 714                     Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"))
 715
 716       --  For all these cases, just return the name unchanged
 717
 718       then
 719          Name_Buffer (Name_Len + 1) := ASCII.Nul;
 720          return;
 721       end if;
 722
 723       Has_Suffix := True;
 724
 725       --  Fixed-point case
 726
 727       if Is_Fixed_Point_Type (E) then
 728          Get_External_Name_With_Suffix (E, "XF_");
 729          Add_Real_To_Buffer (Delta_Value (E));
 730
 731          if Small_Value (E) /= Delta_Value (E) then
 732             Add_Str_To_Name_Buffer ("_");
 733             Add_Real_To_Buffer (Small_Value (E));
 734          end if;
 735
 736       --  Vax floating-point case
 737
 738       elsif Vax_Float (E) then
 739
 740          if Digits_Value (Base_Type (E)) = 6 then
 741             Get_External_Name_With_Suffix (E, "XFF");
 742
 743          elsif Digits_Value (Base_Type (E)) = 9 then
 744             Get_External_Name_With_Suffix (E, "XFF");
 745
 746          else
 747             pragma Assert (Digits_Value (Base_Type (E)) = 15);
 748             Get_External_Name_With_Suffix (E, "XFG");
 749          end if;
 750
 751       --  Discrete case where bounds do not match size
 752
 753       elsif Is_Discrete_Type (E)
 754         and then not Bounds_Match_Size (E)
 755       then
 756          if Has_Biased_Representation (E) then
 757             Get_External_Name_With_Suffix (E, "XB");
 758          else
 759             Get_External_Name_With_Suffix (E, "XD");
 760          end if;
 761
 762          declare
 763             Lo : constant Node_Id := Type_Low_Bound (E);
 764             Hi : constant Node_Id := Type_High_Bound (E);
 765
 766             Lo_Stat : constant Boolean := Is_OK_Static_Expression (Lo);
 767             Hi_Stat : constant Boolean := Is_OK_Static_Expression (Hi);
 768
 769             Lo_Discr : constant Boolean :=
 770                          Nkind (Lo) = N_Identifier
 771                            and then
 772                          Ekind (Entity (Lo)) = E_Discriminant;
 773
 774             Hi_Discr : constant Boolean :=
 775                          Nkind (Hi) = N_Identifier
 776                            and then
 777                          Ekind (Entity (Hi)) = E_Discriminant;
 778
 779             Lo_Encode : constant Boolean := Lo_Stat or Lo_Discr;
 780             Hi_Encode : constant Boolean := Hi_Stat or Hi_Discr;
 781
 782          begin
 783             if Lo_Encode or Hi_Encode then
 784                if Lo_Encode then
 785                   if Hi_Encode then
 786                      Add_Str_To_Name_Buffer ("LU_");
 787                   else
 788                      Add_Str_To_Name_Buffer ("L_");
 789                   end if;
 790                else
 791                   Add_Str_To_Name_Buffer ("U_");
 792                end if;
 793
 794                if Lo_Stat then
 795                   Add_Uint_To_Buffer (Expr_Rep_Value (Lo));
 796                elsif Lo_Discr then
 797                   Get_Name_String_And_Append (Chars (Entity (Lo)));
 798                end if;
 799
 800                if Lo_Encode and Hi_Encode then
 801                   Add_Str_To_Name_Buffer ("__");
 802                end if;
 803
 804                if Hi_Stat then
 805                   Add_Uint_To_Buffer (Expr_Rep_Value (Hi));
 806                elsif Hi_Discr then
 807                   Get_Name_String_And_Append (Chars (Entity (Hi)));
 808                end if;
 809             end if;
 810          end;
 811
 812       --  For all other cases, the encoded name is the normal type name
 813
 814       else
 815          Has_Suffix := False;
 816          Get_External_Name (E, Has_Suffix);
 817       end if;
 818
 819       if Debug_Flag_B and then Has_Suffix then
 820          Write_Str ("**** type ");
 821          Write_Name (Chars (E));
 822          Write_Str (" is encoded as ");
 823          Write_Str (Name_Buffer (1 .. Name_Len));
 824          Write_Eol;
 825       end if;
 826
 827       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 828    end Get_Encoded_Name;
 829
 830    -------------------
 831    -- Get_Entity_Id --
 832    -------------------
 833
 834    function Get_Entity_Id (External_Name : String) return Entity_Id is
 835    begin
 836       return Empty;
 837    end Get_Entity_Id;
 838
 839    -----------------------
 840    -- Get_External_Name --
 841    -----------------------
 842
 843    procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean)
 844    is
 845       E    : Entity_Id := Entity;
 846       Kind : Entity_Kind;
 847
 848       procedure Get_Qualified_Name_And_Append (Entity : Entity_Id);
 849       --  Appends fully qualified name of given entity to Name_Buffer
 850
 851       -----------------------------------
 852       -- Get_Qualified_Name_And_Append --
 853       -----------------------------------
 854
 855       procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is
 856       begin
 857          --  If the entity is a compilation unit, its scope is Standard,
 858          --  there is no outer scope, and the no further qualification
 859          --  is required.
 860
 861          --  If the front end has already computed a fully qualified name,
 862          --  then it is also the case that no further qualification is
 863          --  required
 864
 865          if Present (Scope (Scope (Entity)))
 866            and then not Has_Fully_Qualified_Name (Entity)
 867          then
 868             Get_Qualified_Name_And_Append (Scope (Entity));
 869             Add_Str_To_Name_Buffer ("__");
 870          end if;
 871
 872          Get_Name_String_And_Append (Chars (Entity));
 873       end Get_Qualified_Name_And_Append;
 874
 875    --  Start of processing for Get_External_Name
 876
 877    begin
 878       Name_Len := 0;
 879
 880       --  If this is a child unit, we want the child
 881
 882       if Nkind (E) = N_Defining_Program_Unit_Name then
 883          E := Defining_Identifier (Entity);
 884       end if;
 885
 886       Kind := Ekind (E);
 887
 888       --  Case of interface name being used
 889
 890       if (Kind = E_Procedure or else
 891           Kind = E_Function  or else
 892           Kind = E_Constant  or else
 893           Kind = E_Variable  or else
 894           Kind = E_Exception)
 895         and then Present (Interface_Name (E))
 896         and then No (Address_Clause (E))
 897         and then not Has_Suffix
 898       then
 899          --  The following code needs explanation ???
 900
 901          if Convention (E) = Convention_Stdcall
 902             and then Ekind (E) = E_Variable
 903          then
 904             Add_Str_To_Name_Buffer ("_imp__");
 905          end if;
 906
 907          Add_String_To_Name_Buffer (Strval (Interface_Name (E)));
 908
 909       --  All other cases besides the interface name case
 910
 911       else
 912          --  If this is a library level subprogram (i.e. a subprogram that is a
 913          --  compilation unit other than a subunit), then we prepend _ada_ to
 914          --  ensure distinctions required as described in the spec.
 915          --  Check explicitly for child units, because those are not flagged
 916          --  as Compilation_Units by lib. Should they be ???
 917
 918          if Is_Subprogram (E)
 919            and then (Is_Compilation_Unit (E) or Is_Child_Unit (E))
 920            and then not Has_Suffix
 921          then
 922             Add_Str_To_Name_Buffer ("_ada_");
 923          end if;
 924
 925          --  If the entity is a subprogram instance that is not a compilation
 926          --  unit, generate the name of the original Ada entity, which is the
 927          --  one gdb needs.
 928
 929          if Is_Generic_Instance (E)
 930            and then Is_Subprogram (E)
 931            and then not Is_Compilation_Unit (Scope (E))
 932          then
 933             E := Related_Instance (Scope (E));
 934          end if;
 935
 936          Get_Qualified_Name_And_Append (E);
 937
 938          if Has_Homonym (E) then
 939             declare
 940                H  : Entity_Id := Homonym (E);
 941                Nr : Nat := 1;
 942
 943             begin
 944                while Present (H) loop
 945                   if (Scope (H) = Scope (E)) then
 946                      Nr := Nr + 1;
 947                   end if;
 948
 949                   H := Homonym (H);
 950                end loop;
 951
 952                if Nr > 1 then
 953                   if No_Dollar_In_Label then
 954                      Add_Str_To_Name_Buffer ("__");
 955                   else
 956                      Add_Char_To_Name_Buffer ('$');
 957                   end if;
 958
 959                   Add_Nat_To_Name_Buffer (Nr);
 960                end if;
 961             end;
 962          end if;
 963       end if;
 964
 965       Name_Buffer (Name_Len + 1) := ASCII.Nul;
 966    end Get_External_Name;
 967
 968    -----------------------------------
 969    -- Get_External_Name_With_Suffix --
 970    -----------------------------------
 971
 972    procedure Get_External_Name_With_Suffix
 973      (Entity : Entity_Id;
 974       Suffix : String)
 975    is
 976       Has_Suffix : constant Boolean := (Suffix /= "");
 977    begin
 978       Get_External_Name (Entity, Has_Suffix);
 979
 980       if Has_Suffix then
 981          Add_Str_To_Name_Buffer ("___");
 982          Add_Str_To_Name_Buffer (Suffix);
 983
 984          Name_Buffer (Name_Len + 1) := ASCII.Nul;
 985       end if;
 986    end Get_External_Name_With_Suffix;
 987
 988    --------------------------
 989    -- Get_Variant_Encoding --
 990    --------------------------
 991
 992    procedure Get_Variant_Encoding (V : Node_Id) is
 993       Choice : Node_Id;
 994
 995       procedure Choice_Val (Typ : Character; Choice : Node_Id);
 996       --  Output encoded value for a single choice value. Typ is the key
 997       --  character ('S', 'F', or 'T') that precedes the choice value.
 998
 999       ----------------
1000       -- Choice_Val --
1001       ----------------
1002
1003       procedure Choice_Val (Typ : Character; Choice : Node_Id) is
1004       begin
1005          Add_Char_To_Name_Buffer (Typ);
1006
1007          if Nkind (Choice) = N_Integer_Literal then
1008             Add_Uint_To_Buffer (Intval (Choice));
1009
1010          --  Character literal with no entity present (this is the case
1011          --  Standard.Character or Standard.Wide_Character as root type)
1012
1013          elsif Nkind (Choice) = N_Character_Literal
1014            and then No (Entity (Choice))
1015          then
1016             Add_Uint_To_Buffer
1017               (UI_From_Int (Int (Char_Literal_Value (Choice))));
1018
1019          else
1020             declare
1021                Ent : constant Entity_Id := Entity (Choice);
1022
1023             begin
1024                if Ekind (Ent) = E_Enumeration_Literal then
1025                   Add_Uint_To_Buffer (Enumeration_Rep (Ent));
1026
1027                else
1028                   pragma Assert (Ekind (Ent) = E_Constant);
1029                   Choice_Val (Typ, Constant_Value (Ent));
1030                end if;
1031             end;
1032          end if;
1033       end Choice_Val;
1034
1035    --  Start of processing for Get_Variant_Encoding
1036
1037    begin
1038       Name_Len := 0;
1039
1040       Choice := First (Discrete_Choices (V));
1041       while Present (Choice) loop
1042          if Nkind (Choice) = N_Others_Choice then
1043             Add_Char_To_Name_Buffer ('O');
1044
1045          elsif Nkind (Choice) = N_Range then
1046             Choice_Val ('R', Low_Bound (Choice));
1047             Choice_Val ('T', High_Bound (Choice));
1048
1049          elsif Is_Entity_Name (Choice)
1050            and then Is_Type (Entity (Choice))
1051          then
1052             Choice_Val ('R', Type_Low_Bound (Entity (Choice)));
1053             Choice_Val ('T', Type_High_Bound (Entity (Choice)));
1054
1055          elsif Nkind (Choice) = N_Subtype_Indication then
1056             declare
1057                Rang : constant Node_Id :=
1058                         Range_Expression (Constraint (Choice));
1059             begin
1060                Choice_Val ('R', Low_Bound (Rang));
1061                Choice_Val ('T', High_Bound (Rang));
1062             end;
1063
1064          else
1065             Choice_Val ('S', Choice);
1066          end if;
1067
1068          Next (Choice);
1069       end loop;
1070
1071       Name_Buffer (Name_Len + 1) := ASCII.NUL;
1072
1073       if Debug_Flag_B then
1074          declare
1075             VP : constant Node_Id := Parent (V);    -- Variant_Part
1076             CL : constant Node_Id := Parent (VP);   -- Component_List
1077             RD : constant Node_Id := Parent (CL);   -- Record_Definition
1078             FT : constant Node_Id := Parent (RD);   -- Full_Type_Declaration
1079
1080          begin
1081             Write_Str ("**** variant for type ");
1082             Write_Name (Chars (Defining_Identifier (FT)));
1083             Write_Str (" is encoded as ");
1084             Write_Str (Name_Buffer (1 .. Name_Len));
1085             Write_Eol;
1086          end;
1087       end if;
1088    end Get_Variant_Encoding;
1089
1090    ---------------------------------
1091    -- Make_Packed_Array_Type_Name --
1092    ---------------------------------
1093
1094    function Make_Packed_Array_Type_Name
1095      (Typ   : Entity_Id;
1096       Csize : Uint)
1097       return  Name_Id
1098    is
1099    begin
1100       Get_Name_String (Chars (Typ));
1101       Add_Str_To_Name_Buffer ("___XP");
1102       Add_Uint_To_Buffer (Csize);
1103       return Name_Find;
1104    end Make_Packed_Array_Type_Name;
1105
1106    ------------------------------
1107    -- Prepend_String_To_Buffer --
1108    ------------------------------
1109
1110    procedure Prepend_String_To_Buffer (S : String) is
1111       N : constant Integer := S'Length;
1112
1113    begin
1114       Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len);
1115       Name_Buffer (1 .. N) := S;
1116       Name_Len := Name_Len + N;
1117    end Prepend_String_To_Buffer;
1118
1119    ----------------------------
1120    -- Prepend_Uint_To_Buffer --
1121    ----------------------------
1122
1123    procedure Prepend_Uint_To_Buffer (U : Uint) is
1124    begin
1125       if U < 0 then
1126          Prepend_String_To_Buffer ("m");
1127          Prepend_Uint_To_Buffer (-U);
1128       else
1129          UI_Image (U, Decimal);
1130          Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
1131       end if;
1132    end Prepend_Uint_To_Buffer;
1133
1134    -------------
1135    -- Put_Hex --
1136    -------------
1137
1138    procedure Put_Hex (W : Word; N : Natural) is
1139       Hex : constant array (Word range 0 .. 15) of Character :=
1140               "0123456789abcdef";
1141
1142       Cod : Word;
1143
1144    begin
1145       Cod := W;
1146       for J in reverse N .. N + 7 loop
1147          Name_Buffer (J) := Hex (Cod and 16#F#);
1148          Cod := Cod / 16;
1149       end loop;
1150    end Put_Hex;
1151
1152    ------------------------------
1153    -- Qualify_All_Entity_Names --
1154    ------------------------------
1155
1156    procedure Qualify_All_Entity_Names is
1157       E   : Entity_Id;
1158       Ent : Entity_Id;
1159
1160    begin
1161       for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
1162          E := Defining_Entity (Name_Qualify_Units.Table (J));
1163          Qualify_Entity_Name (E);
1164
1165          Ent := First_Entity (E);
1166          while Present (Ent) loop
1167             Qualify_Entity_Name (Ent);
1168             Next_Entity (Ent);
1169
1170             --  There are odd cases where Last_Entity (E) = E. This happens
1171             --  in the case of renaming of packages. This test avoids getting
1172             --  stuck in such cases.
1173
1174             exit when Ent = E;
1175          end loop;
1176       end loop;
1177
1178       --  Second loop compresses any names that need compressing
1179
1180       for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
1181          E := Defining_Entity (Name_Qualify_Units.Table (J));
1182          Compress_Debug_Name (E);
1183
1184          Ent := First_Entity (E);
1185          while Present (Ent) loop
1186             Compress_Debug_Name (Ent);
1187             Next_Entity (Ent);
1188             exit when Ent = E;
1189          end loop;
1190       end loop;
1191    end Qualify_All_Entity_Names;
1192
1193    -------------------------
1194    -- Qualify_Entity_Name --
1195    -------------------------
1196
1197    procedure Qualify_Entity_Name (Ent : Entity_Id) is
1198
1199       Full_Qualify_Name : String (1 .. Name_Buffer'Length);
1200       Full_Qualify_Len  : Natural := 0;
1201       --  Used to accumulate fully qualified name of subprogram
1202
1203       procedure Fully_Qualify_Name (E : Entity_Id);
1204       --  Used to qualify a subprogram or type name, where full
1205       --  qualification up to Standard is always used. Name is set
1206       --  in Full_Qualify_Name with the length in Full_Qualify_Len.
1207       --  Note that this routine does not prepend the _ada_ string
1208       --  required for library subprograms (this is done in the back end).
1209
1210       function Is_BNPE (S : Entity_Id) return Boolean;
1211       --  Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
1212       --  is defined to be a package which is immediately nested within a
1213       --  package body.
1214
1215       function Qualify_Needed (S : Entity_Id) return Boolean;
1216       --  Given a scope, determines if the scope is to be included in the
1217       --  fully qualified name, True if so, False if not.
1218
1219       procedure Set_BNPE_Suffix (E : Entity_Id);
1220       --  Recursive routine to append the BNPE qualification suffix. Works
1221       --  from right to left with E being the current entity in the list.
1222       --  The result does NOT have the trailing n's and trailing b stripped.
1223       --  The caller must do this required stripping.
1224
1225       procedure Set_Entity_Name (E : Entity_Id);
1226       --  Internal recursive routine that does most of the work. This routine
1227       --  leaves the result sitting in Name_Buffer and Name_Len.
1228
1229       BNPE_Suffix_Needed : Boolean := False;
1230       --  Set true if a body-nested package entity suffix is required
1231
1232       Save_Chars : constant Name_Id := Chars (Ent);
1233       --  Save original name
1234
1235       ------------------------
1236       -- Fully_Qualify_Name --
1237       ------------------------
1238
1239       procedure Fully_Qualify_Name (E : Entity_Id) is
1240          Discard : Boolean := False;
1241
1242       begin
1243          --  If this we are qualifying entities local to a generic
1244          --  instance, use the name of the original instantiation,
1245          --  not that of the anonymous subprogram in the wrapper
1246          --  package, so that gdb doesn't have to know about these.
1247
1248          if Is_Generic_Instance (E)
1249            and then Is_Subprogram (E)
1250            and then not Comes_From_Source (E)
1251            and then not Is_Compilation_Unit (Scope (E))
1252          then
1253             Fully_Qualify_Name (Related_Instance (Scope (E)));
1254             return;
1255          end if;
1256
1257          --  If we reached fully qualified name, then just copy it
1258
1259          if Has_Fully_Qualified_Name (E) then
1260             Get_Name_String (Chars (E));
1261             Strip_BNPE_Suffix (Discard);
1262             Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1263             Full_Qualify_Len := Name_Len;
1264             Set_Has_Fully_Qualified_Name (Ent);
1265
1266          --  Case of non-fully qualified name
1267
1268          else
1269             if Scope (E) = Standard_Standard then
1270                Set_Has_Fully_Qualified_Name (Ent);
1271             else
1272                Fully_Qualify_Name (Scope (E));
1273                Full_Qualify_Name (Full_Qualify_Len + 1) := '_';
1274                Full_Qualify_Name (Full_Qualify_Len + 2) := '_';
1275                Full_Qualify_Len := Full_Qualify_Len + 2;
1276             end if;
1277
1278             if Has_Qualified_Name (E) then
1279                Get_Unqualified_Name_String (Chars (E));
1280             else
1281                Get_Name_String (Chars (E));
1282             end if;
1283
1284             Full_Qualify_Name
1285               (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) :=
1286                 Name_Buffer (1 .. Name_Len);
1287             Full_Qualify_Len := Full_Qualify_Len + Name_Len;
1288          end if;
1289
1290          if Is_BNPE (E) then
1291             BNPE_Suffix_Needed := True;
1292          end if;
1293       end Fully_Qualify_Name;
1294
1295       -------------
1296       -- Is_BNPE --
1297       -------------
1298
1299       function Is_BNPE (S : Entity_Id) return Boolean is
1300       begin
1301          return
1302            Ekind (S) = E_Package
1303              and then Is_Package_Body_Entity (S);
1304       end Is_BNPE;
1305
1306       --------------------
1307       -- Qualify_Needed --
1308       --------------------
1309
1310       function Qualify_Needed (S : Entity_Id) return Boolean is
1311       begin
1312          --  If we got all the way to Standard, then we have certainly
1313          --  fully qualified the name, so set the flag appropriately,
1314          --  and then return False, since we are most certainly done!
1315
1316          if S = Standard_Standard then
1317             Set_Has_Fully_Qualified_Name (Ent, True);
1318             return False;
1319
1320          --  Otherwise figure out if further qualification is required
1321
1322          else
1323             return
1324               Is_Subprogram (Ent)
1325                 or else
1326               Ekind (Ent) = E_Subprogram_Body
1327                 or else
1328                   (Ekind (S) /= E_Block
1329                     and then not Is_Dynamic_Scope (S));
1330          end if;
1331       end Qualify_Needed;
1332
1333       ---------------------
1334       -- Set_BNPE_Suffix --
1335       ---------------------
1336
1337       procedure Set_BNPE_Suffix (E : Entity_Id) is
1338          S : constant Entity_Id := Scope (E);
1339
1340       begin
1341          if Qualify_Needed (S) then
1342             Set_BNPE_Suffix (S);
1343
1344             if Is_BNPE (E) then
1345                Add_Char_To_Name_Buffer ('b');
1346             else
1347                Add_Char_To_Name_Buffer ('n');
1348             end if;
1349
1350          else
1351             Add_Char_To_Name_Buffer ('X');
1352          end if;
1353
1354       end Set_BNPE_Suffix;
1355
1356       ---------------------
1357       -- Set_Entity_Name --
1358       ---------------------
1359
1360       procedure Set_Entity_Name (E : Entity_Id) is
1361          S : constant Entity_Id := Scope (E);
1362
1363       begin
1364          --  If we reach an already qualified name, just take the encoding
1365          --  except that we strip the package body suffixes, since these
1366          --  will be separately put on later.
1367
1368          if Has_Qualified_Name (E) then
1369             Get_Name_String_And_Append (Chars (E));
1370             Strip_BNPE_Suffix (BNPE_Suffix_Needed);
1371
1372             --  If the top level name we are adding is itself fully
1373             --  qualified, then that means that the name that we are
1374             --  preparing for the Fully_Qualify_Name call will also
1375             --  generate a fully qualified name.
1376
1377             if Has_Fully_Qualified_Name (E) then
1378                Set_Has_Fully_Qualified_Name (Ent);
1379             end if;
1380
1381          --  Case where upper level name is not encoded yet
1382
1383          else
1384             --  Recurse if further qualification required
1385
1386             if Qualify_Needed (S) then
1387                Set_Entity_Name (S);
1388                Add_Str_To_Name_Buffer ("__");
1389             end if;
1390
1391             --  Otherwise get name and note if it is a NPBE
1392
1393             Get_Name_String_And_Append (Chars (E));
1394
1395             if Is_BNPE (E) then
1396                BNPE_Suffix_Needed := True;
1397             end if;
1398          end if;
1399       end Set_Entity_Name;
1400
1401    --  Start of processing for Qualify_Entity_Name
1402
1403    begin
1404       if Has_Qualified_Name (Ent) then
1405          return;
1406
1407       --  Here is where we create the proper link for renaming
1408
1409       elsif Ekind (Ent) = E_Enumeration_Literal
1410         and then Present (Debug_Renaming_Link (Ent))
1411       then
1412          Set_Entity_Name (Debug_Renaming_Link (Ent));
1413          Get_Name_String (Chars (Ent));
1414          Prepend_String_To_Buffer
1415            (Get_Name_String (Chars (Debug_Renaming_Link (Ent))));
1416          Set_Chars (Ent, Name_Enter);
1417          Set_Has_Qualified_Name (Ent);
1418          return;
1419
1420       elsif Is_Subprogram (Ent)
1421         or else Ekind (Ent) = E_Subprogram_Body
1422         or else Is_Type (Ent)
1423       then
1424          Fully_Qualify_Name (Ent);
1425          Name_Len := Full_Qualify_Len;
1426          Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
1427
1428       elsif Qualify_Needed (Scope (Ent)) then
1429          Name_Len := 0;
1430          Set_Entity_Name (Ent);
1431
1432       else
1433          Set_Has_Qualified_Name (Ent);
1434          return;
1435       end if;
1436
1437       --  Fall through with a fully qualified name in Name_Buffer/Name_Len
1438
1439       --  Add body-nested package suffix if required
1440
1441       if BNPE_Suffix_Needed
1442         and then Ekind (Ent) /= E_Enumeration_Literal
1443       then
1444          Set_BNPE_Suffix (Ent);
1445
1446          --  Strip trailing n's and last trailing b as required. note that
1447          --  we know there is at least one b, or no suffix would be generated.
1448
1449          while Name_Buffer (Name_Len) = 'n' loop
1450             Name_Len := Name_Len - 1;
1451          end loop;
1452
1453          Name_Len := Name_Len - 1;
1454       end if;
1455
1456       Set_Chars (Ent, Name_Enter);
1457       Set_Has_Qualified_Name (Ent);
1458
1459       if Debug_Flag_BB then
1460          Write_Str ("*** ");
1461          Write_Name (Save_Chars);
1462          Write_Str (" qualified as ");
1463          Write_Name (Chars (Ent));
1464          Write_Eol;
1465       end if;
1466    end Qualify_Entity_Name;
1467
1468    --------------------------
1469    -- Qualify_Entity_Names --
1470    --------------------------
1471
1472    procedure Qualify_Entity_Names (N : Node_Id) is
1473    begin
1474       Name_Qualify_Units.Append (N);
1475    end Qualify_Entity_Names;
1476
1477    --------------------------------
1478    -- Save_Unitname_And_Use_List --
1479    --------------------------------
1480
1481    procedure Save_Unitname_And_Use_List
1482      (Main_Unit_Node : Node_Id;
1483       Main_Kind      : Node_Kind)
1484    is
1485       INITIAL_NAME_LENGTH : constant := 1024;
1486
1487       Item       : Node_Id;
1488       Pack_Name  : Node_Id;
1489
1490       Unit_Spec  : Node_Id := 0;
1491       Unit_Body  : Node_Id := 0;
1492
1493       Main_Name : String_Id;
1494       --  Fully qualified name of Main Unit
1495
1496       Unit_Name : String_Id;
1497       --  Name of unit specified in a Use clause
1498
1499       Spec_Unit_Index : Source_File_Index;
1500       Spec_File_Name  : File_Name_Type := No_File;
1501
1502       Body_Unit_Index : Source_File_Index;
1503       Body_File_Name : File_Name_Type := No_File;
1504
1505       type String_Ptr is access all String;
1506
1507       Spec_File_Name_Str : String_Ptr;
1508       Body_File_Name_Str : String_Ptr;
1509
1510       type Label is record
1511         Label_Name  : String_Ptr;
1512         Name_Length : Integer;
1513         Pos         : Integer;
1514       end record;
1515
1516       Spec_Label : Label;
1517       Body_Label : Label;
1518
1519       procedure Initialize  (L : out Label);
1520       --  Initialize label
1521
1522       procedure Append      (L : in out Label; Ch : Character);
1523       --  Append character to label
1524
1525       procedure Append      (L : in out Label; Str : String);
1526       --  Append string to label
1527
1528       procedure Append_Name (L : in out Label; Unit_Name : String_Id);
1529       --  Append name to label
1530
1531       function  Sufficient_Space
1532         (L         : Label;
1533          Unit_Name : String_Id)
1534          return      Boolean;
1535       --  Does sufficient space exist to append another name?
1536
1537       procedure Append (L : in out Label; Str : String) is
1538       begin
1539          L.Label_Name (L.Pos + 1 .. L.Pos + Str'Length) := Str;
1540          L.Pos := L.Pos + Str'Length;
1541       end Append;
1542
1543       procedure Append (L : in out Label; Ch : Character) is
1544       begin
1545          L.Pos := L.Pos + 1;
1546          L.Label_Name (L.Pos) := Ch;
1547       end Append;
1548
1549       procedure Append_Name (L : in out Label; Unit_Name : String_Id) is
1550          Char         : Char_Code;
1551          Upper_Offset : constant := Character'Pos ('a') - Character'Pos ('A');
1552
1553       begin
1554          for J in 1 .. String_Length (Unit_Name) loop
1555             Char := Get_String_Char (Unit_Name, J);
1556
1557             if Character'Val (Char) = '.' then
1558                Append (L, "__");
1559             elsif Character'Val (Char) in 'A' .. 'Z' then
1560                Append (L, Character'Val (Char + Upper_Offset));
1561             elsif Char /= 0 then
1562                Append (L, Character'Val (Char));
1563             end if;
1564          end loop;
1565       end Append_Name;
1566
1567       procedure Initialize (L : out Label) is
1568       begin
1569          L.Name_Length := INITIAL_NAME_LENGTH;
1570          L.Pos := 0;
1571          L.Label_Name := new String (1 .. L.Name_Length);
1572       end Initialize;
1573
1574       function  Sufficient_Space
1575         (L         : Label;
1576          Unit_Name : String_Id)
1577          return      Boolean
1578       is
1579          Len : Integer := Integer (String_Length (Unit_Name)) + 1;
1580
1581       begin
1582          for J in 1 .. String_Length (Unit_Name) loop
1583             if Character'Val (Get_String_Char (Unit_Name, J)) = '.' then
1584                Len := Len + 1;
1585             end if;
1586          end loop;
1587
1588          return L.Pos + Len < L.Name_Length;
1589       end Sufficient_Space;
1590
1591    --  Start of processing for Save_Unitname_And_Use_List
1592
1593    begin
1594       Initialize (Spec_Label);
1595       Initialize (Body_Label);
1596
1597       case Main_Kind is
1598          when N_Package_Declaration =>
1599             Main_Name := Full_Qualified_Name
1600               (Defining_Unit_Name (Specification (Unit (Main_Unit_Node))));
1601             Unit_Spec := Main_Unit_Node;
1602             Append (Spec_Label, "_LPS__");
1603             Append (Body_Label, "_LPB__");
1604
1605          when N_Package_Body =>
1606             Unit_Spec := Corresponding_Spec (Unit (Main_Unit_Node));
1607             Unit_Body := Main_Unit_Node;
1608             Main_Name := Full_Qualified_Name (Unit_Spec);
1609             Append (Spec_Label, "_LPS__");
1610             Append (Body_Label, "_LPB__");
1611
1612          when N_Subprogram_Body =>
1613             Unit_Body := Main_Unit_Node;
1614
1615             if Present (Corresponding_Spec (Unit (Main_Unit_Node))) then
1616                Unit_Spec := Corresponding_Spec (Unit (Main_Unit_Node));
1617                Main_Name := Full_Qualified_Name
1618                  (Corresponding_Spec (Unit (Main_Unit_Node)));
1619             else
1620                Main_Name := Full_Qualified_Name
1621                  (Defining_Unit_Name (Specification (Unit (Main_Unit_Node))));
1622             end if;
1623
1624             Append (Spec_Label, "_LSS__");
1625             Append (Body_Label, "_LSB__");
1626
1627          when others =>
1628             return;
1629       end case;
1630
1631       Append_Name (Spec_Label, Main_Name);
1632       Append_Name (Body_Label, Main_Name);
1633
1634       --  If we have a body, process it first
1635
1636       if Present (Unit_Body) then
1637
1638          Item := First (Context_Items (Unit_Body));
1639
1640          while Present (Item) loop
1641             if Nkind (Item) = N_Use_Package_Clause then
1642                Pack_Name := First (Names (Item));
1643                while Present (Pack_Name) loop
1644                   Unit_Name := Full_Qualified_Name (Entity (Pack_Name));
1645
1646                   if Sufficient_Space (Body_Label, Unit_Name) then
1647                      Append (Body_Label, '$');
1648                      Append_Name (Body_Label, Unit_Name);
1649                   end if;
1650
1651                   Pack_Name := Next (Pack_Name);
1652                end loop;
1653             end if;
1654
1655             Item := Next (Item);
1656          end loop;
1657       end if;
1658
1659       while Present (Unit_Spec) and then
1660         Nkind (Unit_Spec) /= N_Compilation_Unit
1661       loop
1662          Unit_Spec := Parent (Unit_Spec);
1663       end loop;
1664
1665       if Present (Unit_Spec) then
1666
1667          Item := First (Context_Items (Unit_Spec));
1668
1669          while Present (Item) loop
1670             if Nkind (Item) = N_Use_Package_Clause then
1671                Pack_Name := First (Names (Item));
1672                while Present (Pack_Name) loop
1673                   Unit_Name := Full_Qualified_Name (Entity (Pack_Name));
1674
1675                   if Sufficient_Space (Spec_Label, Unit_Name) then
1676                      Append (Spec_Label, '$');
1677                      Append_Name (Spec_Label, Unit_Name);
1678                   end if;
1679
1680                   if Sufficient_Space (Body_Label, Unit_Name) then
1681                      Append (Body_Label, '$');
1682                      Append_Name (Body_Label, Unit_Name);
1683                   end if;
1684
1685                   Pack_Name := Next (Pack_Name);
1686                end loop;
1687             end if;
1688
1689             Item := Next (Item);
1690          end loop;
1691       end if;
1692
1693       if Present (Unit_Spec) then
1694          Append (Spec_Label, Character'Val (0));
1695          Spec_Unit_Index := Source_Index (Get_Cunit_Unit_Number (Unit_Spec));
1696          Spec_File_Name := Full_File_Name (Spec_Unit_Index);
1697          Get_Name_String (Spec_File_Name);
1698          Spec_File_Name_Str := new String (1 .. Name_Len + 1);
1699          Spec_File_Name_Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1700          Spec_File_Name_Str (Name_Len + 1) := Character'Val (0);
1701          Spec_Filename := Spec_File_Name_Str (1)'Unrestricted_Access;
1702          Spec_Context_List :=
1703            Spec_Label.Label_Name.all (1)'Unrestricted_Access;
1704       end if;
1705
1706       if Present (Unit_Body) then
1707          Append (Body_Label, Character'Val (0));
1708          Body_Unit_Index := Source_Index (Get_Cunit_Unit_Number (Unit_Body));
1709          Body_File_Name := Full_File_Name (Body_Unit_Index);
1710          Get_Name_String (Body_File_Name);
1711          Body_File_Name_Str := new String (1 .. Name_Len + 1);
1712          Body_File_Name_Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1713          Body_File_Name_Str (Name_Len + 1) := Character'Val (0);
1714          Body_Filename := Body_File_Name_Str (1)'Unrestricted_Access;
1715          Body_Context_List :=
1716            Body_Label.Label_Name.all (1)'Unrestricted_Access;
1717       end if;
1718
1719    end Save_Unitname_And_Use_List;
1720
1721    ---------
1722    -- SEq --
1723    ---------
1724
1725    function SEq (F1, F2 : String_Ptr) return Boolean is
1726    begin
1727       return F1.all = F2.all;
1728    end SEq;
1729
1730    -----------
1731    -- SHash --
1732    -----------
1733
1734    function SHash (S : String_Ptr) return Hindex is
1735    begin
1736       return Hindex
1737         (Hindex'First + Hindex (CDN_Hash (S.all) mod Hindex'Range_Length));
1738    end SHash;
1739
1740    -----------------------
1741    -- Strip_BNPE_Suffix --
1742    -----------------------
1743
1744    procedure Strip_BNPE_Suffix (Suffix_Found : in out Boolean) is
1745    begin
1746       for J in reverse 2 .. Name_Len loop
1747          if Name_Buffer (J) = 'X' then
1748             Name_Len := J - 1;
1749             Suffix_Found := True;
1750             exit;
1751          end if;
1752
1753          exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n';
1754       end loop;
1755    end Strip_BNPE_Suffix;
1756
1757 end Exp_Dbug;