1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2021, 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 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Einfo.Entities; use Einfo.Entities;
31 with Einfo.Utils; use Einfo.Utils;
32 with Exp_Util; use Exp_Util;
33 with Nlists; use Nlists;
34 with Nmake; use Nmake;
36 with Output; use Output;
37 with Sem_Aux; use Sem_Aux;
38 with Sem_Eval; use Sem_Eval;
39 with Sem_Util; use Sem_Util;
40 with Sinfo; use Sinfo;
41 with Sinfo.Nodes; use Sinfo.Nodes;
42 with Sinfo.Utils; use Sinfo.Utils;
43 with Stand; use Stand;
44 with Stringt; use Stringt;
46 with Tbuild; use Tbuild;
47 with Urealp; use Urealp;
49 package body Exp_Dbug is
51 -- The following table is used to queue up the entities passed as
52 -- arguments to Qualify_Entity_Names for later processing when
53 -- Qualify_All_Entity_Names is called.
55 package Name_Qualify_Units is new Table.Table (
56 Table_Component_Type => Node_Id,
57 Table_Index_Type => Nat,
59 Table_Initial => Alloc.Name_Qualify_Units_Initial,
60 Table_Increment => Alloc.Name_Qualify_Units_Increment,
61 Table_Name => "Name_Qualify_Units");
63 --------------------------------
64 -- Use of Qualification Flags --
65 --------------------------------
67 -- There are two flags used to keep track of qualification of entities
69 -- Has_Fully_Qualified_Name
72 -- The difference between these is as follows. Has_Qualified_Name is
73 -- set to indicate that the name has been qualified as required by the
74 -- spec of this package. As described there, this may involve the full
75 -- qualification for the name, but for some entities, notably procedure
76 -- local variables, this full qualification is not required.
78 -- The flag Has_Fully_Qualified_Name is set if indeed the name has been
79 -- fully qualified in the Ada sense. If Has_Fully_Qualified_Name is set,
80 -- then Has_Qualified_Name is also set, but the other way round is not
83 -- Consider the following example:
90 -- Here B is a procedure local variable, so it does not need fully
91 -- qualification. The flag Has_Qualified_Name will be set on the
92 -- first attempt to qualify B, to indicate that the job is done
93 -- and need not be redone.
95 -- But Y is qualified as x__y, since procedures are always fully
96 -- qualified, so the first time that an attempt is made to qualify
97 -- the name y, it will be replaced by x__y, and both flags are set.
99 -- Why the two flags? Well there are cases where we derive type names
100 -- from object names. As noted in the spec, type names are always
101 -- fully qualified. Suppose for example that the backend has to build
102 -- a padded type for variable B. then it will construct the PAD name
103 -- from B, but it requires full qualification, so the fully qualified
104 -- type name will be x__b___PAD. The two flags allow the circuit for
105 -- building this name to realize efficiently that b needs further
112 -- The string defined here (and its associated length) is used to gather
113 -- the homonym string that will be appended to Name_Buffer when the name
114 -- is complete. Strip_Suffixes appends to this string as does
115 -- Append_Homonym_Number, and Output_Homonym_Numbers_Suffix appends the
116 -- string to the end of Name_Buffer.
118 Homonym_Numbers : String (1 .. 256);
119 Homonym_Len : Natural := 0;
121 ----------------------
122 -- Local Procedures --
123 ----------------------
125 procedure Add_Uint_To_Buffer (U : Uint);
126 -- Add image of universal integer to Name_Buffer, updating Name_Len
128 procedure Add_Real_To_Buffer (U : Ureal);
129 -- Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of
130 -- the normalized numerator and denominator of the given real value.
132 procedure Append_Homonym_Number (E : Entity_Id);
133 -- If the entity E has homonyms in the same scope, then make an entry
134 -- in the Homonym_Numbers array, bumping Homonym_Count accordingly.
136 function Bounds_Match_Size (E : Entity_Id) return Boolean;
137 -- Determine whether the bounds of E match the size of the type. This is
138 -- used to determine whether encoding is required for a discrete type.
140 procedure Output_Homonym_Numbers_Suffix;
141 -- If homonym numbers are stored, then output them into Name_Buffer
143 procedure Prepend_String_To_Buffer (S : String);
144 -- Prepend given string to the contents of the string buffer, updating
145 -- the value in Name_Len (i.e. string is added at start of buffer).
147 procedure Prepend_Uint_To_Buffer (U : Uint);
148 -- Prepend image of universal integer to Name_Buffer, updating Name_Len
150 procedure Qualify_Entity_Name (Ent : Entity_Id);
151 -- If not already done, replaces the Chars field of the given entity
152 -- with the appropriate fully qualified name.
154 procedure Reset_Buffers;
155 -- Reset the contents of Name_Buffer and Homonym_Numbers by setting their
156 -- respective lengths to zero.
158 procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean);
159 -- Given an qualified entity name in Name_Buffer, remove any plain X or
160 -- X{nb} qualification suffix. The contents of Name_Buffer is not changed
161 -- but Name_Len may be adjusted on return to remove the suffix. If a
162 -- BNPE suffix is found and stripped, then BNPE_Suffix_Found is set to
163 -- True. If no suffix is found, then BNPE_Suffix_Found is not modified.
164 -- This routine also searches for a homonym suffix, and if one is found
165 -- it is also stripped, and the entries are added to the global homonym
166 -- list (Homonym_Numbers) so that they can later be put back.
168 ------------------------
169 -- Add_Real_To_Buffer --
170 ------------------------
172 procedure Add_Real_To_Buffer (U : Ureal) is
174 Add_Uint_To_Buffer (Norm_Num (U));
175 Add_Str_To_Name_Buffer ("_");
176 Add_Uint_To_Buffer (Norm_Den (U));
177 end Add_Real_To_Buffer;
179 ------------------------
180 -- Add_Uint_To_Buffer --
181 ------------------------
183 procedure Add_Uint_To_Buffer (U : Uint) is
186 Add_Uint_To_Buffer (-U);
187 Add_Char_To_Name_Buffer ('m');
189 UI_Image (U, Decimal);
190 Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
192 end Add_Uint_To_Buffer;
194 ---------------------------
195 -- Append_Homonym_Number --
196 ---------------------------
198 procedure Append_Homonym_Number (E : Entity_Id) is
200 procedure Add_Nat_To_H (Nr : Nat);
201 -- Little procedure to append Nr to Homonym_Numbers
207 procedure Add_Nat_To_H (Nr : Nat) is
210 Add_Nat_To_H (Nr / 10);
213 Homonym_Len := Homonym_Len + 1;
214 Homonym_Numbers (Homonym_Len) :=
215 Character'Val (Nr mod 10 + Character'Pos ('0'));
218 -- Start of processing for Append_Homonym_Number
221 if Has_Homonym (E) then
222 if Homonym_Len > 0 then
223 Homonym_Len := Homonym_Len + 1;
224 Homonym_Numbers (Homonym_Len) := '_';
227 Add_Nat_To_H (Homonym_Number (E));
229 end Append_Homonym_Number;
231 -----------------------
232 -- Bounds_Match_Size --
233 -----------------------
235 function Bounds_Match_Size (E : Entity_Id) return Boolean is
239 if not Is_OK_Static_Subtype (E) then
242 elsif Is_Integer_Type (E)
243 and then Subtypes_Statically_Match (E, Base_Type (E))
247 -- Here we check if the static bounds match the natural size, which is
248 -- the size passed through with the debugging information. This is the
249 -- Esize rounded up to 8, 16, 32, 64 or 128 as appropriate.
253 Umark : constant Uintp.Save_Mark := Uintp.Mark;
257 if Esize (E) <= 8 then
259 elsif Esize (E) <= 16 then
261 elsif Esize (E) <= 32 then
263 elsif Esize (E) <= 64 then
269 if Is_Modular_Integer_Type (E) or else Is_Enumeration_Type (E) then
271 Expr_Rep_Value (Type_Low_Bound (E)) = 0
273 2 ** Siz - Expr_Rep_Value (Type_High_Bound (E)) = 1;
277 Expr_Rep_Value (Type_Low_Bound (E)) + 2 ** (Siz - 1) = 0
279 2 ** (Siz - 1) - Expr_Rep_Value (Type_High_Bound (E)) = 1;
286 end Bounds_Match_Size;
288 --------------------------------
289 -- Debug_Renaming_Declaration --
290 --------------------------------
292 function Debug_Renaming_Declaration (N : Node_Id) return Node_Id is
293 Loc : constant Source_Ptr := Sloc (N);
294 Ent : constant Node_Id := Defining_Entity (N);
295 Nam : constant Node_Id := Name (N);
301 Enable : Boolean := Nkind (N) = N_Package_Renaming_Declaration;
302 -- By default, we do not generate an encoding for renaming. This is
303 -- however done (in which case this is set to True) in a few cases:
304 -- - when a package is renamed,
305 -- - when the renaming involves a packed array,
306 -- - when the renaming involves a packed record.
308 Last_Is_Indexed_Comp : Boolean := False;
309 -- Whether the last subscript value was an indexed component access (XS)
311 procedure Enable_If_Packed_Array (N : Node_Id);
312 -- Enable encoding generation if N is a packed array
314 function Output_Subscript (N : Node_Id; S : String) return Boolean;
315 -- Outputs a single subscript value as ?nnn (subscript is compile time
316 -- known value with value nnn) or as ?e (subscript is local constant
317 -- with name e), where S supplies the proper string to use for ?.
318 -- Returns False if the subscript is not of an appropriate type to
319 -- output in one of these two forms. The result is prepended to the
320 -- name stored in Name_Buffer.
322 function Scope_Contains
326 -- Return whether Inner belongs to the Outer scope
328 ----------------------------
329 -- Enable_If_Packed_Array --
330 ----------------------------
332 procedure Enable_If_Packed_Array (N : Node_Id) is
333 T : constant Entity_Id := Underlying_Type (Etype (N));
339 (Ekind (T) in Array_Kind
340 and then Present (Packed_Array_Impl_Type (T)));
341 end Enable_If_Packed_Array;
343 ----------------------
344 -- Output_Subscript --
345 ----------------------
347 function Output_Subscript (N : Node_Id; S : String) return Boolean is
349 if Compile_Time_Known_Value (N) then
350 Prepend_Uint_To_Buffer (Expr_Value (N));
352 elsif Nkind (N) = N_Identifier
353 and then Scope_Contains (Scope (Entity (N)), Ent)
354 and then Ekind (Entity (N)) in E_Constant | E_In_Parameter
356 Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N))));
362 Prepend_String_To_Buffer (S);
364 end Output_Subscript;
370 function Scope_Contains
375 Cur : Entity_Id := Scope (Inner);
378 while Present (Cur) loop
389 -- Start of processing for Debug_Renaming_Declaration
392 if not Comes_From_Source (N) and then not Needs_Debug_Info (Ent) then
396 -- Get renamed entity and compute suffix
401 -- The expression that designates the renamed object is sometimes
402 -- expanded into bit-wise operations. We want to work instead on
403 -- array/record components accesses, so try to analyze the unexpanded
406 Ren := Original_Node (Ren);
412 if not Present (Renamed_Object (Entity (Ren))) then
416 -- This is a renaming of a renaming: traverse until the final
417 -- renaming to see if anything is packed along the way.
419 Ren := Renamed_Object (Entity (Ren));
421 when N_Selected_Component =>
423 Sel_Id : constant Entity_Id :=
424 Entity (Selector_Name (Ren));
428 -- If the renaming involves a call to a primitive function,
429 -- we are out of the scope of renaming encodings. We will
430 -- very likely create a variable to hold the renamed value
431 -- anyway, so the renaming entity will be available in
434 exit when Ekind (Sel_Id) not in E_Component | E_Discriminant;
436 First_Bit := Normalized_First_Bit (Sel_Id);
440 (Underlying_Type (Etype (Prefix (Ren))))
441 or else (First_Bit /= No_Uint
442 and then First_Bit /= Uint_0);
445 Prepend_String_To_Buffer
446 (Get_Name_String (Chars (Selector_Name (Ren))));
447 Prepend_String_To_Buffer ("XR");
449 Last_Is_Indexed_Comp := False;
451 when N_Indexed_Component =>
456 Enable_If_Packed_Array (Prefix (Ren));
458 X := Last (Expressions (Ren));
459 while Present (X) loop
460 if not Output_Subscript (X, "XS") then
461 Set_Materialize_Entity (Ent);
466 Last_Is_Indexed_Comp := True;
474 -- Assuming X is an array:
480 -- GDB cannot handle packed array slices, so avoid describing
481 -- the slice if we can avoid it.
483 if not Last_Is_Indexed_Comp then
484 Enable_If_Packed_Array (Prefix (Ren));
485 Typ := Etype (First_Index (Etype (Ren)));
487 if not Output_Subscript (Type_High_Bound (Typ), "XS") then
488 Set_Materialize_Entity (Ent);
492 if not Output_Subscript (Type_Low_Bound (Typ), "XL") then
493 Set_Materialize_Entity (Ent);
497 Last_Is_Indexed_Comp := False;
502 when N_Explicit_Dereference =>
503 Prepend_String_To_Buffer ("XA");
505 Last_Is_Indexed_Comp := False;
507 -- For now, anything else simply results in no translation
510 Set_Materialize_Entity (Ent);
515 -- If we found no reason here to emit an encoding, stop now
518 Set_Materialize_Entity (Ent);
522 Prepend_String_To_Buffer ("___XE");
524 -- Include the designation of the form of renaming
527 when N_Object_Renaming_Declaration =>
528 Prepend_String_To_Buffer ("___XR");
530 when N_Exception_Renaming_Declaration =>
531 Prepend_String_To_Buffer ("___XRE");
533 when N_Package_Renaming_Declaration =>
534 Prepend_String_To_Buffer ("___XRP");
540 -- Add the name of the renaming entity to the front
542 Prepend_String_To_Buffer (Get_Name_String (Chars (Ent)));
544 -- If it is a child unit create a fully qualified name, to disambiguate
545 -- multiple child units with the same name and different parents.
547 if Nkind (N) = N_Package_Renaming_Declaration
548 and then Is_Child_Unit (Ent)
550 Prepend_String_To_Buffer ("__");
551 Prepend_String_To_Buffer
552 (Get_Name_String (Chars (Scope (Ent))));
555 -- Create the special object whose name is the debug encoding for the
556 -- renaming declaration.
558 -- For now, the object name contains the suffix encoding for the renamed
559 -- object, but not the name of the leading entity. The object is linked
560 -- the renamed entity using the Debug_Renaming_Link field. Then the
561 -- Qualify_Entity_Name procedure uses this link to create the proper
562 -- fully qualified name.
564 -- The reason we do things this way is that we really need to copy the
565 -- qualification of the renamed entity, and it is really much easier to
566 -- do this after the renamed entity has itself been fully qualified.
568 Obj := Make_Defining_Identifier (Loc, Chars => Name_Enter);
570 Make_Object_Declaration (Loc,
571 Defining_Identifier => Obj,
572 Object_Definition => New_Occurrence_Of
573 (Standard_Debug_Renaming_Type, Loc));
575 Set_Debug_Renaming_Link (Obj, Entity (Ren));
577 Set_Debug_Info_Needed (Obj);
579 -- The renamed entity may be a temporary, e.g. the result of an
580 -- implicit dereference in an iterator. Indicate that the temporary
581 -- itself requires debug information. If the renamed entity comes
582 -- from source this is a no-op.
584 Set_Debug_Info_Needed (Entity (Ren));
586 -- Mark the object as internal so that it won't be initialized when
587 -- pragma Initialize_Scalars or Normalize_Scalars is in use.
589 Set_Is_Internal (Obj);
593 -- If we get an exception, just figure it is a case that we cannot
594 -- successfully handle using our current approach, since this is
595 -- only for debugging, no need to take the compilation with us.
599 return Make_Null_Statement (Loc);
600 end Debug_Renaming_Declaration;
602 ----------------------
603 -- Get_Encoded_Name --
604 ----------------------
606 -- Note: see spec for details on encodings
608 procedure Get_Encoded_Name (E : Entity_Id) is
609 Has_Suffix : Boolean;
612 -- If not generating code, there is no need to create encoded names, and
613 -- problems when the back-end is called to annotate types without full
614 -- code generation. See comments in Get_External_Name for additional
617 -- However we do create encoded names if the back end is active, even
618 -- if Operating_Mode got reset. Otherwise any serious error reported
619 -- by the backend calling Error_Msg changes the Compilation_Mode to
620 -- Check_Semantics, which disables the functionality of this routine,
621 -- causing the generation of spurious additional errors.
623 -- Couldn't we just test Original_Operating_Mode here? ???
625 if Operating_Mode /= Generate_Code and then not Generating_Code then
629 Get_Name_String (Chars (E));
631 -- Nothing to do if we do not have a type
635 -- Or if this is an enumeration base type
637 or else (Is_Enumeration_Type (E) and then Is_Base_Type (E))
639 -- Or if this is a dummy type for a renaming
641 or else (Name_Len >= 3 and then
642 Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR")
644 or else (Name_Len >= 4 and then
645 (Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
647 Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"))
649 -- For all these cases, just return the name unchanged
652 Name_Buffer (Name_Len + 1) := ASCII.NUL;
658 -- Fixed-point case: generate GNAT encodings when asked to
660 if Is_Fixed_Point_Type (E)
661 and then GNAT_Encodings = DWARF_GNAT_Encodings_All
663 Get_External_Name (E, True, "XF_");
664 Add_Real_To_Buffer (Delta_Value (E));
666 if Small_Value (E) /= Delta_Value (E) then
667 Add_Str_To_Name_Buffer ("_");
668 Add_Real_To_Buffer (Small_Value (E));
671 -- Discrete case where bounds do not match size. Not necessary if we can
672 -- emit standard DWARF.
674 elsif GNAT_Encodings /= DWARF_GNAT_Encodings_Minimal
675 and then Is_Discrete_Type (E)
676 and then not Bounds_Match_Size (E)
679 Lo : constant Node_Id := Type_Low_Bound (E);
680 Hi : constant Node_Id := Type_High_Bound (E);
682 Lo_Con : constant Boolean := Compile_Time_Known_Value (Lo);
683 Hi_Con : constant Boolean := Compile_Time_Known_Value (Hi);
685 Lo_Discr : constant Boolean :=
686 Nkind (Lo) = N_Identifier
687 and then Ekind (Entity (Lo)) = E_Discriminant;
689 Hi_Discr : constant Boolean :=
690 Nkind (Hi) = N_Identifier
691 and then Ekind (Entity (Hi)) = E_Discriminant;
693 Lo_Encode : constant Boolean := Lo_Con or Lo_Discr;
694 Hi_Encode : constant Boolean := Hi_Con or Hi_Discr;
696 Biased : constant Boolean := Has_Biased_Representation (E);
700 Get_External_Name (E, True, "XB");
702 Get_External_Name (E, True, "XD");
705 if Lo_Encode or Hi_Encode then
707 Add_Str_To_Name_Buffer ("_");
711 Add_Str_To_Name_Buffer ("LU_");
713 Add_Str_To_Name_Buffer ("L_");
716 Add_Str_To_Name_Buffer ("U_");
721 Add_Uint_To_Buffer (Expr_Rep_Value (Lo));
723 Get_Name_String_And_Append (Chars (Entity (Lo)));
726 if Lo_Encode and Hi_Encode then
727 Add_Str_To_Name_Buffer ("__");
731 Add_Uint_To_Buffer (Expr_Rep_Value (Hi));
733 Get_Name_String_And_Append (Chars (Entity (Hi)));
738 -- For all other cases, the encoded name is the normal type name
742 Get_External_Name (E);
745 if Debug_Flag_B and then Has_Suffix then
746 Write_Str ("**** type ");
747 Write_Name (Chars (E));
748 Write_Str (" is encoded as ");
749 Write_Str (Name_Buffer (1 .. Name_Len));
753 Name_Buffer (Name_Len + 1) := ASCII.NUL;
754 end Get_Encoded_Name;
756 -----------------------
757 -- Get_External_Name --
758 -----------------------
760 procedure Get_External_Name
762 Has_Suffix : Boolean := False;
763 Suffix : String := "")
765 procedure Get_Qualified_Name_And_Append (Entity : Entity_Id);
766 -- Appends fully qualified name of given entity to Name_Buffer
768 -----------------------------------
769 -- Get_Qualified_Name_And_Append --
770 -----------------------------------
772 procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is
774 -- If the entity is a compilation unit, its scope is Standard,
775 -- there is no outer scope, and the no further qualification
778 -- If the front end has already computed a fully qualified name,
779 -- then it is also the case that no further qualification is
782 if Present (Scope (Scope (Entity)))
783 and then not Has_Fully_Qualified_Name (Entity)
785 Get_Qualified_Name_And_Append (Scope (Entity));
786 Add_Str_To_Name_Buffer ("__");
787 Get_Name_String_And_Append (Chars (Entity));
788 Append_Homonym_Number (Entity);
791 Get_Name_String_And_Append (Chars (Entity));
793 end Get_Qualified_Name_And_Append;
797 E : Entity_Id := Entity;
799 -- Start of processing for Get_External_Name
802 -- If we are not in code generation mode, this procedure may still be
803 -- called from Back_End (more specifically - from gigi for doing type
804 -- representation annotation or some representation-specific checks).
805 -- But in this mode there is no need to mess with external names.
807 -- Furthermore, the call causes difficulties in this case because the
808 -- string representing the homonym number is not correctly reset as a
809 -- part of the call to Output_Homonym_Numbers_Suffix (which is not
812 if Operating_Mode /= Generate_Code then
818 -- If this is a child unit, we want the child
820 if Nkind (E) = N_Defining_Program_Unit_Name then
821 E := Defining_Identifier (Entity);
824 -- Case of interface name being used
826 if Ekind (E) in E_Constant
831 and then Present (Interface_Name (E))
832 and then No (Address_Clause (E))
833 and then not Has_Suffix
835 Append (Global_Name_Buffer, Strval (Interface_Name (E)));
837 -- All other cases besides the interface name case
840 -- If this is a library level subprogram (i.e. a subprogram that is a
841 -- compilation unit other than a subunit), then we prepend _ada_ to
842 -- ensure distinctions required as described in the spec.
844 -- Check explicitly for child units, because those are not flagged
845 -- as Compilation_Units by lib. Should they be ???
848 and then (Is_Compilation_Unit (E) or Is_Child_Unit (E))
849 and then not Has_Suffix
851 Add_Str_To_Name_Buffer ("_ada_");
854 -- If the entity is a subprogram instance that is not a compilation
855 -- unit, generate the name of the original Ada entity, which is the
858 if Is_Generic_Instance (E)
859 and then Is_Subprogram (E)
860 and then not Is_Compilation_Unit (Scope (E))
861 and then Ekind (Scope (E)) in E_Package | E_Package_Body
862 and then Present (Related_Instance (Scope (E)))
864 E := Related_Instance (Scope (E));
867 Get_Qualified_Name_And_Append (E);
871 Add_Str_To_Name_Buffer ("___");
872 Add_Str_To_Name_Buffer (Suffix);
875 -- Add a special prefix to distinguish Ghost entities. In Ignored Ghost
876 -- mode, these entities should not leak in the "living" space and they
877 -- should be removed by the compiler in a post-processing pass. Thus,
878 -- the prefix allows anyone to check that the final executable indeed
879 -- does not contain such entities, in such a case. Do not insert this
880 -- prefix for compilation units, whose name is used as a basis for the
881 -- name of the generated elaboration procedure and (when appropriate)
882 -- the executable produced. Only insert this prefix once, for Ghost
883 -- entities declared inside other Ghost entities. Three leading
884 -- underscores are used so that "___ghost_" is a unique substring of
885 -- names produced for Ghost entities, while "__ghost_" can appear in
886 -- names of entities inside a child/local package called "Ghost".
888 -- The compiler-generated finalizer for an enabled Ghost unit is treated
889 -- specially, as its name must be known to the binder, which has no
890 -- knowledge of Ghost status. In that case, the finalizer is not marked
891 -- as Ghost so that no prefix is added. Note that the special ___ghost_
892 -- prefix is retained when the Ghost unit is ignored, which still allows
893 -- inspecting the final executable for the presence of an ignored Ghost
894 -- finalizer procedure.
896 if Is_Ghost_Entity (E)
897 and then not Is_Compilation_Unit (E)
898 and then (Name_Len < 9
899 or else Name_Buffer (1 .. 9) /= "___ghost_")
901 Insert_Str_In_Name_Buffer ("___ghost_", 1);
904 Name_Buffer (Name_Len + 1) := ASCII.NUL;
905 end Get_External_Name;
907 --------------------------
908 -- Get_Variant_Encoding --
909 --------------------------
911 procedure Get_Variant_Encoding (V : Node_Id) is
914 procedure Choice_Val (Typ : Character; Choice : Node_Id);
915 -- Output encoded value for a single choice value. Typ is the key
916 -- character ('S', 'F', or 'T') that precedes the choice value.
922 procedure Choice_Val (Typ : Character; Choice : Node_Id) is
924 if Nkind (Choice) = N_Integer_Literal then
925 Add_Char_To_Name_Buffer (Typ);
926 Add_Uint_To_Buffer (Intval (Choice));
928 -- Character literal with no entity present (this is the case
929 -- Standard.Character or Standard.Wide_Character as root type)
931 elsif Nkind (Choice) = N_Character_Literal
932 and then No (Entity (Choice))
934 Add_Char_To_Name_Buffer (Typ);
935 Add_Uint_To_Buffer (Char_Literal_Value (Choice));
939 Ent : constant Entity_Id := Entity (Choice);
942 if Ekind (Ent) = E_Enumeration_Literal then
943 Add_Char_To_Name_Buffer (Typ);
944 Add_Uint_To_Buffer (Enumeration_Rep (Ent));
947 pragma Assert (Ekind (Ent) = E_Constant);
948 Choice_Val (Typ, Constant_Value (Ent));
954 -- Start of processing for Get_Variant_Encoding
959 Choice := First (Discrete_Choices (V));
960 while Present (Choice) loop
961 if Nkind (Choice) = N_Others_Choice then
962 Add_Char_To_Name_Buffer ('O');
964 elsif Nkind (Choice) = N_Range then
965 Choice_Val ('R', Low_Bound (Choice));
966 Choice_Val ('T', High_Bound (Choice));
968 elsif Is_Entity_Name (Choice)
969 and then Is_Type (Entity (Choice))
971 Choice_Val ('R', Type_Low_Bound (Entity (Choice)));
972 Choice_Val ('T', Type_High_Bound (Entity (Choice)));
974 elsif Nkind (Choice) = N_Subtype_Indication then
976 Rang : constant Node_Id :=
977 Range_Expression (Constraint (Choice));
979 Choice_Val ('R', Low_Bound (Rang));
980 Choice_Val ('T', High_Bound (Rang));
984 Choice_Val ('S', Choice);
990 Name_Buffer (Name_Len + 1) := ASCII.NUL;
994 VP : constant Node_Id := Parent (V); -- Variant_Part
995 CL : constant Node_Id := Parent (VP); -- Component_List
996 RD : constant Node_Id := Parent (CL); -- Record_Definition
997 FT : constant Node_Id := Parent (RD); -- Full_Type_Declaration
1000 Write_Str ("**** variant for type ");
1001 Write_Name (Chars (Defining_Identifier (FT)));
1002 Write_Str (" is encoded as ");
1003 Write_Str (Name_Buffer (1 .. Name_Len));
1007 end Get_Variant_Encoding;
1009 -----------------------------------------
1010 -- Build_Subprogram_Instance_Renamings --
1011 -----------------------------------------
1013 procedure Build_Subprogram_Instance_Renamings
1015 Wrapper : Entity_Id)
1022 E := First_Entity (Wrapper);
1023 while Present (E) loop
1024 if Nkind (Parent (E)) = N_Object_Declaration
1025 and then Is_Elementary_Type (Etype (E))
1027 Loc := Sloc (Expression (Parent (E)));
1028 Decl := Make_Object_Renaming_Declaration (Loc,
1029 Defining_Identifier =>
1030 Make_Defining_Identifier (Loc, Chars (E)),
1031 Subtype_Mark => New_Occurrence_Of (Etype (E), Loc),
1032 Name => New_Occurrence_Of (E, Loc));
1034 Append (Decl, Declarations (N));
1035 Set_Debug_Info_Needed (Defining_Identifier (Decl));
1040 end Build_Subprogram_Instance_Renamings;
1042 ------------------------------------
1043 -- Get_Secondary_DT_External_Name --
1044 ------------------------------------
1046 procedure Get_Secondary_DT_External_Name
1048 Ancestor_Typ : Entity_Id;
1052 Get_External_Name (Typ);
1054 if Ancestor_Typ /= Typ then
1056 Len : constant Natural := Name_Len;
1057 Save_Str : constant String (1 .. Name_Len)
1058 := Name_Buffer (1 .. Name_Len);
1060 Get_External_Name (Ancestor_Typ);
1062 -- Append the extended name of the ancestor to the
1063 -- extended name of Typ
1065 Name_Buffer (Len + 2 .. Len + Name_Len + 1) :=
1066 Name_Buffer (1 .. Name_Len);
1067 Name_Buffer (1 .. Len) := Save_Str;
1068 Name_Buffer (Len + 1) := '_';
1069 Name_Len := Len + Name_Len + 1;
1073 Add_Nat_To_Name_Buffer (Suffix_Index);
1074 end Get_Secondary_DT_External_Name;
1076 ---------------------------------
1077 -- Make_Packed_Array_Impl_Type_Name --
1078 ---------------------------------
1080 function Make_Packed_Array_Impl_Type_Name
1086 Get_Name_String (Chars (Typ));
1087 Add_Str_To_Name_Buffer ("___XP");
1088 Add_Uint_To_Buffer (Csize);
1090 end Make_Packed_Array_Impl_Type_Name;
1092 -----------------------------------
1093 -- Output_Homonym_Numbers_Suffix --
1094 -----------------------------------
1096 procedure Output_Homonym_Numbers_Suffix is
1100 if Homonym_Len > 0 then
1102 -- Check for all 1's, in which case we do not output
1106 exit when Homonym_Numbers (J) /= '1';
1108 -- If we reached end of string we do not output
1110 if J = Homonym_Len then
1115 exit when Homonym_Numbers (J + 1) /= '_';
1119 -- If we exit the loop then suffix must be output
1121 Add_Str_To_Name_Buffer ("__");
1122 Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len));
1125 end Output_Homonym_Numbers_Suffix;
1127 ------------------------------
1128 -- Prepend_String_To_Buffer --
1129 ------------------------------
1131 procedure Prepend_String_To_Buffer (S : String) is
1132 N : constant Integer := S'Length;
1134 Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len);
1135 Name_Buffer (1 .. N) := S;
1136 Name_Len := Name_Len + N;
1137 end Prepend_String_To_Buffer;
1139 ----------------------------
1140 -- Prepend_Uint_To_Buffer --
1141 ----------------------------
1143 procedure Prepend_Uint_To_Buffer (U : Uint) is
1146 Prepend_String_To_Buffer ("m");
1147 Prepend_Uint_To_Buffer (-U);
1149 UI_Image (U, Decimal);
1150 Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
1152 end Prepend_Uint_To_Buffer;
1154 ------------------------------
1155 -- Qualify_All_Entity_Names --
1156 ------------------------------
1158 procedure Qualify_All_Entity_Names is
1164 for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
1165 Nod := Name_Qualify_Units.Table (J);
1167 -- When a scoping construct is ignored Ghost, it is rewritten as
1168 -- a null statement. Skip such constructs as they no longer carry
1171 if Nkind (Nod) = N_Null_Statement then
1175 E := Defining_Entity (Nod);
1177 Qualify_Entity_Name (E);
1179 -- Normally entities in the qualification list are scopes, but in the
1180 -- case of a library-level package renaming there is an associated
1181 -- variable that encodes the debugger name and that variable is
1182 -- entered in the list since it occurs in the Aux_Decls list of the
1183 -- compilation and doesn't have a normal scope.
1185 if Ekind (E) /= E_Variable then
1186 Ent := First_Entity (E);
1187 while Present (Ent) loop
1189 Qualify_Entity_Name (Ent);
1192 -- There are odd cases where Last_Entity (E) = E. This happens
1193 -- in the case of renaming of packages. This test avoids
1194 -- getting stuck in such cases.
1203 end Qualify_All_Entity_Names;
1205 -------------------------
1206 -- Qualify_Entity_Name --
1207 -------------------------
1209 procedure Qualify_Entity_Name (Ent : Entity_Id) is
1211 Full_Qualify_Name : String (1 .. Name_Buffer'Length);
1212 Full_Qualify_Len : Natural := 0;
1213 -- Used to accumulate fully qualified name of subprogram
1215 procedure Fully_Qualify_Name (E : Entity_Id);
1216 -- Used to qualify a subprogram or type name, where full
1217 -- qualification up to Standard is always used. Name is set
1218 -- in Full_Qualify_Name with the length in Full_Qualify_Len.
1219 -- Note that this routine does not prepend the _ada_ string
1220 -- required for library subprograms (this is done in the back end).
1222 function Is_BNPE (S : Entity_Id) return Boolean;
1223 -- Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
1224 -- is defined to be a package which is immediately nested within a
1227 function Qualify_Needed (S : Entity_Id) return Boolean;
1228 -- Given a scope, determines if the scope is to be included in the
1229 -- fully qualified name, True if so, False if not. Blocks and loops
1230 -- are excluded from a qualified name.
1232 procedure Set_BNPE_Suffix (E : Entity_Id);
1233 -- Recursive routine to append the BNPE qualification suffix. Works
1234 -- from right to left with E being the current entity in the list.
1235 -- The result does NOT have the trailing n's and trailing b stripped.
1236 -- The caller must do this required stripping.
1238 procedure Set_Entity_Name (E : Entity_Id);
1239 -- Internal recursive routine that does most of the work. This routine
1240 -- leaves the result sitting in Name_Buffer and Name_Len.
1242 BNPE_Suffix_Needed : Boolean := False;
1243 -- Set true if a body-nested package entity suffix is required
1245 Save_Chars : constant Name_Id := Chars (Ent);
1246 -- Save original name
1248 ------------------------
1249 -- Fully_Qualify_Name --
1250 ------------------------
1252 procedure Fully_Qualify_Name (E : Entity_Id) is
1253 Discard : Boolean := False;
1256 -- Ignore empty entry (can happen in error cases)
1261 -- If this we are qualifying entities local to a generic instance,
1262 -- use the name of the original instantiation, not that of the
1263 -- anonymous subprogram in the wrapper package, so that gdb doesn't
1264 -- have to know about these.
1266 elsif Is_Generic_Instance (E)
1267 and then Is_Subprogram (E)
1268 and then not Comes_From_Source (E)
1269 and then not Is_Compilation_Unit (Scope (E))
1271 Fully_Qualify_Name (Related_Instance (Scope (E)));
1275 -- If we reached fully qualified name, then just copy it
1277 if Has_Fully_Qualified_Name (E) then
1278 Get_Name_String (Chars (E));
1279 Strip_Suffixes (Discard);
1280 Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1281 Full_Qualify_Len := Name_Len;
1282 Set_Has_Fully_Qualified_Name (Ent);
1284 -- Case of non-fully qualified name
1287 if Scope (E) = Standard_Standard then
1288 Set_Has_Fully_Qualified_Name (Ent);
1290 Fully_Qualify_Name (Scope (E));
1291 Full_Qualify_Name (Full_Qualify_Len + 1) := '_';
1292 Full_Qualify_Name (Full_Qualify_Len + 2) := '_';
1293 Full_Qualify_Len := Full_Qualify_Len + 2;
1296 if Has_Qualified_Name (E) then
1297 Get_Unqualified_Name_String (Chars (E));
1299 Get_Name_String (Chars (E));
1302 -- Here we do one step of the qualification
1305 (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) :=
1306 Name_Buffer (1 .. Name_Len);
1307 Full_Qualify_Len := Full_Qualify_Len + Name_Len;
1308 Append_Homonym_Number (E);
1312 BNPE_Suffix_Needed := True;
1314 end Fully_Qualify_Name;
1320 function Is_BNPE (S : Entity_Id) return Boolean is
1322 return Ekind (S) = E_Package and then Is_Package_Body_Entity (S);
1325 --------------------
1326 -- Qualify_Needed --
1327 --------------------
1329 function Qualify_Needed (S : Entity_Id) return Boolean is
1331 -- If we got all the way to Standard, then we have certainly
1332 -- fully qualified the name, so set the flag appropriately,
1333 -- and then return False, since we are most certainly done.
1335 if S = Standard_Standard then
1336 Set_Has_Fully_Qualified_Name (Ent, True);
1339 -- Otherwise figure out if further qualification is required
1342 return Is_Subprogram (Ent)
1343 or else Ekind (Ent) = E_Subprogram_Body
1344 or else (Ekind (S) /= E_Block
1345 and then Ekind (S) /= E_Loop
1346 and then not Is_Dynamic_Scope (S));
1350 ---------------------
1351 -- Set_BNPE_Suffix --
1352 ---------------------
1354 procedure Set_BNPE_Suffix (E : Entity_Id) is
1355 S : constant Entity_Id := Scope (E);
1358 if Qualify_Needed (S) then
1359 Set_BNPE_Suffix (S);
1362 Add_Char_To_Name_Buffer ('b');
1364 Add_Char_To_Name_Buffer ('n');
1368 Add_Char_To_Name_Buffer ('X');
1370 end Set_BNPE_Suffix;
1372 ---------------------
1373 -- Set_Entity_Name --
1374 ---------------------
1376 procedure Set_Entity_Name (E : Entity_Id) is
1377 S : constant Entity_Id := Scope (E);
1380 -- If we reach an already qualified name, just take the encoding
1381 -- except that we strip the package body suffixes, since these
1382 -- will be separately put on later.
1384 if Has_Qualified_Name (E) then
1385 Get_Name_String_And_Append (Chars (E));
1386 Strip_Suffixes (BNPE_Suffix_Needed);
1388 -- If the top level name we are adding is itself fully
1389 -- qualified, then that means that the name that we are
1390 -- preparing for the Fully_Qualify_Name call will also
1391 -- generate a fully qualified name.
1393 if Has_Fully_Qualified_Name (E) then
1394 Set_Has_Fully_Qualified_Name (Ent);
1397 -- Case where upper level name is not encoded yet
1400 -- Recurse if further qualification required
1402 if Qualify_Needed (S) then
1403 Set_Entity_Name (S);
1404 Add_Str_To_Name_Buffer ("__");
1407 -- Otherwise get name and note if it is a BNPE
1409 Get_Name_String_And_Append (Chars (E));
1412 BNPE_Suffix_Needed := True;
1415 Append_Homonym_Number (E);
1417 end Set_Entity_Name;
1419 -- Start of processing for Qualify_Entity_Name
1422 if Has_Qualified_Name (Ent) then
1425 -- If the entity is a variable encoding the debug name for an object
1426 -- renaming, then the qualified name of the entity associated with the
1427 -- renamed object can now be incorporated in the debug name.
1429 elsif Ekind (Ent) = E_Variable
1430 and then Present (Debug_Renaming_Link (Ent))
1433 Qualify_Entity_Name (Debug_Renaming_Link (Ent));
1434 Get_Name_String (Chars (Ent));
1436 -- Retrieve the now-qualified name of the renamed entity and insert
1437 -- it in the middle of the name, just preceding the suffix encoding
1438 -- describing the renamed object.
1441 Renamed_Id : constant String :=
1442 Get_Name_String (Chars (Debug_Renaming_Link (Ent)));
1443 Insert_Len : constant Integer := Renamed_Id'Length + 1;
1444 Index : Natural := Name_Len - 3;
1447 -- Loop backwards through the name to find the start of the "___"
1448 -- sequence associated with the suffix.
1450 while Index >= Name_Buffer'First
1451 and then (Name_Buffer (Index + 1) /= '_'
1452 or else Name_Buffer (Index + 2) /= '_'
1453 or else Name_Buffer (Index + 3) /= '_')
1458 pragma Assert (Name_Buffer (Index + 1 .. Index + 3) = "___");
1460 -- Insert an underscore separator and the entity name just in
1461 -- front of the suffix.
1463 Name_Buffer (Index + 1 + Insert_Len .. Name_Len + Insert_Len) :=
1464 Name_Buffer (Index + 1 .. Name_Len);
1465 Name_Buffer (Index + 1) := '_';
1466 Name_Buffer (Index + 2 .. Index + Insert_Len) := Renamed_Id;
1467 Name_Len := Name_Len + Insert_Len;
1470 -- Reset the name of the variable to the new name that includes the
1471 -- name of the renamed entity.
1473 Set_Chars (Ent, Name_Enter);
1475 -- If the entity needs qualification by its scope then develop it
1476 -- here, add the variable's name, and again reset the entity name.
1478 if Qualify_Needed (Scope (Ent)) then
1480 Set_Entity_Name (Scope (Ent));
1481 Add_Str_To_Name_Buffer ("__");
1483 Get_Name_String_And_Append (Chars (Ent));
1485 Set_Chars (Ent, Name_Enter);
1488 Set_Has_Qualified_Name (Ent);
1491 elsif Is_Subprogram (Ent)
1492 or else Ekind (Ent) = E_Subprogram_Body
1493 or else Is_Type (Ent)
1494 or else Ekind (Ent) = E_Exception
1496 Fully_Qualify_Name (Ent);
1497 Name_Len := Full_Qualify_Len;
1498 Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
1500 -- Qualification needed for enumeration literals when generating C code
1501 -- (to simplify their management in the backend).
1503 elsif Modify_Tree_For_C
1504 and then Ekind (Ent) = E_Enumeration_Literal
1505 and then Scope (Ultimate_Alias (Ent)) /= Standard_Standard
1507 Fully_Qualify_Name (Ent);
1508 Name_Len := Full_Qualify_Len;
1509 Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
1511 elsif Qualify_Needed (Scope (Ent)) then
1513 Set_Entity_Name (Ent);
1516 Set_Has_Qualified_Name (Ent);
1518 -- If a variable is hidden by a subsequent loop variable, qualify
1519 -- the name of that loop variable to prevent visibility issues when
1520 -- translating to C. Note that gdb probably never handled properly
1521 -- this accidental hiding, given that loops are not scopes at
1522 -- runtime. We also qualify a name if it hides an outer homonym,
1523 -- and both are declared in blocks.
1525 if Modify_Tree_For_C and then Ekind (Ent) = E_Variable then
1526 if Present (Hiding_Loop_Variable (Ent)) then
1528 Var : constant Entity_Id := Hiding_Loop_Variable (Ent);
1531 Set_Entity_Name (Var);
1532 Add_Str_To_Name_Buffer ("L");
1533 Set_Chars (Var, Name_Enter);
1536 elsif Present (Homonym (Ent))
1537 and then Ekind (Scope (Ent)) = E_Block
1538 and then Ekind (Scope (Homonym (Ent))) = E_Block
1540 Set_Entity_Name (Ent);
1541 Add_Str_To_Name_Buffer ("B");
1542 Set_Chars (Ent, Name_Enter);
1549 -- Fall through with a fully qualified name in Name_Buffer/Name_Len
1551 Output_Homonym_Numbers_Suffix;
1553 -- Add body-nested package suffix if required
1555 if BNPE_Suffix_Needed
1556 and then Ekind (Ent) /= E_Enumeration_Literal
1558 Set_BNPE_Suffix (Ent);
1560 -- Strip trailing n's and last trailing b as required. note that
1561 -- we know there is at least one b, or no suffix would be generated.
1563 while Name_Buffer (Name_Len) = 'n' loop
1564 Name_Len := Name_Len - 1;
1567 Name_Len := Name_Len - 1;
1570 Set_Chars (Ent, Name_Enter);
1571 Set_Has_Qualified_Name (Ent);
1573 if Debug_Flag_BB then
1575 Write_Name (Save_Chars);
1576 Write_Str (" qualified as ");
1577 Write_Name (Chars (Ent));
1580 end Qualify_Entity_Name;
1582 --------------------------
1583 -- Qualify_Entity_Names --
1584 --------------------------
1586 procedure Qualify_Entity_Names (N : Node_Id) is
1588 Name_Qualify_Units.Append (N);
1589 end Qualify_Entity_Names;
1595 procedure Reset_Buffers is
1601 --------------------
1602 -- Strip_Suffixes --
1603 --------------------
1605 procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is
1608 pragma Warnings (Off, BNPE_Suffix_Found);
1609 -- Since this procedure only ever sets the flag
1612 -- Search for and strip BNPE suffix
1614 for J in reverse 2 .. Name_Len loop
1615 if Name_Buffer (J) = 'X' then
1617 BNPE_Suffix_Found := True;
1621 exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n';
1624 -- Search for and strip homonym numbers suffix
1626 for J in reverse 2 .. Name_Len - 2 loop
1627 if Name_Buffer (J) = '_'
1628 and then Name_Buffer (J + 1) = '_'
1630 if Name_Buffer (J + 2) in '0' .. '9' then
1631 if Homonym_Len > 0 then
1632 Homonym_Len := Homonym_Len + 1;
1633 Homonym_Numbers (Homonym_Len) := '-';
1636 SL := Name_Len - (J + 1);
1638 Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) :=
1639 Name_Buffer (J + 2 .. Name_Len);
1641 Homonym_Len := Homonym_Len + SL;