1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2006, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Alloc
; use Alloc
;
28 with Atree
; use Atree
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Namet
; use Namet
;
32 with Nlists
; use Nlists
;
33 with Nmake
; use Nmake
;
35 with Output
; use Output
;
36 with Sem_Eval
; use Sem_Eval
;
37 with Sem_Util
; use Sem_Util
;
38 with Sinfo
; use Sinfo
;
39 with Snames
; use Snames
;
40 with Stand
; use Stand
;
41 with Stringt
; use Stringt
;
43 with Urealp
; use Urealp
;
45 package body Exp_Dbug
is
47 -- The following table is used to queue up the entities passed as
48 -- arguments to Qualify_Entity_Names for later processing when
49 -- Qualify_All_Entity_Names is called.
51 package Name_Qualify_Units
is new Table
.Table
(
52 Table_Component_Type
=> Node_Id
,
53 Table_Index_Type
=> Nat
,
55 Table_Initial
=> Alloc
.Name_Qualify_Units_Initial
,
56 Table_Increment
=> Alloc
.Name_Qualify_Units_Increment
,
57 Table_Name
=> "Name_Qualify_Units");
59 --------------------------------
60 -- Use of Qualification Flags --
61 --------------------------------
63 -- There are two flags used to keep track of qualification of entities
65 -- Has_Fully_Qualified_Name
68 -- The difference between these is as follows. Has_Qualified_Name is
69 -- set to indicate that the name has been qualified as required by the
70 -- spec of this package. As described there, this may involve the full
71 -- qualification for the name, but for some entities, notably procedure
72 -- local variables, this full qualification is not required.
74 -- The flag Has_Fully_Qualified_Name is set if indeed the name has been
75 -- fully qualified in the Ada sense. If Has_Fully_Qualified_Name is set,
76 -- then Has_Qualified_Name is also set, but the other way round is not
79 -- Consider the following example:
86 -- Here B is a procedure local variable, so it does not need fully
87 -- qualification. The flag Has_Qualified_Name will be set on the
88 -- first attempt to qualify B, to indicate that the job is done
89 -- and need not be redone.
91 -- But Y is qualified as x__y, since procedures are always fully
92 -- qualified, so the first time that an attempt is made to qualify
93 -- the name y, it will be replaced by x__y, and both flags are set.
95 -- Why the two flags? Well there are cases where we derive type names
96 -- from object names. As noted in the spec, type names are always
97 -- fully qualified. Suppose for example that the backend has to build
98 -- a padded type for variable B. then it will construct the PAD name
99 -- from B, but it requires full qualification, so the fully qualified
100 -- type name will be x__b___PAD. The two flags allow the circuit for
101 -- building this name to realize efficiently that b needs further
108 -- The string defined here (and its associated length) is used to
109 -- gather the homonym string that will be appended to Name_Buffer
110 -- when the name is complete. Strip_Suffixes appends to this string
111 -- as does Append_Homonym_Number, and Output_Homonym_Numbers_Suffix
112 -- appends the string to the end of Name_Buffer.
114 Homonym_Numbers
: String (1 .. 256);
115 Homonym_Len
: Natural := 0;
117 ----------------------
118 -- Local Procedures --
119 ----------------------
121 procedure Add_Uint_To_Buffer
(U
: Uint
);
122 -- Add image of universal integer to Name_Buffer, updating Name_Len
124 procedure Add_Real_To_Buffer
(U
: Ureal
);
125 -- Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of
126 -- the normalized numerator and denominator of the given real value.
128 procedure Append_Homonym_Number
(E
: Entity_Id
);
129 -- If the entity E has homonyms in the same scope, then make an entry
130 -- in the Homonym_Numbers array, bumping Homonym_Count accordingly.
132 function Bounds_Match_Size
(E
: Entity_Id
) return Boolean;
133 -- Determine whether the bounds of E match the size of the type. This is
134 -- used to determine whether encoding is required for a discrete type.
136 procedure Output_Homonym_Numbers_Suffix
;
137 -- If homonym numbers are stored, then output them into Name_Buffer
139 procedure Prepend_String_To_Buffer
(S
: String);
140 -- Prepend given string to the contents of the string buffer, updating
141 -- the value in Name_Len (i.e. string is added at start of buffer).
143 procedure Prepend_Uint_To_Buffer
(U
: Uint
);
144 -- Prepend image of universal integer to Name_Buffer, updating Name_Len
146 procedure Qualify_Entity_Name
(Ent
: Entity_Id
);
147 -- If not already done, replaces the Chars field of the given entity
148 -- with the appropriate fully qualified name.
150 procedure Strip_Suffixes
(BNPE_Suffix_Found
: in out Boolean);
151 -- Given an qualified entity name in Name_Buffer, remove any plain X or
152 -- X{nb} qualification suffix. The contents of Name_Buffer is not changed
153 -- but Name_Len may be adjusted on return to remove the suffix. If a
154 -- BNPE suffix is found and stripped, then BNPE_Suffix_Found is set to
155 -- True. If no suffix is found, then BNPE_Suffix_Found is not modified.
156 -- This routine also searches for a homonym suffix, and if one is found
157 -- it is also stripped, and the entries are added to the global homonym
158 -- list (Homonym_Numbers) so that they can later be put back.
160 ------------------------
161 -- Add_Real_To_Buffer --
162 ------------------------
164 procedure Add_Real_To_Buffer
(U
: Ureal
) is
166 Add_Uint_To_Buffer
(Norm_Num
(U
));
167 Add_Str_To_Name_Buffer
("_");
168 Add_Uint_To_Buffer
(Norm_Den
(U
));
169 end Add_Real_To_Buffer
;
171 ------------------------
172 -- Add_Uint_To_Buffer --
173 ------------------------
175 procedure Add_Uint_To_Buffer
(U
: Uint
) is
178 Add_Uint_To_Buffer
(-U
);
179 Add_Char_To_Name_Buffer
('m');
181 UI_Image
(U
, Decimal
);
182 Add_Str_To_Name_Buffer
(UI_Image_Buffer
(1 .. UI_Image_Length
));
184 end Add_Uint_To_Buffer
;
186 ---------------------------
187 -- Append_Homonym_Number --
188 ---------------------------
190 procedure Append_Homonym_Number
(E
: Entity_Id
) is
192 procedure Add_Nat_To_H
(Nr
: Nat
);
193 -- Little procedure to append Nr to Homonym_Numbers
199 procedure Add_Nat_To_H
(Nr
: Nat
) is
202 Add_Nat_To_H
(Nr
/ 10);
205 Homonym_Len
:= Homonym_Len
+ 1;
206 Homonym_Numbers
(Homonym_Len
) :=
207 Character'Val (Nr
mod 10 + Character'Pos ('0'));
210 -- Start of processing for Append_Homonym_Number
213 if Has_Homonym
(E
) then
215 H
: Entity_Id
:= Homonym
(E
);
219 while Present
(H
) loop
220 if Scope
(H
) = Scope
(E
) then
227 if Homonym_Len
> 0 then
228 Homonym_Len
:= Homonym_Len
+ 1;
229 Homonym_Numbers
(Homonym_Len
) := '_';
235 end Append_Homonym_Number
;
237 -----------------------
238 -- Bounds_Match_Size --
239 -----------------------
241 function Bounds_Match_Size
(E
: Entity_Id
) return Boolean is
245 if not Is_OK_Static_Subtype
(E
) then
248 elsif Is_Integer_Type
(E
)
249 and then Subtypes_Statically_Match
(E
, Base_Type
(E
))
253 -- Here we check if the static bounds match the natural size, which is
254 -- the size passed through with the debugging information. This is the
255 -- Esize rounded up to 8, 16, 32 or 64 as appropriate.
259 Umark
: constant Uintp
.Save_Mark
:= Uintp
.Mark
;
263 if Esize
(E
) <= 8 then
265 elsif Esize
(E
) <= 16 then
267 elsif Esize
(E
) <= 32 then
273 if Is_Modular_Integer_Type
(E
) or else Is_Enumeration_Type
(E
) then
275 Expr_Rep_Value
(Type_Low_Bound
(E
)) = 0
277 2 ** Siz
- Expr_Rep_Value
(Type_High_Bound
(E
)) = 1;
281 Expr_Rep_Value
(Type_Low_Bound
(E
)) + 2 ** (Siz
- 1) = 0
283 2 ** (Siz
- 1) - Expr_Rep_Value
(Type_High_Bound
(E
)) = 1;
290 end Bounds_Match_Size
;
292 --------------------------------
293 -- Debug_Renaming_Declaration --
294 --------------------------------
296 function Debug_Renaming_Declaration
(N
: Node_Id
) return Node_Id
is
297 Loc
: constant Source_Ptr
:= Sloc
(N
);
298 Ent
: constant Node_Id
:= Defining_Entity
(N
);
299 Nam
: constant Node_Id
:= Name
(N
);
307 function Output_Subscript
(N
: Node_Id
; S
: String) return Boolean;
308 -- Outputs a single subscript value as ?nnn (subscript is compile time
309 -- known value with value nnn) or as ?e (subscript is local constant
310 -- with name e), where S supplies the proper string to use for ?.
311 -- Returns False if the subscript is not of an appropriate type to
312 -- output in one of these two forms. The result is prepended to the
313 -- name stored in Name_Buffer.
315 ----------------------
316 -- Output_Subscript --
317 ----------------------
319 function Output_Subscript
(N
: Node_Id
; S
: String) return Boolean is
321 if Compile_Time_Known_Value
(N
) then
322 Prepend_Uint_To_Buffer
(Expr_Value
(N
));
324 elsif Nkind
(N
) = N_Identifier
325 and then Scope
(Entity
(N
)) = Scope
(Ent
)
326 and then Ekind
(Entity
(N
)) = E_Constant
328 Prepend_String_To_Buffer
(Get_Name_String
(Chars
(Entity
(N
))));
334 Prepend_String_To_Buffer
(S
);
336 end Output_Subscript
;
338 -- Start of processing for Debug_Renaming_Declaration
341 if not Comes_From_Source
(N
)
342 and then not Needs_Debug_Info
(Ent
)
347 -- Prepare entity name for type declaration
349 Get_Name_String
(Chars
(Ent
));
352 when N_Object_Renaming_Declaration
=>
353 Add_Str_To_Name_Buffer
("___XR");
355 when N_Exception_Renaming_Declaration
=>
356 Add_Str_To_Name_Buffer
("___XRE");
358 when N_Package_Renaming_Declaration
=>
359 Add_Str_To_Name_Buffer
("___XRP");
361 -- If it is a child unit create a fully qualified name, to
362 -- disambiguate multiple child units with the same name and
363 -- different parents.
365 if Is_Child_Unit
(Ent
) then
366 Prepend_String_To_Buffer
("__");
367 Prepend_String_To_Buffer
368 (Get_Name_String
(Chars
(Scope
(Ent
))));
377 -- Get renamed entity and compute suffix
387 when N_Expanded_Name
=>
389 -- The entity field for an N_Expanded_Name is on the expanded
390 -- name node itself, so we are done here too.
394 when N_Selected_Component
=>
395 Prepend_String_To_Buffer
396 (Get_Name_String
(Chars
(Selector_Name
(Ren
))));
397 Prepend_String_To_Buffer
("XR");
400 when N_Indexed_Component
=>
402 X
: Node_Id
:= Last
(Expressions
(Ren
));
405 while Present
(X
) loop
406 if not Output_Subscript
(X
, "XS") then
407 Set_Materialize_Entity
(Ent
);
419 Typ
:= Etype
(First_Index
(Etype
(Nam
)));
421 if not Output_Subscript
(Type_High_Bound
(Typ
), "XS") then
422 Set_Materialize_Entity
(Ent
);
426 if not Output_Subscript
(Type_Low_Bound
(Typ
), "XL") then
427 Set_Materialize_Entity
(Ent
);
433 when N_Explicit_Dereference
=>
434 Set_Materialize_Entity
(Ent
);
435 Prepend_String_To_Buffer
("XA");
438 -- For now, anything else simply results in no translation
441 Set_Materialize_Entity
(Ent
);
446 Prepend_String_To_Buffer
("___XE");
448 -- For now, the literal name contains only the suffix. The Entity_Id
449 -- value for the name is used to create a link from this literal name
450 -- to the renamed entity using the Debug_Renaming_Link field. Then the
451 -- Qualify_Entity_Name procedure uses this link to create the proper
452 -- fully qualified name.
454 -- The reason we do things this way is that we really need to copy the
455 -- qualification of the renamed entity, and it is really much easier to
456 -- do this after the renamed entity has itself been fully qualified.
458 Lit
:= Make_Defining_Identifier
(Loc
, Chars
=> Name_Enter
);
459 Set_Debug_Renaming_Link
(Lit
, Entity
(Ren
));
461 -- Return the appropriate enumeration type
463 Def
:= Make_Defining_Identifier
(Loc
, Chars
=> Rnm
);
465 Make_Full_Type_Declaration
(Loc
,
466 Defining_Identifier
=> Def
,
468 Make_Enumeration_Type_Definition
(Loc
,
469 Literals
=> New_List
(Lit
)));
471 Set_Needs_Debug_Info
(Def
);
472 Set_Needs_Debug_Info
(Lit
);
474 Set_Discard_Names
(Defining_Identifier
(Res
));
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
497 -- names, and problems when the back-end is called to annotate
498 -- types without full code generation. See comments at beginning
499 -- of Get_External_Name_With_Suffix for additional details.
501 if Operating_Mode
/= Generate_Code
then
505 Get_Name_String
(Chars
(E
));
507 -- Nothing to do if we do not have a type
511 -- Or if this is an enumeration base type
513 or else (Is_Enumeration_Type
(E
)
514 and then E
= Base_Type
(E
))
516 -- Or if this is a dummy type for a renaming
518 or else (Name_Len
>= 3 and then
519 Name_Buffer
(Name_Len
- 2 .. Name_Len
) = "_XR")
521 or else (Name_Len
>= 4 and then
522 (Name_Buffer
(Name_Len
- 3 .. Name_Len
) = "_XRE"
524 Name_Buffer
(Name_Len
- 3 .. Name_Len
) = "_XRP"))
526 -- For all these cases, just return the name unchanged
529 Name_Buffer
(Name_Len
+ 1) := ASCII
.Nul
;
537 if Is_Fixed_Point_Type
(E
) then
538 Get_External_Name_With_Suffix
(E
, "XF_");
539 Add_Real_To_Buffer
(Delta_Value
(E
));
541 if Small_Value
(E
) /= Delta_Value
(E
) then
542 Add_Str_To_Name_Buffer
("_");
543 Add_Real_To_Buffer
(Small_Value
(E
));
546 -- Vax floating-point case
548 elsif Vax_Float
(E
) then
550 if Digits_Value
(Base_Type
(E
)) = 6 then
551 Get_External_Name_With_Suffix
(E
, "XFF");
553 elsif Digits_Value
(Base_Type
(E
)) = 9 then
554 Get_External_Name_With_Suffix
(E
, "XFF");
557 pragma Assert
(Digits_Value
(Base_Type
(E
)) = 15);
558 Get_External_Name_With_Suffix
(E
, "XFG");
561 -- Discrete case where bounds do not match size
563 elsif Is_Discrete_Type
(E
)
564 and then not Bounds_Match_Size
(E
)
567 Lo
: constant Node_Id
:= Type_Low_Bound
(E
);
568 Hi
: constant Node_Id
:= Type_High_Bound
(E
);
570 Lo_Con
: constant Boolean := Compile_Time_Known_Value
(Lo
);
571 Hi_Con
: constant Boolean := Compile_Time_Known_Value
(Hi
);
573 Lo_Discr
: constant Boolean :=
574 Nkind
(Lo
) = N_Identifier
576 Ekind
(Entity
(Lo
)) = E_Discriminant
;
578 Hi_Discr
: constant Boolean :=
579 Nkind
(Hi
) = N_Identifier
581 Ekind
(Entity
(Hi
)) = E_Discriminant
;
583 Lo_Encode
: constant Boolean := Lo_Con
or Lo_Discr
;
584 Hi_Encode
: constant Boolean := Hi_Con
or Hi_Discr
;
586 Biased
: constant Boolean := Has_Biased_Representation
(E
);
590 Get_External_Name_With_Suffix
(E
, "XB");
592 Get_External_Name_With_Suffix
(E
, "XD");
595 if Lo_Encode
or Hi_Encode
then
597 Add_Str_To_Name_Buffer
("_");
601 Add_Str_To_Name_Buffer
("LU_");
603 Add_Str_To_Name_Buffer
("L_");
606 Add_Str_To_Name_Buffer
("U_");
611 Add_Uint_To_Buffer
(Expr_Rep_Value
(Lo
));
613 Get_Name_String_And_Append
(Chars
(Entity
(Lo
)));
616 if Lo_Encode
and Hi_Encode
then
617 Add_Str_To_Name_Buffer
("__");
621 Add_Uint_To_Buffer
(Expr_Rep_Value
(Hi
));
623 Get_Name_String_And_Append
(Chars
(Entity
(Hi
)));
628 -- For all other cases, the encoded name is the normal type name
632 Get_External_Name
(E
, Has_Suffix
);
635 if Debug_Flag_B
and then Has_Suffix
then
636 Write_Str
("**** type ");
637 Write_Name
(Chars
(E
));
638 Write_Str
(" is encoded as ");
639 Write_Str
(Name_Buffer
(1 .. Name_Len
));
643 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
644 end Get_Encoded_Name
;
646 -----------------------
647 -- Get_External_Name --
648 -----------------------
650 procedure Get_External_Name
(Entity
: Entity_Id
; Has_Suffix
: Boolean) is
651 E
: Entity_Id
:= Entity
;
654 procedure Get_Qualified_Name_And_Append
(Entity
: Entity_Id
);
655 -- Appends fully qualified name of given entity to Name_Buffer
657 -----------------------------------
658 -- Get_Qualified_Name_And_Append --
659 -----------------------------------
661 procedure Get_Qualified_Name_And_Append
(Entity
: Entity_Id
) is
663 -- If the entity is a compilation unit, its scope is Standard,
664 -- there is no outer scope, and the no further qualification
667 -- If the front end has already computed a fully qualified name,
668 -- then it is also the case that no further qualification is
671 if Present
(Scope
(Scope
(Entity
)))
672 and then not Has_Fully_Qualified_Name
(Entity
)
674 Get_Qualified_Name_And_Append
(Scope
(Entity
));
675 Add_Str_To_Name_Buffer
("__");
676 Get_Name_String_And_Append
(Chars
(Entity
));
677 Append_Homonym_Number
(Entity
);
680 Get_Name_String_And_Append
(Chars
(Entity
));
683 end Get_Qualified_Name_And_Append
;
685 -- Start of processing for Get_External_Name
690 -- If this is a child unit, we want the child
692 if Nkind
(E
) = N_Defining_Program_Unit_Name
then
693 E
:= Defining_Identifier
(Entity
);
698 -- Case of interface name being used
700 if (Kind
= E_Procedure
or else
701 Kind
= E_Function
or else
702 Kind
= E_Constant
or else
703 Kind
= E_Variable
or else
705 and then Present
(Interface_Name
(E
))
706 and then No
(Address_Clause
(E
))
707 and then not Has_Suffix
709 Add_String_To_Name_Buffer
(Strval
(Interface_Name
(E
)));
711 -- All other cases besides the interface name case
714 -- If this is a library level subprogram (i.e. a subprogram that is a
715 -- compilation unit other than a subunit), then we prepend _ada_ to
716 -- ensure distinctions required as described in the spec.
718 -- Check explicitly for child units, because those are not flagged
719 -- as Compilation_Units by lib. Should they be ???
722 and then (Is_Compilation_Unit
(E
) or Is_Child_Unit
(E
))
723 and then not Has_Suffix
725 Add_Str_To_Name_Buffer
("_ada_");
728 -- If the entity is a subprogram instance that is not a compilation
729 -- unit, generate the name of the original Ada entity, which is the
732 if Is_Generic_Instance
(E
)
733 and then Is_Subprogram
(E
)
734 and then not Is_Compilation_Unit
(Scope
(E
))
735 and then (Ekind
(Scope
(E
)) = E_Package
737 Ekind
(Scope
(E
)) = E_Package_Body
)
738 and then Present
(Related_Instance
(Scope
(E
)))
740 E
:= Related_Instance
(Scope
(E
));
743 Get_Qualified_Name_And_Append
(E
);
746 Name_Buffer
(Name_Len
+ 1) := ASCII
.Nul
;
747 end Get_External_Name
;
749 -----------------------------------
750 -- Get_External_Name_With_Suffix --
751 -----------------------------------
753 procedure Get_External_Name_With_Suffix
757 Has_Suffix
: constant Boolean := (Suffix
/= "");
760 -- If we are not in code generation mode, this procedure may still be
761 -- called from Back_End (more specifically - from gigi for doing type
762 -- representation annotation or some representation-specific checks).
763 -- But in this mode there is no need to mess with external names.
765 -- Furthermore, the call causes difficulties in this case because the
766 -- string representing the homonym number is not correctly reset as a
767 -- part of the call to Output_Homonym_Numbers_Suffix (which is not
770 if Operating_Mode
/= Generate_Code
then
774 Get_External_Name
(Entity
, Has_Suffix
);
777 Add_Str_To_Name_Buffer
("___");
778 Add_Str_To_Name_Buffer
(Suffix
);
779 Name_Buffer
(Name_Len
+ 1) := ASCII
.Nul
;
781 end Get_External_Name_With_Suffix
;
783 --------------------------
784 -- Get_Variant_Encoding --
785 --------------------------
787 procedure Get_Variant_Encoding
(V
: Node_Id
) is
790 procedure Choice_Val
(Typ
: Character; Choice
: Node_Id
);
791 -- Output encoded value for a single choice value. Typ is the key
792 -- character ('S', 'F', or 'T') that precedes the choice value.
798 procedure Choice_Val
(Typ
: Character; Choice
: Node_Id
) is
800 if Nkind
(Choice
) = N_Integer_Literal
then
801 Add_Char_To_Name_Buffer
(Typ
);
802 Add_Uint_To_Buffer
(Intval
(Choice
));
804 -- Character literal with no entity present (this is the case
805 -- Standard.Character or Standard.Wide_Character as root type)
807 elsif Nkind
(Choice
) = N_Character_Literal
808 and then No
(Entity
(Choice
))
810 Add_Char_To_Name_Buffer
(Typ
);
811 Add_Uint_To_Buffer
(Char_Literal_Value
(Choice
));
815 Ent
: constant Entity_Id
:= Entity
(Choice
);
818 if Ekind
(Ent
) = E_Enumeration_Literal
then
819 Add_Char_To_Name_Buffer
(Typ
);
820 Add_Uint_To_Buffer
(Enumeration_Rep
(Ent
));
823 pragma Assert
(Ekind
(Ent
) = E_Constant
);
824 Choice_Val
(Typ
, Constant_Value
(Ent
));
830 -- Start of processing for Get_Variant_Encoding
835 Choice
:= First
(Discrete_Choices
(V
));
836 while Present
(Choice
) loop
837 if Nkind
(Choice
) = N_Others_Choice
then
838 Add_Char_To_Name_Buffer
('O');
840 elsif Nkind
(Choice
) = N_Range
then
841 Choice_Val
('R', Low_Bound
(Choice
));
842 Choice_Val
('T', High_Bound
(Choice
));
844 elsif Is_Entity_Name
(Choice
)
845 and then Is_Type
(Entity
(Choice
))
847 Choice_Val
('R', Type_Low_Bound
(Entity
(Choice
)));
848 Choice_Val
('T', Type_High_Bound
(Entity
(Choice
)));
850 elsif Nkind
(Choice
) = N_Subtype_Indication
then
852 Rang
: constant Node_Id
:=
853 Range_Expression
(Constraint
(Choice
));
855 Choice_Val
('R', Low_Bound
(Rang
));
856 Choice_Val
('T', High_Bound
(Rang
));
860 Choice_Val
('S', Choice
);
866 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
870 VP
: constant Node_Id
:= Parent
(V
); -- Variant_Part
871 CL
: constant Node_Id
:= Parent
(VP
); -- Component_List
872 RD
: constant Node_Id
:= Parent
(CL
); -- Record_Definition
873 FT
: constant Node_Id
:= Parent
(RD
); -- Full_Type_Declaration
876 Write_Str
("**** variant for type ");
877 Write_Name
(Chars
(Defining_Identifier
(FT
)));
878 Write_Str
(" is encoded as ");
879 Write_Str
(Name_Buffer
(1 .. Name_Len
));
883 end Get_Variant_Encoding
;
885 ------------------------------------
886 -- Get_Secondary_DT_External_Name --
887 ------------------------------------
889 procedure Get_Secondary_DT_External_Name
891 Ancestor_Typ
: Entity_Id
;
892 Suffix_Index
: Int
) is
894 Get_External_Name
(Typ
, Has_Suffix
=> False);
896 if Ancestor_Typ
/= Typ
then
898 Len
: constant Natural := Name_Len
;
899 Save_Str
: constant String (1 .. Name_Len
)
900 := Name_Buffer
(1 .. Name_Len
);
902 Get_External_Name
(Ancestor_Typ
, Has_Suffix
=> False);
904 -- Append the extended name of the ancestor to the
905 -- extended name of Typ
907 Name_Buffer
(Len
+ 2 .. Len
+ Name_Len
+ 1) :=
908 Name_Buffer
(1 .. Name_Len
);
909 Name_Buffer
(1 .. Len
) := Save_Str
;
910 Name_Buffer
(Len
+ 1) := '_';
911 Name_Len
:= Len
+ Name_Len
+ 1;
915 Add_Nat_To_Name_Buffer
(Suffix_Index
);
916 end Get_Secondary_DT_External_Name
;
918 ---------------------------------
919 -- Make_Packed_Array_Type_Name --
920 ---------------------------------
922 function Make_Packed_Array_Type_Name
928 Get_Name_String
(Chars
(Typ
));
929 Add_Str_To_Name_Buffer
("___XP");
930 Add_Uint_To_Buffer
(Csize
);
932 end Make_Packed_Array_Type_Name
;
934 -----------------------------------
935 -- Output_Homonym_Numbers_Suffix --
936 -----------------------------------
938 procedure Output_Homonym_Numbers_Suffix
is
942 if Homonym_Len
> 0 then
944 -- Check for all 1's, in which case we do not output
948 exit when Homonym_Numbers
(J
) /= '1';
950 -- If we reached end of string we do not output
952 if J
= Homonym_Len
then
957 exit when Homonym_Numbers
(J
+ 1) /= '_';
961 -- If we exit the loop then suffix must be output
963 Add_Str_To_Name_Buffer
("__");
964 Add_Str_To_Name_Buffer
(Homonym_Numbers
(1 .. Homonym_Len
));
967 end Output_Homonym_Numbers_Suffix
;
969 ------------------------------
970 -- Prepend_String_To_Buffer --
971 ------------------------------
973 procedure Prepend_String_To_Buffer
(S
: String) is
974 N
: constant Integer := S
'Length;
976 Name_Buffer
(1 + N
.. Name_Len
+ N
) := Name_Buffer
(1 .. Name_Len
);
977 Name_Buffer
(1 .. N
) := S
;
978 Name_Len
:= Name_Len
+ N
;
979 end Prepend_String_To_Buffer
;
981 ----------------------------
982 -- Prepend_Uint_To_Buffer --
983 ----------------------------
985 procedure Prepend_Uint_To_Buffer
(U
: Uint
) is
988 Prepend_String_To_Buffer
("m");
989 Prepend_Uint_To_Buffer
(-U
);
991 UI_Image
(U
, Decimal
);
992 Prepend_String_To_Buffer
(UI_Image_Buffer
(1 .. UI_Image_Length
));
994 end Prepend_Uint_To_Buffer
;
996 ------------------------------
997 -- Qualify_All_Entity_Names --
998 ------------------------------
1000 procedure Qualify_All_Entity_Names
is
1005 for J
in Name_Qualify_Units
.First
.. Name_Qualify_Units
.Last
loop
1006 E
:= Defining_Entity
(Name_Qualify_Units
.Table
(J
));
1007 Qualify_Entity_Name
(E
);
1009 Ent
:= First_Entity
(E
);
1010 while Present
(Ent
) loop
1011 Qualify_Entity_Name
(Ent
);
1014 -- There are odd cases where Last_Entity (E) = E. This happens
1015 -- in the case of renaming of packages. This test avoids getting
1016 -- stuck in such cases.
1021 end Qualify_All_Entity_Names
;
1023 -------------------------
1024 -- Qualify_Entity_Name --
1025 -------------------------
1027 procedure Qualify_Entity_Name
(Ent
: Entity_Id
) is
1029 Full_Qualify_Name
: String (1 .. Name_Buffer
'Length);
1030 Full_Qualify_Len
: Natural := 0;
1031 -- Used to accumulate fully qualified name of subprogram
1033 procedure Fully_Qualify_Name
(E
: Entity_Id
);
1034 -- Used to qualify a subprogram or type name, where full
1035 -- qualification up to Standard is always used. Name is set
1036 -- in Full_Qualify_Name with the length in Full_Qualify_Len.
1037 -- Note that this routine does not prepend the _ada_ string
1038 -- required for library subprograms (this is done in the back end).
1040 function Is_BNPE
(S
: Entity_Id
) return Boolean;
1041 -- Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
1042 -- is defined to be a package which is immediately nested within a
1045 function Qualify_Needed
(S
: Entity_Id
) return Boolean;
1046 -- Given a scope, determines if the scope is to be included in the
1047 -- fully qualified name, True if so, False if not.
1049 procedure Set_BNPE_Suffix
(E
: Entity_Id
);
1050 -- Recursive routine to append the BNPE qualification suffix. Works
1051 -- from right to left with E being the current entity in the list.
1052 -- The result does NOT have the trailing n's and trailing b stripped.
1053 -- The caller must do this required stripping.
1055 procedure Set_Entity_Name
(E
: Entity_Id
);
1056 -- Internal recursive routine that does most of the work. This routine
1057 -- leaves the result sitting in Name_Buffer and Name_Len.
1059 BNPE_Suffix_Needed
: Boolean := False;
1060 -- Set true if a body-nested package entity suffix is required
1062 Save_Chars
: constant Name_Id
:= Chars
(Ent
);
1063 -- Save original name
1065 ------------------------
1066 -- Fully_Qualify_Name --
1067 ------------------------
1069 procedure Fully_Qualify_Name
(E
: Entity_Id
) is
1070 Discard
: Boolean := False;
1073 -- Ignore empty entry (can happen in error cases)
1078 -- If this we are qualifying entities local to a generic
1079 -- instance, use the name of the original instantiation,
1080 -- not that of the anonymous subprogram in the wrapper
1081 -- package, so that gdb doesn't have to know about these.
1083 elsif Is_Generic_Instance
(E
)
1084 and then Is_Subprogram
(E
)
1085 and then not Comes_From_Source
(E
)
1086 and then not Is_Compilation_Unit
(Scope
(E
))
1088 Fully_Qualify_Name
(Related_Instance
(Scope
(E
)));
1092 -- If we reached fully qualified name, then just copy it
1094 if Has_Fully_Qualified_Name
(E
) then
1095 Get_Name_String
(Chars
(E
));
1096 Strip_Suffixes
(Discard
);
1097 Full_Qualify_Name
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
1098 Full_Qualify_Len
:= Name_Len
;
1099 Set_Has_Fully_Qualified_Name
(Ent
);
1101 -- Case of non-fully qualified name
1104 if Scope
(E
) = Standard_Standard
then
1105 Set_Has_Fully_Qualified_Name
(Ent
);
1107 Fully_Qualify_Name
(Scope
(E
));
1108 Full_Qualify_Name
(Full_Qualify_Len
+ 1) := '_';
1109 Full_Qualify_Name
(Full_Qualify_Len
+ 2) := '_';
1110 Full_Qualify_Len
:= Full_Qualify_Len
+ 2;
1113 if Has_Qualified_Name
(E
) then
1114 Get_Unqualified_Name_String
(Chars
(E
));
1116 Get_Name_String
(Chars
(E
));
1119 -- A special check here, we never add internal block or loop
1120 -- names, since they intefere with debugging. We identify these
1121 -- by the fact that they start with an upper case B or L.
1122 -- But do add these if what we are qualifying is a __clean
1123 -- procedure since those need to be made unique.
1125 if (Name_Buffer
(1) = 'B' or else Name_Buffer
(1) = 'L')
1126 and then (not Debug_Flag_VV
)
1127 and then Full_Qualify_Len
> 2
1128 and then Chars
(Ent
) /= Name_uClean
1130 Full_Qualify_Len
:= Full_Qualify_Len
- 2;
1134 (Full_Qualify_Len
+ 1 .. Full_Qualify_Len
+ Name_Len
) :=
1135 Name_Buffer
(1 .. Name_Len
);
1136 Full_Qualify_Len
:= Full_Qualify_Len
+ Name_Len
;
1137 Append_Homonym_Number
(E
);
1142 BNPE_Suffix_Needed
:= True;
1144 end Fully_Qualify_Name
;
1150 function Is_BNPE
(S
: Entity_Id
) return Boolean is
1153 Ekind
(S
) = E_Package
1154 and then Is_Package_Body_Entity
(S
);
1157 --------------------
1158 -- Qualify_Needed --
1159 --------------------
1161 function Qualify_Needed
(S
: Entity_Id
) return Boolean is
1163 -- If we got all the way to Standard, then we have certainly
1164 -- fully qualified the name, so set the flag appropriately,
1165 -- and then return False, since we are most certainly done!
1167 if S
= Standard_Standard
then
1168 Set_Has_Fully_Qualified_Name
(Ent
, True);
1171 -- Otherwise figure out if further qualification is required
1177 Ekind
(Ent
) = E_Subprogram_Body
1179 (Ekind
(S
) /= E_Block
1180 and then not Is_Dynamic_Scope
(S
));
1184 ---------------------
1185 -- Set_BNPE_Suffix --
1186 ---------------------
1188 procedure Set_BNPE_Suffix
(E
: Entity_Id
) is
1189 S
: constant Entity_Id
:= Scope
(E
);
1192 if Qualify_Needed
(S
) then
1193 Set_BNPE_Suffix
(S
);
1196 Add_Char_To_Name_Buffer
('b');
1198 Add_Char_To_Name_Buffer
('n');
1202 Add_Char_To_Name_Buffer
('X');
1204 end Set_BNPE_Suffix
;
1206 ---------------------
1207 -- Set_Entity_Name --
1208 ---------------------
1210 procedure Set_Entity_Name
(E
: Entity_Id
) is
1211 S
: constant Entity_Id
:= Scope
(E
);
1214 -- If we reach an already qualified name, just take the encoding
1215 -- except that we strip the package body suffixes, since these
1216 -- will be separately put on later.
1218 if Has_Qualified_Name
(E
) then
1219 Get_Name_String_And_Append
(Chars
(E
));
1220 Strip_Suffixes
(BNPE_Suffix_Needed
);
1222 -- If the top level name we are adding is itself fully
1223 -- qualified, then that means that the name that we are
1224 -- preparing for the Fully_Qualify_Name call will also
1225 -- generate a fully qualified name.
1227 if Has_Fully_Qualified_Name
(E
) then
1228 Set_Has_Fully_Qualified_Name
(Ent
);
1231 -- Case where upper level name is not encoded yet
1234 -- Recurse if further qualification required
1236 if Qualify_Needed
(S
) then
1237 Set_Entity_Name
(S
);
1238 Add_Str_To_Name_Buffer
("__");
1241 -- Otherwise get name and note if it is a NPBE
1243 Get_Name_String_And_Append
(Chars
(E
));
1246 BNPE_Suffix_Needed
:= True;
1249 Append_Homonym_Number
(E
);
1251 end Set_Entity_Name
;
1253 -- Start of processing for Qualify_Entity_Name
1256 if Has_Qualified_Name
(Ent
) then
1259 -- Here is where we create the proper link for renaming
1261 elsif Ekind
(Ent
) = E_Enumeration_Literal
1262 and then Present
(Debug_Renaming_Link
(Ent
))
1265 Qualify_Entity_Name
(Debug_Renaming_Link
(Ent
));
1266 Get_Name_String
(Chars
(Ent
));
1267 Prepend_String_To_Buffer
1268 (Get_Name_String
(Chars
(Debug_Renaming_Link
(Ent
))));
1269 Set_Chars
(Ent
, Name_Enter
);
1270 Set_Has_Qualified_Name
(Ent
);
1273 elsif Is_Subprogram
(Ent
)
1274 or else Ekind
(Ent
) = E_Subprogram_Body
1275 or else Is_Type
(Ent
)
1277 Fully_Qualify_Name
(Ent
);
1278 Name_Len
:= Full_Qualify_Len
;
1279 Name_Buffer
(1 .. Name_Len
) := Full_Qualify_Name
(1 .. Name_Len
);
1281 elsif Qualify_Needed
(Scope
(Ent
)) then
1283 Set_Entity_Name
(Ent
);
1286 Set_Has_Qualified_Name
(Ent
);
1290 -- Fall through with a fully qualified name in Name_Buffer/Name_Len
1292 Output_Homonym_Numbers_Suffix
;
1294 -- Add body-nested package suffix if required
1296 if BNPE_Suffix_Needed
1297 and then Ekind
(Ent
) /= E_Enumeration_Literal
1299 Set_BNPE_Suffix
(Ent
);
1301 -- Strip trailing n's and last trailing b as required. note that
1302 -- we know there is at least one b, or no suffix would be generated.
1304 while Name_Buffer
(Name_Len
) = 'n' loop
1305 Name_Len
:= Name_Len
- 1;
1308 Name_Len
:= Name_Len
- 1;
1311 Set_Chars
(Ent
, Name_Enter
);
1312 Set_Has_Qualified_Name
(Ent
);
1314 if Debug_Flag_BB
then
1316 Write_Name
(Save_Chars
);
1317 Write_Str
(" qualified as ");
1318 Write_Name
(Chars
(Ent
));
1321 end Qualify_Entity_Name
;
1323 --------------------------
1324 -- Qualify_Entity_Names --
1325 --------------------------
1327 procedure Qualify_Entity_Names
(N
: Node_Id
) is
1329 Name_Qualify_Units
.Append
(N
);
1330 end Qualify_Entity_Names
;
1332 --------------------
1333 -- Strip_Suffixes --
1334 --------------------
1336 procedure Strip_Suffixes
(BNPE_Suffix_Found
: in out Boolean) is
1340 -- Search for and strip BNPE suffix
1342 for J
in reverse 2 .. Name_Len
loop
1343 if Name_Buffer
(J
) = 'X' then
1345 BNPE_Suffix_Found
:= True;
1349 exit when Name_Buffer
(J
) /= 'b' and then Name_Buffer
(J
) /= 'n';
1352 -- Search for and strip homonym numbers suffix
1354 for J
in reverse 2 .. Name_Len
- 2 loop
1355 if Name_Buffer
(J
) = '_'
1356 and then Name_Buffer
(J
+ 1) = '_'
1358 if Name_Buffer
(J
+ 2) in '0' .. '9' then
1359 if Homonym_Len
> 0 then
1360 Homonym_Len
:= Homonym_Len
+ 1;
1361 Homonym_Numbers
(Homonym_Len
) := '-';
1364 SL
:= Name_Len
- (J
+ 1);
1366 Homonym_Numbers
(Homonym_Len
+ 1 .. Homonym_Len
+ SL
) :=
1367 Name_Buffer
(J
+ 2 .. Name_Len
);
1369 Homonym_Len
:= Homonym_Len
+ SL
;