?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* tree-ssa-address.c (create_mem_ref): Remove ", bsi" from
[official-gcc.git] / gcc / ada / lib-xref.adb
blob3148afeb2e4a1f7766a2d8ef09b1c265c84b0e19
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- L I B . X R E F --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1998-2006, 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 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. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
26
27 with Atree; use Atree;
28 with Csets; use Csets;
29 with Elists; use Elists;
30 with Errout; use Errout;
31 with Lib.Util; use Lib.Util;
32 with Namet; use Namet;
33 with Nlists; use Nlists;
34 with Opt; use Opt;
35 with Restrict; use Restrict;
36 with Rident; use Rident;
37 with Sem; use Sem;
38 with Sem_Prag; use Sem_Prag;
39 with Sem_Util; use Sem_Util;
40 with Sem_Warn; use Sem_Warn;
41 with Sinfo; use Sinfo;
42 with Sinput; use Sinput;
43 with Snames; use Snames;
44 with Stringt; use Stringt;
45 with Stand; use Stand;
46 with Table; use Table;
47 with Widechar; use Widechar;
48
49 with GNAT.Heap_Sort_A;
50
51 package body Lib.Xref is
52
53 ------------------
54 -- Declarations --
55 ------------------
56
57 -- The Xref table is used to record references. The Loc field is set
58 -- to No_Location for a definition entry.
59
60 subtype Xref_Entry_Number is Int;
61
62 type Xref_Entry is record
63 Ent : Entity_Id;
64 -- Entity referenced (E parameter to Generate_Reference)
65
66 Def : Source_Ptr;
67 -- Original source location for entity being referenced. Note that
68 -- these values are used only during the output process, they are
69 -- not set when the entries are originally built. This is because
70 -- private entities can be swapped when the initial call is made.
71
72 Loc : Source_Ptr;
73 -- Location of reference (Original_Location (Sloc field of N parameter
74 -- to Generate_Reference). Set to No_Location for the case of a
75 -- defining occurrence.
76
77 Typ : Character;
78 -- Reference type (Typ param to Generate_Reference)
79
80 Eun : Unit_Number_Type;
81 -- Unit number corresponding to Ent
82
83 Lun : Unit_Number_Type;
84 -- Unit number corresponding to Loc. Value is undefined and not
85 -- referenced if Loc is set to No_Location.
86
87 end record;
88
89 package Xrefs is new Table.Table (
90 Table_Component_Type => Xref_Entry,
91 Table_Index_Type => Xref_Entry_Number,
92 Table_Low_Bound => 1,
93 Table_Initial => Alloc.Xrefs_Initial,
94 Table_Increment => Alloc.Xrefs_Increment,
95 Table_Name => "Xrefs");
96
97 -------------------------
98 -- Generate_Definition --
99 -------------------------
100
101 procedure Generate_Definition (E : Entity_Id) is
102 Loc : Source_Ptr;
103 Indx : Nat;
104
105 begin
106 pragma Assert (Nkind (E) in N_Entity);
107
108 -- Note that we do not test Xref_Entity_Letters here. It is too
109 -- early to do so, since we are often called before the entity
110 -- is fully constructed, so that the Ekind is still E_Void.
111
112 if Opt.Xref_Active
113
114 -- Definition must come from source
115
116 -- We make an exception for subprogram child units that have no
117 -- spec. For these we generate a subprogram declaration for library
118 -- use, and the corresponding entity does not come from source.
119 -- Nevertheless, all references will be attached to it and we have
120 -- to treat is as coming from user code.
121
122 and then (Comes_From_Source (E) or else Is_Child_Unit (E))
123
124 -- And must have a reasonable source location that is not
125 -- within an instance (all entities in instances are ignored)
126
127 and then Sloc (E) > No_Location
128 and then Instantiation_Location (Sloc (E)) = No_Location
129
130 -- And must be a non-internal name from the main source unit
131
132 and then In_Extended_Main_Source_Unit (E)
133 and then not Is_Internal_Name (Chars (E))
134 then
135 Xrefs.Increment_Last;
136 Indx := Xrefs.Last;
137 Loc := Original_Location (Sloc (E));
138
139 Xrefs.Table (Indx).Ent := E;
140 Xrefs.Table (Indx).Loc := No_Location;
141 Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
142 Xrefs.Table (Indx).Lun := No_Unit;
143 Set_Has_Xref_Entry (E);
144
145 if In_Inlined_Body then
146 Set_Referenced (E);
147 end if;
148 end if;
149 end Generate_Definition;
150
151 ---------------------------------
152 -- Generate_Operator_Reference --
153 ---------------------------------
154
155 procedure Generate_Operator_Reference
156 (N : Node_Id;
157 T : Entity_Id)
158 is
159 begin
160 if not In_Extended_Main_Source_Unit (N) then
161 return;
162 end if;
163
164 -- If the operator is not a Standard operator, then we generate
165 -- a real reference to the user defined operator.
166
167 if Sloc (Entity (N)) /= Standard_Location then
168 Generate_Reference (Entity (N), N);
169
170 -- A reference to an implicit inequality operator is a also a
171 -- reference to the user-defined equality.
172
173 if Nkind (N) = N_Op_Ne
174 and then not Comes_From_Source (Entity (N))
175 and then Present (Corresponding_Equality (Entity (N)))
176 then
177 Generate_Reference (Corresponding_Equality (Entity (N)), N);
178 end if;
179
180 -- For the case of Standard operators, we mark the result type
181 -- as referenced. This ensures that in the case where we are
182 -- using a derived operator, we mark an entity of the unit that
183 -- implicitly defines this operator as used. Otherwise we may
184 -- think that no entity of the unit is used. The actual entity
185 -- marked as referenced is the first subtype, which is the user
186 -- defined entity that is relevant.
187
188 -- Note: we only do this for operators that come from source.
189 -- The generated code sometimes reaches for entities that do
190 -- not need to be explicitly visible (for example, when we
191 -- expand the code for comparing two record types, the fields
192 -- of the record may not be visible).
193
194 elsif Comes_From_Source (N) then
195 Set_Referenced (First_Subtype (T));
196 end if;
197 end Generate_Operator_Reference;
198
199 ------------------------
200 -- Generate_Reference --
201 ------------------------
202
203 procedure Generate_Reference
204 (E : Entity_Id;
205 N : Node_Id;
206 Typ : Character := 'r';
207 Set_Ref : Boolean := True;
208 Force : Boolean := False)
209 is
210 Indx : Nat;
211 Nod : Node_Id;
212 Ref : Source_Ptr;
213 Def : Source_Ptr;
214 Ent : Entity_Id;
215
216 function Is_On_LHS (Node : Node_Id) return Boolean;
217 -- Used to check if a node is on the left hand side of an assignment.
218 -- The following cases are handled:
219 --
220 -- Variable Node is a direct descendant of an assignment statement.
221 --
222 -- Prefix Of an indexed or selected component that is present in a
223 -- subtree rooted by an assignment statement. There is no
224 -- restriction of nesting of components, thus cases such as
225 -- A.B(C).D are handled properly.
226
227 ---------------
228 -- Is_On_LHS --
229 ---------------
230
231 -- Couldn't we use Is_Lvalue or whatever it is called ???
232
233 function Is_On_LHS (Node : Node_Id) return Boolean is
234 N : Node_Id := Node;
235
236 begin
237 -- Only identifiers are considered, is this necessary???
238
239 if Nkind (N) /= N_Identifier then
240 return False;
241 end if;
242
243 -- Reach the assignment statement subtree root. In the case of a
244 -- variable being a direct descendant of an assignment statement,
245 -- the loop is skiped.
246
247 while Nkind (Parent (N)) /= N_Assignment_Statement loop
248
249 -- Check whether the parent is a component and the
250 -- current node is its prefix.
251
252 if (Nkind (Parent (N)) = N_Selected_Component
253 or else
254 Nkind (Parent (N)) = N_Indexed_Component)
255 and then Prefix (Parent (N)) = N
256 then
257 N := Parent (N);
258 else
259 return False;
260 end if;
261 end loop;
262
263 -- Parent (N) is assignment statement, check whether N is its name
264
265 return Name (Parent (N)) = N;
266 end Is_On_LHS;
267
268 -- Start of processing for Generate_Reference
269
270 begin
271 pragma Assert (Nkind (E) in N_Entity);
272
273 -- Check for obsolescent reference to package ASCII. GNAT treats this
274 -- element of annex J specially since in practice, programs make a lot
275 -- of use of this feature, so we don't include it in the set of features
276 -- diagnosed when Warn_On_Obsolescent_Features mode is set. However we
277 -- are required to note it as a violation of the RM defined restriction.
278
279 if E = Standard_ASCII then
280 Check_Restriction (No_Obsolescent_Features, N);
281 end if;
282
283 -- Check for reference to entity marked with Is_Obsolescent
284
285 -- Note that we always allow obsolescent references in the compiler
286 -- itself and the run time, since we assume that we know what we are
287 -- doing in such cases. For example the calls in Ada.Characters.Handling
288 -- to its own obsolescent subprograms are just fine.
289
290 -- In any case we do not generate warnings within the extended source
291 -- unit of the entity in question, since we assume the source unit
292 -- itself knows what is going on (and for sure we do not want silly
293 -- warnings, e.g. on the end line of an obsolescent procedure body).
294
295 if Is_Obsolescent (E)
296 and then not GNAT_Mode
297 and then not In_Extended_Main_Source_Unit (E)
298 then
299 Check_Restriction (No_Obsolescent_Features, N);
300
301 if Warn_On_Obsolescent_Feature then
302 Output_Obsolescent_Entity_Warnings (N, E);
303 end if;
304 end if;
305
306 -- Warn if reference to Ada 2005 entity not in Ada 2005 mode. We only
307 -- detect real explicit references (modifications and references).
308
309 if Is_Ada_2005_Only (E)
310 and then Ada_Version < Ada_05
311 and then Warn_On_Ada_2005_Compatibility
312 and then (Typ = 'm' or else Typ = 'r')
313 then
314 Error_Msg_NE ("& is only defined in Ada 2005?", N, E);
315 end if;
316
317 -- Never collect references if not in main source unit. However, we omit
318 -- this test if Typ is 'e' or 'k', since these entries are structural,
319 -- and it is useful to have them in units that reference packages as
320 -- well as units that define packages. We also omit the test for the
321 -- case of 'p' since we want to include inherited primitive operations
322 -- from other packages.
323
324 -- We also omit this test is this is a body reference for a subprogram
325 -- instantiation. In this case the reference is to the generic body,
326 -- which clearly need not be in the main unit containing the instance.
327 -- For the same reason we accept an implicit reference generated for
328 -- a default in an instance.
329
330 if not In_Extended_Main_Source_Unit (N) then
331 if Typ = 'e'
332 or else Typ = 'p'
333 or else Typ = 'i'
334 or else Typ = 'k'
335 or else (Typ = 'b' and then Is_Generic_Instance (E))
336 then
337 null;
338 else
339 return;
340 end if;
341 end if;
342
343 -- For reference type p, the entity must be in main source unit
344
345 if Typ = 'p' and then not In_Extended_Main_Source_Unit (E) then
346 return;
347 end if;
348
349 -- Unless the reference is forced, we ignore references where the
350 -- reference itself does not come from Source.
351
352 if not Force and then not Comes_From_Source (N) then
353 return;
354 end if;
355
356 -- Deal with setting entity as referenced, unless suppressed. Note that
357 -- we still do Set_Referenced on entities that do not come from source.
358 -- This situation arises when we have a source reference to a derived
359 -- operation, where the derived operation itself does not come from
360 -- source, but we still want to mark it as referenced, since we really
361 -- are referencing an entity in the corresponding package (this avoids
362 -- wrong complaints that the package contains no referenced entities).
363
364 if Set_Ref then
365
366 -- For a variable that appears on the left side of an assignment
367 -- statement, we set the Referenced_As_LHS flag since this is indeed
368 -- a left hand side. We also set the Referenced_As_LHS flag of a
369 -- prefix of selected or indexed component.
370
371 if Ekind (E) = E_Variable
372 and then Is_On_LHS (N)
373 then
374 Set_Referenced_As_LHS (E);
375
376 -- Check for a reference in a pragma that should not count as a
377 -- making the variable referenced for warning purposes.
378
379 elsif Is_Non_Significant_Pragma_Reference (N) then
380 null;
381
382 -- A reference in an attribute definition clause does not count as a
383 -- reference except for the case of Address. The reason that 'Address
384 -- is an exception is that it creates an alias through which the
385 -- variable may be referenced.
386
387 elsif Nkind (Parent (N)) = N_Attribute_Definition_Clause
388 and then Chars (Parent (N)) /= Name_Address
389 and then N = Name (Parent (N))
390 then
391 null;
392
393 -- Constant completion does not count as a reference
394
395 elsif Typ = 'c'
396 and then Ekind (E) = E_Constant
397 then
398 null;
399
400 -- Record representation clause does not count as a reference
401
402 elsif Nkind (N) = N_Identifier
403 and then Nkind (Parent (N)) = N_Record_Representation_Clause
404 then
405 null;
406
407 -- Discriminants do not need to produce a reference to record type
408
409 elsif Typ = 'd'
410 and then Nkind (Parent (N)) = N_Discriminant_Specification
411 then
412 null;
413
414 -- Any other occurrence counts as referencing the entity
415
416 else
417 Set_Referenced (E);
418
419 if Ekind (E) = E_Variable then
420 Set_Last_Assignment (E, Empty);
421 end if;
422 end if;
423
424 -- Check for pragma Unreferenced given and reference is within
425 -- this source unit (occasion for possible warning to be issued)
426
427 if Has_Pragma_Unreferenced (E)
428 and then In_Same_Extended_Unit (E, N)
429 then
430 -- A reference as a named parameter in a call does not count
431 -- as a violation of pragma Unreferenced for this purpose.
432
433 if Nkind (N) = N_Identifier
434 and then Nkind (Parent (N)) = N_Parameter_Association
435 and then Selector_Name (Parent (N)) = N
436 then
437 null;
438
439 -- Neither does a reference to a variable on the left side
440 -- of an assignment.
441
442 elsif Is_On_LHS (N) then
443 null;
444
445 -- For entry formals, we want to place the warning message on the
446 -- corresponding entity in the accept statement. The current scope
447 -- is the body of the accept, so we find the formal whose name
448 -- matches that of the entry formal (there is no link between the
449 -- two entities, and the one in the accept statement is only used
450 -- for conformance checking).
451
452 elsif Ekind (Scope (E)) = E_Entry then
453 declare
454 BE : Entity_Id;
455
456 begin
457 BE := First_Entity (Current_Scope);
458 while Present (BE) loop
459 if Chars (BE) = Chars (E) then
460 Error_Msg_NE
461 ("?pragma Unreferenced given for&", N, BE);
462 exit;
463 end if;
464
465 Next_Entity (BE);
466 end loop;
467 end;
468
469 -- Here we issue the warning, since this is a real reference
470
471 else
472 Error_Msg_NE ("?pragma Unreferenced given for&", N, E);
473 end if;
474 end if;
475
476 -- If this is a subprogram instance, mark as well the internal
477 -- subprogram in the wrapper package, which may be a visible
478 -- compilation unit.
479
480 if Is_Overloadable (E)
481 and then Is_Generic_Instance (E)
482 and then Present (Alias (E))
483 then
484 Set_Referenced (Alias (E));
485 end if;
486 end if;
487
488 -- Generate reference if all conditions are met:
489
490 if
491 -- Cross referencing must be active
492
493 Opt.Xref_Active
494
495 -- The entity must be one for which we collect references
496
497 and then Xref_Entity_Letters (Ekind (E)) /= ' '
498
499 -- Both Sloc values must be set to something sensible
500
501 and then Sloc (E) > No_Location
502 and then Sloc (N) > No_Location
503
504 -- We ignore references from within an instance
505
506 and then Instantiation_Location (Sloc (N)) = No_Location
507
508 -- Ignore dummy references
509
510 and then Typ /= ' '
511 then
512 if Nkind (N) = N_Identifier
513 or else
514 Nkind (N) = N_Defining_Identifier
515 or else
516 Nkind (N) in N_Op
517 or else
518 Nkind (N) = N_Defining_Operator_Symbol
519 or else
520 Nkind (N) = N_Operator_Symbol
521 or else
522 (Nkind (N) = N_Character_Literal
523 and then Sloc (Entity (N)) /= Standard_Location)
524 or else
525 Nkind (N) = N_Defining_Character_Literal
526 then
527 Nod := N;
528
529 elsif Nkind (N) = N_Expanded_Name
530 or else
531 Nkind (N) = N_Selected_Component
532 then
533 Nod := Selector_Name (N);
534
535 else
536 return;
537 end if;
538
539 -- Normal case of source entity comes from source
540
541 if Comes_From_Source (E) then
542 Ent := E;
543
544 -- Entity does not come from source, but is a derived subprogram
545 -- and the derived subprogram comes from source (after one or more
546 -- derivations) in which case the reference is to parent subprogram.
547
548 elsif Is_Overloadable (E)
549 and then Present (Alias (E))
550 then
551 Ent := Alias (E);
552 while not Comes_From_Source (Ent) loop
553 if No (Alias (Ent)) then
554 return;
555 end if;
556
557 Ent := Alias (Ent);
558 end loop;
559
560 -- The internally created defining entity for a child subprogram
561 -- that has no previous spec has valid references.
562
563 elsif Is_Overloadable (E)
564 and then Is_Child_Unit (E)
565 then
566 Ent := E;
567
568 -- Record components of discriminated subtypes or derived types
569 -- must be treated as references to the original component.
570
571 elsif Ekind (E) = E_Component
572 and then Comes_From_Source (Original_Record_Component (E))
573 then
574 Ent := Original_Record_Component (E);
575
576 -- Ignore reference to any other entity that is not from source
577
578 else
579 return;
580 end if;
581
582 -- Record reference to entity
583
584 Ref := Original_Location (Sloc (Nod));
585 Def := Original_Location (Sloc (Ent));
586
587 Xrefs.Increment_Last;
588 Indx := Xrefs.Last;
589
590 Xrefs.Table (Indx).Loc := Ref;
591
592 -- Overriding operations are marked with 'P'
593
594 if Typ = 'p'
595 and then Is_Subprogram (N)
596 and then Is_Overriding_Operation (N)
597 then
598 Xrefs.Table (Indx).Typ := 'P';
599 else
600 Xrefs.Table (Indx).Typ := Typ;
601 end if;
602
603 Xrefs.Table (Indx).Eun := Get_Source_Unit (Def);
604 Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref);
605 Xrefs.Table (Indx).Ent := Ent;
606 Set_Has_Xref_Entry (Ent);
607 end if;
608 end Generate_Reference;
609
610 -----------------------------------
611 -- Generate_Reference_To_Formals --
612 -----------------------------------
613
614 procedure Generate_Reference_To_Formals (E : Entity_Id) is
615 Formal : Entity_Id;
616
617 begin
618 if Is_Generic_Subprogram (E) then
619 Formal := First_Entity (E);
620
621 while Present (Formal)
622 and then not Is_Formal (Formal)
623 loop
624 Next_Entity (Formal);
625 end loop;
626
627 else
628 Formal := First_Formal (E);
629 end if;
630
631 while Present (Formal) loop
632 if Ekind (Formal) = E_In_Parameter then
633
634 if Nkind (Parameter_Type (Parent (Formal)))
635 = N_Access_Definition
636 then
637 Generate_Reference (E, Formal, '^', False);
638 else
639 Generate_Reference (E, Formal, '>', False);
640 end if;
641
642 elsif Ekind (Formal) = E_In_Out_Parameter then
643 Generate_Reference (E, Formal, '=', False);
644
645 else
646 Generate_Reference (E, Formal, '<', False);
647 end if;
648
649 Next_Formal (Formal);
650 end loop;
651 end Generate_Reference_To_Formals;
652
653 -------------------------------------------
654 -- Generate_Reference_To_Generic_Formals --
655 -------------------------------------------
656
657 procedure Generate_Reference_To_Generic_Formals (E : Entity_Id) is
658 Formal : Entity_Id;
659
660 begin
661 Formal := First_Entity (E);
662 while Present (Formal) loop
663 if Comes_From_Source (Formal) then
664 Generate_Reference (E, Formal, 'z', False);
665 end if;
666
667 Next_Entity (Formal);
668 end loop;
669 end Generate_Reference_To_Generic_Formals;
670
671 ----------------
672 -- Initialize --
673 ----------------
674
675 procedure Initialize is
676 begin
677 Xrefs.Init;
678 end Initialize;
679
680 -----------------------
681 -- Output_References --
682 -----------------------
683
684 procedure Output_References is
685
686 procedure Get_Type_Reference
687 (Ent : Entity_Id;
688 Tref : out Entity_Id;
689 Left : out Character;
690 Right : out Character);
691 -- Given an entity id Ent, determines whether a type reference is
692 -- required. If so, Tref is set to the entity for the type reference
693 -- and Left and Right are set to the left/right brackets to be
694 -- output for the reference. If no type reference is required, then
695 -- Tref is set to Empty, and Left/Right are set to space.
696
697 procedure Output_Import_Export_Info (Ent : Entity_Id);
698 -- Ouput language and external name information for an interfaced
699 -- entity, using the format <language, external_name>,
700
701 ------------------------
702 -- Get_Type_Reference --
703 ------------------------
704
705 procedure Get_Type_Reference
706 (Ent : Entity_Id;
707 Tref : out Entity_Id;
708 Left : out Character;
709 Right : out Character)
710 is
711 Sav : Entity_Id;
712
713 begin
714 -- See if we have a type reference
715
716 Tref := Ent;
717 Left := '{';
718 Right := '}';
719
720 loop
721 Sav := Tref;
722
723 -- Processing for types
724
725 if Is_Type (Tref) then
726
727 -- Case of base type
728
729 if Base_Type (Tref) = Tref then
730
731 -- If derived, then get first subtype
732
733 if Tref /= Etype (Tref) then
734 Tref := First_Subtype (Etype (Tref));
735
736 -- Set brackets for derived type, but don't
737 -- override pointer case since the fact that
738 -- something is a pointer is more important
739
740 if Left /= '(' then
741 Left := '<';
742 Right := '>';
743 end if;
744
745 -- If non-derived ptr, get directly designated type.
746 -- If the type has a full view, all references are
747 -- on the partial view, that is seen first.
748
749 elsif Is_Access_Type (Tref) then
750 Tref := Directly_Designated_Type (Tref);
751 Left := '(';
752 Right := ')';
753
754 elsif Is_Private_Type (Tref)
755 and then Present (Full_View (Tref))
756 then
757 if Is_Access_Type (Full_View (Tref)) then
758 Tref := Directly_Designated_Type (Full_View (Tref));
759 Left := '(';
760 Right := ')';
761
762 -- If the full view is an array type, we also retrieve
763 -- the corresponding component type, because the ali
764 -- entry already indicates that this is an array.
765
766 elsif Is_Array_Type (Full_View (Tref)) then
767 Tref := Component_Type (Full_View (Tref));
768 Left := '(';
769 Right := ')';
770 end if;
771
772 -- If non-derived array, get component type. Skip component
773 -- type for case of String or Wide_String, saves worthwhile
774 -- space.
775
776 elsif Is_Array_Type (Tref)
777 and then Tref /= Standard_String
778 and then Tref /= Standard_Wide_String
779 then
780 Tref := Component_Type (Tref);
781 Left := '(';
782 Right := ')';
783
784 -- For other non-derived base types, nothing
785
786 else
787 exit;
788 end if;
789
790 -- For a subtype, go to ancestor subtype
791
792 else
793 Tref := Ancestor_Subtype (Tref);
794
795 -- If no ancestor subtype, go to base type
796
797 if No (Tref) then
798 Tref := Base_Type (Sav);
799 end if;
800 end if;
801
802 -- For objects, functions, enum literals,
803 -- just get type from Etype field.
804
805 elsif Is_Object (Tref)
806 or else Ekind (Tref) = E_Enumeration_Literal
807 or else Ekind (Tref) = E_Function
808 or else Ekind (Tref) = E_Operator
809 then
810 Tref := Etype (Tref);
811
812 -- For anything else, exit
813
814 else
815 exit;
816 end if;
817
818 -- Exit if no type reference, or we are stuck in
819 -- some loop trying to find the type reference, or
820 -- if the type is standard void type (the latter is
821 -- an implementation artifact that should not show
822 -- up in the generated cross-references).
823
824 exit when No (Tref)
825 or else Tref = Sav
826 or else Tref = Standard_Void_Type;
827
828 -- If we have a usable type reference, return, otherwise
829 -- keep looking for something useful (we are looking for
830 -- something that either comes from source or standard)
831
832 if Sloc (Tref) = Standard_Location
833 or else Comes_From_Source (Tref)
834 then
835 -- If the reference is a subtype created for a generic
836 -- actual, go to actual directly, the inner subtype is
837 -- not user visible.
838
839 if Nkind (Parent (Tref)) = N_Subtype_Declaration
840 and then not Comes_From_Source (Parent (Tref))
841 and then
842 (Is_Wrapper_Package (Scope (Tref))
843 or else Is_Generic_Instance (Scope (Tref)))
844 then
845 Tref := First_Subtype (Base_Type (Tref));
846 end if;
847
848 return;
849 end if;
850 end loop;
851
852 -- If we fall through the loop, no type reference
853
854 Tref := Empty;
855 Left := ' ';
856 Right := ' ';
857 end Get_Type_Reference;
858
859 -------------------------------
860 -- Output_Import_Export_Info --
861 -------------------------------
862
863 procedure Output_Import_Export_Info (Ent : Entity_Id) is
864 Language_Name : Name_Id;
865 Conv : constant Convention_Id := Convention (Ent);
866
867 begin
868 -- Generate language name from convention
869
870 if Conv = Convention_C then
871 Language_Name := Name_C;
872
873 elsif Conv = Convention_CPP then
874 Language_Name := Name_CPP;
875
876 elsif Conv = Convention_Ada then
877 Language_Name := Name_Ada;
878
879 else
880 -- For the moment we ignore all other cases ???
881
882 return;
883 end if;
884
885 Write_Info_Char ('<');
886 Get_Unqualified_Name_String (Language_Name);
887
888 for J in 1 .. Name_Len loop
889 Write_Info_Char (Name_Buffer (J));
890 end loop;
891
892 if Present (Interface_Name (Ent)) then
893 Write_Info_Char (',');
894 String_To_Name_Buffer (Strval (Interface_Name (Ent)));
895
896 for J in 1 .. Name_Len loop
897 Write_Info_Char (Name_Buffer (J));
898 end loop;
899 end if;
900
901 Write_Info_Char ('>');
902 end Output_Import_Export_Info;
903
904 -- Start of processing for Output_References
905
906 begin
907 if not Opt.Xref_Active then
908 return;
909 end if;
910
911 -- Before we go ahead and output the references we have a problem
912 -- that needs dealing with. So far we have captured things that are
913 -- definitely referenced by the main unit, or defined in the main
914 -- unit. That's because we don't want to clutter up the ali file
915 -- for this unit with definition lines for entities in other units
916 -- that are not referenced.
917
918 -- But there is a glitch. We may reference an entity in another unit,
919 -- and it may have a type reference to an entity that is not directly
920 -- referenced in the main unit, which may mean that there is no xref
921 -- entry for this entity yet in the list of references.
922
923 -- If we don't do something about this, we will end with an orphan
924 -- type reference, i.e. it will point to an entity that does not
925 -- appear within the generated references in the ali file. That is
926 -- not good for tools using the xref information.
927
928 -- To fix this, we go through the references adding definition
929 -- entries for any unreferenced entities that can be referenced
930 -- in a type reference. There is a recursion problem here, and
931 -- that is dealt with by making sure that this traversal also
932 -- traverses any entries that get added by the traversal.
933
934 declare
935 J : Nat;
936 Tref : Entity_Id;
937 L, R : Character;
938 Indx : Nat;
939 Ent : Entity_Id;
940 Loc : Source_Ptr;
941
942 begin
943 -- Note that this is not a for loop for a very good reason. The
944 -- processing of items in the table can add new items to the
945 -- table, and they must be processed as well
946
947 J := 1;
948 while J <= Xrefs.Last loop
949 Ent := Xrefs.Table (J).Ent;
950 Get_Type_Reference (Ent, Tref, L, R);
951
952 if Present (Tref)
953 and then not Has_Xref_Entry (Tref)
954 and then Sloc (Tref) > No_Location
955 then
956 Xrefs.Increment_Last;
957 Indx := Xrefs.Last;
958 Loc := Original_Location (Sloc (Tref));
959 Xrefs.Table (Indx).Ent := Tref;
960 Xrefs.Table (Indx).Loc := No_Location;
961 Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
962 Xrefs.Table (Indx).Lun := No_Unit;
963 Set_Has_Xref_Entry (Tref);
964 end if;
965
966 -- Collect inherited primitive operations that may be
967 -- declared in another unit and have no visible reference
968 -- in the current one.
969
970 if Is_Type (Ent)
971 and then Is_Tagged_Type (Ent)
972 and then Is_Derived_Type (Ent)
973 and then Ent = Base_Type (Ent)
974 and then In_Extended_Main_Source_Unit (Ent)
975 then
976 declare
977 Op_List : constant Elist_Id := Primitive_Operations (Ent);
978 Op : Elmt_Id;
979 Prim : Entity_Id;
980
981 function Parent_Op (E : Entity_Id) return Entity_Id;
982 -- Find original operation, which may be inherited
983 -- through several derivations.
984
985 function Parent_Op (E : Entity_Id) return Entity_Id is
986 Orig_Op : constant Entity_Id := Alias (E);
987 begin
988 if No (Orig_Op) then
989 return Empty;
990 elsif not Comes_From_Source (E)
991 and then not Has_Xref_Entry (Orig_Op)
992 and then Comes_From_Source (Orig_Op)
993 then
994 return Orig_Op;
995 else
996 return Parent_Op (Orig_Op);
997 end if;
998 end Parent_Op;
999
1000 begin
1001 Op := First_Elmt (Op_List);
1002 while Present (Op) loop
1003 Prim := Parent_Op (Node (Op));
1004
1005 if Present (Prim) then
1006 Xrefs.Increment_Last;
1007 Indx := Xrefs.Last;
1008 Loc := Original_Location (Sloc (Prim));
1009 Xrefs.Table (Indx).Ent := Prim;
1010 Xrefs.Table (Indx).Loc := No_Location;
1011 Xrefs.Table (Indx).Eun :=
1012 Get_Source_Unit (Sloc (Prim));
1013 Xrefs.Table (Indx).Lun := No_Unit;
1014 Set_Has_Xref_Entry (Prim);
1015 end if;
1016
1017 Next_Elmt (Op);
1018 end loop;
1019 end;
1020 end if;
1021
1022 J := J + 1;
1023 end loop;
1024 end;
1025
1026 -- Now we have all the references, including those for any embedded
1027 -- type references, so we can sort them, and output them.
1028
1029 Output_Refs : declare
1030
1031 Nrefs : Nat := Xrefs.Last;
1032 -- Number of references in table. This value may get reset
1033 -- (reduced) when we eliminate duplicate reference entries.
1034
1035 Rnums : array (0 .. Nrefs) of Nat;
1036 -- This array contains numbers of references in the Xrefs table.
1037 -- This list is sorted in output order. The extra 0'th entry is
1038 -- convenient for the call to sort. When we sort the table, we
1039 -- move the entries in Rnums around, but we do not move the
1040 -- original table entries.
1041
1042 Curxu : Unit_Number_Type;
1043 -- Current xref unit
1044
1045 Curru : Unit_Number_Type;
1046 -- Current reference unit for one entity
1047
1048 Cursrc : Source_Buffer_Ptr;
1049 -- Current xref unit source text
1050
1051 Curent : Entity_Id;
1052 -- Current entity
1053
1054 Curnam : String (1 .. Name_Buffer'Length);
1055 Curlen : Natural;
1056 -- Simple name and length of current entity
1057
1058 Curdef : Source_Ptr;
1059 -- Original source location for current entity
1060
1061 Crloc : Source_Ptr;
1062 -- Current reference location
1063
1064 Ctyp : Character;
1065 -- Entity type character
1066
1067 Tref : Entity_Id;
1068 -- Type reference
1069
1070 Rref : Node_Id;
1071 -- Renaming reference
1072
1073 Trunit : Unit_Number_Type;
1074 -- Unit number for type reference
1075
1076 function Lt (Op1, Op2 : Natural) return Boolean;
1077 -- Comparison function for Sort call
1078
1079 function Name_Change (X : Entity_Id) return Boolean;
1080 -- Determines if entity X has a different simple name from Curent
1081
1082 procedure Move (From : Natural; To : Natural);
1083 -- Move procedure for Sort call
1084
1085 --------
1086 -- Lt --
1087 --------
1088
1089 function Lt (Op1, Op2 : Natural) return Boolean is
1090 T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
1091 T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
1092
1093 begin
1094 -- First test. If entity is in different unit, sort by unit
1095
1096 if T1.Eun /= T2.Eun then
1097 return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun);
1098
1099 -- Second test, within same unit, sort by entity Sloc
1100
1101 elsif T1.Def /= T2.Def then
1102 return T1.Def < T2.Def;
1103
1104 -- Third test, sort definitions ahead of references
1105
1106 elsif T1.Loc = No_Location then
1107 return True;
1108
1109 elsif T2.Loc = No_Location then
1110 return False;
1111
1112 -- Fourth test, for same entity, sort by reference location unit
1113
1114 elsif T1.Lun /= T2.Lun then
1115 return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
1116
1117 -- Fifth test order of location within referencing unit
1118
1119 elsif T1.Loc /= T2.Loc then
1120 return T1.Loc < T2.Loc;
1121
1122 -- Finally, for two locations at the same address, we prefer
1123 -- the one that does NOT have the type 'r' so that a modification
1124 -- or extension takes preference, when there are more than one
1125 -- reference at the same location.
1126
1127 else
1128 return T2.Typ = 'r';
1129 end if;
1130 end Lt;
1131
1132 ----------
1133 -- Move --
1134 ----------
1135
1136 procedure Move (From : Natural; To : Natural) is
1137 begin
1138 Rnums (Nat (To)) := Rnums (Nat (From));
1139 end Move;
1140
1141 -----------------
1142 -- Name_Change --
1143 -----------------
1144
1145 -- Why a string comparison here??? Why not compare Name_Id values???
1146
1147 function Name_Change (X : Entity_Id) return Boolean is
1148 begin
1149 Get_Unqualified_Name_String (Chars (X));
1150
1151 if Name_Len /= Curlen then
1152 return True;
1153
1154 else
1155 return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen);
1156 end if;
1157 end Name_Change;
1158
1159 -- Start of processing for Output_Refs
1160
1161 begin
1162 -- Capture the definition Sloc values. We delay doing this till now,
1163 -- since at the time the reference or definition is made, private
1164 -- types may be swapped, and the Sloc value may be incorrect. We
1165 -- also set up the pointer vector for the sort.
1166
1167 for J in 1 .. Nrefs loop
1168 Rnums (J) := J;
1169 Xrefs.Table (J).Def :=
1170 Original_Location (Sloc (Xrefs.Table (J).Ent));
1171 end loop;
1172
1173 -- Sort the references
1174
1175 GNAT.Heap_Sort_A.Sort
1176 (Integer (Nrefs),
1177 Move'Unrestricted_Access,
1178 Lt'Unrestricted_Access);
1179
1180 -- Eliminate duplicate entries
1181
1182 declare
1183 NR : constant Nat := Nrefs;
1184
1185 begin
1186 -- We need this test for NR because if we force ALI file
1187 -- generation in case of errors detected, it may be the case
1188 -- that Nrefs is 0, so we should not reset it here
1189
1190 if NR >= 2 then
1191 Nrefs := 1;
1192
1193 for J in 2 .. NR loop
1194 if Xrefs.Table (Rnums (J)) /=
1195 Xrefs.Table (Rnums (Nrefs))
1196 then
1197 Nrefs := Nrefs + 1;
1198 Rnums (Nrefs) := Rnums (J);
1199 end if;
1200 end loop;
1201 end if;
1202 end;
1203
1204 -- Initialize loop through references
1205
1206 Curxu := No_Unit;
1207 Curent := Empty;
1208 Curdef := No_Location;
1209 Curru := No_Unit;
1210 Crloc := No_Location;
1211
1212 -- Loop to output references
1213
1214 for Refno in 1 .. Nrefs loop
1215 Output_One_Ref : declare
1216 P2 : Source_Ptr;
1217 WC : Char_Code;
1218 Err : Boolean;
1219 Ent : Entity_Id;
1220
1221 XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
1222 -- The current entry to be accessed
1223
1224 P : Source_Ptr;
1225 -- Used to index into source buffer to get entity name
1226
1227 Left : Character;
1228 Right : Character;
1229 -- Used for {} or <> or () for type reference
1230
1231 procedure Output_Instantiation_Refs (Loc : Source_Ptr);
1232 -- Recursive procedure to output instantiation references for
1233 -- the given source ptr in [file|line[...]] form. No output
1234 -- if the given location is not a generic template reference.
1235
1236 procedure Output_Overridden_Op (Old_E : Entity_Id);
1237 -- For a subprogram that is overriding, display information
1238 -- about the inherited operation that it overrides.
1239
1240 -------------------------------
1241 -- Output_Instantiation_Refs --
1242 -------------------------------
1243
1244 procedure Output_Instantiation_Refs (Loc : Source_Ptr) is
1245 Iloc : constant Source_Ptr := Instantiation_Location (Loc);
1246 Lun : Unit_Number_Type;
1247 Cu : constant Unit_Number_Type := Curru;
1248
1249 begin
1250 -- Nothing to do if this is not an instantiation
1251
1252 if Iloc = No_Location then
1253 return;
1254 end if;
1255
1256 -- Output instantiation reference
1257
1258 Write_Info_Char ('[');
1259 Lun := Get_Source_Unit (Iloc);
1260
1261 if Lun /= Curru then
1262 Curru := Lun;
1263 Write_Info_Nat (Dependency_Num (Curru));
1264 Write_Info_Char ('|');
1265 end if;
1266
1267 Write_Info_Nat (Int (Get_Logical_Line_Number (Iloc)));
1268
1269 -- Recursive call to get nested instantiations
1270
1271 Output_Instantiation_Refs (Iloc);
1272
1273 -- Output final ] after call to get proper nesting
1274
1275 Write_Info_Char (']');
1276 Curru := Cu;
1277 return;
1278 end Output_Instantiation_Refs;
1279
1280 --------------------------
1281 -- Output_Overridden_Op --
1282 --------------------------
1283
1284 procedure Output_Overridden_Op (Old_E : Entity_Id) is
1285 begin
1286 if Present (Old_E)
1287 and then Sloc (Old_E) /= Standard_Location
1288 then
1289 declare
1290 Loc : constant Source_Ptr := Sloc (Old_E);
1291 Par_Unit : constant Unit_Number_Type :=
1292 Get_Source_Unit (Loc);
1293 begin
1294 Write_Info_Char ('<');
1295
1296 if Par_Unit /= Curxu then
1297 Write_Info_Nat (Dependency_Num (Par_Unit));
1298 Write_Info_Char ('|');
1299 end if;
1300
1301 Write_Info_Nat (Int (Get_Logical_Line_Number (Loc)));
1302 Write_Info_Char ('p');
1303 Write_Info_Nat (Int (Get_Column_Number (Loc)));
1304 Write_Info_Char ('>');
1305 end;
1306 end if;
1307 end Output_Overridden_Op;
1308
1309 -- Start of processing for Output_One_Ref
1310
1311 begin
1312 Ent := XE.Ent;
1313 Ctyp := Xref_Entity_Letters (Ekind (Ent));
1314
1315 -- Skip reference if it is the only reference to an entity,
1316 -- and it is an end-line reference, and the entity is not in
1317 -- the current extended source. This prevents junk entries
1318 -- consisting only of packages with end lines, where no
1319 -- entity from the package is actually referenced.
1320
1321 if XE.Typ = 'e'
1322 and then Ent /= Curent
1323 and then (Refno = Nrefs or else
1324 Ent /= Xrefs.Table (Rnums (Refno + 1)).Ent)
1325 and then
1326 not In_Extended_Main_Source_Unit (Ent)
1327 then
1328 goto Continue;
1329 end if;
1330
1331 -- For private type, get full view type
1332
1333 if Ctyp = '+'
1334 and then Present (Full_View (XE.Ent))
1335 then
1336 Ent := Underlying_Type (Ent);
1337
1338 if Present (Ent) then
1339 Ctyp := Xref_Entity_Letters (Ekind (Ent));
1340 end if;
1341 end if;
1342
1343 -- Special exception for Boolean
1344
1345 if Ctyp = 'E' and then Is_Boolean_Type (Ent) then
1346 Ctyp := 'B';
1347 end if;
1348
1349 -- For variable reference, get corresponding type
1350
1351 if Ctyp = '*' then
1352 Ent := Etype (XE.Ent);
1353 Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
1354
1355 -- If variable is private type, get full view type
1356
1357 if Ctyp = '+'
1358 and then Present (Full_View (Etype (XE.Ent)))
1359 then
1360 Ent := Underlying_Type (Etype (XE.Ent));
1361
1362 if Present (Ent) then
1363 Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
1364 end if;
1365
1366 elsif Is_Generic_Type (Ent) then
1367
1368 -- If the type of the entity is a generic private type
1369 -- there is no usable full view, so retain the indication
1370 -- that this is an object.
1371
1372 Ctyp := '*';
1373 end if;
1374
1375 -- Special handling for access parameter
1376
1377 declare
1378 K : constant Entity_Kind := Ekind (Etype (XE.Ent));
1379
1380 begin
1381 if (K = E_Anonymous_Access_Type
1382 or else
1383 K = E_Anonymous_Access_Subprogram_Type
1384 or else K =
1385 E_Anonymous_Access_Protected_Subprogram_Type)
1386 and then Is_Formal (XE.Ent)
1387 then
1388 Ctyp := 'p';
1389
1390 -- Special handling for Boolean
1391
1392 elsif Ctyp = 'e' and then Is_Boolean_Type (Ent) then
1393 Ctyp := 'b';
1394 end if;
1395 end;
1396 end if;
1397
1398 -- Special handling for abstract types and operations
1399
1400 if Is_Abstract (XE.Ent) then
1401 if Ctyp = 'U' then
1402 Ctyp := 'x'; -- abstract procedure
1403
1404 elsif Ctyp = 'V' then
1405 Ctyp := 'y'; -- abstract function
1406
1407 elsif Ctyp = 'R' then
1408 Ctyp := 'H'; -- abstract type
1409 end if;
1410 end if;
1411
1412 -- Only output reference if interesting type of entity, and
1413 -- suppress self references, except for bodies that act as
1414 -- specs. Also suppress definitions of body formals (we only
1415 -- treat these as references, and the references were
1416 -- separately recorded).
1417
1418 if Ctyp = ' '
1419 or else (XE.Loc = XE.Def
1420 and then
1421 (XE.Typ /= 'b'
1422 or else not Is_Subprogram (XE.Ent)))
1423 or else (Is_Formal (XE.Ent)
1424 and then Present (Spec_Entity (XE.Ent)))
1425 then
1426 null;
1427
1428 else
1429 -- Start new Xref section if new xref unit
1430
1431 if XE.Eun /= Curxu then
1432 if Write_Info_Col > 1 then
1433 Write_Info_EOL;
1434 end if;
1435
1436 Curxu := XE.Eun;
1437 Cursrc := Source_Text (Source_Index (Curxu));
1438
1439 Write_Info_Initiate ('X');
1440 Write_Info_Char (' ');
1441 Write_Info_Nat (Dependency_Num (XE.Eun));
1442 Write_Info_Char (' ');
1443 Write_Info_Name (Reference_Name (Source_Index (XE.Eun)));
1444 end if;
1445
1446 -- Start new Entity line if new entity. Note that we
1447 -- consider two entities the same if they have the same
1448 -- name and source location. This causes entities in
1449 -- instantiations to be treated as though they referred
1450 -- to the template.
1451
1452 if No (Curent)
1453 or else
1454 (XE.Ent /= Curent
1455 and then
1456 (Name_Change (XE.Ent) or else XE.Def /= Curdef))
1457 then
1458 Curent := XE.Ent;
1459 Curdef := XE.Def;
1460
1461 Get_Unqualified_Name_String (Chars (XE.Ent));
1462 Curlen := Name_Len;
1463 Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);
1464
1465 if Write_Info_Col > 1 then
1466 Write_Info_EOL;
1467 end if;
1468
1469 -- Write column number information
1470
1471 Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Def)));
1472 Write_Info_Char (Ctyp);
1473 Write_Info_Nat (Int (Get_Column_Number (XE.Def)));
1474
1475 -- Write level information
1476
1477 Write_Level_Info : declare
1478 function Is_Visible_Generic_Entity
1479 (E : Entity_Id) return Boolean;
1480 -- Check whether E is declared in the visible part
1481 -- of a generic package. For source navigation
1482 -- purposes, treat this as a visible entity.
1483
1484 function Is_Private_Record_Component
1485 (E : Entity_Id) return Boolean;
1486 -- Check whether E is a non-inherited component of a
1487 -- private extension. Even if the enclosing record is
1488 -- public, we want to treat the component as private
1489 -- for navigation purposes.
1490
1491 ---------------------------------
1492 -- Is_Private_Record_Component --
1493 ---------------------------------
1494
1495 function Is_Private_Record_Component
1496 (E : Entity_Id) return Boolean
1497 is
1498 S : constant Entity_Id := Scope (E);
1499 begin
1500 return
1501 Ekind (E) = E_Component
1502 and then Nkind (Declaration_Node (S)) =
1503 N_Private_Extension_Declaration
1504 and then Original_Record_Component (E) = E;
1505 end Is_Private_Record_Component;
1506
1507 -------------------------------
1508 -- Is_Visible_Generic_Entity --
1509 -------------------------------
1510
1511 function Is_Visible_Generic_Entity
1512 (E : Entity_Id) return Boolean
1513 is
1514 Par : Node_Id;
1515
1516 begin
1517 if Ekind (Scope (E)) /= E_Generic_Package then
1518 return False;
1519 end if;
1520
1521 Par := Parent (E);
1522 while Present (Par) loop
1523 if
1524 Nkind (Par) = N_Generic_Package_Declaration
1525 then
1526 -- Entity is a generic formal
1527
1528 return False;
1529
1530 elsif
1531 Nkind (Parent (Par)) = N_Package_Specification
1532 then
1533 return
1534 Is_List_Member (Par)
1535 and then List_Containing (Par) =
1536 Visible_Declarations (Parent (Par));
1537 else
1538 Par := Parent (Par);
1539 end if;
1540 end loop;
1541
1542 return False;
1543 end Is_Visible_Generic_Entity;
1544
1545 -- Start of processing for Write_Level_Info
1546
1547 begin
1548 if Is_Hidden (Curent)
1549 or else Is_Private_Record_Component (Curent)
1550 then
1551 Write_Info_Char (' ');
1552
1553 elsif
1554 Is_Public (Curent)
1555 or else Is_Visible_Generic_Entity (Curent)
1556 then
1557 Write_Info_Char ('*');
1558
1559 else
1560 Write_Info_Char (' ');
1561 end if;
1562 end Write_Level_Info;
1563
1564 -- Output entity name. We use the occurrence from the
1565 -- actual source program at the definition point
1566
1567 P := Original_Location (Sloc (XE.Ent));
1568
1569 -- Entity is character literal
1570
1571 if Cursrc (P) = ''' then
1572 Write_Info_Char (Cursrc (P));
1573 Write_Info_Char (Cursrc (P + 1));
1574 Write_Info_Char (Cursrc (P + 2));
1575
1576 -- Entity is operator symbol
1577
1578 elsif Cursrc (P) = '"' or else Cursrc (P) = '%' then
1579 Write_Info_Char (Cursrc (P));
1580
1581 P2 := P;
1582 loop
1583 P2 := P2 + 1;
1584 Write_Info_Char (Cursrc (P2));
1585 exit when Cursrc (P2) = Cursrc (P);
1586 end loop;
1587
1588 -- Entity is identifier
1589
1590 else
1591 loop
1592 if Is_Start_Of_Wide_Char (Cursrc, P) then
1593 Scan_Wide (Cursrc, P, WC, Err);
1594 elsif not Identifier_Char (Cursrc (P)) then
1595 exit;
1596 else
1597 P := P + 1;
1598 end if;
1599 end loop;
1600
1601 -- Write out the identifier by copying the exact
1602 -- source characters used in its declaration. Note
1603 -- that this means wide characters will be in their
1604 -- original encoded form.
1605
1606 for J in
1607 Original_Location (Sloc (XE.Ent)) .. P - 1
1608 loop
1609 Write_Info_Char (Cursrc (J));
1610 end loop;
1611 end if;
1612
1613 -- See if we have a renaming reference
1614
1615 if Is_Object (XE.Ent)
1616 and then Present (Renamed_Object (XE.Ent))
1617 then
1618 Rref := Renamed_Object (XE.Ent);
1619
1620 elsif Is_Overloadable (XE.Ent)
1621 and then Nkind (Parent (Declaration_Node (XE.Ent))) =
1622 N_Subprogram_Renaming_Declaration
1623 then
1624 Rref := Name (Parent (Declaration_Node (XE.Ent)));
1625
1626 elsif Ekind (XE.Ent) = E_Package
1627 and then Nkind (Declaration_Node (XE.Ent)) =
1628 N_Package_Renaming_Declaration
1629 then
1630 Rref := Name (Declaration_Node (XE.Ent));
1631
1632 else
1633 Rref := Empty;
1634 end if;
1635
1636 if Present (Rref) then
1637 if Nkind (Rref) = N_Expanded_Name then
1638 Rref := Selector_Name (Rref);
1639 end if;
1640
1641 if Nkind (Rref) = N_Identifier
1642 or else Nkind (Rref) = N_Operator_Symbol
1643 then
1644 null;
1645
1646 -- For renamed array components, use the array name
1647 -- for the renamed entity, which reflect the fact that
1648 -- in general the whole array is aliased.
1649
1650 elsif Nkind (Rref) = N_Indexed_Component then
1651 if Nkind (Prefix (Rref)) = N_Identifier then
1652 Rref := Prefix (Rref);
1653 elsif Nkind (Prefix (Rref)) = N_Expanded_Name then
1654 Rref := Selector_Name (Prefix (Rref));
1655 else
1656 Rref := Empty;
1657 end if;
1658
1659 else
1660 Rref := Empty;
1661 end if;
1662 end if;
1663
1664 -- Write out renaming reference if we have one
1665
1666 if Present (Rref) then
1667 Write_Info_Char ('=');
1668 Write_Info_Nat
1669 (Int (Get_Logical_Line_Number (Sloc (Rref))));
1670 Write_Info_Char (':');
1671 Write_Info_Nat
1672 (Int (Get_Column_Number (Sloc (Rref))));
1673 end if;
1674
1675 -- Indicate that the entity is in the unit of the current
1676 -- xref xection.
1677
1678 Curru := Curxu;
1679
1680 -- Write out information about generic parent, if entity
1681 -- is an instance.
1682
1683 if Is_Generic_Instance (XE.Ent) then
1684 declare
1685 Gen_Par : constant Entity_Id :=
1686 Generic_Parent
1687 (Specification
1688 (Unit_Declaration_Node (XE.Ent)));
1689 Loc : constant Source_Ptr := Sloc (Gen_Par);
1690 Gen_U : constant Unit_Number_Type :=
1691 Get_Source_Unit (Loc);
1692
1693 begin
1694 Write_Info_Char ('[');
1695 if Curru /= Gen_U then
1696 Write_Info_Nat (Dependency_Num (Gen_U));
1697 Write_Info_Char ('|');
1698 end if;
1699
1700 Write_Info_Nat
1701 (Int (Get_Logical_Line_Number (Loc)));
1702 Write_Info_Char (']');
1703 end;
1704 end if;
1705
1706 -- See if we have a type reference and if so output
1707
1708 Get_Type_Reference (XE.Ent, Tref, Left, Right);
1709
1710 if Present (Tref) then
1711
1712 -- Case of standard entity, output name
1713
1714 if Sloc (Tref) = Standard_Location then
1715 Write_Info_Char (Left);
1716 Write_Info_Name (Chars (Tref));
1717 Write_Info_Char (Right);
1718
1719 -- Case of source entity, output location
1720
1721 else
1722 Write_Info_Char (Left);
1723 Trunit := Get_Source_Unit (Sloc (Tref));
1724
1725 if Trunit /= Curxu then
1726 Write_Info_Nat (Dependency_Num (Trunit));
1727 Write_Info_Char ('|');
1728 end if;
1729
1730 Write_Info_Nat
1731 (Int (Get_Logical_Line_Number (Sloc (Tref))));
1732
1733 declare
1734 Ent : Entity_Id := Tref;
1735 Kind : constant Entity_Kind := Ekind (Ent);
1736 Ctyp : Character := Xref_Entity_Letters (Kind);
1737
1738 begin
1739 if Ctyp = '+'
1740 and then Present (Full_View (Ent))
1741 then
1742 Ent := Underlying_Type (Ent);
1743
1744 if Present (Ent) then
1745 Ctyp := Xref_Entity_Letters (Ekind (Ent));
1746 end if;
1747 end if;
1748
1749 Write_Info_Char (Ctyp);
1750 end;
1751
1752 Write_Info_Nat
1753 (Int (Get_Column_Number (Sloc (Tref))));
1754
1755 -- If the type comes from an instantiation,
1756 -- add the corresponding info.
1757
1758 Output_Instantiation_Refs (Sloc (Tref));
1759 Write_Info_Char (Right);
1760 end if;
1761 end if;
1762
1763 -- If the entity is an overriding operation, write
1764 -- info on operation that was overridden.
1765
1766 if Is_Subprogram (XE.Ent)
1767 and then Is_Overriding_Operation (XE.Ent)
1768 then
1769 Output_Overridden_Op (Overridden_Operation (XE.Ent));
1770 end if;
1771
1772 -- End of processing for entity output
1773
1774 Crloc := No_Location;
1775 end if;
1776
1777 -- Output the reference
1778
1779 if XE.Loc /= No_Location
1780 and then XE.Loc /= Crloc
1781 then
1782 Crloc := XE.Loc;
1783
1784 -- Start continuation if line full, else blank
1785
1786 if Write_Info_Col > 72 then
1787 Write_Info_EOL;
1788 Write_Info_Initiate ('.');
1789 end if;
1790
1791 Write_Info_Char (' ');
1792
1793 -- Output file number if changed
1794
1795 if XE.Lun /= Curru then
1796 Curru := XE.Lun;
1797 Write_Info_Nat (Dependency_Num (Curru));
1798 Write_Info_Char ('|');
1799 end if;
1800
1801 Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Loc)));
1802 Write_Info_Char (XE.Typ);
1803
1804 if Is_Overloadable (XE.Ent)
1805 and then Is_Imported (XE.Ent)
1806 and then XE.Typ = 'b'
1807 then
1808 Output_Import_Export_Info (XE.Ent);
1809 end if;
1810
1811 Write_Info_Nat (Int (Get_Column_Number (XE.Loc)));
1812
1813 Output_Instantiation_Refs (Sloc (XE.Ent));
1814 end if;
1815 end if;
1816 end Output_One_Ref;
1817
1818 <<Continue>>
1819 null;
1820 end loop;
1821
1822 Write_Info_EOL;
1823 end Output_Refs;
1824 end Output_References;
1825
1826 end Lib.Xref;
Mirror of the offical gcc git repository hosted at gcc.gnu.org