1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2007, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Alloc; use Alloc;
28 with Atree; use Atree;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Nlists; use Nlists;
32 with Nmake; use Nmake;
34 with Output; use Output;
35 with Sem_Eval; use Sem_Eval;
36 with Sem_Util; use Sem_Util;
37 with Sinfo; use Sinfo;
38 with Stand; use Stand;
39 with Stringt; use Stringt;
41 with Urealp; use Urealp;
43 package body Exp_Dbug is
45 -- The following table is used to queue up the entities passed as
46 -- arguments to Qualify_Entity_Names for later processing when
47 -- Qualify_All_Entity_Names is called.
49 package Name_Qualify_Units is new Table.Table (
50 Table_Component_Type => Node_Id,
51 Table_Index_Type => Nat,
53 Table_Initial => Alloc.Name_Qualify_Units_Initial,
54 Table_Increment => Alloc.Name_Qualify_Units_Increment,
55 Table_Name => "Name_Qualify_Units");
57 --------------------------------
58 -- Use of Qualification Flags --
59 --------------------------------
61 -- There are two flags used to keep track of qualification of entities
63 -- Has_Fully_Qualified_Name
66 -- The difference between these is as follows. Has_Qualified_Name is
67 -- set to indicate that the name has been qualified as required by the
68 -- spec of this package. As described there, this may involve the full
69 -- qualification for the name, but for some entities, notably procedure
70 -- local variables, this full qualification is not required.
72 -- The flag Has_Fully_Qualified_Name is set if indeed the name has been
73 -- fully qualified in the Ada sense. If Has_Fully_Qualified_Name is set,
74 -- then Has_Qualified_Name is also set, but the other way round is not
77 -- Consider the following example:
84 -- Here B is a procedure local variable, so it does not need fully
85 -- qualification. The flag Has_Qualified_Name will be set on the
86 -- first attempt to qualify B, to indicate that the job is done
87 -- and need not be redone.
89 -- But Y is qualified as x__y, since procedures are always fully
90 -- qualified, so the first time that an attempt is made to qualify
91 -- the name y, it will be replaced by x__y, and both flags are set.
93 -- Why the two flags? Well there are cases where we derive type names
94 -- from object names. As noted in the spec, type names are always
95 -- fully qualified. Suppose for example that the backend has to build
96 -- a padded type for variable B. then it will construct the PAD name
97 -- from B, but it requires full qualification, so the fully qualified
98 -- type name will be x__b___PAD. The two flags allow the circuit for
99 -- building this name to realize efficiently that b needs further
106 -- The string defined here (and its associated length) is used to
107 -- gather the homonym string that will be appended to Name_Buffer
108 -- when the name is complete. Strip_Suffixes appends to this string
109 -- as does Append_Homonym_Number, and Output_Homonym_Numbers_Suffix
110 -- appends the string to the end of Name_Buffer.
112 Homonym_Numbers : String (1 .. 256);
113 Homonym_Len : Natural := 0;
115 ----------------------
116 -- Local Procedures --
117 ----------------------
119 procedure Add_Uint_To_Buffer (U : Uint);
120 -- Add image of universal integer to Name_Buffer, updating Name_Len
122 procedure Add_Real_To_Buffer (U : Ureal);
123 -- Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of
124 -- the normalized numerator and denominator of the given real value.
126 procedure Append_Homonym_Number (E : Entity_Id);
127 -- If the entity E has homonyms in the same scope, then make an entry
128 -- in the Homonym_Numbers array, bumping Homonym_Count accordingly.
130 function Bounds_Match_Size (E : Entity_Id) return Boolean;
131 -- Determine whether the bounds of E match the size of the type. This is
132 -- used to determine whether encoding is required for a discrete type.
134 procedure Output_Homonym_Numbers_Suffix;
135 -- If homonym numbers are stored, then output them into Name_Buffer
137 procedure Prepend_String_To_Buffer (S : String);
138 -- Prepend given string to the contents of the string buffer, updating
139 -- the value in Name_Len (i.e. string is added at start of buffer).
141 procedure Prepend_Uint_To_Buffer (U : Uint);
142 -- Prepend image of universal integer to Name_Buffer, updating Name_Len
144 procedure Qualify_Entity_Name (Ent : Entity_Id);
145 -- If not already done, replaces the Chars field of the given entity
146 -- with the appropriate fully qualified name.
148 procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean);
149 -- Given an qualified entity name in Name_Buffer, remove any plain X or
150 -- X{nb} qualification suffix. The contents of Name_Buffer is not changed
151 -- but Name_Len may be adjusted on return to remove the suffix. If a
152 -- BNPE suffix is found and stripped, then BNPE_Suffix_Found is set to
153 -- True. If no suffix is found, then BNPE_Suffix_Found is not modified.
154 -- This routine also searches for a homonym suffix, and if one is found
155 -- it is also stripped, and the entries are added to the global homonym
156 -- list (Homonym_Numbers) so that they can later be put back.
158 ------------------------
159 -- Add_Real_To_Buffer --
160 ------------------------
162 procedure Add_Real_To_Buffer (U : Ureal) is
164 Add_Uint_To_Buffer (Norm_Num (U));
165 Add_Str_To_Name_Buffer ("_");
166 Add_Uint_To_Buffer (Norm_Den (U));
167 end Add_Real_To_Buffer;
169 ------------------------
170 -- Add_Uint_To_Buffer --
171 ------------------------
173 procedure Add_Uint_To_Buffer (U : Uint) is
176 Add_Uint_To_Buffer (-U);
177 Add_Char_To_Name_Buffer ('m');
179 UI_Image (U, Decimal);
180 Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
182 end Add_Uint_To_Buffer;
184 ---------------------------
185 -- Append_Homonym_Number --
186 ---------------------------
188 procedure Append_Homonym_Number (E : Entity_Id) is
190 procedure Add_Nat_To_H (Nr : Nat);
191 -- Little procedure to append Nr to Homonym_Numbers
197 procedure Add_Nat_To_H (Nr : Nat) is
200 Add_Nat_To_H (Nr / 10);
203 Homonym_Len := Homonym_Len + 1;
204 Homonym_Numbers (Homonym_Len) :=
205 Character'Val (Nr mod 10 + Character'Pos ('0'));
208 -- Start of processing for Append_Homonym_Number
211 if Has_Homonym (E) then
213 H : Entity_Id := Homonym (E);
217 while Present (H) loop
218 if Scope (H) = Scope (E) then
225 if Homonym_Len > 0 then
226 Homonym_Len := Homonym_Len + 1;
227 Homonym_Numbers (Homonym_Len) := '_';
233 end Append_Homonym_Number;
235 -----------------------
236 -- Bounds_Match_Size --
237 -----------------------
239 function Bounds_Match_Size (E : Entity_Id) return Boolean is
243 if not Is_OK_Static_Subtype (E) then
246 elsif Is_Integer_Type (E)
247 and then Subtypes_Statically_Match (E, Base_Type (E))
251 -- Here we check if the static bounds match the natural size, which is
252 -- the size passed through with the debugging information. This is the
253 -- Esize rounded up to 8, 16, 32 or 64 as appropriate.
257 Umark : constant Uintp.Save_Mark := Uintp.Mark;
261 if Esize (E) <= 8 then
263 elsif Esize (E) <= 16 then
265 elsif Esize (E) <= 32 then
271 if Is_Modular_Integer_Type (E) or else Is_Enumeration_Type (E) then
273 Expr_Rep_Value (Type_Low_Bound (E)) = 0
275 2 ** Siz - Expr_Rep_Value (Type_High_Bound (E)) = 1;
279 Expr_Rep_Value (Type_Low_Bound (E)) + 2 ** (Siz - 1) = 0
281 2 ** (Siz - 1) - Expr_Rep_Value (Type_High_Bound (E)) = 1;
288 end Bounds_Match_Size;
290 --------------------------------
291 -- Debug_Renaming_Declaration --
292 --------------------------------
294 function Debug_Renaming_Declaration (N : Node_Id) return Node_Id is
295 Loc : constant Source_Ptr := Sloc (N);
296 Ent : constant Node_Id := Defining_Entity (N);
297 Nam : constant Node_Id := Name (N);
305 function Output_Subscript (N : Node_Id; S : String) return Boolean;
306 -- Outputs a single subscript value as ?nnn (subscript is compile time
307 -- known value with value nnn) or as ?e (subscript is local constant
308 -- with name e), where S supplies the proper string to use for ?.
309 -- Returns False if the subscript is not of an appropriate type to
310 -- output in one of these two forms. The result is prepended to the
311 -- name stored in Name_Buffer.
313 ----------------------
314 -- Output_Subscript --
315 ----------------------
317 function Output_Subscript (N : Node_Id; S : String) return Boolean is
319 if Compile_Time_Known_Value (N) then
320 Prepend_Uint_To_Buffer (Expr_Value (N));
322 elsif Nkind (N) = N_Identifier
323 and then Scope (Entity (N)) = Scope (Ent)
324 and then Ekind (Entity (N)) = E_Constant
326 Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N))));
332 Prepend_String_To_Buffer (S);
334 end Output_Subscript;
336 -- Start of processing for Debug_Renaming_Declaration
339 if not Comes_From_Source (N)
340 and then not Needs_Debug_Info (Ent)
345 -- Prepare entity name for type declaration
347 Get_Name_String (Chars (Ent));
350 when N_Object_Renaming_Declaration =>
351 Add_Str_To_Name_Buffer ("___XR");
353 when N_Exception_Renaming_Declaration =>
354 Add_Str_To_Name_Buffer ("___XRE");
356 when N_Package_Renaming_Declaration =>
357 Add_Str_To_Name_Buffer ("___XRP");
359 -- If it is a child unit create a fully qualified name, to
360 -- disambiguate multiple child units with the same name and
361 -- different parents.
363 if Is_Child_Unit (Ent) then
364 Prepend_String_To_Buffer ("__");
365 Prepend_String_To_Buffer
366 (Get_Name_String (Chars (Scope (Ent))));
375 -- Get renamed entity and compute suffix
385 when N_Expanded_Name =>
387 -- The entity field for an N_Expanded_Name is on the expanded
388 -- name node itself, so we are done here too.
392 when N_Selected_Component =>
393 Prepend_String_To_Buffer
394 (Get_Name_String (Chars (Selector_Name (Ren))));
395 Prepend_String_To_Buffer ("XR");
398 when N_Indexed_Component =>
400 X : Node_Id := Last (Expressions (Ren));
403 while Present (X) loop
404 if not Output_Subscript (X, "XS") then
405 Set_Materialize_Entity (Ent);
417 Typ := Etype (First_Index (Etype (Nam)));
419 if not Output_Subscript (Type_High_Bound (Typ), "XS") then
420 Set_Materialize_Entity (Ent);
424 if not Output_Subscript (Type_Low_Bound (Typ), "XL") then
425 Set_Materialize_Entity (Ent);
431 when N_Explicit_Dereference =>
432 Set_Materialize_Entity (Ent);
433 Prepend_String_To_Buffer ("XA");
436 -- For now, anything else simply results in no translation
439 Set_Materialize_Entity (Ent);
444 Prepend_String_To_Buffer ("___XE");
446 -- For now, the literal name contains only the suffix. The Entity_Id
447 -- value for the name is used to create a link from this literal name
448 -- to the renamed entity using the Debug_Renaming_Link field. Then the
449 -- Qualify_Entity_Name procedure uses this link to create the proper
450 -- fully qualified name.
452 -- The reason we do things this way is that we really need to copy the
453 -- qualification of the renamed entity, and it is really much easier to
454 -- do this after the renamed entity has itself been fully qualified.
456 Lit := Make_Defining_Identifier (Loc, Chars => Name_Enter);
457 Set_Debug_Renaming_Link (Lit, Entity (Ren));
459 -- Return the appropriate enumeration type
461 Def := Make_Defining_Identifier (Loc, Chars => Rnm);
463 Make_Full_Type_Declaration (Loc,
464 Defining_Identifier => Def,
466 Make_Enumeration_Type_Definition (Loc,
467 Literals => New_List (Lit)));
469 Set_Needs_Debug_Info (Def);
470 Set_Needs_Debug_Info (Lit);
472 Set_Discard_Names (Defining_Identifier (Res));
475 -- If we get an exception, just figure it is a case that we cannot
476 -- successfully handle using our current approach, since this is
477 -- only for debugging, no need to take the compilation with us!
481 return Make_Null_Statement (Loc);
482 end Debug_Renaming_Declaration;
484 ----------------------
485 -- Get_Encoded_Name --
486 ----------------------
488 -- Note: see spec for details on encodings
490 procedure Get_Encoded_Name (E : Entity_Id) is
491 Has_Suffix : Boolean;
494 -- If not generating code, there is no need to create encoded names, and
495 -- problems when the back-end is called to annotate types without full
496 -- code generation. See comments in Get_External_Name_With_Suffix for
497 -- additional details.
499 -- However we do create encoded names if the back end is active, even
500 -- if Operating_Mode got reset. Otherwise any serious error reported
501 -- by the backend calling Error_Msg changes the Compilation_Mode to
502 -- Check_Semantics, which disables the functionality of this routine,
503 -- causing the generation of spurious additional errors.
505 -- Couldn't we just test Original_Operating_Mode here? ???
507 if Operating_Mode /= Generate_Code
508 and then not Generating_Code
513 Get_Name_String (Chars (E));
515 -- Nothing to do if we do not have a type
519 -- Or if this is an enumeration base type
521 or else (Is_Enumeration_Type (E)
522 and then E = Base_Type (E))
524 -- Or if this is a dummy type for a renaming
526 or else (Name_Len >= 3 and then
527 Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR")
529 or else (Name_Len >= 4 and then
530 (Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
532 Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"))
534 -- For all these cases, just return the name unchanged
537 Name_Buffer (Name_Len + 1) := ASCII.Nul;
545 if Is_Fixed_Point_Type (E) then
546 Get_External_Name_With_Suffix (E, "XF_");
547 Add_Real_To_Buffer (Delta_Value (E));
549 if Small_Value (E) /= Delta_Value (E) then
550 Add_Str_To_Name_Buffer ("_");
551 Add_Real_To_Buffer (Small_Value (E));
554 -- Vax floating-point case
556 elsif Vax_Float (E) then
557 if Digits_Value (Base_Type (E)) = 6 then
558 Get_External_Name_With_Suffix (E, "XFF");
560 elsif Digits_Value (Base_Type (E)) = 9 then
561 Get_External_Name_With_Suffix (E, "XFF");
564 pragma Assert (Digits_Value (Base_Type (E)) = 15);
565 Get_External_Name_With_Suffix (E, "XFG");
568 -- Discrete case where bounds do not match size
570 elsif Is_Discrete_Type (E)
571 and then not Bounds_Match_Size (E)
574 Lo : constant Node_Id := Type_Low_Bound (E);
575 Hi : constant Node_Id := Type_High_Bound (E);
577 Lo_Con : constant Boolean := Compile_Time_Known_Value (Lo);
578 Hi_Con : constant Boolean := Compile_Time_Known_Value (Hi);
580 Lo_Discr : constant Boolean :=
581 Nkind (Lo) = N_Identifier
583 Ekind (Entity (Lo)) = E_Discriminant;
585 Hi_Discr : constant Boolean :=
586 Nkind (Hi) = N_Identifier
588 Ekind (Entity (Hi)) = E_Discriminant;
590 Lo_Encode : constant Boolean := Lo_Con or Lo_Discr;
591 Hi_Encode : constant Boolean := Hi_Con or Hi_Discr;
593 Biased : constant Boolean := Has_Biased_Representation (E);
597 Get_External_Name_With_Suffix (E, "XB");
599 Get_External_Name_With_Suffix (E, "XD");
602 if Lo_Encode or Hi_Encode then
604 Add_Str_To_Name_Buffer ("_");
608 Add_Str_To_Name_Buffer ("LU_");
610 Add_Str_To_Name_Buffer ("L_");
613 Add_Str_To_Name_Buffer ("U_");
618 Add_Uint_To_Buffer (Expr_Rep_Value (Lo));
620 Get_Name_String_And_Append (Chars (Entity (Lo)));
623 if Lo_Encode and Hi_Encode then
624 Add_Str_To_Name_Buffer ("__");
628 Add_Uint_To_Buffer (Expr_Rep_Value (Hi));
630 Get_Name_String_And_Append (Chars (Entity (Hi)));
635 -- For all other cases, the encoded name is the normal type name
639 Get_External_Name (E, Has_Suffix);
642 if Debug_Flag_B and then Has_Suffix then
643 Write_Str ("**** type ");
644 Write_Name (Chars (E));
645 Write_Str (" is encoded as ");
646 Write_Str (Name_Buffer (1 .. Name_Len));
650 Name_Buffer (Name_Len + 1) := ASCII.NUL;
651 end Get_Encoded_Name;
653 -----------------------
654 -- Get_External_Name --
655 -----------------------
657 procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean) is
658 E : Entity_Id := Entity;
661 procedure Get_Qualified_Name_And_Append (Entity : Entity_Id);
662 -- Appends fully qualified name of given entity to Name_Buffer
664 -----------------------------------
665 -- Get_Qualified_Name_And_Append --
666 -----------------------------------
668 procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is
670 -- If the entity is a compilation unit, its scope is Standard,
671 -- there is no outer scope, and the no further qualification
674 -- If the front end has already computed a fully qualified name,
675 -- then it is also the case that no further qualification is
678 if Present (Scope (Scope (Entity)))
679 and then not Has_Fully_Qualified_Name (Entity)
681 Get_Qualified_Name_And_Append (Scope (Entity));
682 Add_Str_To_Name_Buffer ("__");
683 Get_Name_String_And_Append (Chars (Entity));
684 Append_Homonym_Number (Entity);
687 Get_Name_String_And_Append (Chars (Entity));
689 end Get_Qualified_Name_And_Append;
691 -- Start of processing for Get_External_Name
697 -- If this is a child unit, we want the child
699 if Nkind (E) = N_Defining_Program_Unit_Name then
700 E := Defining_Identifier (Entity);
705 -- Case of interface name being used
707 if (Kind = E_Procedure or else
708 Kind = E_Function or else
709 Kind = E_Constant or else
710 Kind = E_Variable or else
712 and then Present (Interface_Name (E))
713 and then No (Address_Clause (E))
714 and then not Has_Suffix
716 Add_String_To_Name_Buffer (Strval (Interface_Name (E)));
718 -- All other cases besides the interface name case
721 -- If this is a library level subprogram (i.e. a subprogram that is a
722 -- compilation unit other than a subunit), then we prepend _ada_ to
723 -- ensure distinctions required as described in the spec.
725 -- Check explicitly for child units, because those are not flagged
726 -- as Compilation_Units by lib. Should they be ???
729 and then (Is_Compilation_Unit (E) or Is_Child_Unit (E))
730 and then not Has_Suffix
732 Add_Str_To_Name_Buffer ("_ada_");
735 -- If the entity is a subprogram instance that is not a compilation
736 -- unit, generate the name of the original Ada entity, which is the
739 if Is_Generic_Instance (E)
740 and then Is_Subprogram (E)
741 and then not Is_Compilation_Unit (Scope (E))
742 and then (Ekind (Scope (E)) = E_Package
744 Ekind (Scope (E)) = E_Package_Body)
745 and then Present (Related_Instance (Scope (E)))
747 E := Related_Instance (Scope (E));
750 Get_Qualified_Name_And_Append (E);
753 Name_Buffer (Name_Len + 1) := ASCII.Nul;
754 end Get_External_Name;
756 -----------------------------------
757 -- Get_External_Name_With_Suffix --
758 -----------------------------------
760 procedure Get_External_Name_With_Suffix
764 Has_Suffix : constant Boolean := (Suffix /= "");
767 -- If we are not in code generation mode, this procedure may still be
768 -- called from Back_End (more specifically - from gigi for doing type
769 -- representation annotation or some representation-specific checks).
770 -- But in this mode there is no need to mess with external names.
772 -- Furthermore, the call causes difficulties in this case because the
773 -- string representing the homonym number is not correctly reset as a
774 -- part of the call to Output_Homonym_Numbers_Suffix (which is not
777 if Operating_Mode /= Generate_Code then
781 Get_External_Name (Entity, Has_Suffix);
784 Add_Str_To_Name_Buffer ("___");
785 Add_Str_To_Name_Buffer (Suffix);
786 Name_Buffer (Name_Len + 1) := ASCII.Nul;
788 end Get_External_Name_With_Suffix;
790 --------------------------
791 -- Get_Variant_Encoding --
792 --------------------------
794 procedure Get_Variant_Encoding (V : Node_Id) is
797 procedure Choice_Val (Typ : Character; Choice : Node_Id);
798 -- Output encoded value for a single choice value. Typ is the key
799 -- character ('S', 'F', or 'T') that precedes the choice value.
805 procedure Choice_Val (Typ : Character; Choice : Node_Id) is
807 if Nkind (Choice) = N_Integer_Literal then
808 Add_Char_To_Name_Buffer (Typ);
809 Add_Uint_To_Buffer (Intval (Choice));
811 -- Character literal with no entity present (this is the case
812 -- Standard.Character or Standard.Wide_Character as root type)
814 elsif Nkind (Choice) = N_Character_Literal
815 and then No (Entity (Choice))
817 Add_Char_To_Name_Buffer (Typ);
818 Add_Uint_To_Buffer (Char_Literal_Value (Choice));
822 Ent : constant Entity_Id := Entity (Choice);
825 if Ekind (Ent) = E_Enumeration_Literal then
826 Add_Char_To_Name_Buffer (Typ);
827 Add_Uint_To_Buffer (Enumeration_Rep (Ent));
830 pragma Assert (Ekind (Ent) = E_Constant);
831 Choice_Val (Typ, Constant_Value (Ent));
837 -- Start of processing for Get_Variant_Encoding
842 Choice := First (Discrete_Choices (V));
843 while Present (Choice) loop
844 if Nkind (Choice) = N_Others_Choice then
845 Add_Char_To_Name_Buffer ('O');
847 elsif Nkind (Choice) = N_Range then
848 Choice_Val ('R', Low_Bound (Choice));
849 Choice_Val ('T', High_Bound (Choice));
851 elsif Is_Entity_Name (Choice)
852 and then Is_Type (Entity (Choice))
854 Choice_Val ('R', Type_Low_Bound (Entity (Choice)));
855 Choice_Val ('T', Type_High_Bound (Entity (Choice)));
857 elsif Nkind (Choice) = N_Subtype_Indication then
859 Rang : constant Node_Id :=
860 Range_Expression (Constraint (Choice));
862 Choice_Val ('R', Low_Bound (Rang));
863 Choice_Val ('T', High_Bound (Rang));
867 Choice_Val ('S', Choice);
873 Name_Buffer (Name_Len + 1) := ASCII.NUL;
877 VP : constant Node_Id := Parent (V); -- Variant_Part
878 CL : constant Node_Id := Parent (VP); -- Component_List
879 RD : constant Node_Id := Parent (CL); -- Record_Definition
880 FT : constant Node_Id := Parent (RD); -- Full_Type_Declaration
883 Write_Str ("**** variant for type ");
884 Write_Name (Chars (Defining_Identifier (FT)));
885 Write_Str (" is encoded as ");
886 Write_Str (Name_Buffer (1 .. Name_Len));
890 end Get_Variant_Encoding;
892 ------------------------------------
893 -- Get_Secondary_DT_External_Name --
894 ------------------------------------
896 procedure Get_Secondary_DT_External_Name
898 Ancestor_Typ : Entity_Id;
902 Get_External_Name (Typ, Has_Suffix => False);
904 if Ancestor_Typ /= Typ then
906 Len : constant Natural := Name_Len;
907 Save_Str : constant String (1 .. Name_Len)
908 := Name_Buffer (1 .. Name_Len);
910 Get_External_Name (Ancestor_Typ, Has_Suffix => False);
912 -- Append the extended name of the ancestor to the
913 -- extended name of Typ
915 Name_Buffer (Len + 2 .. Len + Name_Len + 1) :=
916 Name_Buffer (1 .. Name_Len);
917 Name_Buffer (1 .. Len) := Save_Str;
918 Name_Buffer (Len + 1) := '_';
919 Name_Len := Len + Name_Len + 1;
923 Add_Nat_To_Name_Buffer (Suffix_Index);
924 end Get_Secondary_DT_External_Name;
926 ---------------------------------
927 -- Make_Packed_Array_Type_Name --
928 ---------------------------------
930 function Make_Packed_Array_Type_Name
936 Get_Name_String (Chars (Typ));
937 Add_Str_To_Name_Buffer ("___XP");
938 Add_Uint_To_Buffer (Csize);
940 end Make_Packed_Array_Type_Name;
942 -----------------------------------
943 -- Output_Homonym_Numbers_Suffix --
944 -----------------------------------
946 procedure Output_Homonym_Numbers_Suffix is
950 if Homonym_Len > 0 then
952 -- Check for all 1's, in which case we do not output
956 exit when Homonym_Numbers (J) /= '1';
958 -- If we reached end of string we do not output
960 if J = Homonym_Len then
965 exit when Homonym_Numbers (J + 1) /= '_';
969 -- If we exit the loop then suffix must be output
971 Add_Str_To_Name_Buffer ("__");
972 Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len));
975 end Output_Homonym_Numbers_Suffix;
977 ------------------------------
978 -- Prepend_String_To_Buffer --
979 ------------------------------
981 procedure Prepend_String_To_Buffer (S : String) is
982 N : constant Integer := S'Length;
984 Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len);
985 Name_Buffer (1 .. N) := S;
986 Name_Len := Name_Len + N;
987 end Prepend_String_To_Buffer;
989 ----------------------------
990 -- Prepend_Uint_To_Buffer --
991 ----------------------------
993 procedure Prepend_Uint_To_Buffer (U : Uint) is
996 Prepend_String_To_Buffer ("m");
997 Prepend_Uint_To_Buffer (-U);
999 UI_Image (U, Decimal);
1000 Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
1002 end Prepend_Uint_To_Buffer;
1004 ------------------------------
1005 -- Qualify_All_Entity_Names --
1006 ------------------------------
1008 procedure Qualify_All_Entity_Names is
1013 for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
1014 E := Defining_Entity (Name_Qualify_Units.Table (J));
1015 Qualify_Entity_Name (E);
1017 Ent := First_Entity (E);
1018 while Present (Ent) loop
1019 Qualify_Entity_Name (Ent);
1022 -- There are odd cases where Last_Entity (E) = E. This happens
1023 -- in the case of renaming of packages. This test avoids getting
1024 -- stuck in such cases.
1029 end Qualify_All_Entity_Names;
1031 -------------------------
1032 -- Qualify_Entity_Name --
1033 -------------------------
1035 procedure Qualify_Entity_Name (Ent : Entity_Id) is
1037 Full_Qualify_Name : String (1 .. Name_Buffer'Length);
1038 Full_Qualify_Len : Natural := 0;
1039 -- Used to accumulate fully qualified name of subprogram
1041 procedure Fully_Qualify_Name (E : Entity_Id);
1042 -- Used to qualify a subprogram or type name, where full
1043 -- qualification up to Standard is always used. Name is set
1044 -- in Full_Qualify_Name with the length in Full_Qualify_Len.
1045 -- Note that this routine does not prepend the _ada_ string
1046 -- required for library subprograms (this is done in the back end).
1048 function Is_BNPE (S : Entity_Id) return Boolean;
1049 -- Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
1050 -- is defined to be a package which is immediately nested within a
1053 function Qualify_Needed (S : Entity_Id) return Boolean;
1054 -- Given a scope, determines if the scope is to be included in the
1055 -- fully qualified name, True if so, False if not.
1057 procedure Set_BNPE_Suffix (E : Entity_Id);
1058 -- Recursive routine to append the BNPE qualification suffix. Works
1059 -- from right to left with E being the current entity in the list.
1060 -- The result does NOT have the trailing n's and trailing b stripped.
1061 -- The caller must do this required stripping.
1063 procedure Set_Entity_Name (E : Entity_Id);
1064 -- Internal recursive routine that does most of the work. This routine
1065 -- leaves the result sitting in Name_Buffer and Name_Len.
1067 BNPE_Suffix_Needed : Boolean := False;
1068 -- Set true if a body-nested package entity suffix is required
1070 Save_Chars : constant Name_Id := Chars (Ent);
1071 -- Save original name
1073 ------------------------
1074 -- Fully_Qualify_Name --
1075 ------------------------
1077 procedure Fully_Qualify_Name (E : Entity_Id) is
1078 Discard : Boolean := False;
1081 -- Ignore empty entry (can happen in error cases)
1086 -- If this we are qualifying entities local to a generic
1087 -- instance, use the name of the original instantiation,
1088 -- not that of the anonymous subprogram in the wrapper
1089 -- package, so that gdb doesn't have to know about these.
1091 elsif Is_Generic_Instance (E)
1092 and then Is_Subprogram (E)
1093 and then not Comes_From_Source (E)
1094 and then not Is_Compilation_Unit (Scope (E))
1096 Fully_Qualify_Name (Related_Instance (Scope (E)));
1100 -- If we reached fully qualified name, then just copy it
1102 if Has_Fully_Qualified_Name (E) then
1103 Get_Name_String (Chars (E));
1104 Strip_Suffixes (Discard);
1105 Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1106 Full_Qualify_Len := Name_Len;
1107 Set_Has_Fully_Qualified_Name (Ent);
1109 -- Case of non-fully qualified name
1112 if Scope (E) = Standard_Standard then
1113 Set_Has_Fully_Qualified_Name (Ent);
1115 Fully_Qualify_Name (Scope (E));
1116 Full_Qualify_Name (Full_Qualify_Len + 1) := '_';
1117 Full_Qualify_Name (Full_Qualify_Len + 2) := '_';
1118 Full_Qualify_Len := Full_Qualify_Len + 2;
1121 if Has_Qualified_Name (E) then
1122 Get_Unqualified_Name_String (Chars (E));
1124 Get_Name_String (Chars (E));
1127 -- Here we do one step of the qualification
1130 (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) :=
1131 Name_Buffer (1 .. Name_Len);
1132 Full_Qualify_Len := Full_Qualify_Len + Name_Len;
1133 Append_Homonym_Number (E);
1137 BNPE_Suffix_Needed := True;
1139 end Fully_Qualify_Name;
1145 function Is_BNPE (S : Entity_Id) return Boolean is
1148 Ekind (S) = E_Package
1149 and then Is_Package_Body_Entity (S);
1152 --------------------
1153 -- Qualify_Needed --
1154 --------------------
1156 function Qualify_Needed (S : Entity_Id) return Boolean is
1158 -- If we got all the way to Standard, then we have certainly
1159 -- fully qualified the name, so set the flag appropriately,
1160 -- and then return False, since we are most certainly done!
1162 if S = Standard_Standard then
1163 Set_Has_Fully_Qualified_Name (Ent, True);
1166 -- Otherwise figure out if further qualification is required
1172 Ekind (Ent) = E_Subprogram_Body
1174 (Ekind (S) /= E_Block
1175 and then not Is_Dynamic_Scope (S));
1179 ---------------------
1180 -- Set_BNPE_Suffix --
1181 ---------------------
1183 procedure Set_BNPE_Suffix (E : Entity_Id) is
1184 S : constant Entity_Id := Scope (E);
1187 if Qualify_Needed (S) then
1188 Set_BNPE_Suffix (S);
1191 Add_Char_To_Name_Buffer ('b');
1193 Add_Char_To_Name_Buffer ('n');
1197 Add_Char_To_Name_Buffer ('X');
1199 end Set_BNPE_Suffix;
1201 ---------------------
1202 -- Set_Entity_Name --
1203 ---------------------
1205 procedure Set_Entity_Name (E : Entity_Id) is
1206 S : constant Entity_Id := Scope (E);
1209 -- If we reach an already qualified name, just take the encoding
1210 -- except that we strip the package body suffixes, since these
1211 -- will be separately put on later.
1213 if Has_Qualified_Name (E) then
1214 Get_Name_String_And_Append (Chars (E));
1215 Strip_Suffixes (BNPE_Suffix_Needed);
1217 -- If the top level name we are adding is itself fully
1218 -- qualified, then that means that the name that we are
1219 -- preparing for the Fully_Qualify_Name call will also
1220 -- generate a fully qualified name.
1222 if Has_Fully_Qualified_Name (E) then
1223 Set_Has_Fully_Qualified_Name (Ent);
1226 -- Case where upper level name is not encoded yet
1229 -- Recurse if further qualification required
1231 if Qualify_Needed (S) then
1232 Set_Entity_Name (S);
1233 Add_Str_To_Name_Buffer ("__");
1236 -- Otherwise get name and note if it is a NPBE
1238 Get_Name_String_And_Append (Chars (E));
1241 BNPE_Suffix_Needed := True;
1244 Append_Homonym_Number (E);
1246 end Set_Entity_Name;
1248 -- Start of processing for Qualify_Entity_Name
1251 if Has_Qualified_Name (Ent) then
1254 -- Here is where we create the proper link for renaming
1256 elsif Ekind (Ent) = E_Enumeration_Literal
1257 and then Present (Debug_Renaming_Link (Ent))
1260 Qualify_Entity_Name (Debug_Renaming_Link (Ent));
1261 Get_Name_String (Chars (Ent));
1262 Prepend_String_To_Buffer
1263 (Get_Name_String (Chars (Debug_Renaming_Link (Ent))));
1264 Set_Chars (Ent, Name_Enter);
1265 Set_Has_Qualified_Name (Ent);
1268 elsif Is_Subprogram (Ent)
1269 or else Ekind (Ent) = E_Subprogram_Body
1270 or else Is_Type (Ent)
1272 Fully_Qualify_Name (Ent);
1273 Name_Len := Full_Qualify_Len;
1274 Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
1276 elsif Qualify_Needed (Scope (Ent)) then
1278 Set_Entity_Name (Ent);
1281 Set_Has_Qualified_Name (Ent);
1285 -- Fall through with a fully qualified name in Name_Buffer/Name_Len
1287 Output_Homonym_Numbers_Suffix;
1289 -- Add body-nested package suffix if required
1291 if BNPE_Suffix_Needed
1292 and then Ekind (Ent) /= E_Enumeration_Literal
1294 Set_BNPE_Suffix (Ent);
1296 -- Strip trailing n's and last trailing b as required. note that
1297 -- we know there is at least one b, or no suffix would be generated.
1299 while Name_Buffer (Name_Len) = 'n' loop
1300 Name_Len := Name_Len - 1;
1303 Name_Len := Name_Len - 1;
1306 Set_Chars (Ent, Name_Enter);
1307 Set_Has_Qualified_Name (Ent);
1309 if Debug_Flag_BB then
1311 Write_Name (Save_Chars);
1312 Write_Str (" qualified as ");
1313 Write_Name (Chars (Ent));
1316 end Qualify_Entity_Name;
1318 --------------------------
1319 -- Qualify_Entity_Names --
1320 --------------------------
1322 procedure Qualify_Entity_Names (N : Node_Id) is
1324 Name_Qualify_Units.Append (N);
1325 end Qualify_Entity_Names;
1327 --------------------
1328 -- Strip_Suffixes --
1329 --------------------
1331 procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is
1335 -- Search for and strip BNPE suffix
1337 for J in reverse 2 .. Name_Len loop
1338 if Name_Buffer (J) = 'X' then
1340 BNPE_Suffix_Found := True;
1344 exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n';
1347 -- Search for and strip homonym numbers suffix
1349 for J in reverse 2 .. Name_Len - 2 loop
1350 if Name_Buffer (J) = '_'
1351 and then Name_Buffer (J + 1) = '_'
1353 if Name_Buffer (J + 2) in '0' .. '9' then
1354 if Homonym_Len > 0 then
1355 Homonym_Len := Homonym_Len + 1;
1356 Homonym_Numbers (Homonym_Len) := '-';
1359 SL := Name_Len - (J + 1);
1361 Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) :=
1362 Name_Buffer (J + 2 .. Name_Len);
1364 Homonym_Len := Homonym_Len + SL;