1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2016, 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_Aux
; use Sem_Aux
;
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 Tbuild
; use Tbuild
;
42 with Urealp
; use Urealp
;
44 package body Exp_Dbug
is
46 -- The following table is used to queue up the entities passed as
47 -- arguments to Qualify_Entity_Names for later processing when
48 -- Qualify_All_Entity_Names is called.
50 package Name_Qualify_Units
is new Table
.Table
(
51 Table_Component_Type
=> Node_Id
,
52 Table_Index_Type
=> Nat
,
54 Table_Initial
=> Alloc
.Name_Qualify_Units_Initial
,
55 Table_Increment
=> Alloc
.Name_Qualify_Units_Increment
,
56 Table_Name
=> "Name_Qualify_Units");
58 --------------------------------
59 -- Use of Qualification Flags --
60 --------------------------------
62 -- There are two flags used to keep track of qualification of entities
64 -- Has_Fully_Qualified_Name
67 -- The difference between these is as follows. Has_Qualified_Name is
68 -- set to indicate that the name has been qualified as required by the
69 -- spec of this package. As described there, this may involve the full
70 -- qualification for the name, but for some entities, notably procedure
71 -- local variables, this full qualification is not required.
73 -- The flag Has_Fully_Qualified_Name is set if indeed the name has been
74 -- fully qualified in the Ada sense. If Has_Fully_Qualified_Name is set,
75 -- then Has_Qualified_Name is also set, but the other way round is not
78 -- Consider the following example:
85 -- Here B is a procedure local variable, so it does not need fully
86 -- qualification. The flag Has_Qualified_Name will be set on the
87 -- first attempt to qualify B, to indicate that the job is done
88 -- and need not be redone.
90 -- But Y is qualified as x__y, since procedures are always fully
91 -- qualified, so the first time that an attempt is made to qualify
92 -- the name y, it will be replaced by x__y, and both flags are set.
94 -- Why the two flags? Well there are cases where we derive type names
95 -- from object names. As noted in the spec, type names are always
96 -- fully qualified. Suppose for example that the backend has to build
97 -- a padded type for variable B. then it will construct the PAD name
98 -- from B, but it requires full qualification, so the fully qualified
99 -- type name will be x__b___PAD. The two flags allow the circuit for
100 -- building this name to realize efficiently that b needs further
107 -- The string defined here (and its associated length) is used to gather
108 -- the homonym string that will be appended to Name_Buffer when the name
109 -- is complete. Strip_Suffixes appends to this string as does
110 -- Append_Homonym_Number, and Output_Homonym_Numbers_Suffix appends the
111 -- string to the end of Name_Buffer.
113 Homonym_Numbers
: String (1 .. 256);
114 Homonym_Len
: Natural := 0;
116 ----------------------
117 -- Local Procedures --
118 ----------------------
120 procedure Add_Uint_To_Buffer
(U
: Uint
);
121 -- Add image of universal integer to Name_Buffer, updating Name_Len
123 procedure Add_Real_To_Buffer
(U
: Ureal
);
124 -- Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of
125 -- the normalized numerator and denominator of the given real value.
127 procedure Append_Homonym_Number
(E
: Entity_Id
);
128 -- If the entity E has homonyms in the same scope, then make an entry
129 -- in the Homonym_Numbers array, bumping Homonym_Count accordingly.
131 function Bounds_Match_Size
(E
: Entity_Id
) return Boolean;
132 -- Determine whether the bounds of E match the size of the type. This is
133 -- used to determine whether encoding is required for a discrete type.
135 function Is_Handled_Scale_Factor
(U
: Ureal
) return Boolean;
136 -- The argument U is the Small_Value of a fixed-point type. This function
137 -- determines whether the back-end can handle this scale factor. When it
138 -- cannot, we have to output a GNAT encoding for the corresponding 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
223 H
: Entity_Id
:= Homonym
(E
);
227 while Present
(H
) loop
228 if Scope
(H
) = Scope
(E
) then
235 if Homonym_Len
> 0 then
236 Homonym_Len
:= Homonym_Len
+ 1;
237 Homonym_Numbers
(Homonym_Len
) := '_';
243 end Append_Homonym_Number
;
245 -----------------------
246 -- Bounds_Match_Size --
247 -----------------------
249 function Bounds_Match_Size
(E
: Entity_Id
) return Boolean is
253 if not Is_OK_Static_Subtype
(E
) then
256 elsif Is_Integer_Type
(E
)
257 and then Subtypes_Statically_Match
(E
, Base_Type
(E
))
261 -- Here we check if the static bounds match the natural size, which is
262 -- the size passed through with the debugging information. This is the
263 -- Esize rounded up to 8, 16, 32 or 64 as appropriate.
267 Umark
: constant Uintp
.Save_Mark
:= Uintp
.Mark
;
271 if Esize
(E
) <= 8 then
273 elsif Esize
(E
) <= 16 then
275 elsif Esize
(E
) <= 32 then
281 if Is_Modular_Integer_Type
(E
) or else Is_Enumeration_Type
(E
) then
283 Expr_Rep_Value
(Type_Low_Bound
(E
)) = 0
285 2 ** Siz
- Expr_Rep_Value
(Type_High_Bound
(E
)) = 1;
289 Expr_Rep_Value
(Type_Low_Bound
(E
)) + 2 ** (Siz
- 1) = 0
291 2 ** (Siz
- 1) - Expr_Rep_Value
(Type_High_Bound
(E
)) = 1;
298 end Bounds_Match_Size
;
300 --------------------------------
301 -- Debug_Renaming_Declaration --
302 --------------------------------
304 function Debug_Renaming_Declaration
(N
: Node_Id
) return Node_Id
is
305 Loc
: constant Source_Ptr
:= Sloc
(N
);
306 Ent
: constant Node_Id
:= Defining_Entity
(N
);
307 Nam
: constant Node_Id
:= Name
(N
);
313 Enable
: Boolean := Nkind
(N
) = N_Package_Renaming_Declaration
;
314 -- By default, we do not generate an encoding for renaming. This is
315 -- however done (in which case this is set to True) in a few cases:
316 -- - when a package is renamed,
317 -- - when the renaming involves a packed array,
318 -- - when the renaming involves a packed record.
320 procedure Enable_If_Packed_Array
(N
: Node_Id
);
321 -- Enable encoding generation if N is a packed array
323 function Output_Subscript
(N
: Node_Id
; S
: String) return Boolean;
324 -- Outputs a single subscript value as ?nnn (subscript is compile time
325 -- known value with value nnn) or as ?e (subscript is local constant
326 -- with name e), where S supplies the proper string to use for ?.
327 -- Returns False if the subscript is not of an appropriate type to
328 -- output in one of these two forms. The result is prepended to the
329 -- name stored in Name_Buffer.
331 ----------------------------
332 -- Enable_If_Packed_Array --
333 ----------------------------
335 procedure Enable_If_Packed_Array
(N
: Node_Id
) is
336 T
: constant Entity_Id
:= Etype
(N
);
339 Enable
or else (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
(Entity
(N
)) = Scope
(Ent
)
354 and then Ekind
(Entity
(N
)) = E_Constant
356 Prepend_String_To_Buffer
(Get_Name_String
(Chars
(Entity
(N
))));
362 Prepend_String_To_Buffer
(S
);
364 end Output_Subscript
;
366 -- Start of processing for Debug_Renaming_Declaration
369 if not Comes_From_Source
(N
)
370 and then not Needs_Debug_Info
(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 Enable
:= Enable
or else Is_Packed
(Etype
(Prefix
(Ren
)));
394 Prepend_String_To_Buffer
395 (Get_Name_String
(Chars
(Selector_Name
(Ren
))));
396 Prepend_String_To_Buffer
("XR");
399 when N_Indexed_Component
=>
404 Enable_If_Packed_Array
(Prefix
(Ren
));
406 X
:= Last
(Expressions
(Ren
));
407 while Present
(X
) loop
408 if not Output_Subscript
(X
, "XS") then
409 Set_Materialize_Entity
(Ent
);
420 Enable_If_Packed_Array
(Prefix
(Ren
));
421 Typ
:= Etype
(First_Index
(Etype
(Nam
)));
423 if not Output_Subscript
(Type_High_Bound
(Typ
), "XS") then
424 Set_Materialize_Entity
(Ent
);
428 if not Output_Subscript
(Type_Low_Bound
(Typ
), "XL") then
429 Set_Materialize_Entity
(Ent
);
435 when N_Explicit_Dereference
=>
436 Prepend_String_To_Buffer
("XA");
439 -- For now, anything else simply results in no translation
442 Set_Materialize_Entity
(Ent
);
447 -- If we found no reason here to emit an encoding, stop now
450 Set_Materialize_Entity
(Ent
);
454 Prepend_String_To_Buffer
("___XE");
456 -- Include the designation of the form of renaming
459 when N_Object_Renaming_Declaration
=>
460 Prepend_String_To_Buffer
("___XR");
462 when N_Exception_Renaming_Declaration
=>
463 Prepend_String_To_Buffer
("___XRE");
465 when N_Package_Renaming_Declaration
=>
466 Prepend_String_To_Buffer
("___XRP");
472 -- Add the name of the renaming entity to the front
474 Prepend_String_To_Buffer
(Get_Name_String
(Chars
(Ent
)));
476 -- If it is a child unit create a fully qualified name, to disambiguate
477 -- multiple child units with the same name and different parents.
479 if Nkind
(N
) = N_Package_Renaming_Declaration
480 and then Is_Child_Unit
(Ent
)
482 Prepend_String_To_Buffer
("__");
483 Prepend_String_To_Buffer
484 (Get_Name_String
(Chars
(Scope
(Ent
))));
487 -- Create the special object whose name is the debug encoding for the
488 -- renaming declaration.
490 -- For now, the object name contains the suffix encoding for the renamed
491 -- object, but not the name of the leading entity. The object is linked
492 -- the renamed entity using the Debug_Renaming_Link field. Then the
493 -- Qualify_Entity_Name procedure uses this link to create the proper
494 -- fully qualified name.
496 -- The reason we do things this way is that we really need to copy the
497 -- qualification of the renamed entity, and it is really much easier to
498 -- do this after the renamed entity has itself been fully qualified.
500 Obj
:= Make_Defining_Identifier
(Loc
, Chars
=> Name_Enter
);
502 Make_Object_Declaration
(Loc
,
503 Defining_Identifier
=> Obj
,
504 Object_Definition
=> New_Occurrence_Of
505 (Standard_Debug_Renaming_Type
, Loc
));
507 Set_Debug_Renaming_Link
(Obj
, Entity
(Ren
));
509 Set_Debug_Info_Needed
(Obj
);
511 -- The renamed entity may be a temporary, e.g. the result of an
512 -- implicit dereference in an iterator. Indicate that the temporary
513 -- itself requires debug information. If the renamed entity comes
514 -- from source this is a no-op.
516 Set_Debug_Info_Needed
(Entity
(Ren
));
518 -- Mark the object as internal so that it won't be initialized when
519 -- pragma Initialize_Scalars or Normalize_Scalars is in use.
521 Set_Is_Internal
(Obj
);
525 -- If we get an exception, just figure it is a case that we cannot
526 -- successfully handle using our current approach, since this is
527 -- only for debugging, no need to take the compilation with us.
531 return Make_Null_Statement
(Loc
);
532 end Debug_Renaming_Declaration
;
534 -----------------------------
535 -- Is_Handled_Scale_Factor --
536 -----------------------------
538 function Is_Handled_Scale_Factor
(U
: Ureal
) return Boolean is
540 -- Keep in sync with gigi (see E_*_Fixed_Point_Type handling in
541 -- decl.c:gnat_to_gnu_entity).
543 if UI_Eq
(Numerator
(U
), Uint_1
) then
544 if Rbase
(U
) = 2 or else Rbase
(U
) = 10 then
550 (UI_Is_In_Int_Range
(Norm_Num
(U
))
552 UI_Is_In_Int_Range
(Norm_Den
(U
)));
553 end Is_Handled_Scale_Factor
;
555 ----------------------
556 -- Get_Encoded_Name --
557 ----------------------
559 -- Note: see spec for details on encodings
561 procedure Get_Encoded_Name
(E
: Entity_Id
) is
562 Has_Suffix
: Boolean;
565 -- If not generating code, there is no need to create encoded names, and
566 -- problems when the back-end is called to annotate types without full
567 -- code generation. See comments in Get_External_Name for additional
570 -- However we do create encoded names if the back end is active, even
571 -- if Operating_Mode got reset. Otherwise any serious error reported
572 -- by the backend calling Error_Msg changes the Compilation_Mode to
573 -- Check_Semantics, which disables the functionality of this routine,
574 -- causing the generation of spurious additional errors.
576 -- Couldn't we just test Original_Operating_Mode here? ???
578 if Operating_Mode
/= Generate_Code
and then not Generating_Code
then
582 Get_Name_String
(Chars
(E
));
584 -- Nothing to do if we do not have a type
588 -- Or if this is an enumeration base type
590 or else (Is_Enumeration_Type
(E
) and then Is_Base_Type
(E
))
592 -- Or if this is a dummy type for a renaming
594 or else (Name_Len
>= 3 and then
595 Name_Buffer
(Name_Len
- 2 .. Name_Len
) = "_XR")
597 or else (Name_Len
>= 4 and then
598 (Name_Buffer
(Name_Len
- 3 .. Name_Len
) = "_XRE"
600 Name_Buffer
(Name_Len
- 3 .. Name_Len
) = "_XRP"))
602 -- For all these cases, just return the name unchanged
605 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
611 -- Fixed-point case: generate GNAT encodings when asked to or when we
612 -- know the back-end will not be able to handle the scale factor.
614 if Is_Fixed_Point_Type
(E
)
615 and then (GNAT_Encodings
/= DWARF_GNAT_Encodings_Minimal
616 or else not Is_Handled_Scale_Factor
(Small_Value
(E
)))
618 Get_External_Name
(E
, True, "XF_");
619 Add_Real_To_Buffer
(Delta_Value
(E
));
621 if Small_Value
(E
) /= Delta_Value
(E
) then
622 Add_Str_To_Name_Buffer
("_");
623 Add_Real_To_Buffer
(Small_Value
(E
));
626 -- Discrete case where bounds do not match size. Not necessary if we can
627 -- emit standard DWARF.
629 elsif GNAT_Encodings
/= DWARF_GNAT_Encodings_Minimal
630 and then Is_Discrete_Type
(E
)
631 and then not Bounds_Match_Size
(E
)
634 Lo
: constant Node_Id
:= Type_Low_Bound
(E
);
635 Hi
: constant Node_Id
:= Type_High_Bound
(E
);
637 Lo_Con
: constant Boolean := Compile_Time_Known_Value
(Lo
);
638 Hi_Con
: constant Boolean := Compile_Time_Known_Value
(Hi
);
640 Lo_Discr
: constant Boolean :=
641 Nkind
(Lo
) = N_Identifier
642 and then Ekind
(Entity
(Lo
)) = E_Discriminant
;
644 Hi_Discr
: constant Boolean :=
645 Nkind
(Hi
) = N_Identifier
646 and then Ekind
(Entity
(Hi
)) = E_Discriminant
;
648 Lo_Encode
: constant Boolean := Lo_Con
or Lo_Discr
;
649 Hi_Encode
: constant Boolean := Hi_Con
or Hi_Discr
;
651 Biased
: constant Boolean := Has_Biased_Representation
(E
);
655 Get_External_Name
(E
, True, "XB");
657 Get_External_Name
(E
, True, "XD");
660 if Lo_Encode
or Hi_Encode
then
662 Add_Str_To_Name_Buffer
("_");
666 Add_Str_To_Name_Buffer
("LU_");
668 Add_Str_To_Name_Buffer
("L_");
671 Add_Str_To_Name_Buffer
("U_");
676 Add_Uint_To_Buffer
(Expr_Rep_Value
(Lo
));
678 Get_Name_String_And_Append
(Chars
(Entity
(Lo
)));
681 if Lo_Encode
and Hi_Encode
then
682 Add_Str_To_Name_Buffer
("__");
686 Add_Uint_To_Buffer
(Expr_Rep_Value
(Hi
));
688 Get_Name_String_And_Append
(Chars
(Entity
(Hi
)));
693 -- For all other cases, the encoded name is the normal type name
697 Get_External_Name
(E
);
700 if Debug_Flag_B
and then Has_Suffix
then
701 Write_Str
("**** type ");
702 Write_Name
(Chars
(E
));
703 Write_Str
(" is encoded as ");
704 Write_Str
(Name_Buffer
(1 .. Name_Len
));
708 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
709 end Get_Encoded_Name
;
711 -----------------------
712 -- Get_External_Name --
713 -----------------------
715 procedure Get_External_Name
717 Has_Suffix
: Boolean := False;
718 Suffix
: String := "")
720 procedure Get_Qualified_Name_And_Append
(Entity
: Entity_Id
);
721 -- Appends fully qualified name of given entity to Name_Buffer
723 -----------------------------------
724 -- Get_Qualified_Name_And_Append --
725 -----------------------------------
727 procedure Get_Qualified_Name_And_Append
(Entity
: Entity_Id
) is
729 -- If the entity is a compilation unit, its scope is Standard,
730 -- there is no outer scope, and the no further qualification
733 -- If the front end has already computed a fully qualified name,
734 -- then it is also the case that no further qualification is
737 if Present
(Scope
(Scope
(Entity
)))
738 and then not Has_Fully_Qualified_Name
(Entity
)
740 Get_Qualified_Name_And_Append
(Scope
(Entity
));
741 Add_Str_To_Name_Buffer
("__");
742 Get_Name_String_And_Append
(Chars
(Entity
));
743 Append_Homonym_Number
(Entity
);
746 Get_Name_String_And_Append
(Chars
(Entity
));
748 end Get_Qualified_Name_And_Append
;
752 E
: Entity_Id
:= Entity
;
754 -- Start of processing for Get_External_Name
757 -- If we are not in code generation mode, this procedure may still be
758 -- called from Back_End (more specifically - from gigi for doing type
759 -- representation annotation or some representation-specific checks).
760 -- But in this mode there is no need to mess with external names.
762 -- Furthermore, the call causes difficulties in this case because the
763 -- string representing the homonym number is not correctly reset as a
764 -- part of the call to Output_Homonym_Numbers_Suffix (which is not
767 if Operating_Mode
/= Generate_Code
then
773 -- If this is a child unit, we want the child
775 if Nkind
(E
) = N_Defining_Program_Unit_Name
then
776 E
:= Defining_Identifier
(Entity
);
779 -- Case of interface name being used
781 if Ekind_In
(E
, E_Constant
,
786 and then Present
(Interface_Name
(E
))
787 and then No
(Address_Clause
(E
))
788 and then not Has_Suffix
790 Add_String_To_Name_Buffer
(Strval
(Interface_Name
(E
)));
792 -- All other cases besides the interface name case
795 -- If this is a library level subprogram (i.e. a subprogram that is a
796 -- compilation unit other than a subunit), then we prepend _ada_ to
797 -- ensure distinctions required as described in the spec.
799 -- Check explicitly for child units, because those are not flagged
800 -- as Compilation_Units by lib. Should they be ???
803 and then (Is_Compilation_Unit
(E
) or Is_Child_Unit
(E
))
804 and then not Has_Suffix
806 Add_Str_To_Name_Buffer
("_ada_");
809 -- If the entity is a subprogram instance that is not a compilation
810 -- unit, generate the name of the original Ada entity, which is the
813 if Is_Generic_Instance
(E
)
814 and then Is_Subprogram
(E
)
815 and then not Is_Compilation_Unit
(Scope
(E
))
816 and then Ekind_In
(Scope
(E
), E_Package
, E_Package_Body
)
817 and then Present
(Related_Instance
(Scope
(E
)))
819 E
:= Related_Instance
(Scope
(E
));
822 Get_Qualified_Name_And_Append
(E
);
826 Add_Str_To_Name_Buffer
("___");
827 Add_Str_To_Name_Buffer
(Suffix
);
830 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
831 end Get_External_Name
;
833 --------------------------
834 -- Get_Variant_Encoding --
835 --------------------------
837 procedure Get_Variant_Encoding
(V
: Node_Id
) is
840 procedure Choice_Val
(Typ
: Character; Choice
: Node_Id
);
841 -- Output encoded value for a single choice value. Typ is the key
842 -- character ('S', 'F', or 'T') that precedes the choice value.
848 procedure Choice_Val
(Typ
: Character; Choice
: Node_Id
) is
850 if Nkind
(Choice
) = N_Integer_Literal
then
851 Add_Char_To_Name_Buffer
(Typ
);
852 Add_Uint_To_Buffer
(Intval
(Choice
));
854 -- Character literal with no entity present (this is the case
855 -- Standard.Character or Standard.Wide_Character as root type)
857 elsif Nkind
(Choice
) = N_Character_Literal
858 and then No
(Entity
(Choice
))
860 Add_Char_To_Name_Buffer
(Typ
);
861 Add_Uint_To_Buffer
(Char_Literal_Value
(Choice
));
865 Ent
: constant Entity_Id
:= Entity
(Choice
);
868 if Ekind
(Ent
) = E_Enumeration_Literal
then
869 Add_Char_To_Name_Buffer
(Typ
);
870 Add_Uint_To_Buffer
(Enumeration_Rep
(Ent
));
873 pragma Assert
(Ekind
(Ent
) = E_Constant
);
874 Choice_Val
(Typ
, Constant_Value
(Ent
));
880 -- Start of processing for Get_Variant_Encoding
885 Choice
:= First
(Discrete_Choices
(V
));
886 while Present
(Choice
) loop
887 if Nkind
(Choice
) = N_Others_Choice
then
888 Add_Char_To_Name_Buffer
('O');
890 elsif Nkind
(Choice
) = N_Range
then
891 Choice_Val
('R', Low_Bound
(Choice
));
892 Choice_Val
('T', High_Bound
(Choice
));
894 elsif Is_Entity_Name
(Choice
)
895 and then Is_Type
(Entity
(Choice
))
897 Choice_Val
('R', Type_Low_Bound
(Entity
(Choice
)));
898 Choice_Val
('T', Type_High_Bound
(Entity
(Choice
)));
900 elsif Nkind
(Choice
) = N_Subtype_Indication
then
902 Rang
: constant Node_Id
:=
903 Range_Expression
(Constraint
(Choice
));
905 Choice_Val
('R', Low_Bound
(Rang
));
906 Choice_Val
('T', High_Bound
(Rang
));
910 Choice_Val
('S', Choice
);
916 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
920 VP
: constant Node_Id
:= Parent
(V
); -- Variant_Part
921 CL
: constant Node_Id
:= Parent
(VP
); -- Component_List
922 RD
: constant Node_Id
:= Parent
(CL
); -- Record_Definition
923 FT
: constant Node_Id
:= Parent
(RD
); -- Full_Type_Declaration
926 Write_Str
("**** variant for type ");
927 Write_Name
(Chars
(Defining_Identifier
(FT
)));
928 Write_Str
(" is encoded as ");
929 Write_Str
(Name_Buffer
(1 .. Name_Len
));
933 end Get_Variant_Encoding
;
935 -----------------------------------------
936 -- Build_Subprogram_Instance_Renamings --
937 -----------------------------------------
939 procedure Build_Subprogram_Instance_Renamings
948 E
:= First_Entity
(Wrapper
);
949 while Present
(E
) loop
950 if Nkind
(Parent
(E
)) = N_Object_Declaration
951 and then Is_Elementary_Type
(Etype
(E
))
953 Loc
:= Sloc
(Expression
(Parent
(E
)));
954 Decl
:= Make_Object_Renaming_Declaration
(Loc
,
955 Defining_Identifier
=>
956 Make_Defining_Identifier
(Loc
, Chars
(E
)),
957 Subtype_Mark
=> New_Occurrence_Of
(Etype
(E
), Loc
),
958 Name
=> New_Occurrence_Of
(E
, Loc
));
960 Append
(Decl
, Declarations
(N
));
961 Set_Needs_Debug_Info
(Defining_Identifier
(Decl
));
966 end Build_Subprogram_Instance_Renamings
;
968 ------------------------------------
969 -- Get_Secondary_DT_External_Name --
970 ------------------------------------
972 procedure Get_Secondary_DT_External_Name
974 Ancestor_Typ
: Entity_Id
;
978 Get_External_Name
(Typ
);
980 if Ancestor_Typ
/= Typ
then
982 Len
: constant Natural := Name_Len
;
983 Save_Str
: constant String (1 .. Name_Len
)
984 := Name_Buffer
(1 .. Name_Len
);
986 Get_External_Name
(Ancestor_Typ
);
988 -- Append the extended name of the ancestor to the
989 -- extended name of Typ
991 Name_Buffer
(Len
+ 2 .. Len
+ Name_Len
+ 1) :=
992 Name_Buffer
(1 .. Name_Len
);
993 Name_Buffer
(1 .. Len
) := Save_Str
;
994 Name_Buffer
(Len
+ 1) := '_';
995 Name_Len
:= Len
+ Name_Len
+ 1;
999 Add_Nat_To_Name_Buffer
(Suffix_Index
);
1000 end Get_Secondary_DT_External_Name
;
1002 ---------------------------------
1003 -- Make_Packed_Array_Impl_Type_Name --
1004 ---------------------------------
1006 function Make_Packed_Array_Impl_Type_Name
1012 Get_Name_String
(Chars
(Typ
));
1013 Add_Str_To_Name_Buffer
("___XP");
1014 Add_Uint_To_Buffer
(Csize
);
1016 end Make_Packed_Array_Impl_Type_Name
;
1018 -----------------------------------
1019 -- Output_Homonym_Numbers_Suffix --
1020 -----------------------------------
1022 procedure Output_Homonym_Numbers_Suffix
is
1026 if Homonym_Len
> 0 then
1028 -- Check for all 1's, in which case we do not output
1032 exit when Homonym_Numbers
(J
) /= '1';
1034 -- If we reached end of string we do not output
1036 if J
= Homonym_Len
then
1041 exit when Homonym_Numbers
(J
+ 1) /= '_';
1045 -- If we exit the loop then suffix must be output
1047 Add_Str_To_Name_Buffer
("__");
1048 Add_Str_To_Name_Buffer
(Homonym_Numbers
(1 .. Homonym_Len
));
1051 end Output_Homonym_Numbers_Suffix
;
1053 ------------------------------
1054 -- Prepend_String_To_Buffer --
1055 ------------------------------
1057 procedure Prepend_String_To_Buffer
(S
: String) is
1058 N
: constant Integer := S
'Length;
1060 Name_Buffer
(1 + N
.. Name_Len
+ N
) := Name_Buffer
(1 .. Name_Len
);
1061 Name_Buffer
(1 .. N
) := S
;
1062 Name_Len
:= Name_Len
+ N
;
1063 end Prepend_String_To_Buffer
;
1065 ----------------------------
1066 -- Prepend_Uint_To_Buffer --
1067 ----------------------------
1069 procedure Prepend_Uint_To_Buffer
(U
: Uint
) is
1072 Prepend_String_To_Buffer
("m");
1073 Prepend_Uint_To_Buffer
(-U
);
1075 UI_Image
(U
, Decimal
);
1076 Prepend_String_To_Buffer
(UI_Image_Buffer
(1 .. UI_Image_Length
));
1078 end Prepend_Uint_To_Buffer
;
1080 ------------------------------
1081 -- Qualify_All_Entity_Names --
1082 ------------------------------
1084 procedure Qualify_All_Entity_Names
is
1090 for J
in Name_Qualify_Units
.First
.. Name_Qualify_Units
.Last
loop
1091 Nod
:= Name_Qualify_Units
.Table
(J
);
1093 -- When a scoping construct is ignored Ghost, it is rewritten as
1094 -- a null statement. Skip such constructs as they no longer carry
1097 if Nkind
(Nod
) = N_Null_Statement
then
1101 E
:= Defining_Entity
(Nod
);
1103 Qualify_Entity_Name
(E
);
1105 -- Normally entities in the qualification list are scopes, but in the
1106 -- case of a library-level package renaming there is an associated
1107 -- variable that encodes the debugger name and that variable is
1108 -- entered in the list since it occurs in the Aux_Decls list of the
1109 -- compilation and doesn't have a normal scope.
1111 if Ekind
(E
) /= E_Variable
then
1112 Ent
:= First_Entity
(E
);
1113 while Present
(Ent
) loop
1115 Qualify_Entity_Name
(Ent
);
1118 -- There are odd cases where Last_Entity (E) = E. This happens
1119 -- in the case of renaming of packages. This test avoids
1120 -- getting stuck in such cases.
1129 end Qualify_All_Entity_Names
;
1131 -------------------------
1132 -- Qualify_Entity_Name --
1133 -------------------------
1135 procedure Qualify_Entity_Name
(Ent
: Entity_Id
) is
1137 Full_Qualify_Name
: String (1 .. Name_Buffer
'Length);
1138 Full_Qualify_Len
: Natural := 0;
1139 -- Used to accumulate fully qualified name of subprogram
1141 procedure Fully_Qualify_Name
(E
: Entity_Id
);
1142 -- Used to qualify a subprogram or type name, where full
1143 -- qualification up to Standard is always used. Name is set
1144 -- in Full_Qualify_Name with the length in Full_Qualify_Len.
1145 -- Note that this routine does not prepend the _ada_ string
1146 -- required for library subprograms (this is done in the back end).
1148 function Is_BNPE
(S
: Entity_Id
) return Boolean;
1149 -- Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
1150 -- is defined to be a package which is immediately nested within a
1153 function Qualify_Needed
(S
: Entity_Id
) return Boolean;
1154 -- Given a scope, determines if the scope is to be included in the
1155 -- fully qualified name, True if so, False if not. Blocks and loops
1156 -- are excluded from a qualified name.
1158 procedure Set_BNPE_Suffix
(E
: Entity_Id
);
1159 -- Recursive routine to append the BNPE qualification suffix. Works
1160 -- from right to left with E being the current entity in the list.
1161 -- The result does NOT have the trailing n's and trailing b stripped.
1162 -- The caller must do this required stripping.
1164 procedure Set_Entity_Name
(E
: Entity_Id
);
1165 -- Internal recursive routine that does most of the work. This routine
1166 -- leaves the result sitting in Name_Buffer and Name_Len.
1168 BNPE_Suffix_Needed
: Boolean := False;
1169 -- Set true if a body-nested package entity suffix is required
1171 Save_Chars
: constant Name_Id
:= Chars
(Ent
);
1172 -- Save original name
1174 ------------------------
1175 -- Fully_Qualify_Name --
1176 ------------------------
1178 procedure Fully_Qualify_Name
(E
: Entity_Id
) is
1179 Discard
: Boolean := False;
1182 -- Ignore empty entry (can happen in error cases)
1187 -- If this we are qualifying entities local to a generic instance,
1188 -- use the name of the original instantiation, not that of the
1189 -- anonymous subprogram in the wrapper package, so that gdb doesn't
1190 -- have to know about these.
1192 elsif Is_Generic_Instance
(E
)
1193 and then Is_Subprogram
(E
)
1194 and then not Comes_From_Source
(E
)
1195 and then not Is_Compilation_Unit
(Scope
(E
))
1197 Fully_Qualify_Name
(Related_Instance
(Scope
(E
)));
1201 -- If we reached fully qualified name, then just copy it
1203 if Has_Fully_Qualified_Name
(E
) then
1204 Get_Name_String
(Chars
(E
));
1205 Strip_Suffixes
(Discard
);
1206 Full_Qualify_Name
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
1207 Full_Qualify_Len
:= Name_Len
;
1208 Set_Has_Fully_Qualified_Name
(Ent
);
1210 -- Case of non-fully qualified name
1213 if Scope
(E
) = Standard_Standard
then
1214 Set_Has_Fully_Qualified_Name
(Ent
);
1216 Fully_Qualify_Name
(Scope
(E
));
1217 Full_Qualify_Name
(Full_Qualify_Len
+ 1) := '_';
1218 Full_Qualify_Name
(Full_Qualify_Len
+ 2) := '_';
1219 Full_Qualify_Len
:= Full_Qualify_Len
+ 2;
1222 if Has_Qualified_Name
(E
) then
1223 Get_Unqualified_Name_String
(Chars
(E
));
1225 Get_Name_String
(Chars
(E
));
1228 -- Here we do one step of the qualification
1231 (Full_Qualify_Len
+ 1 .. Full_Qualify_Len
+ Name_Len
) :=
1232 Name_Buffer
(1 .. Name_Len
);
1233 Full_Qualify_Len
:= Full_Qualify_Len
+ Name_Len
;
1234 Append_Homonym_Number
(E
);
1238 BNPE_Suffix_Needed
:= True;
1240 end Fully_Qualify_Name
;
1246 function Is_BNPE
(S
: Entity_Id
) return Boolean is
1248 return Ekind
(S
) = E_Package
and then Is_Package_Body_Entity
(S
);
1251 --------------------
1252 -- Qualify_Needed --
1253 --------------------
1255 function Qualify_Needed
(S
: Entity_Id
) return Boolean is
1257 -- If we got all the way to Standard, then we have certainly
1258 -- fully qualified the name, so set the flag appropriately,
1259 -- and then return False, since we are most certainly done.
1261 if S
= Standard_Standard
then
1262 Set_Has_Fully_Qualified_Name
(Ent
, True);
1265 -- Otherwise figure out if further qualification is required
1268 return Is_Subprogram
(Ent
)
1269 or else Ekind
(Ent
) = E_Subprogram_Body
1270 or else (Ekind
(S
) /= E_Block
1271 and then Ekind
(S
) /= E_Loop
1272 and then not Is_Dynamic_Scope
(S
));
1276 ---------------------
1277 -- Set_BNPE_Suffix --
1278 ---------------------
1280 procedure Set_BNPE_Suffix
(E
: Entity_Id
) is
1281 S
: constant Entity_Id
:= Scope
(E
);
1284 if Qualify_Needed
(S
) then
1285 Set_BNPE_Suffix
(S
);
1288 Add_Char_To_Name_Buffer
('b');
1290 Add_Char_To_Name_Buffer
('n');
1294 Add_Char_To_Name_Buffer
('X');
1296 end Set_BNPE_Suffix
;
1298 ---------------------
1299 -- Set_Entity_Name --
1300 ---------------------
1302 procedure Set_Entity_Name
(E
: Entity_Id
) is
1303 S
: constant Entity_Id
:= Scope
(E
);
1306 -- If we reach an already qualified name, just take the encoding
1307 -- except that we strip the package body suffixes, since these
1308 -- will be separately put on later.
1310 if Has_Qualified_Name
(E
) then
1311 Get_Name_String_And_Append
(Chars
(E
));
1312 Strip_Suffixes
(BNPE_Suffix_Needed
);
1314 -- If the top level name we are adding is itself fully
1315 -- qualified, then that means that the name that we are
1316 -- preparing for the Fully_Qualify_Name call will also
1317 -- generate a fully qualified name.
1319 if Has_Fully_Qualified_Name
(E
) then
1320 Set_Has_Fully_Qualified_Name
(Ent
);
1323 -- Case where upper level name is not encoded yet
1326 -- Recurse if further qualification required
1328 if Qualify_Needed
(S
) then
1329 Set_Entity_Name
(S
);
1330 Add_Str_To_Name_Buffer
("__");
1333 -- Otherwise get name and note if it is a BNPE
1335 Get_Name_String_And_Append
(Chars
(E
));
1338 BNPE_Suffix_Needed
:= True;
1341 Append_Homonym_Number
(E
);
1343 end Set_Entity_Name
;
1345 -- Start of processing for Qualify_Entity_Name
1348 if Has_Qualified_Name
(Ent
) then
1351 -- In formal verification mode, simply append a suffix for homonyms.
1352 -- We used to qualify entity names as full expansion does, but this was
1353 -- removed as this prevents the verification back-end from using a short
1354 -- name for debugging and user interaction. The verification back-end
1355 -- already takes care of qualifying names when needed. Still mark the
1356 -- name as being qualified, as Qualify_Entity_Name may be called more
1357 -- than once on the same entity.
1359 elsif GNATprove_Mode
then
1360 if Has_Homonym
(Ent
) then
1361 Get_Name_String
(Chars
(Ent
));
1362 Append_Homonym_Number
(Ent
);
1363 Output_Homonym_Numbers_Suffix
;
1364 Set_Chars
(Ent
, Name_Enter
);
1367 Set_Has_Qualified_Name
(Ent
);
1370 -- If the entity is a variable encoding the debug name for an object
1371 -- renaming, then the qualified name of the entity associated with the
1372 -- renamed object can now be incorporated in the debug name.
1374 elsif Ekind
(Ent
) = E_Variable
1375 and then Present
(Debug_Renaming_Link
(Ent
))
1378 Qualify_Entity_Name
(Debug_Renaming_Link
(Ent
));
1379 Get_Name_String
(Chars
(Ent
));
1381 -- Retrieve the now-qualified name of the renamed entity and insert
1382 -- it in the middle of the name, just preceding the suffix encoding
1383 -- describing the renamed object.
1386 Renamed_Id
: constant String :=
1387 Get_Name_String
(Chars
(Debug_Renaming_Link
(Ent
)));
1388 Insert_Len
: constant Integer := Renamed_Id
'Length + 1;
1389 Index
: Natural := Name_Len
- 3;
1392 -- Loop backwards through the name to find the start of the "___"
1393 -- sequence associated with the suffix.
1395 while Index
>= Name_Buffer
'First
1396 and then (Name_Buffer
(Index
+ 1) /= '_'
1397 or else Name_Buffer
(Index
+ 2) /= '_'
1398 or else Name_Buffer
(Index
+ 3) /= '_')
1403 pragma Assert
(Name_Buffer
(Index
+ 1 .. Index
+ 3) = "___");
1405 -- Insert an underscore separator and the entity name just in
1406 -- front of the suffix.
1408 Name_Buffer
(Index
+ 1 + Insert_Len
.. Name_Len
+ Insert_Len
) :=
1409 Name_Buffer
(Index
+ 1 .. Name_Len
);
1410 Name_Buffer
(Index
+ 1) := '_';
1411 Name_Buffer
(Index
+ 2 .. Index
+ Insert_Len
) := Renamed_Id
;
1412 Name_Len
:= Name_Len
+ Insert_Len
;
1415 -- Reset the name of the variable to the new name that includes the
1416 -- name of the renamed entity.
1418 Set_Chars
(Ent
, Name_Enter
);
1420 -- If the entity needs qualification by its scope then develop it
1421 -- here, add the variable's name, and again reset the entity name.
1423 if Qualify_Needed
(Scope
(Ent
)) then
1425 Set_Entity_Name
(Scope
(Ent
));
1426 Add_Str_To_Name_Buffer
("__");
1428 Get_Name_String_And_Append
(Chars
(Ent
));
1430 Set_Chars
(Ent
, Name_Enter
);
1433 Set_Has_Qualified_Name
(Ent
);
1436 elsif Is_Subprogram
(Ent
)
1437 or else Ekind
(Ent
) = E_Subprogram_Body
1438 or else Is_Type
(Ent
)
1440 Fully_Qualify_Name
(Ent
);
1441 Name_Len
:= Full_Qualify_Len
;
1442 Name_Buffer
(1 .. Name_Len
) := Full_Qualify_Name
(1 .. Name_Len
);
1444 -- Qualification needed for enumeration literals when generating C code
1445 -- (to simplify their management in the backend).
1447 elsif Generate_C_Code
1448 and then Ekind
(Ent
) = E_Enumeration_Literal
1449 and then Scope
(Ultimate_Alias
(Ent
)) /= Standard_Standard
1451 Fully_Qualify_Name
(Ent
);
1452 Name_Len
:= Full_Qualify_Len
;
1453 Name_Buffer
(1 .. Name_Len
) := Full_Qualify_Name
(1 .. Name_Len
);
1455 elsif Qualify_Needed
(Scope
(Ent
)) then
1457 Set_Entity_Name
(Ent
);
1460 Set_Has_Qualified_Name
(Ent
);
1462 -- If a variable is hidden by a subsequent loop variable, qualify
1463 -- the name of that loop variable to prevent visibility issues when
1464 -- translating to C. Note that gdb probably never handled properly
1465 -- this accidental hiding, given that loops are not scopes at
1466 -- runtime. We also qualify a name if it hides an outer homonym,
1467 -- and both are declared in blocks.
1469 if Modify_Tree_For_C
and then Ekind
(Ent
) = E_Variable
then
1470 if Present
(Hiding_Loop_Variable
(Ent
)) then
1472 Var
: constant Entity_Id
:= Hiding_Loop_Variable
(Ent
);
1475 Set_Entity_Name
(Var
);
1476 Add_Str_To_Name_Buffer
("L");
1477 Set_Chars
(Var
, Name_Enter
);
1480 elsif Present
(Homonym
(Ent
))
1481 and then Ekind
(Scope
(Ent
)) = E_Block
1482 and then Ekind
(Scope
(Homonym
(Ent
))) = E_Block
1484 Set_Entity_Name
(Ent
);
1485 Add_Str_To_Name_Buffer
("B");
1486 Set_Chars
(Ent
, Name_Enter
);
1493 -- Fall through with a fully qualified name in Name_Buffer/Name_Len
1495 Output_Homonym_Numbers_Suffix
;
1497 -- Add body-nested package suffix if required
1499 if BNPE_Suffix_Needed
1500 and then Ekind
(Ent
) /= E_Enumeration_Literal
1502 Set_BNPE_Suffix
(Ent
);
1504 -- Strip trailing n's and last trailing b as required. note that
1505 -- we know there is at least one b, or no suffix would be generated.
1507 while Name_Buffer
(Name_Len
) = 'n' loop
1508 Name_Len
:= Name_Len
- 1;
1511 Name_Len
:= Name_Len
- 1;
1514 Set_Chars
(Ent
, Name_Enter
);
1515 Set_Has_Qualified_Name
(Ent
);
1517 if Debug_Flag_BB
then
1519 Write_Name
(Save_Chars
);
1520 Write_Str
(" qualified as ");
1521 Write_Name
(Chars
(Ent
));
1524 end Qualify_Entity_Name
;
1526 --------------------------
1527 -- Qualify_Entity_Names --
1528 --------------------------
1530 procedure Qualify_Entity_Names
(N
: Node_Id
) is
1532 Name_Qualify_Units
.Append
(N
);
1533 end Qualify_Entity_Names
;
1539 procedure Reset_Buffers
is
1545 --------------------
1546 -- Strip_Suffixes --
1547 --------------------
1549 procedure Strip_Suffixes
(BNPE_Suffix_Found
: in out Boolean) is
1552 pragma Warnings
(Off
, BNPE_Suffix_Found
);
1553 -- Since this procedure only ever sets the flag
1556 -- Search for and strip BNPE suffix
1558 for J
in reverse 2 .. Name_Len
loop
1559 if Name_Buffer
(J
) = 'X' then
1561 BNPE_Suffix_Found
:= True;
1565 exit when Name_Buffer
(J
) /= 'b' and then Name_Buffer
(J
) /= 'n';
1568 -- Search for and strip homonym numbers suffix
1570 for J
in reverse 2 .. Name_Len
- 2 loop
1571 if Name_Buffer
(J
) = '_'
1572 and then Name_Buffer
(J
+ 1) = '_'
1574 if Name_Buffer
(J
+ 2) in '0' .. '9' then
1575 if Homonym_Len
> 0 then
1576 Homonym_Len
:= Homonym_Len
+ 1;
1577 Homonym_Numbers
(Homonym_Len
) := '-';
1580 SL
:= Name_Len
- (J
+ 1);
1582 Homonym_Numbers
(Homonym_Len
+ 1 .. Homonym_Len
+ SL
) :=
1583 Name_Buffer
(J
+ 2 .. Name_Len
);
1585 Homonym_Len
:= Homonym_Len
+ SL
;