1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2008, 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
108 -- gather the homonym string that will be appended to Name_Buffer
109 -- when the name is complete. Strip_Suffixes appends to this string
110 -- as does Append_Homonym_Number, and Output_Homonym_Numbers_Suffix
111 -- appends the 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 procedure Output_Homonym_Numbers_Suffix
;
136 -- If homonym numbers are stored, then output them into Name_Buffer
138 procedure Prepend_String_To_Buffer
(S
: String);
139 -- Prepend given string to the contents of the string buffer, updating
140 -- the value in Name_Len (i.e. string is added at start of buffer).
142 procedure Prepend_Uint_To_Buffer
(U
: Uint
);
143 -- Prepend image of universal integer to Name_Buffer, updating Name_Len
145 procedure Qualify_Entity_Name
(Ent
: Entity_Id
);
146 -- If not already done, replaces the Chars field of the given entity
147 -- with the appropriate fully qualified name.
149 procedure Strip_Suffixes
(BNPE_Suffix_Found
: in out Boolean);
150 -- Given an qualified entity name in Name_Buffer, remove any plain X or
151 -- X{nb} qualification suffix. The contents of Name_Buffer is not changed
152 -- but Name_Len may be adjusted on return to remove the suffix. If a
153 -- BNPE suffix is found and stripped, then BNPE_Suffix_Found is set to
154 -- True. If no suffix is found, then BNPE_Suffix_Found is not modified.
155 -- This routine also searches for a homonym suffix, and if one is found
156 -- it is also stripped, and the entries are added to the global homonym
157 -- list (Homonym_Numbers) so that they can later be put back.
159 ------------------------
160 -- Add_Real_To_Buffer --
161 ------------------------
163 procedure Add_Real_To_Buffer
(U
: Ureal
) is
165 Add_Uint_To_Buffer
(Norm_Num
(U
));
166 Add_Str_To_Name_Buffer
("_");
167 Add_Uint_To_Buffer
(Norm_Den
(U
));
168 end Add_Real_To_Buffer
;
170 ------------------------
171 -- Add_Uint_To_Buffer --
172 ------------------------
174 procedure Add_Uint_To_Buffer
(U
: Uint
) is
177 Add_Uint_To_Buffer
(-U
);
178 Add_Char_To_Name_Buffer
('m');
180 UI_Image
(U
, Decimal
);
181 Add_Str_To_Name_Buffer
(UI_Image_Buffer
(1 .. UI_Image_Length
));
183 end Add_Uint_To_Buffer
;
185 ---------------------------
186 -- Append_Homonym_Number --
187 ---------------------------
189 procedure Append_Homonym_Number
(E
: Entity_Id
) is
191 procedure Add_Nat_To_H
(Nr
: Nat
);
192 -- Little procedure to append Nr to Homonym_Numbers
198 procedure Add_Nat_To_H
(Nr
: Nat
) is
201 Add_Nat_To_H
(Nr
/ 10);
204 Homonym_Len
:= Homonym_Len
+ 1;
205 Homonym_Numbers
(Homonym_Len
) :=
206 Character'Val (Nr
mod 10 + Character'Pos ('0'));
209 -- Start of processing for Append_Homonym_Number
212 if Has_Homonym
(E
) then
214 H
: Entity_Id
:= Homonym
(E
);
218 while Present
(H
) loop
219 if Scope
(H
) = Scope
(E
) then
226 if Homonym_Len
> 0 then
227 Homonym_Len
:= Homonym_Len
+ 1;
228 Homonym_Numbers
(Homonym_Len
) := '_';
234 end Append_Homonym_Number
;
236 -----------------------
237 -- Bounds_Match_Size --
238 -----------------------
240 function Bounds_Match_Size
(E
: Entity_Id
) return Boolean is
244 if not Is_OK_Static_Subtype
(E
) then
247 elsif Is_Integer_Type
(E
)
248 and then Subtypes_Statically_Match
(E
, Base_Type
(E
))
252 -- Here we check if the static bounds match the natural size, which is
253 -- the size passed through with the debugging information. This is the
254 -- Esize rounded up to 8, 16, 32 or 64 as appropriate.
258 Umark
: constant Uintp
.Save_Mark
:= Uintp
.Mark
;
262 if Esize
(E
) <= 8 then
264 elsif Esize
(E
) <= 16 then
266 elsif Esize
(E
) <= 32 then
272 if Is_Modular_Integer_Type
(E
) or else Is_Enumeration_Type
(E
) then
274 Expr_Rep_Value
(Type_Low_Bound
(E
)) = 0
276 2 ** Siz
- Expr_Rep_Value
(Type_High_Bound
(E
)) = 1;
280 Expr_Rep_Value
(Type_Low_Bound
(E
)) + 2 ** (Siz
- 1) = 0
282 2 ** (Siz
- 1) - Expr_Rep_Value
(Type_High_Bound
(E
)) = 1;
289 end Bounds_Match_Size
;
291 --------------------------------
292 -- Debug_Renaming_Declaration --
293 --------------------------------
295 function Debug_Renaming_Declaration
(N
: Node_Id
) return Node_Id
is
296 Loc
: constant Source_Ptr
:= Sloc
(N
);
297 Ent
: constant Node_Id
:= Defining_Entity
(N
);
298 Nam
: constant Node_Id
:= Name
(N
);
304 function Output_Subscript
(N
: Node_Id
; S
: String) return Boolean;
305 -- Outputs a single subscript value as ?nnn (subscript is compile time
306 -- known value with value nnn) or as ?e (subscript is local constant
307 -- with name e), where S supplies the proper string to use for ?.
308 -- Returns False if the subscript is not of an appropriate type to
309 -- output in one of these two forms. The result is prepended to the
310 -- name stored in Name_Buffer.
312 ----------------------
313 -- Output_Subscript --
314 ----------------------
316 function Output_Subscript
(N
: Node_Id
; S
: String) return Boolean is
318 if Compile_Time_Known_Value
(N
) then
319 Prepend_Uint_To_Buffer
(Expr_Value
(N
));
321 elsif Nkind
(N
) = N_Identifier
322 and then Scope
(Entity
(N
)) = Scope
(Ent
)
323 and then Ekind
(Entity
(N
)) = E_Constant
325 Prepend_String_To_Buffer
(Get_Name_String
(Chars
(Entity
(N
))));
331 Prepend_String_To_Buffer
(S
);
333 end Output_Subscript
;
335 -- Start of processing for Debug_Renaming_Declaration
338 if not Comes_From_Source
(N
)
339 and then not Needs_Debug_Info
(Ent
)
344 -- Get renamed entity and compute suffix
354 when N_Expanded_Name
=>
356 -- The entity field for an N_Expanded_Name is on the expanded
357 -- name node itself, so we are done here too.
361 when N_Selected_Component
=>
362 Prepend_String_To_Buffer
363 (Get_Name_String
(Chars
(Selector_Name
(Ren
))));
364 Prepend_String_To_Buffer
("XR");
367 when N_Indexed_Component
=>
369 X
: Node_Id
:= Last
(Expressions
(Ren
));
372 while Present
(X
) loop
373 if not Output_Subscript
(X
, "XS") then
374 Set_Materialize_Entity
(Ent
);
386 Typ
:= Etype
(First_Index
(Etype
(Nam
)));
388 if not Output_Subscript
(Type_High_Bound
(Typ
), "XS") then
389 Set_Materialize_Entity
(Ent
);
393 if not Output_Subscript
(Type_Low_Bound
(Typ
), "XL") then
394 Set_Materialize_Entity
(Ent
);
400 when N_Explicit_Dereference
=>
401 Set_Materialize_Entity
(Ent
);
402 Prepend_String_To_Buffer
("XA");
405 -- For now, anything else simply results in no translation
408 Set_Materialize_Entity
(Ent
);
413 Prepend_String_To_Buffer
("___XE");
415 -- Include the designation of the form of renaming
418 when N_Object_Renaming_Declaration
=>
419 Prepend_String_To_Buffer
("___XR");
421 when N_Exception_Renaming_Declaration
=>
422 Prepend_String_To_Buffer
("___XRE");
424 when N_Package_Renaming_Declaration
=>
425 Prepend_String_To_Buffer
("___XRP");
431 -- Add the name of the renaming entity to the front
433 Prepend_String_To_Buffer
(Get_Name_String
(Chars
(Ent
)));
435 -- If it is a child unit create a fully qualified name, to disambiguate
436 -- multiple child units with the same name and different parents.
438 if Nkind
(N
) = N_Package_Renaming_Declaration
439 and then Is_Child_Unit
(Ent
)
441 Prepend_String_To_Buffer
("__");
442 Prepend_String_To_Buffer
443 (Get_Name_String
(Chars
(Scope
(Ent
))));
446 -- Create the special object whose name is the debug encoding for the
447 -- renaming declaration.
449 -- For now, the object name contains the suffix encoding for the renamed
450 -- object, but not the name of the leading entity. The object is linked
451 -- the renamed entity using the Debug_Renaming_Link field. Then the
452 -- Qualify_Entity_Name procedure uses this link to create the proper
453 -- fully qualified name.
455 -- The reason we do things this way is that we really need to copy the
456 -- qualification of the renamed entity, and it is really much easier to
457 -- do this after the renamed entity has itself been fully qualified.
459 Obj
:= Make_Defining_Identifier
(Loc
, Chars
=> Name_Enter
);
461 Make_Object_Declaration
(Loc
,
462 Defining_Identifier
=> Obj
,
463 Object_Definition
=> New_Reference_To
464 (Standard_Debug_Renaming_Type
, Loc
));
466 Set_Debug_Renaming_Link
(Obj
, Entity
(Ren
));
468 Set_Debug_Info_Needed
(Obj
);
470 -- Mark the object as internal so that it won't be initialized when
471 -- pragma Initialize_Scalars or Normalize_Scalars is in use.
473 Set_Is_Internal
(Obj
);
477 -- If we get an exception, just figure it is a case that we cannot
478 -- successfully handle using our current approach, since this is
479 -- only for debugging, no need to take the compilation with us!
483 return Make_Null_Statement
(Loc
);
484 end Debug_Renaming_Declaration
;
486 ----------------------
487 -- Get_Encoded_Name --
488 ----------------------
490 -- Note: see spec for details on encodings
492 procedure Get_Encoded_Name
(E
: Entity_Id
) is
493 Has_Suffix
: Boolean;
496 -- If not generating code, there is no need to create encoded names, and
497 -- problems when the back-end is called to annotate types without full
498 -- code generation. See comments in Get_External_Name_With_Suffix for
499 -- additional details.
501 -- However we do create encoded names if the back end is active, even
502 -- if Operating_Mode got reset. Otherwise any serious error reported
503 -- by the backend calling Error_Msg changes the Compilation_Mode to
504 -- Check_Semantics, which disables the functionality of this routine,
505 -- causing the generation of spurious additional errors.
507 -- Couldn't we just test Original_Operating_Mode here? ???
509 if Operating_Mode
/= Generate_Code
510 and then not Generating_Code
515 Get_Name_String
(Chars
(E
));
517 -- Nothing to do if we do not have a type
521 -- Or if this is an enumeration base type
523 or else (Is_Enumeration_Type
(E
)
524 and then E
= Base_Type
(E
))
526 -- Or if this is a dummy type for a renaming
528 or else (Name_Len
>= 3 and then
529 Name_Buffer
(Name_Len
- 2 .. Name_Len
) = "_XR")
531 or else (Name_Len
>= 4 and then
532 (Name_Buffer
(Name_Len
- 3 .. Name_Len
) = "_XRE"
534 Name_Buffer
(Name_Len
- 3 .. Name_Len
) = "_XRP"))
536 -- For all these cases, just return the name unchanged
539 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
547 if Is_Fixed_Point_Type
(E
) then
548 Get_External_Name_With_Suffix
(E
, "XF_");
549 Add_Real_To_Buffer
(Delta_Value
(E
));
551 if Small_Value
(E
) /= Delta_Value
(E
) then
552 Add_Str_To_Name_Buffer
("_");
553 Add_Real_To_Buffer
(Small_Value
(E
));
556 -- Vax floating-point case
558 elsif Vax_Float
(E
) then
559 if Digits_Value
(Base_Type
(E
)) = 6 then
560 Get_External_Name_With_Suffix
(E
, "XFF");
562 elsif Digits_Value
(Base_Type
(E
)) = 9 then
563 Get_External_Name_With_Suffix
(E
, "XFF");
566 pragma Assert
(Digits_Value
(Base_Type
(E
)) = 15);
567 Get_External_Name_With_Suffix
(E
, "XFG");
570 -- Discrete case where bounds do not match size
572 elsif Is_Discrete_Type
(E
)
573 and then not Bounds_Match_Size
(E
)
576 Lo
: constant Node_Id
:= Type_Low_Bound
(E
);
577 Hi
: constant Node_Id
:= Type_High_Bound
(E
);
579 Lo_Con
: constant Boolean := Compile_Time_Known_Value
(Lo
);
580 Hi_Con
: constant Boolean := Compile_Time_Known_Value
(Hi
);
582 Lo_Discr
: constant Boolean :=
583 Nkind
(Lo
) = N_Identifier
585 Ekind
(Entity
(Lo
)) = E_Discriminant
;
587 Hi_Discr
: constant Boolean :=
588 Nkind
(Hi
) = N_Identifier
590 Ekind
(Entity
(Hi
)) = E_Discriminant
;
592 Lo_Encode
: constant Boolean := Lo_Con
or Lo_Discr
;
593 Hi_Encode
: constant Boolean := Hi_Con
or Hi_Discr
;
595 Biased
: constant Boolean := Has_Biased_Representation
(E
);
599 Get_External_Name_With_Suffix
(E
, "XB");
601 Get_External_Name_With_Suffix
(E
, "XD");
604 if Lo_Encode
or Hi_Encode
then
606 Add_Str_To_Name_Buffer
("_");
610 Add_Str_To_Name_Buffer
("LU_");
612 Add_Str_To_Name_Buffer
("L_");
615 Add_Str_To_Name_Buffer
("U_");
620 Add_Uint_To_Buffer
(Expr_Rep_Value
(Lo
));
622 Get_Name_String_And_Append
(Chars
(Entity
(Lo
)));
625 if Lo_Encode
and Hi_Encode
then
626 Add_Str_To_Name_Buffer
("__");
630 Add_Uint_To_Buffer
(Expr_Rep_Value
(Hi
));
632 Get_Name_String_And_Append
(Chars
(Entity
(Hi
)));
637 -- For all other cases, the encoded name is the normal type name
641 Get_External_Name
(E
, Has_Suffix
);
644 if Debug_Flag_B
and then Has_Suffix
then
645 Write_Str
("**** type ");
646 Write_Name
(Chars
(E
));
647 Write_Str
(" is encoded as ");
648 Write_Str
(Name_Buffer
(1 .. Name_Len
));
652 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
653 end Get_Encoded_Name
;
655 -----------------------
656 -- Get_External_Name --
657 -----------------------
659 procedure Get_External_Name
(Entity
: Entity_Id
; Has_Suffix
: Boolean) is
660 E
: Entity_Id
:= Entity
;
663 procedure Get_Qualified_Name_And_Append
(Entity
: Entity_Id
);
664 -- Appends fully qualified name of given entity to Name_Buffer
666 -----------------------------------
667 -- Get_Qualified_Name_And_Append --
668 -----------------------------------
670 procedure Get_Qualified_Name_And_Append
(Entity
: Entity_Id
) is
672 -- If the entity is a compilation unit, its scope is Standard,
673 -- there is no outer scope, and the no further qualification
676 -- If the front end has already computed a fully qualified name,
677 -- then it is also the case that no further qualification is
680 if Present
(Scope
(Scope
(Entity
)))
681 and then not Has_Fully_Qualified_Name
(Entity
)
683 Get_Qualified_Name_And_Append
(Scope
(Entity
));
684 Add_Str_To_Name_Buffer
("__");
685 Get_Name_String_And_Append
(Chars
(Entity
));
686 Append_Homonym_Number
(Entity
);
689 Get_Name_String_And_Append
(Chars
(Entity
));
691 end Get_Qualified_Name_And_Append
;
693 -- Start of processing for Get_External_Name
699 -- If this is a child unit, we want the child
701 if Nkind
(E
) = N_Defining_Program_Unit_Name
then
702 E
:= Defining_Identifier
(Entity
);
707 -- Case of interface name being used
709 if (Kind
= E_Procedure
or else
710 Kind
= E_Function
or else
711 Kind
= E_Constant
or else
712 Kind
= E_Variable
or else
714 and then Present
(Interface_Name
(E
))
715 and then No
(Address_Clause
(E
))
716 and then not Has_Suffix
718 Add_String_To_Name_Buffer
(Strval
(Interface_Name
(E
)));
720 -- All other cases besides the interface name case
723 -- If this is a library level subprogram (i.e. a subprogram that is a
724 -- compilation unit other than a subunit), then we prepend _ada_ to
725 -- ensure distinctions required as described in the spec.
727 -- Check explicitly for child units, because those are not flagged
728 -- as Compilation_Units by lib. Should they be ???
731 and then (Is_Compilation_Unit
(E
) or Is_Child_Unit
(E
))
732 and then not Has_Suffix
734 Add_Str_To_Name_Buffer
("_ada_");
737 -- If the entity is a subprogram instance that is not a compilation
738 -- unit, generate the name of the original Ada entity, which is the
741 if Is_Generic_Instance
(E
)
742 and then Is_Subprogram
(E
)
743 and then not Is_Compilation_Unit
(Scope
(E
))
744 and then (Ekind
(Scope
(E
)) = E_Package
746 Ekind
(Scope
(E
)) = E_Package_Body
)
747 and then Present
(Related_Instance
(Scope
(E
)))
749 E
:= Related_Instance
(Scope
(E
));
752 Get_Qualified_Name_And_Append
(E
);
755 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
756 end Get_External_Name
;
758 -----------------------------------
759 -- Get_External_Name_With_Suffix --
760 -----------------------------------
762 procedure Get_External_Name_With_Suffix
766 Has_Suffix
: constant Boolean := (Suffix
/= "");
769 -- If we are not in code generation mode, this procedure may still be
770 -- called from Back_End (more specifically - from gigi for doing type
771 -- representation annotation or some representation-specific checks).
772 -- But in this mode there is no need to mess with external names.
774 -- Furthermore, the call causes difficulties in this case because the
775 -- string representing the homonym number is not correctly reset as a
776 -- part of the call to Output_Homonym_Numbers_Suffix (which is not
779 if Operating_Mode
/= Generate_Code
then
783 Get_External_Name
(Entity
, Has_Suffix
);
786 Add_Str_To_Name_Buffer
("___");
787 Add_Str_To_Name_Buffer
(Suffix
);
788 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
790 end Get_External_Name_With_Suffix
;
792 --------------------------
793 -- Get_Variant_Encoding --
794 --------------------------
796 procedure Get_Variant_Encoding
(V
: Node_Id
) is
799 procedure Choice_Val
(Typ
: Character; Choice
: Node_Id
);
800 -- Output encoded value for a single choice value. Typ is the key
801 -- character ('S', 'F', or 'T') that precedes the choice value.
807 procedure Choice_Val
(Typ
: Character; Choice
: Node_Id
) is
809 if Nkind
(Choice
) = N_Integer_Literal
then
810 Add_Char_To_Name_Buffer
(Typ
);
811 Add_Uint_To_Buffer
(Intval
(Choice
));
813 -- Character literal with no entity present (this is the case
814 -- Standard.Character or Standard.Wide_Character as root type)
816 elsif Nkind
(Choice
) = N_Character_Literal
817 and then No
(Entity
(Choice
))
819 Add_Char_To_Name_Buffer
(Typ
);
820 Add_Uint_To_Buffer
(Char_Literal_Value
(Choice
));
824 Ent
: constant Entity_Id
:= Entity
(Choice
);
827 if Ekind
(Ent
) = E_Enumeration_Literal
then
828 Add_Char_To_Name_Buffer
(Typ
);
829 Add_Uint_To_Buffer
(Enumeration_Rep
(Ent
));
832 pragma Assert
(Ekind
(Ent
) = E_Constant
);
833 Choice_Val
(Typ
, Constant_Value
(Ent
));
839 -- Start of processing for Get_Variant_Encoding
844 Choice
:= First
(Discrete_Choices
(V
));
845 while Present
(Choice
) loop
846 if Nkind
(Choice
) = N_Others_Choice
then
847 Add_Char_To_Name_Buffer
('O');
849 elsif Nkind
(Choice
) = N_Range
then
850 Choice_Val
('R', Low_Bound
(Choice
));
851 Choice_Val
('T', High_Bound
(Choice
));
853 elsif Is_Entity_Name
(Choice
)
854 and then Is_Type
(Entity
(Choice
))
856 Choice_Val
('R', Type_Low_Bound
(Entity
(Choice
)));
857 Choice_Val
('T', Type_High_Bound
(Entity
(Choice
)));
859 elsif Nkind
(Choice
) = N_Subtype_Indication
then
861 Rang
: constant Node_Id
:=
862 Range_Expression
(Constraint
(Choice
));
864 Choice_Val
('R', Low_Bound
(Rang
));
865 Choice_Val
('T', High_Bound
(Rang
));
869 Choice_Val
('S', Choice
);
875 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
879 VP
: constant Node_Id
:= Parent
(V
); -- Variant_Part
880 CL
: constant Node_Id
:= Parent
(VP
); -- Component_List
881 RD
: constant Node_Id
:= Parent
(CL
); -- Record_Definition
882 FT
: constant Node_Id
:= Parent
(RD
); -- Full_Type_Declaration
885 Write_Str
("**** variant for type ");
886 Write_Name
(Chars
(Defining_Identifier
(FT
)));
887 Write_Str
(" is encoded as ");
888 Write_Str
(Name_Buffer
(1 .. Name_Len
));
892 end Get_Variant_Encoding
;
894 ------------------------------------
895 -- Get_Secondary_DT_External_Name --
896 ------------------------------------
898 procedure Get_Secondary_DT_External_Name
900 Ancestor_Typ
: Entity_Id
;
904 Get_External_Name
(Typ
, Has_Suffix
=> False);
906 if Ancestor_Typ
/= Typ
then
908 Len
: constant Natural := Name_Len
;
909 Save_Str
: constant String (1 .. Name_Len
)
910 := Name_Buffer
(1 .. Name_Len
);
912 Get_External_Name
(Ancestor_Typ
, Has_Suffix
=> False);
914 -- Append the extended name of the ancestor to the
915 -- extended name of Typ
917 Name_Buffer
(Len
+ 2 .. Len
+ Name_Len
+ 1) :=
918 Name_Buffer
(1 .. Name_Len
);
919 Name_Buffer
(1 .. Len
) := Save_Str
;
920 Name_Buffer
(Len
+ 1) := '_';
921 Name_Len
:= Len
+ Name_Len
+ 1;
925 Add_Nat_To_Name_Buffer
(Suffix_Index
);
926 end Get_Secondary_DT_External_Name
;
928 ---------------------------------
929 -- Make_Packed_Array_Type_Name --
930 ---------------------------------
932 function Make_Packed_Array_Type_Name
938 Get_Name_String
(Chars
(Typ
));
939 Add_Str_To_Name_Buffer
("___XP");
940 Add_Uint_To_Buffer
(Csize
);
942 end Make_Packed_Array_Type_Name
;
944 -----------------------------------
945 -- Output_Homonym_Numbers_Suffix --
946 -----------------------------------
948 procedure Output_Homonym_Numbers_Suffix
is
952 if Homonym_Len
> 0 then
954 -- Check for all 1's, in which case we do not output
958 exit when Homonym_Numbers
(J
) /= '1';
960 -- If we reached end of string we do not output
962 if J
= Homonym_Len
then
967 exit when Homonym_Numbers
(J
+ 1) /= '_';
971 -- If we exit the loop then suffix must be output
973 Add_Str_To_Name_Buffer
("__");
974 Add_Str_To_Name_Buffer
(Homonym_Numbers
(1 .. Homonym_Len
));
977 end Output_Homonym_Numbers_Suffix
;
979 ------------------------------
980 -- Prepend_String_To_Buffer --
981 ------------------------------
983 procedure Prepend_String_To_Buffer
(S
: String) is
984 N
: constant Integer := S
'Length;
986 Name_Buffer
(1 + N
.. Name_Len
+ N
) := Name_Buffer
(1 .. Name_Len
);
987 Name_Buffer
(1 .. N
) := S
;
988 Name_Len
:= Name_Len
+ N
;
989 end Prepend_String_To_Buffer
;
991 ----------------------------
992 -- Prepend_Uint_To_Buffer --
993 ----------------------------
995 procedure Prepend_Uint_To_Buffer
(U
: Uint
) is
998 Prepend_String_To_Buffer
("m");
999 Prepend_Uint_To_Buffer
(-U
);
1001 UI_Image
(U
, Decimal
);
1002 Prepend_String_To_Buffer
(UI_Image_Buffer
(1 .. UI_Image_Length
));
1004 end Prepend_Uint_To_Buffer
;
1006 ------------------------------
1007 -- Qualify_All_Entity_Names --
1008 ------------------------------
1010 procedure Qualify_All_Entity_Names
is
1015 for J
in Name_Qualify_Units
.First
.. Name_Qualify_Units
.Last
loop
1016 E
:= Defining_Entity
(Name_Qualify_Units
.Table
(J
));
1017 Qualify_Entity_Name
(E
);
1019 -- Normally entities in the qualification list are scopes, but in the
1020 -- case of a library-level package renaming there is an associated
1021 -- variable that encodes the debugger name and that variable is
1022 -- entered in the list since it occurs in the Aux_Decls list of the
1023 -- compilation and doesn't have a normal scope.
1025 if Ekind
(E
) /= E_Variable
then
1026 Ent
:= First_Entity
(E
);
1027 while Present
(Ent
) loop
1028 Qualify_Entity_Name
(Ent
);
1031 -- There are odd cases where Last_Entity (E) = E. This happens
1032 -- in the case of renaming of packages. This test avoids
1033 -- getting stuck in such cases.
1039 end Qualify_All_Entity_Names
;
1041 -------------------------
1042 -- Qualify_Entity_Name --
1043 -------------------------
1045 procedure Qualify_Entity_Name
(Ent
: Entity_Id
) is
1047 Full_Qualify_Name
: String (1 .. Name_Buffer
'Length);
1048 Full_Qualify_Len
: Natural := 0;
1049 -- Used to accumulate fully qualified name of subprogram
1051 procedure Fully_Qualify_Name
(E
: Entity_Id
);
1052 -- Used to qualify a subprogram or type name, where full
1053 -- qualification up to Standard is always used. Name is set
1054 -- in Full_Qualify_Name with the length in Full_Qualify_Len.
1055 -- Note that this routine does not prepend the _ada_ string
1056 -- required for library subprograms (this is done in the back end).
1058 function Is_BNPE
(S
: Entity_Id
) return Boolean;
1059 -- Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
1060 -- is defined to be a package which is immediately nested within a
1063 function Qualify_Needed
(S
: Entity_Id
) return Boolean;
1064 -- Given a scope, determines if the scope is to be included in the
1065 -- fully qualified name, True if so, False if not.
1067 procedure Set_BNPE_Suffix
(E
: Entity_Id
);
1068 -- Recursive routine to append the BNPE qualification suffix. Works
1069 -- from right to left with E being the current entity in the list.
1070 -- The result does NOT have the trailing n's and trailing b stripped.
1071 -- The caller must do this required stripping.
1073 procedure Set_Entity_Name
(E
: Entity_Id
);
1074 -- Internal recursive routine that does most of the work. This routine
1075 -- leaves the result sitting in Name_Buffer and Name_Len.
1077 BNPE_Suffix_Needed
: Boolean := False;
1078 -- Set true if a body-nested package entity suffix is required
1080 Save_Chars
: constant Name_Id
:= Chars
(Ent
);
1081 -- Save original name
1083 ------------------------
1084 -- Fully_Qualify_Name --
1085 ------------------------
1087 procedure Fully_Qualify_Name
(E
: Entity_Id
) is
1088 Discard
: Boolean := False;
1091 -- Ignore empty entry (can happen in error cases)
1096 -- If this we are qualifying entities local to a generic
1097 -- instance, use the name of the original instantiation,
1098 -- not that of the anonymous subprogram in the wrapper
1099 -- package, so that gdb doesn't have to know about these.
1101 elsif Is_Generic_Instance
(E
)
1102 and then Is_Subprogram
(E
)
1103 and then not Comes_From_Source
(E
)
1104 and then not Is_Compilation_Unit
(Scope
(E
))
1106 Fully_Qualify_Name
(Related_Instance
(Scope
(E
)));
1110 -- If we reached fully qualified name, then just copy it
1112 if Has_Fully_Qualified_Name
(E
) then
1113 Get_Name_String
(Chars
(E
));
1114 Strip_Suffixes
(Discard
);
1115 Full_Qualify_Name
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
1116 Full_Qualify_Len
:= Name_Len
;
1117 Set_Has_Fully_Qualified_Name
(Ent
);
1119 -- Case of non-fully qualified name
1122 if Scope
(E
) = Standard_Standard
then
1123 Set_Has_Fully_Qualified_Name
(Ent
);
1125 Fully_Qualify_Name
(Scope
(E
));
1126 Full_Qualify_Name
(Full_Qualify_Len
+ 1) := '_';
1127 Full_Qualify_Name
(Full_Qualify_Len
+ 2) := '_';
1128 Full_Qualify_Len
:= Full_Qualify_Len
+ 2;
1131 if Has_Qualified_Name
(E
) then
1132 Get_Unqualified_Name_String
(Chars
(E
));
1134 Get_Name_String
(Chars
(E
));
1137 -- Here we do one step of the qualification
1140 (Full_Qualify_Len
+ 1 .. Full_Qualify_Len
+ Name_Len
) :=
1141 Name_Buffer
(1 .. Name_Len
);
1142 Full_Qualify_Len
:= Full_Qualify_Len
+ Name_Len
;
1143 Append_Homonym_Number
(E
);
1147 BNPE_Suffix_Needed
:= True;
1149 end Fully_Qualify_Name
;
1155 function Is_BNPE
(S
: Entity_Id
) return Boolean is
1158 Ekind
(S
) = E_Package
1159 and then Is_Package_Body_Entity
(S
);
1162 --------------------
1163 -- Qualify_Needed --
1164 --------------------
1166 function Qualify_Needed
(S
: Entity_Id
) return Boolean is
1168 -- If we got all the way to Standard, then we have certainly
1169 -- fully qualified the name, so set the flag appropriately,
1170 -- and then return False, since we are most certainly done!
1172 if S
= Standard_Standard
then
1173 Set_Has_Fully_Qualified_Name
(Ent
, True);
1176 -- Otherwise figure out if further qualification is required
1182 Ekind
(Ent
) = E_Subprogram_Body
1184 (Ekind
(S
) /= E_Block
1185 and then not Is_Dynamic_Scope
(S
));
1189 ---------------------
1190 -- Set_BNPE_Suffix --
1191 ---------------------
1193 procedure Set_BNPE_Suffix
(E
: Entity_Id
) is
1194 S
: constant Entity_Id
:= Scope
(E
);
1197 if Qualify_Needed
(S
) then
1198 Set_BNPE_Suffix
(S
);
1201 Add_Char_To_Name_Buffer
('b');
1203 Add_Char_To_Name_Buffer
('n');
1207 Add_Char_To_Name_Buffer
('X');
1209 end Set_BNPE_Suffix
;
1211 ---------------------
1212 -- Set_Entity_Name --
1213 ---------------------
1215 procedure Set_Entity_Name
(E
: Entity_Id
) is
1216 S
: constant Entity_Id
:= Scope
(E
);
1219 -- If we reach an already qualified name, just take the encoding
1220 -- except that we strip the package body suffixes, since these
1221 -- will be separately put on later.
1223 if Has_Qualified_Name
(E
) then
1224 Get_Name_String_And_Append
(Chars
(E
));
1225 Strip_Suffixes
(BNPE_Suffix_Needed
);
1227 -- If the top level name we are adding is itself fully
1228 -- qualified, then that means that the name that we are
1229 -- preparing for the Fully_Qualify_Name call will also
1230 -- generate a fully qualified name.
1232 if Has_Fully_Qualified_Name
(E
) then
1233 Set_Has_Fully_Qualified_Name
(Ent
);
1236 -- Case where upper level name is not encoded yet
1239 -- Recurse if further qualification required
1241 if Qualify_Needed
(S
) then
1242 Set_Entity_Name
(S
);
1243 Add_Str_To_Name_Buffer
("__");
1246 -- Otherwise get name and note if it is a BNPE
1248 Get_Name_String_And_Append
(Chars
(E
));
1251 BNPE_Suffix_Needed
:= True;
1254 Append_Homonym_Number
(E
);
1256 end Set_Entity_Name
;
1258 -- Start of processing for Qualify_Entity_Name
1261 if Has_Qualified_Name
(Ent
) then
1264 -- If the entity is a variable encoding the debug name for an object
1265 -- renaming, then the qualified name of the entity associated with the
1266 -- renamed object can now be incorporated in the debug name.
1268 elsif Ekind
(Ent
) = E_Variable
1269 and then Present
(Debug_Renaming_Link
(Ent
))
1272 Qualify_Entity_Name
(Debug_Renaming_Link
(Ent
));
1273 Get_Name_String
(Chars
(Ent
));
1275 -- Retrieve the now-qualified name of the renamed entity and insert
1276 -- it in the middle of the name, just preceding the suffix encoding
1277 -- describing the renamed object.
1280 Renamed_Id
: constant String :=
1281 Get_Name_String
(Chars
(Debug_Renaming_Link
(Ent
)));
1282 Insert_Len
: constant Integer := Renamed_Id
'Length + 1;
1283 Index
: Natural := Name_Len
- 3;
1286 -- Loop backwards through the name to find the start of the "___"
1287 -- sequence associated with the suffix.
1289 while Index
>= Name_Buffer
'First
1290 and then (Name_Buffer
(Index
+ 1) /= '_'
1291 or else Name_Buffer
(Index
+ 2) /= '_'
1292 or else Name_Buffer
(Index
+ 3) /= '_')
1297 pragma Assert
(Name_Buffer
(Index
+ 1 .. Index
+ 3) = "___");
1299 -- Insert an underscore separator and the entity name just in
1300 -- front of the suffix.
1302 Name_Buffer
(Index
+ 1 + Insert_Len
.. Name_Len
+ Insert_Len
) :=
1303 Name_Buffer
(Index
+ 1 .. Name_Len
);
1304 Name_Buffer
(Index
+ 1) := '_';
1305 Name_Buffer
(Index
+ 2 .. Index
+ Insert_Len
) := Renamed_Id
;
1306 Name_Len
:= Name_Len
+ Insert_Len
;
1309 -- Reset the name of the variable to the new name that includes the
1310 -- name of the renamed entity.
1312 Set_Chars
(Ent
, Name_Enter
);
1314 -- If the entity needs qualification by its scope then develop it
1315 -- here, add the variable's name, and again reset the entity name.
1317 if Qualify_Needed
(Scope
(Ent
)) then
1319 Set_Entity_Name
(Scope
(Ent
));
1320 Add_Str_To_Name_Buffer
("__");
1322 Get_Name_String_And_Append
(Chars
(Ent
));
1324 Set_Chars
(Ent
, Name_Enter
);
1327 Set_Has_Qualified_Name
(Ent
);
1330 elsif Is_Subprogram
(Ent
)
1331 or else Ekind
(Ent
) = E_Subprogram_Body
1332 or else Is_Type
(Ent
)
1334 Fully_Qualify_Name
(Ent
);
1335 Name_Len
:= Full_Qualify_Len
;
1336 Name_Buffer
(1 .. Name_Len
) := Full_Qualify_Name
(1 .. Name_Len
);
1338 elsif Qualify_Needed
(Scope
(Ent
)) then
1340 Set_Entity_Name
(Ent
);
1343 Set_Has_Qualified_Name
(Ent
);
1347 -- Fall through with a fully qualified name in Name_Buffer/Name_Len
1349 Output_Homonym_Numbers_Suffix
;
1351 -- Add body-nested package suffix if required
1353 if BNPE_Suffix_Needed
1354 and then Ekind
(Ent
) /= E_Enumeration_Literal
1356 Set_BNPE_Suffix
(Ent
);
1358 -- Strip trailing n's and last trailing b as required. note that
1359 -- we know there is at least one b, or no suffix would be generated.
1361 while Name_Buffer
(Name_Len
) = 'n' loop
1362 Name_Len
:= Name_Len
- 1;
1365 Name_Len
:= Name_Len
- 1;
1368 Set_Chars
(Ent
, Name_Enter
);
1369 Set_Has_Qualified_Name
(Ent
);
1371 if Debug_Flag_BB
then
1373 Write_Name
(Save_Chars
);
1374 Write_Str
(" qualified as ");
1375 Write_Name
(Chars
(Ent
));
1378 end Qualify_Entity_Name
;
1380 --------------------------
1381 -- Qualify_Entity_Names --
1382 --------------------------
1384 procedure Qualify_Entity_Names
(N
: Node_Id
) is
1386 Name_Qualify_Units
.Append
(N
);
1387 end Qualify_Entity_Names
;
1389 --------------------
1390 -- Strip_Suffixes --
1391 --------------------
1393 procedure Strip_Suffixes
(BNPE_Suffix_Found
: in out Boolean) is
1396 pragma Warnings
(Off
, BNPE_Suffix_Found
);
1397 -- Since this procedure only ever sets the flag
1400 -- Search for and strip BNPE suffix
1402 for J
in reverse 2 .. Name_Len
loop
1403 if Name_Buffer
(J
) = 'X' then
1405 BNPE_Suffix_Found
:= True;
1409 exit when Name_Buffer
(J
) /= 'b' and then Name_Buffer
(J
) /= 'n';
1412 -- Search for and strip homonym numbers suffix
1414 for J
in reverse 2 .. Name_Len
- 2 loop
1415 if Name_Buffer
(J
) = '_'
1416 and then Name_Buffer
(J
+ 1) = '_'
1418 if Name_Buffer
(J
+ 2) in '0' .. '9' then
1419 if Homonym_Len
> 0 then
1420 Homonym_Len
:= Homonym_Len
+ 1;
1421 Homonym_Numbers
(Homonym_Len
) := '-';
1424 SL
:= Name_Len
- (J
+ 1);
1426 Homonym_Numbers
(Homonym_Len
+ 1 .. Homonym_Len
+ SL
) :=
1427 Name_Buffer
(J
+ 2 .. Name_Len
);
1429 Homonym_Len
:= Homonym_Len
+ SL
;