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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Alloc; use Alloc;
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Nlists; use Nlists;
31 with Nmake; use Nmake;
33 with Output; use Output;
34 with Sem_Eval; use Sem_Eval;
35 with Sem_Util; use Sem_Util;
36 with Sinfo; use Sinfo;
37 with Stand; use Stand;
38 with Stringt; use Stringt;
40 with Tbuild; use Tbuild;
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);
303 function Output_Subscript (N : Node_Id; S : String) return Boolean;
304 -- Outputs a single subscript value as ?nnn (subscript is compile time
305 -- known value with value nnn) or as ?e (subscript is local constant
306 -- with name e), where S supplies the proper string to use for ?.
307 -- Returns False if the subscript is not of an appropriate type to
308 -- output in one of these two forms. The result is prepended to the
309 -- name stored in Name_Buffer.
311 ----------------------
312 -- Output_Subscript --
313 ----------------------
315 function Output_Subscript (N : Node_Id; S : String) return Boolean is
317 if Compile_Time_Known_Value (N) then
318 Prepend_Uint_To_Buffer (Expr_Value (N));
320 elsif Nkind (N) = N_Identifier
321 and then Scope (Entity (N)) = Scope (Ent)
322 and then Ekind (Entity (N)) = E_Constant
324 Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N))));
330 Prepend_String_To_Buffer (S);
332 end Output_Subscript;
334 -- Start of processing for Debug_Renaming_Declaration
337 if not Comes_From_Source (N)
338 and then not Needs_Debug_Info (Ent)
343 -- Get renamed entity and compute suffix
353 when N_Expanded_Name =>
355 -- The entity field for an N_Expanded_Name is on the expanded
356 -- name node itself, so we are done here too.
360 when N_Selected_Component =>
361 Prepend_String_To_Buffer
362 (Get_Name_String (Chars (Selector_Name (Ren))));
363 Prepend_String_To_Buffer ("XR");
366 when N_Indexed_Component =>
368 X : Node_Id := Last (Expressions (Ren));
371 while Present (X) loop
372 if not Output_Subscript (X, "XS") then
373 Set_Materialize_Entity (Ent);
385 Typ := Etype (First_Index (Etype (Nam)));
387 if not Output_Subscript (Type_High_Bound (Typ), "XS") then
388 Set_Materialize_Entity (Ent);
392 if not Output_Subscript (Type_Low_Bound (Typ), "XL") then
393 Set_Materialize_Entity (Ent);
399 when N_Explicit_Dereference =>
400 Set_Materialize_Entity (Ent);
401 Prepend_String_To_Buffer ("XA");
404 -- For now, anything else simply results in no translation
407 Set_Materialize_Entity (Ent);
412 Prepend_String_To_Buffer ("___XE");
414 -- Include the designation of the form of renaming
417 when N_Object_Renaming_Declaration =>
418 Prepend_String_To_Buffer ("___XR");
420 when N_Exception_Renaming_Declaration =>
421 Prepend_String_To_Buffer ("___XRE");
423 when N_Package_Renaming_Declaration =>
424 Prepend_String_To_Buffer ("___XRP");
430 -- Add the name of the renaming entity to the front
432 Prepend_String_To_Buffer (Get_Name_String (Chars (Ent)));
434 -- If it is a child unit create a fully qualified name, to disambiguate
435 -- multiple child units with the same name and different parents.
437 if Nkind (N) = N_Package_Renaming_Declaration
438 and then Is_Child_Unit (Ent)
440 Prepend_String_To_Buffer ("__");
441 Prepend_String_To_Buffer
442 (Get_Name_String (Chars (Scope (Ent))));
445 -- Create the special object whose name is the debug encoding for the
446 -- renaming declaration.
448 -- For now, the object name contains the suffix encoding for the renamed
449 -- object, but not the name of the leading entity. The object is linked
450 -- the renamed entity using the Debug_Renaming_Link field. Then the
451 -- Qualify_Entity_Name procedure uses this link to create the proper
452 -- fully qualified name.
454 -- The reason we do things this way is that we really need to copy the
455 -- qualification of the renamed entity, and it is really much easier to
456 -- do this after the renamed entity has itself been fully qualified.
458 Obj := Make_Defining_Identifier (Loc, Chars => Name_Enter);
460 Make_Object_Declaration (Loc,
461 Defining_Identifier => Obj,
462 Object_Definition => New_Reference_To
463 (Standard_Debug_Renaming_Type, Loc));
465 Set_Debug_Renaming_Link (Obj, Entity (Ren));
467 Set_Needs_Debug_Info (Obj);
471 -- If we get an exception, just figure it is a case that we cannot
472 -- successfully handle using our current approach, since this is
473 -- only for debugging, no need to take the compilation with us!
477 return Make_Null_Statement (Loc);
478 end Debug_Renaming_Declaration;
480 ----------------------
481 -- Get_Encoded_Name --
482 ----------------------
484 -- Note: see spec for details on encodings
486 procedure Get_Encoded_Name (E : Entity_Id) is
487 Has_Suffix : Boolean;
490 -- If not generating code, there is no need to create encoded names, and
491 -- problems when the back-end is called to annotate types without full
492 -- code generation. See comments in Get_External_Name_With_Suffix for
493 -- additional details.
495 -- However we do create encoded names if the back end is active, even
496 -- if Operating_Mode got reset. Otherwise any serious error reported
497 -- by the backend calling Error_Msg changes the Compilation_Mode to
498 -- Check_Semantics, which disables the functionality of this routine,
499 -- causing the generation of spurious additional errors.
501 -- Couldn't we just test Original_Operating_Mode here? ???
503 if Operating_Mode /= Generate_Code
504 and then not Generating_Code
509 Get_Name_String (Chars (E));
511 -- Nothing to do if we do not have a type
515 -- Or if this is an enumeration base type
517 or else (Is_Enumeration_Type (E)
518 and then E = Base_Type (E))
520 -- Or if this is a dummy type for a renaming
522 or else (Name_Len >= 3 and then
523 Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR")
525 or else (Name_Len >= 4 and then
526 (Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
528 Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"))
530 -- For all these cases, just return the name unchanged
533 Name_Buffer (Name_Len + 1) := ASCII.Nul;
541 if Is_Fixed_Point_Type (E) then
542 Get_External_Name_With_Suffix (E, "XF_");
543 Add_Real_To_Buffer (Delta_Value (E));
545 if Small_Value (E) /= Delta_Value (E) then
546 Add_Str_To_Name_Buffer ("_");
547 Add_Real_To_Buffer (Small_Value (E));
550 -- Vax floating-point case
552 elsif Vax_Float (E) then
553 if Digits_Value (Base_Type (E)) = 6 then
554 Get_External_Name_With_Suffix (E, "XFF");
556 elsif Digits_Value (Base_Type (E)) = 9 then
557 Get_External_Name_With_Suffix (E, "XFF");
560 pragma Assert (Digits_Value (Base_Type (E)) = 15);
561 Get_External_Name_With_Suffix (E, "XFG");
564 -- Discrete case where bounds do not match size
566 elsif Is_Discrete_Type (E)
567 and then not Bounds_Match_Size (E)
570 Lo : constant Node_Id := Type_Low_Bound (E);
571 Hi : constant Node_Id := Type_High_Bound (E);
573 Lo_Con : constant Boolean := Compile_Time_Known_Value (Lo);
574 Hi_Con : constant Boolean := Compile_Time_Known_Value (Hi);
576 Lo_Discr : constant Boolean :=
577 Nkind (Lo) = N_Identifier
579 Ekind (Entity (Lo)) = E_Discriminant;
581 Hi_Discr : constant Boolean :=
582 Nkind (Hi) = N_Identifier
584 Ekind (Entity (Hi)) = E_Discriminant;
586 Lo_Encode : constant Boolean := Lo_Con or Lo_Discr;
587 Hi_Encode : constant Boolean := Hi_Con or Hi_Discr;
589 Biased : constant Boolean := Has_Biased_Representation (E);
593 Get_External_Name_With_Suffix (E, "XB");
595 Get_External_Name_With_Suffix (E, "XD");
598 if Lo_Encode or Hi_Encode then
600 Add_Str_To_Name_Buffer ("_");
604 Add_Str_To_Name_Buffer ("LU_");
606 Add_Str_To_Name_Buffer ("L_");
609 Add_Str_To_Name_Buffer ("U_");
614 Add_Uint_To_Buffer (Expr_Rep_Value (Lo));
616 Get_Name_String_And_Append (Chars (Entity (Lo)));
619 if Lo_Encode and Hi_Encode then
620 Add_Str_To_Name_Buffer ("__");
624 Add_Uint_To_Buffer (Expr_Rep_Value (Hi));
626 Get_Name_String_And_Append (Chars (Entity (Hi)));
631 -- For all other cases, the encoded name is the normal type name
635 Get_External_Name (E, Has_Suffix);
638 if Debug_Flag_B and then Has_Suffix then
639 Write_Str ("**** type ");
640 Write_Name (Chars (E));
641 Write_Str (" is encoded as ");
642 Write_Str (Name_Buffer (1 .. Name_Len));
646 Name_Buffer (Name_Len + 1) := ASCII.NUL;
647 end Get_Encoded_Name;
649 -----------------------
650 -- Get_External_Name --
651 -----------------------
653 procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean) is
654 E : Entity_Id := Entity;
657 procedure Get_Qualified_Name_And_Append (Entity : Entity_Id);
658 -- Appends fully qualified name of given entity to Name_Buffer
660 -----------------------------------
661 -- Get_Qualified_Name_And_Append --
662 -----------------------------------
664 procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is
666 -- If the entity is a compilation unit, its scope is Standard,
667 -- there is no outer scope, and the no further qualification
670 -- If the front end has already computed a fully qualified name,
671 -- then it is also the case that no further qualification is
674 if Present (Scope (Scope (Entity)))
675 and then not Has_Fully_Qualified_Name (Entity)
677 Get_Qualified_Name_And_Append (Scope (Entity));
678 Add_Str_To_Name_Buffer ("__");
679 Get_Name_String_And_Append (Chars (Entity));
680 Append_Homonym_Number (Entity);
683 Get_Name_String_And_Append (Chars (Entity));
685 end Get_Qualified_Name_And_Append;
687 -- Start of processing for Get_External_Name
693 -- If this is a child unit, we want the child
695 if Nkind (E) = N_Defining_Program_Unit_Name then
696 E := Defining_Identifier (Entity);
701 -- Case of interface name being used
703 if (Kind = E_Procedure or else
704 Kind = E_Function or else
705 Kind = E_Constant or else
706 Kind = E_Variable or else
708 and then Present (Interface_Name (E))
709 and then No (Address_Clause (E))
710 and then not Has_Suffix
712 Add_String_To_Name_Buffer (Strval (Interface_Name (E)));
714 -- All other cases besides the interface name case
717 -- If this is a library level subprogram (i.e. a subprogram that is a
718 -- compilation unit other than a subunit), then we prepend _ada_ to
719 -- ensure distinctions required as described in the spec.
721 -- Check explicitly for child units, because those are not flagged
722 -- as Compilation_Units by lib. Should they be ???
725 and then (Is_Compilation_Unit (E) or Is_Child_Unit (E))
726 and then not Has_Suffix
728 Add_Str_To_Name_Buffer ("_ada_");
731 -- If the entity is a subprogram instance that is not a compilation
732 -- unit, generate the name of the original Ada entity, which is the
735 if Is_Generic_Instance (E)
736 and then Is_Subprogram (E)
737 and then not Is_Compilation_Unit (Scope (E))
738 and then (Ekind (Scope (E)) = E_Package
740 Ekind (Scope (E)) = E_Package_Body)
741 and then Present (Related_Instance (Scope (E)))
743 E := Related_Instance (Scope (E));
746 Get_Qualified_Name_And_Append (E);
749 Name_Buffer (Name_Len + 1) := ASCII.Nul;
750 end Get_External_Name;
752 -----------------------------------
753 -- Get_External_Name_With_Suffix --
754 -----------------------------------
756 procedure Get_External_Name_With_Suffix
760 Has_Suffix : constant Boolean := (Suffix /= "");
763 -- If we are not in code generation mode, this procedure may still be
764 -- called from Back_End (more specifically - from gigi for doing type
765 -- representation annotation or some representation-specific checks).
766 -- But in this mode there is no need to mess with external names.
768 -- Furthermore, the call causes difficulties in this case because the
769 -- string representing the homonym number is not correctly reset as a
770 -- part of the call to Output_Homonym_Numbers_Suffix (which is not
773 if Operating_Mode /= Generate_Code then
777 Get_External_Name (Entity, Has_Suffix);
780 Add_Str_To_Name_Buffer ("___");
781 Add_Str_To_Name_Buffer (Suffix);
782 Name_Buffer (Name_Len + 1) := ASCII.Nul;
784 end Get_External_Name_With_Suffix;
786 --------------------------
787 -- Get_Variant_Encoding --
788 --------------------------
790 procedure Get_Variant_Encoding (V : Node_Id) is
793 procedure Choice_Val (Typ : Character; Choice : Node_Id);
794 -- Output encoded value for a single choice value. Typ is the key
795 -- character ('S', 'F', or 'T') that precedes the choice value.
801 procedure Choice_Val (Typ : Character; Choice : Node_Id) is
803 if Nkind (Choice) = N_Integer_Literal then
804 Add_Char_To_Name_Buffer (Typ);
805 Add_Uint_To_Buffer (Intval (Choice));
807 -- Character literal with no entity present (this is the case
808 -- Standard.Character or Standard.Wide_Character as root type)
810 elsif Nkind (Choice) = N_Character_Literal
811 and then No (Entity (Choice))
813 Add_Char_To_Name_Buffer (Typ);
814 Add_Uint_To_Buffer (Char_Literal_Value (Choice));
818 Ent : constant Entity_Id := Entity (Choice);
821 if Ekind (Ent) = E_Enumeration_Literal then
822 Add_Char_To_Name_Buffer (Typ);
823 Add_Uint_To_Buffer (Enumeration_Rep (Ent));
826 pragma Assert (Ekind (Ent) = E_Constant);
827 Choice_Val (Typ, Constant_Value (Ent));
833 -- Start of processing for Get_Variant_Encoding
838 Choice := First (Discrete_Choices (V));
839 while Present (Choice) loop
840 if Nkind (Choice) = N_Others_Choice then
841 Add_Char_To_Name_Buffer ('O');
843 elsif Nkind (Choice) = N_Range then
844 Choice_Val ('R', Low_Bound (Choice));
845 Choice_Val ('T', High_Bound (Choice));
847 elsif Is_Entity_Name (Choice)
848 and then Is_Type (Entity (Choice))
850 Choice_Val ('R', Type_Low_Bound (Entity (Choice)));
851 Choice_Val ('T', Type_High_Bound (Entity (Choice)));
853 elsif Nkind (Choice) = N_Subtype_Indication then
855 Rang : constant Node_Id :=
856 Range_Expression (Constraint (Choice));
858 Choice_Val ('R', Low_Bound (Rang));
859 Choice_Val ('T', High_Bound (Rang));
863 Choice_Val ('S', Choice);
869 Name_Buffer (Name_Len + 1) := ASCII.NUL;
873 VP : constant Node_Id := Parent (V); -- Variant_Part
874 CL : constant Node_Id := Parent (VP); -- Component_List
875 RD : constant Node_Id := Parent (CL); -- Record_Definition
876 FT : constant Node_Id := Parent (RD); -- Full_Type_Declaration
879 Write_Str ("**** variant for type ");
880 Write_Name (Chars (Defining_Identifier (FT)));
881 Write_Str (" is encoded as ");
882 Write_Str (Name_Buffer (1 .. Name_Len));
886 end Get_Variant_Encoding;
888 ------------------------------------
889 -- Get_Secondary_DT_External_Name --
890 ------------------------------------
892 procedure Get_Secondary_DT_External_Name
894 Ancestor_Typ : Entity_Id;
898 Get_External_Name (Typ, Has_Suffix => False);
900 if Ancestor_Typ /= Typ then
902 Len : constant Natural := Name_Len;
903 Save_Str : constant String (1 .. Name_Len)
904 := Name_Buffer (1 .. Name_Len);
906 Get_External_Name (Ancestor_Typ, Has_Suffix => False);
908 -- Append the extended name of the ancestor to the
909 -- extended name of Typ
911 Name_Buffer (Len + 2 .. Len + Name_Len + 1) :=
912 Name_Buffer (1 .. Name_Len);
913 Name_Buffer (1 .. Len) := Save_Str;
914 Name_Buffer (Len + 1) := '_';
915 Name_Len := Len + Name_Len + 1;
919 Add_Nat_To_Name_Buffer (Suffix_Index);
920 end Get_Secondary_DT_External_Name;
922 ---------------------------------
923 -- Make_Packed_Array_Type_Name --
924 ---------------------------------
926 function Make_Packed_Array_Type_Name
932 Get_Name_String (Chars (Typ));
933 Add_Str_To_Name_Buffer ("___XP");
934 Add_Uint_To_Buffer (Csize);
936 end Make_Packed_Array_Type_Name;
938 -----------------------------------
939 -- Output_Homonym_Numbers_Suffix --
940 -----------------------------------
942 procedure Output_Homonym_Numbers_Suffix is
946 if Homonym_Len > 0 then
948 -- Check for all 1's, in which case we do not output
952 exit when Homonym_Numbers (J) /= '1';
954 -- If we reached end of string we do not output
956 if J = Homonym_Len then
961 exit when Homonym_Numbers (J + 1) /= '_';
965 -- If we exit the loop then suffix must be output
967 Add_Str_To_Name_Buffer ("__");
968 Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len));
971 end Output_Homonym_Numbers_Suffix;
973 ------------------------------
974 -- Prepend_String_To_Buffer --
975 ------------------------------
977 procedure Prepend_String_To_Buffer (S : String) is
978 N : constant Integer := S'Length;
980 Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len);
981 Name_Buffer (1 .. N) := S;
982 Name_Len := Name_Len + N;
983 end Prepend_String_To_Buffer;
985 ----------------------------
986 -- Prepend_Uint_To_Buffer --
987 ----------------------------
989 procedure Prepend_Uint_To_Buffer (U : Uint) is
992 Prepend_String_To_Buffer ("m");
993 Prepend_Uint_To_Buffer (-U);
995 UI_Image (U, Decimal);
996 Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
998 end Prepend_Uint_To_Buffer;
1000 ------------------------------
1001 -- Qualify_All_Entity_Names --
1002 ------------------------------
1004 procedure Qualify_All_Entity_Names is
1009 for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
1010 E := Defining_Entity (Name_Qualify_Units.Table (J));
1011 Qualify_Entity_Name (E);
1013 -- Normally entities in the qualification list are scopes, but in the
1014 -- case of a library-level package renaming there is an associated
1015 -- variable that encodes the debugger name and that variable is
1016 -- entered in the list since it occurs in the Aux_Decls list of the
1017 -- compilation and doesn't have a normal scope.
1019 if Ekind (E) /= E_Variable then
1020 Ent := First_Entity (E);
1021 while Present (Ent) loop
1022 Qualify_Entity_Name (Ent);
1025 -- There are odd cases where Last_Entity (E) = E. This happens
1026 -- in the case of renaming of packages. This test avoids
1027 -- getting stuck in such cases.
1033 end Qualify_All_Entity_Names;
1035 -------------------------
1036 -- Qualify_Entity_Name --
1037 -------------------------
1039 procedure Qualify_Entity_Name (Ent : Entity_Id) is
1041 Full_Qualify_Name : String (1 .. Name_Buffer'Length);
1042 Full_Qualify_Len : Natural := 0;
1043 -- Used to accumulate fully qualified name of subprogram
1045 procedure Fully_Qualify_Name (E : Entity_Id);
1046 -- Used to qualify a subprogram or type name, where full
1047 -- qualification up to Standard is always used. Name is set
1048 -- in Full_Qualify_Name with the length in Full_Qualify_Len.
1049 -- Note that this routine does not prepend the _ada_ string
1050 -- required for library subprograms (this is done in the back end).
1052 function Is_BNPE (S : Entity_Id) return Boolean;
1053 -- Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
1054 -- is defined to be a package which is immediately nested within a
1057 function Qualify_Needed (S : Entity_Id) return Boolean;
1058 -- Given a scope, determines if the scope is to be included in the
1059 -- fully qualified name, True if so, False if not.
1061 procedure Set_BNPE_Suffix (E : Entity_Id);
1062 -- Recursive routine to append the BNPE qualification suffix. Works
1063 -- from right to left with E being the current entity in the list.
1064 -- The result does NOT have the trailing n's and trailing b stripped.
1065 -- The caller must do this required stripping.
1067 procedure Set_Entity_Name (E : Entity_Id);
1068 -- Internal recursive routine that does most of the work. This routine
1069 -- leaves the result sitting in Name_Buffer and Name_Len.
1071 BNPE_Suffix_Needed : Boolean := False;
1072 -- Set true if a body-nested package entity suffix is required
1074 Save_Chars : constant Name_Id := Chars (Ent);
1075 -- Save original name
1077 ------------------------
1078 -- Fully_Qualify_Name --
1079 ------------------------
1081 procedure Fully_Qualify_Name (E : Entity_Id) is
1082 Discard : Boolean := False;
1085 -- Ignore empty entry (can happen in error cases)
1090 -- If this we are qualifying entities local to a generic
1091 -- instance, use the name of the original instantiation,
1092 -- not that of the anonymous subprogram in the wrapper
1093 -- package, so that gdb doesn't have to know about these.
1095 elsif Is_Generic_Instance (E)
1096 and then Is_Subprogram (E)
1097 and then not Comes_From_Source (E)
1098 and then not Is_Compilation_Unit (Scope (E))
1100 Fully_Qualify_Name (Related_Instance (Scope (E)));
1104 -- If we reached fully qualified name, then just copy it
1106 if Has_Fully_Qualified_Name (E) then
1107 Get_Name_String (Chars (E));
1108 Strip_Suffixes (Discard);
1109 Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1110 Full_Qualify_Len := Name_Len;
1111 Set_Has_Fully_Qualified_Name (Ent);
1113 -- Case of non-fully qualified name
1116 if Scope (E) = Standard_Standard then
1117 Set_Has_Fully_Qualified_Name (Ent);
1119 Fully_Qualify_Name (Scope (E));
1120 Full_Qualify_Name (Full_Qualify_Len + 1) := '_';
1121 Full_Qualify_Name (Full_Qualify_Len + 2) := '_';
1122 Full_Qualify_Len := Full_Qualify_Len + 2;
1125 if Has_Qualified_Name (E) then
1126 Get_Unqualified_Name_String (Chars (E));
1128 Get_Name_String (Chars (E));
1131 -- Here we do one step of the qualification
1134 (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) :=
1135 Name_Buffer (1 .. Name_Len);
1136 Full_Qualify_Len := Full_Qualify_Len + Name_Len;
1137 Append_Homonym_Number (E);
1141 BNPE_Suffix_Needed := True;
1143 end Fully_Qualify_Name;
1149 function Is_BNPE (S : Entity_Id) return Boolean is
1152 Ekind (S) = E_Package
1153 and then Is_Package_Body_Entity (S);
1156 --------------------
1157 -- Qualify_Needed --
1158 --------------------
1160 function Qualify_Needed (S : Entity_Id) return Boolean is
1162 -- If we got all the way to Standard, then we have certainly
1163 -- fully qualified the name, so set the flag appropriately,
1164 -- and then return False, since we are most certainly done!
1166 if S = Standard_Standard then
1167 Set_Has_Fully_Qualified_Name (Ent, True);
1170 -- Otherwise figure out if further qualification is required
1176 Ekind (Ent) = E_Subprogram_Body
1178 (Ekind (S) /= E_Block
1179 and then not Is_Dynamic_Scope (S));
1183 ---------------------
1184 -- Set_BNPE_Suffix --
1185 ---------------------
1187 procedure Set_BNPE_Suffix (E : Entity_Id) is
1188 S : constant Entity_Id := Scope (E);
1191 if Qualify_Needed (S) then
1192 Set_BNPE_Suffix (S);
1195 Add_Char_To_Name_Buffer ('b');
1197 Add_Char_To_Name_Buffer ('n');
1201 Add_Char_To_Name_Buffer ('X');
1203 end Set_BNPE_Suffix;
1205 ---------------------
1206 -- Set_Entity_Name --
1207 ---------------------
1209 procedure Set_Entity_Name (E : Entity_Id) is
1210 S : constant Entity_Id := Scope (E);
1213 -- If we reach an already qualified name, just take the encoding
1214 -- except that we strip the package body suffixes, since these
1215 -- will be separately put on later.
1217 if Has_Qualified_Name (E) then
1218 Get_Name_String_And_Append (Chars (E));
1219 Strip_Suffixes (BNPE_Suffix_Needed);
1221 -- If the top level name we are adding is itself fully
1222 -- qualified, then that means that the name that we are
1223 -- preparing for the Fully_Qualify_Name call will also
1224 -- generate a fully qualified name.
1226 if Has_Fully_Qualified_Name (E) then
1227 Set_Has_Fully_Qualified_Name (Ent);
1230 -- Case where upper level name is not encoded yet
1233 -- Recurse if further qualification required
1235 if Qualify_Needed (S) then
1236 Set_Entity_Name (S);
1237 Add_Str_To_Name_Buffer ("__");
1240 -- Otherwise get name and note if it is a NPBE
1242 Get_Name_String_And_Append (Chars (E));
1245 BNPE_Suffix_Needed := True;
1248 Append_Homonym_Number (E);
1250 end Set_Entity_Name;
1252 -- Start of processing for Qualify_Entity_Name
1255 if Has_Qualified_Name (Ent) then
1258 -- If the entity is a variable encoding the debug name for an object
1259 -- renaming, then the qualified name of the entity associated with the
1260 -- renamed object can now be incorporated in the debug name.
1262 elsif Ekind (Ent) = E_Variable
1263 and then Present (Debug_Renaming_Link (Ent))
1266 Qualify_Entity_Name (Debug_Renaming_Link (Ent));
1267 Get_Name_String (Chars (Ent));
1269 -- Retrieve the now-qualified name of the renamed entity and insert
1270 -- it in the middle of the name, just preceding the suffix encoding
1271 -- describing the renamed object.
1274 Renamed_Id : constant String :=
1275 Get_Name_String (Chars (Debug_Renaming_Link (Ent)));
1276 Insert_Len : constant Integer := Renamed_Id'Length + 1;
1277 Index : Natural := Name_Len - 3;
1280 -- Loop backwards through the name to find the start of the "___"
1281 -- sequence associated with the suffix.
1283 while Index >= Name_Buffer'First
1284 and then (Name_Buffer (Index + 1) /= '_'
1285 or else Name_Buffer (Index + 2) /= '_'
1286 or else Name_Buffer (Index + 3) /= '_')
1291 pragma Assert (Name_Buffer (Index + 1 .. Index + 3) = "___");
1293 -- Insert an underscore separator and the entity name just in
1294 -- front of the suffix.
1296 Name_Buffer (Index + 1 + Insert_Len .. Name_Len + Insert_Len) :=
1297 Name_Buffer (Index + 1 .. Name_Len);
1298 Name_Buffer (Index + 1) := '_';
1299 Name_Buffer (Index + 2 .. Index + Insert_Len) := Renamed_Id;
1300 Name_Len := Name_Len + Insert_Len;
1303 -- Reset the name of the variable to the new name that includes the
1304 -- name of the renamed entity.
1306 Set_Chars (Ent, Name_Enter);
1308 -- If the entity needs qualification by its scope then develop it
1309 -- here, add the variable's name, and again reset the entity name.
1311 if Qualify_Needed (Scope (Ent)) then
1313 Set_Entity_Name (Scope (Ent));
1314 Add_Str_To_Name_Buffer ("__");
1316 Get_Name_String_And_Append (Chars (Ent));
1318 Set_Chars (Ent, Name_Enter);
1321 Set_Has_Qualified_Name (Ent);
1324 elsif Is_Subprogram (Ent)
1325 or else Ekind (Ent) = E_Subprogram_Body
1326 or else Is_Type (Ent)
1328 Fully_Qualify_Name (Ent);
1329 Name_Len := Full_Qualify_Len;
1330 Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
1332 elsif Qualify_Needed (Scope (Ent)) then
1334 Set_Entity_Name (Ent);
1337 Set_Has_Qualified_Name (Ent);
1341 -- Fall through with a fully qualified name in Name_Buffer/Name_Len
1343 Output_Homonym_Numbers_Suffix;
1345 -- Add body-nested package suffix if required
1347 if BNPE_Suffix_Needed
1348 and then Ekind (Ent) /= E_Enumeration_Literal
1350 Set_BNPE_Suffix (Ent);
1352 -- Strip trailing n's and last trailing b as required. note that
1353 -- we know there is at least one b, or no suffix would be generated.
1355 while Name_Buffer (Name_Len) = 'n' loop
1356 Name_Len := Name_Len - 1;
1359 Name_Len := Name_Len - 1;
1362 Set_Chars (Ent, Name_Enter);
1363 Set_Has_Qualified_Name (Ent);
1365 if Debug_Flag_BB then
1367 Write_Name (Save_Chars);
1368 Write_Str (" qualified as ");
1369 Write_Name (Chars (Ent));
1372 end Qualify_Entity_Name;
1374 --------------------------
1375 -- Qualify_Entity_Names --
1376 --------------------------
1378 procedure Qualify_Entity_Names (N : Node_Id) is
1380 Name_Qualify_Units.Append (N);
1381 end Qualify_Entity_Names;
1383 --------------------
1384 -- Strip_Suffixes --
1385 --------------------
1387 procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is
1390 pragma Warnings (Off, BNPE_Suffix_Found);
1391 -- Since this procedure only ever sets the flag
1394 -- Search for and strip BNPE suffix
1396 for J in reverse 2 .. Name_Len loop
1397 if Name_Buffer (J) = 'X' then
1399 BNPE_Suffix_Found := True;
1403 exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n';
1406 -- Search for and strip homonym numbers suffix
1408 for J in reverse 2 .. Name_Len - 2 loop
1409 if Name_Buffer (J) = '_'
1410 and then Name_Buffer (J + 1) = '_'
1412 if Name_Buffer (J + 2) in '0' .. '9' then
1413 if Homonym_Len > 0 then
1414 Homonym_Len := Homonym_Len + 1;
1415 Homonym_Numbers (Homonym_Len) := '-';
1418 SL := Name_Len - (J + 1);
1420 Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) :=
1421 Name_Buffer (J + 2 .. Name_Len);
1423 Homonym_Len := Homonym_Len + SL;