File : exp_dbug.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ D B U G --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1996-2016, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
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;
32 with Opt; use Opt;
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;
40 with Table;
41 with Tbuild; use Tbuild;
42 with Urealp; use Urealp;
43
44 package body Exp_Dbug is
45
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.
49
50 package Name_Qualify_Units is new Table.Table (
51 Table_Component_Type => Node_Id,
52 Table_Index_Type => Nat,
53 Table_Low_Bound => 1,
54 Table_Initial => Alloc.Name_Qualify_Units_Initial,
55 Table_Increment => Alloc.Name_Qualify_Units_Increment,
56 Table_Name => "Name_Qualify_Units");
57
58 --------------------------------
59 -- Use of Qualification Flags --
60 --------------------------------
61
62 -- There are two flags used to keep track of qualification of entities
63
64 -- Has_Fully_Qualified_Name
65 -- Has_Qualified_Name
66
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.
72
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
76 -- the case.
77
78 -- Consider the following example:
79
80 -- with ...
81 -- procedure X is
82 -- B : Ddd.Ttt;
83 -- procedure Y is ..
84
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.
89
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.
93
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
101 -- qualification.
102
103 --------------------
104 -- Homonym_Suffix --
105 --------------------
106
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.
112
113 Homonym_Numbers : String (1 .. 256);
114 Homonym_Len : Natural := 0;
115
116 ----------------------
117 -- Local Procedures --
118 ----------------------
119
120 procedure Add_Uint_To_Buffer (U : Uint);
121 -- Add image of universal integer to Name_Buffer, updating Name_Len
122
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.
126
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.
130
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.
134
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.
139
140 procedure Output_Homonym_Numbers_Suffix;
141 -- If homonym numbers are stored, then output them into Name_Buffer
142
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).
146
147 procedure Prepend_Uint_To_Buffer (U : Uint);
148 -- Prepend image of universal integer to Name_Buffer, updating Name_Len
149
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.
153
154 procedure Reset_Buffers;
155 -- Reset the contents of Name_Buffer and Homonym_Numbers by setting their
156 -- respective lengths to zero.
157
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.
167
168 ------------------------
169 -- Add_Real_To_Buffer --
170 ------------------------
171
172 procedure Add_Real_To_Buffer (U : Ureal) is
173 begin
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;
178
179 ------------------------
180 -- Add_Uint_To_Buffer --
181 ------------------------
182
183 procedure Add_Uint_To_Buffer (U : Uint) is
184 begin
185 if U < 0 then
186 Add_Uint_To_Buffer (-U);
187 Add_Char_To_Name_Buffer ('m');
188 else
189 UI_Image (U, Decimal);
190 Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
191 end if;
192 end Add_Uint_To_Buffer;
193
194 ---------------------------
195 -- Append_Homonym_Number --
196 ---------------------------
197
198 procedure Append_Homonym_Number (E : Entity_Id) is
199
200 procedure Add_Nat_To_H (Nr : Nat);
201 -- Little procedure to append Nr to Homonym_Numbers
202
203 ------------------
204 -- Add_Nat_To_H --
205 ------------------
206
207 procedure Add_Nat_To_H (Nr : Nat) is
208 begin
209 if Nr >= 10 then
210 Add_Nat_To_H (Nr / 10);
211 end if;
212
213 Homonym_Len := Homonym_Len + 1;
214 Homonym_Numbers (Homonym_Len) :=
215 Character'Val (Nr mod 10 + Character'Pos ('0'));
216 end Add_Nat_To_H;
217
218 -- Start of processing for Append_Homonym_Number
219
220 begin
221 if Has_Homonym (E) then
222 declare
223 H : Entity_Id := Homonym (E);
224 Nr : Nat := 1;
225
226 begin
227 while Present (H) loop
228 if Scope (H) = Scope (E) then
229 Nr := Nr + 1;
230 end if;
231
232 H := Homonym (H);
233 end loop;
234
235 if Homonym_Len > 0 then
236 Homonym_Len := Homonym_Len + 1;
237 Homonym_Numbers (Homonym_Len) := '_';
238 end if;
239
240 Add_Nat_To_H (Nr);
241 end;
242 end if;
243 end Append_Homonym_Number;
244
245 -----------------------
246 -- Bounds_Match_Size --
247 -----------------------
248
249 function Bounds_Match_Size (E : Entity_Id) return Boolean is
250 Siz : Uint;
251
252 begin
253 if not Is_OK_Static_Subtype (E) then
254 return False;
255
256 elsif Is_Integer_Type (E)
257 and then Subtypes_Statically_Match (E, Base_Type (E))
258 then
259 return True;
260
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.
264
265 else
266 declare
267 Umark : constant Uintp.Save_Mark := Uintp.Mark;
268 Result : Boolean;
269
270 begin
271 if Esize (E) <= 8 then
272 Siz := Uint_8;
273 elsif Esize (E) <= 16 then
274 Siz := Uint_16;
275 elsif Esize (E) <= 32 then
276 Siz := Uint_32;
277 else
278 Siz := Uint_64;
279 end if;
280
281 if Is_Modular_Integer_Type (E) or else Is_Enumeration_Type (E) then
282 Result :=
283 Expr_Rep_Value (Type_Low_Bound (E)) = 0
284 and then
285 2 ** Siz - Expr_Rep_Value (Type_High_Bound (E)) = 1;
286
287 else
288 Result :=
289 Expr_Rep_Value (Type_Low_Bound (E)) + 2 ** (Siz - 1) = 0
290 and then
291 2 ** (Siz - 1) - Expr_Rep_Value (Type_High_Bound (E)) = 1;
292 end if;
293
294 Release (Umark);
295 return Result;
296 end;
297 end if;
298 end Bounds_Match_Size;
299
300 --------------------------------
301 -- Debug_Renaming_Declaration --
302 --------------------------------
303
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);
308 Ren : Node_Id;
309 Typ : Entity_Id;
310 Obj : Entity_Id;
311 Res : Node_Id;
312
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.
319
320 procedure Enable_If_Packed_Array (N : Node_Id);
321 -- Enable encoding generation if N is a packed array
322
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.
330
331 ----------------------------
332 -- Enable_If_Packed_Array --
333 ----------------------------
334
335 procedure Enable_If_Packed_Array (N : Node_Id) is
336 T : constant Entity_Id := Etype (N);
337 begin
338 Enable :=
339 Enable or else (Ekind (T) in Array_Kind
340 and then Present (Packed_Array_Impl_Type (T)));
341 end Enable_If_Packed_Array;
342
343 ----------------------
344 -- Output_Subscript --
345 ----------------------
346
347 function Output_Subscript (N : Node_Id; S : String) return Boolean is
348 begin
349 if Compile_Time_Known_Value (N) then
350 Prepend_Uint_To_Buffer (Expr_Value (N));
351
352 elsif Nkind (N) = N_Identifier
353 and then Scope (Entity (N)) = Scope (Ent)
354 and then Ekind (Entity (N)) = E_Constant
355 then
356 Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N))));
357
358 else
359 return False;
360 end if;
361
362 Prepend_String_To_Buffer (S);
363 return True;
364 end Output_Subscript;
365
366 -- Start of processing for Debug_Renaming_Declaration
367
368 begin
369 if not Comes_From_Source (N)
370 and then not Needs_Debug_Info (Ent)
371 then
372 return Empty;
373 end if;
374
375 -- Get renamed entity and compute suffix
376
377 Name_Len := 0;
378 Ren := Nam;
379 loop
380 case Nkind (Ren) is
381
382 when N_Identifier =>
383 exit;
384
385 when N_Expanded_Name =>
386
387 -- The entity field for an N_Expanded_Name is on the expanded
388 -- name node itself, so we are done here too.
389
390 exit;
391
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");
397 Ren := Prefix (Ren);
398
399 when N_Indexed_Component =>
400 declare
401 X : Node_Id;
402
403 begin
404 Enable_If_Packed_Array (Prefix (Ren));
405
406 X := Last (Expressions (Ren));
407 while Present (X) loop
408 if not Output_Subscript (X, "XS") then
409 Set_Materialize_Entity (Ent);
410 return Empty;
411 end if;
412
413 Prev (X);
414 end loop;
415 end;
416
417 Ren := Prefix (Ren);
418
419 when N_Slice =>
420 Enable_If_Packed_Array (Prefix (Ren));
421 Typ := Etype (First_Index (Etype (Nam)));
422
423 if not Output_Subscript (Type_High_Bound (Typ), "XS") then
424 Set_Materialize_Entity (Ent);
425 return Empty;
426 end if;
427
428 if not Output_Subscript (Type_Low_Bound (Typ), "XL") then
429 Set_Materialize_Entity (Ent);
430 return Empty;
431 end if;
432
433 Ren := Prefix (Ren);
434
435 when N_Explicit_Dereference =>
436 Prepend_String_To_Buffer ("XA");
437 Ren := Prefix (Ren);
438
439 -- For now, anything else simply results in no translation
440
441 when others =>
442 Set_Materialize_Entity (Ent);
443 return Empty;
444 end case;
445 end loop;
446
447 -- If we found no reason here to emit an encoding, stop now
448
449 if not Enable then
450 Set_Materialize_Entity (Ent);
451 return Empty;
452 end if;
453
454 Prepend_String_To_Buffer ("___XE");
455
456 -- Include the designation of the form of renaming
457
458 case Nkind (N) is
459 when N_Object_Renaming_Declaration =>
460 Prepend_String_To_Buffer ("___XR");
461
462 when N_Exception_Renaming_Declaration =>
463 Prepend_String_To_Buffer ("___XRE");
464
465 when N_Package_Renaming_Declaration =>
466 Prepend_String_To_Buffer ("___XRP");
467
468 when others =>
469 return Empty;
470 end case;
471
472 -- Add the name of the renaming entity to the front
473
474 Prepend_String_To_Buffer (Get_Name_String (Chars (Ent)));
475
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.
478
479 if Nkind (N) = N_Package_Renaming_Declaration
480 and then Is_Child_Unit (Ent)
481 then
482 Prepend_String_To_Buffer ("__");
483 Prepend_String_To_Buffer
484 (Get_Name_String (Chars (Scope (Ent))));
485 end if;
486
487 -- Create the special object whose name is the debug encoding for the
488 -- renaming declaration.
489
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.
495
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.
499
500 Obj := Make_Defining_Identifier (Loc, Chars => Name_Enter);
501 Res :=
502 Make_Object_Declaration (Loc,
503 Defining_Identifier => Obj,
504 Object_Definition => New_Occurrence_Of
505 (Standard_Debug_Renaming_Type, Loc));
506
507 Set_Debug_Renaming_Link (Obj, Entity (Ren));
508
509 Set_Debug_Info_Needed (Obj);
510
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.
515
516 Set_Debug_Info_Needed (Entity (Ren));
517
518 -- Mark the object as internal so that it won't be initialized when
519 -- pragma Initialize_Scalars or Normalize_Scalars is in use.
520
521 Set_Is_Internal (Obj);
522
523 return Res;
524
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.
528
529 exception
530 when others =>
531 return Make_Null_Statement (Loc);
532 end Debug_Renaming_Declaration;
533
534 -----------------------------
535 -- Is_Handled_Scale_Factor --
536 -----------------------------
537
538 function Is_Handled_Scale_Factor (U : Ureal) return Boolean is
539 begin
540 -- Keep in sync with gigi (see E_*_Fixed_Point_Type handling in
541 -- decl.c:gnat_to_gnu_entity).
542
543 if UI_Eq (Numerator (U), Uint_1) then
544 if Rbase (U) = 2 or else Rbase (U) = 10 then
545 return True;
546 end if;
547 end if;
548
549 return
550 (UI_Is_In_Int_Range (Norm_Num (U))
551 and then
552 UI_Is_In_Int_Range (Norm_Den (U)));
553 end Is_Handled_Scale_Factor;
554
555 ----------------------
556 -- Get_Encoded_Name --
557 ----------------------
558
559 -- Note: see spec for details on encodings
560
561 procedure Get_Encoded_Name (E : Entity_Id) is
562 Has_Suffix : Boolean;
563
564 begin
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
568 -- details.
569
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.
575
576 -- Couldn't we just test Original_Operating_Mode here? ???
577
578 if Operating_Mode /= Generate_Code and then not Generating_Code then
579 return;
580 end if;
581
582 Get_Name_String (Chars (E));
583
584 -- Nothing to do if we do not have a type
585
586 if not Is_Type (E)
587
588 -- Or if this is an enumeration base type
589
590 or else (Is_Enumeration_Type (E) and then Is_Base_Type (E))
591
592 -- Or if this is a dummy type for a renaming
593
594 or else (Name_Len >= 3 and then
595 Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR")
596
597 or else (Name_Len >= 4 and then
598 (Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
599 or else
600 Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"))
601
602 -- For all these cases, just return the name unchanged
603
604 then
605 Name_Buffer (Name_Len + 1) := ASCII.NUL;
606 return;
607 end if;
608
609 Has_Suffix := True;
610
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.
613
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)))
617 then
618 Get_External_Name (E, True, "XF_");
619 Add_Real_To_Buffer (Delta_Value (E));
620
621 if Small_Value (E) /= Delta_Value (E) then
622 Add_Str_To_Name_Buffer ("_");
623 Add_Real_To_Buffer (Small_Value (E));
624 end if;
625
626 -- Discrete case where bounds do not match size. Not necessary if we can
627 -- emit standard DWARF.
628
629 elsif GNAT_Encodings /= DWARF_GNAT_Encodings_Minimal
630 and then Is_Discrete_Type (E)
631 and then not Bounds_Match_Size (E)
632 then
633 declare
634 Lo : constant Node_Id := Type_Low_Bound (E);
635 Hi : constant Node_Id := Type_High_Bound (E);
636
637 Lo_Con : constant Boolean := Compile_Time_Known_Value (Lo);
638 Hi_Con : constant Boolean := Compile_Time_Known_Value (Hi);
639
640 Lo_Discr : constant Boolean :=
641 Nkind (Lo) = N_Identifier
642 and then Ekind (Entity (Lo)) = E_Discriminant;
643
644 Hi_Discr : constant Boolean :=
645 Nkind (Hi) = N_Identifier
646 and then Ekind (Entity (Hi)) = E_Discriminant;
647
648 Lo_Encode : constant Boolean := Lo_Con or Lo_Discr;
649 Hi_Encode : constant Boolean := Hi_Con or Hi_Discr;
650
651 Biased : constant Boolean := Has_Biased_Representation (E);
652
653 begin
654 if Biased then
655 Get_External_Name (E, True, "XB");
656 else
657 Get_External_Name (E, True, "XD");
658 end if;
659
660 if Lo_Encode or Hi_Encode then
661 if Biased then
662 Add_Str_To_Name_Buffer ("_");
663 else
664 if Lo_Encode then
665 if Hi_Encode then
666 Add_Str_To_Name_Buffer ("LU_");
667 else
668 Add_Str_To_Name_Buffer ("L_");
669 end if;
670 else
671 Add_Str_To_Name_Buffer ("U_");
672 end if;
673 end if;
674
675 if Lo_Con then
676 Add_Uint_To_Buffer (Expr_Rep_Value (Lo));
677 elsif Lo_Discr then
678 Get_Name_String_And_Append (Chars (Entity (Lo)));
679 end if;
680
681 if Lo_Encode and Hi_Encode then
682 Add_Str_To_Name_Buffer ("__");
683 end if;
684
685 if Hi_Con then
686 Add_Uint_To_Buffer (Expr_Rep_Value (Hi));
687 elsif Hi_Discr then
688 Get_Name_String_And_Append (Chars (Entity (Hi)));
689 end if;
690 end if;
691 end;
692
693 -- For all other cases, the encoded name is the normal type name
694
695 else
696 Has_Suffix := False;
697 Get_External_Name (E);
698 end if;
699
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));
705 Write_Eol;
706 end if;
707
708 Name_Buffer (Name_Len + 1) := ASCII.NUL;
709 end Get_Encoded_Name;
710
711 -----------------------
712 -- Get_External_Name --
713 -----------------------
714
715 procedure Get_External_Name
716 (Entity : Entity_Id;
717 Has_Suffix : Boolean := False;
718 Suffix : String := "")
719 is
720 procedure Get_Qualified_Name_And_Append (Entity : Entity_Id);
721 -- Appends fully qualified name of given entity to Name_Buffer
722
723 -----------------------------------
724 -- Get_Qualified_Name_And_Append --
725 -----------------------------------
726
727 procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is
728 begin
729 -- If the entity is a compilation unit, its scope is Standard,
730 -- there is no outer scope, and the no further qualification
731 -- is required.
732
733 -- If the front end has already computed a fully qualified name,
734 -- then it is also the case that no further qualification is
735 -- required.
736
737 if Present (Scope (Scope (Entity)))
738 and then not Has_Fully_Qualified_Name (Entity)
739 then
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);
744
745 else
746 Get_Name_String_And_Append (Chars (Entity));
747 end if;
748 end Get_Qualified_Name_And_Append;
749
750 -- Local variables
751
752 E : Entity_Id := Entity;
753
754 -- Start of processing for Get_External_Name
755
756 begin
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.
761
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
765 -- called in gigi).
766
767 if Operating_Mode /= Generate_Code then
768 return;
769 end if;
770
771 Reset_Buffers;
772
773 -- If this is a child unit, we want the child
774
775 if Nkind (E) = N_Defining_Program_Unit_Name then
776 E := Defining_Identifier (Entity);
777 end if;
778
779 -- Case of interface name being used
780
781 if Ekind_In (E, E_Constant,
782 E_Exception,
783 E_Function,
784 E_Procedure,
785 E_Variable)
786 and then Present (Interface_Name (E))
787 and then No (Address_Clause (E))
788 and then not Has_Suffix
789 then
790 Add_String_To_Name_Buffer (Strval (Interface_Name (E)));
791
792 -- All other cases besides the interface name case
793
794 else
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.
798
799 -- Check explicitly for child units, because those are not flagged
800 -- as Compilation_Units by lib. Should they be ???
801
802 if Is_Subprogram (E)
803 and then (Is_Compilation_Unit (E) or Is_Child_Unit (E))
804 and then not Has_Suffix
805 then
806 Add_Str_To_Name_Buffer ("_ada_");
807 end if;
808
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
811 -- one gdb needs.
812
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)))
818 then
819 E := Related_Instance (Scope (E));
820 end if;
821
822 Get_Qualified_Name_And_Append (E);
823 end if;
824
825 if Has_Suffix then
826 Add_Str_To_Name_Buffer ("___");
827 Add_Str_To_Name_Buffer (Suffix);
828 end if;
829
830 Name_Buffer (Name_Len + 1) := ASCII.NUL;
831 end Get_External_Name;
832
833 --------------------------
834 -- Get_Variant_Encoding --
835 --------------------------
836
837 procedure Get_Variant_Encoding (V : Node_Id) is
838 Choice : Node_Id;
839
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.
843
844 ----------------
845 -- Choice_Val --
846 ----------------
847
848 procedure Choice_Val (Typ : Character; Choice : Node_Id) is
849 begin
850 if Nkind (Choice) = N_Integer_Literal then
851 Add_Char_To_Name_Buffer (Typ);
852 Add_Uint_To_Buffer (Intval (Choice));
853
854 -- Character literal with no entity present (this is the case
855 -- Standard.Character or Standard.Wide_Character as root type)
856
857 elsif Nkind (Choice) = N_Character_Literal
858 and then No (Entity (Choice))
859 then
860 Add_Char_To_Name_Buffer (Typ);
861 Add_Uint_To_Buffer (Char_Literal_Value (Choice));
862
863 else
864 declare
865 Ent : constant Entity_Id := Entity (Choice);
866
867 begin
868 if Ekind (Ent) = E_Enumeration_Literal then
869 Add_Char_To_Name_Buffer (Typ);
870 Add_Uint_To_Buffer (Enumeration_Rep (Ent));
871
872 else
873 pragma Assert (Ekind (Ent) = E_Constant);
874 Choice_Val (Typ, Constant_Value (Ent));
875 end if;
876 end;
877 end if;
878 end Choice_Val;
879
880 -- Start of processing for Get_Variant_Encoding
881
882 begin
883 Name_Len := 0;
884
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');
889
890 elsif Nkind (Choice) = N_Range then
891 Choice_Val ('R', Low_Bound (Choice));
892 Choice_Val ('T', High_Bound (Choice));
893
894 elsif Is_Entity_Name (Choice)
895 and then Is_Type (Entity (Choice))
896 then
897 Choice_Val ('R', Type_Low_Bound (Entity (Choice)));
898 Choice_Val ('T', Type_High_Bound (Entity (Choice)));
899
900 elsif Nkind (Choice) = N_Subtype_Indication then
901 declare
902 Rang : constant Node_Id :=
903 Range_Expression (Constraint (Choice));
904 begin
905 Choice_Val ('R', Low_Bound (Rang));
906 Choice_Val ('T', High_Bound (Rang));
907 end;
908
909 else
910 Choice_Val ('S', Choice);
911 end if;
912
913 Next (Choice);
914 end loop;
915
916 Name_Buffer (Name_Len + 1) := ASCII.NUL;
917
918 if Debug_Flag_B then
919 declare
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
924
925 begin
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));
930 Write_Eol;
931 end;
932 end if;
933 end Get_Variant_Encoding;
934
935 -----------------------------------------
936 -- Build_Subprogram_Instance_Renamings --
937 -----------------------------------------
938
939 procedure Build_Subprogram_Instance_Renamings
940 (N : Node_Id;
941 Wrapper : Entity_Id)
942 is
943 Loc : Source_Ptr;
944 Decl : Node_Id;
945 E : Entity_Id;
946
947 begin
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))
952 then
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));
959
960 Append (Decl, Declarations (N));
961 Set_Needs_Debug_Info (Defining_Identifier (Decl));
962 end if;
963
964 Next_Entity (E);
965 end loop;
966 end Build_Subprogram_Instance_Renamings;
967
968 ------------------------------------
969 -- Get_Secondary_DT_External_Name --
970 ------------------------------------
971
972 procedure Get_Secondary_DT_External_Name
973 (Typ : Entity_Id;
974 Ancestor_Typ : Entity_Id;
975 Suffix_Index : Int)
976 is
977 begin
978 Get_External_Name (Typ);
979
980 if Ancestor_Typ /= Typ then
981 declare
982 Len : constant Natural := Name_Len;
983 Save_Str : constant String (1 .. Name_Len)
984 := Name_Buffer (1 .. Name_Len);
985 begin
986 Get_External_Name (Ancestor_Typ);
987
988 -- Append the extended name of the ancestor to the
989 -- extended name of Typ
990
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;
996 end;
997 end if;
998
999 Add_Nat_To_Name_Buffer (Suffix_Index);
1000 end Get_Secondary_DT_External_Name;
1001
1002 ---------------------------------
1003 -- Make_Packed_Array_Impl_Type_Name --
1004 ---------------------------------
1005
1006 function Make_Packed_Array_Impl_Type_Name
1007 (Typ : Entity_Id;
1008 Csize : Uint)
1009 return Name_Id
1010 is
1011 begin
1012 Get_Name_String (Chars (Typ));
1013 Add_Str_To_Name_Buffer ("___XP");
1014 Add_Uint_To_Buffer (Csize);
1015 return Name_Find;
1016 end Make_Packed_Array_Impl_Type_Name;
1017
1018 -----------------------------------
1019 -- Output_Homonym_Numbers_Suffix --
1020 -----------------------------------
1021
1022 procedure Output_Homonym_Numbers_Suffix is
1023 J : Natural;
1024
1025 begin
1026 if Homonym_Len > 0 then
1027
1028 -- Check for all 1's, in which case we do not output
1029
1030 J := 1;
1031 loop
1032 exit when Homonym_Numbers (J) /= '1';
1033
1034 -- If we reached end of string we do not output
1035
1036 if J = Homonym_Len then
1037 Homonym_Len := 0;
1038 return;
1039 end if;
1040
1041 exit when Homonym_Numbers (J + 1) /= '_';
1042 J := J + 2;
1043 end loop;
1044
1045 -- If we exit the loop then suffix must be output
1046
1047 Add_Str_To_Name_Buffer ("__");
1048 Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len));
1049 Homonym_Len := 0;
1050 end if;
1051 end Output_Homonym_Numbers_Suffix;
1052
1053 ------------------------------
1054 -- Prepend_String_To_Buffer --
1055 ------------------------------
1056
1057 procedure Prepend_String_To_Buffer (S : String) is
1058 N : constant Integer := S'Length;
1059 begin
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;
1064
1065 ----------------------------
1066 -- Prepend_Uint_To_Buffer --
1067 ----------------------------
1068
1069 procedure Prepend_Uint_To_Buffer (U : Uint) is
1070 begin
1071 if U < 0 then
1072 Prepend_String_To_Buffer ("m");
1073 Prepend_Uint_To_Buffer (-U);
1074 else
1075 UI_Image (U, Decimal);
1076 Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
1077 end if;
1078 end Prepend_Uint_To_Buffer;
1079
1080 ------------------------------
1081 -- Qualify_All_Entity_Names --
1082 ------------------------------
1083
1084 procedure Qualify_All_Entity_Names is
1085 E : Entity_Id;
1086 Ent : Entity_Id;
1087 Nod : Node_Id;
1088
1089 begin
1090 for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
1091 Nod := Name_Qualify_Units.Table (J);
1092
1093 -- When a scoping construct is ignored Ghost, it is rewritten as
1094 -- a null statement. Skip such constructs as they no longer carry
1095 -- names.
1096
1097 if Nkind (Nod) = N_Null_Statement then
1098 goto Continue;
1099 end if;
1100
1101 E := Defining_Entity (Nod);
1102 Reset_Buffers;
1103 Qualify_Entity_Name (E);
1104
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.
1110
1111 if Ekind (E) /= E_Variable then
1112 Ent := First_Entity (E);
1113 while Present (Ent) loop
1114 Reset_Buffers;
1115 Qualify_Entity_Name (Ent);
1116 Next_Entity (Ent);
1117
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.
1121
1122 exit when Ent = E;
1123 end loop;
1124 end if;
1125
1126 <<Continue>>
1127 null;
1128 end loop;
1129 end Qualify_All_Entity_Names;
1130
1131 -------------------------
1132 -- Qualify_Entity_Name --
1133 -------------------------
1134
1135 procedure Qualify_Entity_Name (Ent : Entity_Id) is
1136
1137 Full_Qualify_Name : String (1 .. Name_Buffer'Length);
1138 Full_Qualify_Len : Natural := 0;
1139 -- Used to accumulate fully qualified name of subprogram
1140
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).
1147
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
1151 -- package body.
1152
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.
1157
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.
1163
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.
1167
1168 BNPE_Suffix_Needed : Boolean := False;
1169 -- Set true if a body-nested package entity suffix is required
1170
1171 Save_Chars : constant Name_Id := Chars (Ent);
1172 -- Save original name
1173
1174 ------------------------
1175 -- Fully_Qualify_Name --
1176 ------------------------
1177
1178 procedure Fully_Qualify_Name (E : Entity_Id) is
1179 Discard : Boolean := False;
1180
1181 begin
1182 -- Ignore empty entry (can happen in error cases)
1183
1184 if No (E) then
1185 return;
1186
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.
1191
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))
1196 then
1197 Fully_Qualify_Name (Related_Instance (Scope (E)));
1198 return;
1199 end if;
1200
1201 -- If we reached fully qualified name, then just copy it
1202
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);
1209
1210 -- Case of non-fully qualified name
1211
1212 else
1213 if Scope (E) = Standard_Standard then
1214 Set_Has_Fully_Qualified_Name (Ent);
1215 else
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;
1220 end if;
1221
1222 if Has_Qualified_Name (E) then
1223 Get_Unqualified_Name_String (Chars (E));
1224 else
1225 Get_Name_String (Chars (E));
1226 end if;
1227
1228 -- Here we do one step of the qualification
1229
1230 Full_Qualify_Name
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);
1235 end if;
1236
1237 if Is_BNPE (E) then
1238 BNPE_Suffix_Needed := True;
1239 end if;
1240 end Fully_Qualify_Name;
1241
1242 -------------
1243 -- Is_BNPE --
1244 -------------
1245
1246 function Is_BNPE (S : Entity_Id) return Boolean is
1247 begin
1248 return Ekind (S) = E_Package and then Is_Package_Body_Entity (S);
1249 end Is_BNPE;
1250
1251 --------------------
1252 -- Qualify_Needed --
1253 --------------------
1254
1255 function Qualify_Needed (S : Entity_Id) return Boolean is
1256 begin
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.
1260
1261 if S = Standard_Standard then
1262 Set_Has_Fully_Qualified_Name (Ent, True);
1263 return False;
1264
1265 -- Otherwise figure out if further qualification is required
1266
1267 else
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));
1273 end if;
1274 end Qualify_Needed;
1275
1276 ---------------------
1277 -- Set_BNPE_Suffix --
1278 ---------------------
1279
1280 procedure Set_BNPE_Suffix (E : Entity_Id) is
1281 S : constant Entity_Id := Scope (E);
1282
1283 begin
1284 if Qualify_Needed (S) then
1285 Set_BNPE_Suffix (S);
1286
1287 if Is_BNPE (E) then
1288 Add_Char_To_Name_Buffer ('b');
1289 else
1290 Add_Char_To_Name_Buffer ('n');
1291 end if;
1292
1293 else
1294 Add_Char_To_Name_Buffer ('X');
1295 end if;
1296 end Set_BNPE_Suffix;
1297
1298 ---------------------
1299 -- Set_Entity_Name --
1300 ---------------------
1301
1302 procedure Set_Entity_Name (E : Entity_Id) is
1303 S : constant Entity_Id := Scope (E);
1304
1305 begin
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.
1309
1310 if Has_Qualified_Name (E) then
1311 Get_Name_String_And_Append (Chars (E));
1312 Strip_Suffixes (BNPE_Suffix_Needed);
1313
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.
1318
1319 if Has_Fully_Qualified_Name (E) then
1320 Set_Has_Fully_Qualified_Name (Ent);
1321 end if;
1322
1323 -- Case where upper level name is not encoded yet
1324
1325 else
1326 -- Recurse if further qualification required
1327
1328 if Qualify_Needed (S) then
1329 Set_Entity_Name (S);
1330 Add_Str_To_Name_Buffer ("__");
1331 end if;
1332
1333 -- Otherwise get name and note if it is a BNPE
1334
1335 Get_Name_String_And_Append (Chars (E));
1336
1337 if Is_BNPE (E) then
1338 BNPE_Suffix_Needed := True;
1339 end if;
1340
1341 Append_Homonym_Number (E);
1342 end if;
1343 end Set_Entity_Name;
1344
1345 -- Start of processing for Qualify_Entity_Name
1346
1347 begin
1348 if Has_Qualified_Name (Ent) then
1349 return;
1350
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.
1358
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);
1365 end if;
1366
1367 Set_Has_Qualified_Name (Ent);
1368 return;
1369
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.
1373
1374 elsif Ekind (Ent) = E_Variable
1375 and then Present (Debug_Renaming_Link (Ent))
1376 then
1377 Name_Len := 0;
1378 Qualify_Entity_Name (Debug_Renaming_Link (Ent));
1379 Get_Name_String (Chars (Ent));
1380
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.
1384
1385 declare
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;
1390
1391 begin
1392 -- Loop backwards through the name to find the start of the "___"
1393 -- sequence associated with the suffix.
1394
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) /= '_')
1399 loop
1400 Index := Index - 1;
1401 end loop;
1402
1403 pragma Assert (Name_Buffer (Index + 1 .. Index + 3) = "___");
1404
1405 -- Insert an underscore separator and the entity name just in
1406 -- front of the suffix.
1407
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;
1413 end;
1414
1415 -- Reset the name of the variable to the new name that includes the
1416 -- name of the renamed entity.
1417
1418 Set_Chars (Ent, Name_Enter);
1419
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.
1422
1423 if Qualify_Needed (Scope (Ent)) then
1424 Name_Len := 0;
1425 Set_Entity_Name (Scope (Ent));
1426 Add_Str_To_Name_Buffer ("__");
1427
1428 Get_Name_String_And_Append (Chars (Ent));
1429
1430 Set_Chars (Ent, Name_Enter);
1431 end if;
1432
1433 Set_Has_Qualified_Name (Ent);
1434 return;
1435
1436 elsif Is_Subprogram (Ent)
1437 or else Ekind (Ent) = E_Subprogram_Body
1438 or else Is_Type (Ent)
1439 then
1440 Fully_Qualify_Name (Ent);
1441 Name_Len := Full_Qualify_Len;
1442 Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
1443
1444 -- Qualification needed for enumeration literals when generating C code
1445 -- (to simplify their management in the backend).
1446
1447 elsif Generate_C_Code
1448 and then Ekind (Ent) = E_Enumeration_Literal
1449 and then Scope (Ultimate_Alias (Ent)) /= Standard_Standard
1450 then
1451 Fully_Qualify_Name (Ent);
1452 Name_Len := Full_Qualify_Len;
1453 Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
1454
1455 elsif Qualify_Needed (Scope (Ent)) then
1456 Name_Len := 0;
1457 Set_Entity_Name (Ent);
1458
1459 else
1460 Set_Has_Qualified_Name (Ent);
1461
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.
1468
1469 if Modify_Tree_For_C and then Ekind (Ent) = E_Variable then
1470 if Present (Hiding_Loop_Variable (Ent)) then
1471 declare
1472 Var : constant Entity_Id := Hiding_Loop_Variable (Ent);
1473
1474 begin
1475 Set_Entity_Name (Var);
1476 Add_Str_To_Name_Buffer ("L");
1477 Set_Chars (Var, Name_Enter);
1478 end;
1479
1480 elsif Present (Homonym (Ent))
1481 and then Ekind (Scope (Ent)) = E_Block
1482 and then Ekind (Scope (Homonym (Ent))) = E_Block
1483 then
1484 Set_Entity_Name (Ent);
1485 Add_Str_To_Name_Buffer ("B");
1486 Set_Chars (Ent, Name_Enter);
1487 end if;
1488 end if;
1489
1490 return;
1491 end if;
1492
1493 -- Fall through with a fully qualified name in Name_Buffer/Name_Len
1494
1495 Output_Homonym_Numbers_Suffix;
1496
1497 -- Add body-nested package suffix if required
1498
1499 if BNPE_Suffix_Needed
1500 and then Ekind (Ent) /= E_Enumeration_Literal
1501 then
1502 Set_BNPE_Suffix (Ent);
1503
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.
1506
1507 while Name_Buffer (Name_Len) = 'n' loop
1508 Name_Len := Name_Len - 1;
1509 end loop;
1510
1511 Name_Len := Name_Len - 1;
1512 end if;
1513
1514 Set_Chars (Ent, Name_Enter);
1515 Set_Has_Qualified_Name (Ent);
1516
1517 if Debug_Flag_BB then
1518 Write_Str ("*** ");
1519 Write_Name (Save_Chars);
1520 Write_Str (" qualified as ");
1521 Write_Name (Chars (Ent));
1522 Write_Eol;
1523 end if;
1524 end Qualify_Entity_Name;
1525
1526 --------------------------
1527 -- Qualify_Entity_Names --
1528 --------------------------
1529
1530 procedure Qualify_Entity_Names (N : Node_Id) is
1531 begin
1532 Name_Qualify_Units.Append (N);
1533 end Qualify_Entity_Names;
1534
1535 -------------------
1536 -- Reset_Buffers --
1537 -------------------
1538
1539 procedure Reset_Buffers is
1540 begin
1541 Name_Len := 0;
1542 Homonym_Len := 0;
1543 end Reset_Buffers;
1544
1545 --------------------
1546 -- Strip_Suffixes --
1547 --------------------
1548
1549 procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is
1550 SL : Natural;
1551
1552 pragma Warnings (Off, BNPE_Suffix_Found);
1553 -- Since this procedure only ever sets the flag
1554
1555 begin
1556 -- Search for and strip BNPE suffix
1557
1558 for J in reverse 2 .. Name_Len loop
1559 if Name_Buffer (J) = 'X' then
1560 Name_Len := J - 1;
1561 BNPE_Suffix_Found := True;
1562 exit;
1563 end if;
1564
1565 exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n';
1566 end loop;
1567
1568 -- Search for and strip homonym numbers suffix
1569
1570 for J in reverse 2 .. Name_Len - 2 loop
1571 if Name_Buffer (J) = '_'
1572 and then Name_Buffer (J + 1) = '_'
1573 then
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) := '-';
1578 end if;
1579
1580 SL := Name_Len - (J + 1);
1581
1582 Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) :=
1583 Name_Buffer (J + 2 .. Name_Len);
1584 Name_Len := J - 1;
1585 Homonym_Len := Homonym_Len + SL;
1586 end if;
1587
1588 exit;
1589 end if;
1590 end loop;
1591 end Strip_Suffixes;
1592
1593 end Exp_Dbug;