lib-xref.adb, [...]: Minor reformatting & code reorganization.
[gcc.git] / gcc / ada / lib-xref.adb
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-2012, 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 Atree; use Atree;
27 with Csets; use Csets;
28 with Elists; use Elists;
29 with Errout; use Errout;
30 with Nlists; use Nlists;
31 with Opt; use Opt;
32 with Restrict; use Restrict;
33 with Rident; use Rident;
34 with Sem; use Sem;
35 with Sem_Aux; use Sem_Aux;
36 with Sem_Prag; use Sem_Prag;
37 with Sem_Util; use Sem_Util;
38 with Sem_Warn; use Sem_Warn;
39 with Sinfo; use Sinfo;
40 with Sinput; use Sinput;
41 with Snames; use Snames;
42 with Stringt; use Stringt;
43 with Stand; use Stand;
44 with Table; use Table;
45
46 with GNAT.Heap_Sort_G;
47 with GNAT.HTable;
48
49 package body Lib.Xref is
50
51 ------------------
52 -- Declarations --
53 ------------------
54
55 -- The Xref table is used to record references. The Loc field is set
56 -- to No_Location for a definition entry.
57
58 subtype Xref_Entry_Number is Int;
59
60 type Xref_Key is record
61 -- These are the components of Xref_Entry that participate in hash
62 -- lookups.
63
64 Ent : Entity_Id;
65 -- Entity referenced (E parameter to Generate_Reference)
66
67 Loc : Source_Ptr;
68 -- Location of reference (Original_Location (Sloc field of N parameter
69 -- to Generate_Reference). Set to No_Location for the case of a
70 -- defining occurrence.
71
72 Typ : Character;
73 -- Reference type (Typ param to Generate_Reference)
74
75 Eun : Unit_Number_Type;
76 -- Unit number corresponding to Ent
77
78 Lun : Unit_Number_Type;
79 -- Unit number corresponding to Loc. Value is undefined and not
80 -- referenced if Loc is set to No_Location.
81
82 -- The following components are only used for Alfa cross-references
83
84 Ref_Scope : Entity_Id;
85 -- Entity of the closest subprogram or package enclosing the reference
86
87 Ent_Scope : Entity_Id;
88 -- Entity of the closest subprogram or package enclosing the definition,
89 -- which should be located in the same file as the definition itself.
90 end record;
91
92 type Xref_Entry is record
93 Key : Xref_Key;
94
95 Ent_Scope_File : Unit_Number_Type;
96 -- File for entity Ent_Scope
97
98 Def : Source_Ptr;
99 -- Original source location for entity being referenced. Note that these
100 -- values are used only during the output process, they are not set when
101 -- the entries are originally built. This is because private entities
102 -- can be swapped when the initial call is made.
103
104 HTable_Next : Xref_Entry_Number;
105 -- For use only by Static_HTable
106 end record;
107
108 package Xrefs is new Table.Table (
109 Table_Component_Type => Xref_Entry,
110 Table_Index_Type => Xref_Entry_Number,
111 Table_Low_Bound => 1,
112 Table_Initial => Alloc.Xrefs_Initial,
113 Table_Increment => Alloc.Xrefs_Increment,
114 Table_Name => "Xrefs");
115
116 --------------
117 -- Xref_Set --
118 --------------
119
120 -- We keep a set of xref entries, in order to avoid inserting duplicate
121 -- entries into the above Xrefs table. An entry is in Xref_Set if and only
122 -- if it is in Xrefs.
123
124 Num_Buckets : constant := 2**16;
125
126 subtype Header_Num is Integer range 0 .. Num_Buckets - 1;
127 type Null_Type is null record;
128 pragma Unreferenced (Null_Type);
129
130 function Hash (F : Xref_Entry_Number) return Header_Num;
131
132 function Equal (F1, F2 : Xref_Entry_Number) return Boolean;
133
134 procedure HT_Set_Next (E : Xref_Entry_Number; Next : Xref_Entry_Number);
135
136 function HT_Next (E : Xref_Entry_Number) return Xref_Entry_Number;
137
138 function Get_Key (E : Xref_Entry_Number) return Xref_Entry_Number;
139
140 pragma Inline (Hash, Equal, HT_Set_Next, HT_Next, Get_Key);
141
142 package Xref_Set is new GNAT.HTable.Static_HTable (
143 Header_Num,
144 Element => Xref_Entry,
145 Elmt_Ptr => Xref_Entry_Number,
146 Null_Ptr => 0,
147 Set_Next => HT_Set_Next,
148 Next => HT_Next,
149 Key => Xref_Entry_Number,
150 Get_Key => Get_Key,
151 Hash => Hash,
152 Equal => Equal);
153
154 ----------------------
155 -- Alfa Information --
156 ----------------------
157
158 package body Alfa is separate;
159
160 ------------------------
161 -- Local Subprograms --
162 ------------------------
163
164 procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type);
165 -- Add an entry to the tables of Xref_Entries, avoiding duplicates
166
167 procedure Generate_Prim_Op_References (Typ : Entity_Id);
168 -- For a tagged type, generate implicit references to its primitive
169 -- operations, for source navigation. This is done right before emitting
170 -- cross-reference information rather than at the freeze point of the type
171 -- in order to handle late bodies that are primitive operations.
172
173 function Lt (T1, T2 : Xref_Entry) return Boolean;
174 -- Order cross-references
175
176 ---------------
177 -- Add_Entry --
178 ---------------
179
180 procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type) is
181 begin
182 Xrefs.Increment_Last; -- tentative
183 Xrefs.Table (Xrefs.Last).Key := Key;
184
185 -- Set the entry in Xref_Set, and if newly set, keep the above
186 -- tentative increment.
187
188 if Xref_Set.Set_If_Not_Present (Xrefs.Last) then
189 Xrefs.Table (Xrefs.Last).Ent_Scope_File := Ent_Scope_File;
190 -- Leave Def and HTable_Next uninitialized
191
192 Set_Has_Xref_Entry (Key.Ent);
193
194 -- It was already in Xref_Set, so throw away the tentatively-added
195 -- entry
196
197 else
198 Xrefs.Decrement_Last;
199 end if;
200 end Add_Entry;
201
202 -----------
203 -- Equal --
204 -----------
205
206 function Equal (F1, F2 : Xref_Entry_Number) return Boolean is
207 Result : constant Boolean :=
208 Xrefs.Table (F1).Key = Xrefs.Table (F2).Key;
209 begin
210 return Result;
211 end Equal;
212
213 -------------------------
214 -- Generate_Definition --
215 -------------------------
216
217 procedure Generate_Definition (E : Entity_Id) is
218 begin
219 pragma Assert (Nkind (E) in N_Entity);
220
221 -- Note that we do not test Xref_Entity_Letters here. It is too early
222 -- to do so, since we are often called before the entity is fully
223 -- constructed, so that the Ekind is still E_Void.
224
225 if Opt.Xref_Active
226
227 -- Definition must come from source
228
229 -- We make an exception for subprogram child units that have no spec.
230 -- For these we generate a subprogram declaration for library use,
231 -- and the corresponding entity does not come from source.
232 -- Nevertheless, all references will be attached to it and we have
233 -- to treat is as coming from user code.
234
235 and then (Comes_From_Source (E) or else Is_Child_Unit (E))
236
237 -- And must have a reasonable source location that is not
238 -- within an instance (all entities in instances are ignored)
239
240 and then Sloc (E) > No_Location
241 and then Instantiation_Location (Sloc (E)) = No_Location
242
243 -- And must be a non-internal name from the main source unit
244
245 and then In_Extended_Main_Source_Unit (E)
246 and then not Is_Internal_Name (Chars (E))
247 then
248 Add_Entry
249 ((Ent => E,
250 Loc => No_Location,
251 Typ => ' ',
252 Eun => Get_Source_Unit (Original_Location (Sloc (E))),
253 Lun => No_Unit,
254 Ref_Scope => Empty,
255 Ent_Scope => Empty),
256 Ent_Scope_File => No_Unit);
257
258 if In_Inlined_Body then
259 Set_Referenced (E);
260 end if;
261 end if;
262 end Generate_Definition;
263
264 ---------------------------------
265 -- Generate_Operator_Reference --
266 ---------------------------------
267
268 procedure Generate_Operator_Reference
269 (N : Node_Id;
270 T : Entity_Id)
271 is
272 begin
273 if not In_Extended_Main_Source_Unit (N) then
274 return;
275 end if;
276
277 -- If the operator is not a Standard operator, then we generate a real
278 -- reference to the user defined operator.
279
280 if Sloc (Entity (N)) /= Standard_Location then
281 Generate_Reference (Entity (N), N);
282
283 -- A reference to an implicit inequality operator is also a reference
284 -- to the user-defined equality.
285
286 if Nkind (N) = N_Op_Ne
287 and then not Comes_From_Source (Entity (N))
288 and then Present (Corresponding_Equality (Entity (N)))
289 then
290 Generate_Reference (Corresponding_Equality (Entity (N)), N);
291 end if;
292
293 -- For the case of Standard operators, we mark the result type as
294 -- referenced. This ensures that in the case where we are using a
295 -- derived operator, we mark an entity of the unit that implicitly
296 -- defines this operator as used. Otherwise we may think that no entity
297 -- of the unit is used. The actual entity marked as referenced is the
298 -- first subtype, which is the relevant user defined entity.
299
300 -- Note: we only do this for operators that come from source. The
301 -- generated code sometimes reaches for entities that do not need to be
302 -- explicitly visible (for example, when we expand the code for
303 -- comparing two record objects, the fields of the record may not be
304 -- visible).
305
306 elsif Comes_From_Source (N) then
307 Set_Referenced (First_Subtype (T));
308 end if;
309 end Generate_Operator_Reference;
310
311 ---------------------------------
312 -- Generate_Prim_Op_References --
313 ---------------------------------
314
315 procedure Generate_Prim_Op_References (Typ : Entity_Id) is
316 Base_T : Entity_Id;
317 Prim : Elmt_Id;
318 Prim_List : Elist_Id;
319
320 begin
321 -- Handle subtypes of synchronized types
322
323 if Ekind (Typ) = E_Protected_Subtype
324 or else Ekind (Typ) = E_Task_Subtype
325 then
326 Base_T := Etype (Typ);
327 else
328 Base_T := Typ;
329 end if;
330
331 -- References to primitive operations are only relevant for tagged types
332
333 if not Is_Tagged_Type (Base_T)
334 or else Is_Class_Wide_Type (Base_T)
335 then
336 return;
337 end if;
338
339 -- Ada 2005 (AI-345): For synchronized types generate reference to the
340 -- wrapper that allow us to dispatch calls through their implemented
341 -- abstract interface types.
342
343 -- The check for Present here is to protect against previously reported
344 -- critical errors.
345
346 Prim_List := Primitive_Operations (Base_T);
347
348 if No (Prim_List) then
349 return;
350 end if;
351
352 Prim := First_Elmt (Prim_List);
353 while Present (Prim) loop
354
355 -- If the operation is derived, get the original for cross-reference
356 -- reference purposes (it is the original for which we want the xref
357 -- and for which the comes_from_source test must be performed).
358
359 Generate_Reference
360 (Typ, Ultimate_Alias (Node (Prim)), 'p', Set_Ref => False);
361 Next_Elmt (Prim);
362 end loop;
363 end Generate_Prim_Op_References;
364
365 ------------------------
366 -- Generate_Reference --
367 ------------------------
368
369 procedure Generate_Reference
370 (E : Entity_Id;
371 N : Node_Id;
372 Typ : Character := 'r';
373 Set_Ref : Boolean := True;
374 Force : Boolean := False)
375 is
376 Actual_Typ : Character := Typ;
377 Call : Node_Id;
378 Def : Source_Ptr;
379 Ent : Entity_Id;
380 Ent_Scope : Entity_Id;
381 Formal : Entity_Id;
382 Kind : Entity_Kind;
383 Nod : Node_Id;
384 Ref : Source_Ptr;
385 Ref_Scope : Entity_Id;
386
387 function Get_Through_Renamings (E : Entity_Id) return Entity_Id;
388 -- Get the enclosing entity through renamings, which may come from
389 -- source or from the translation of generic instantiations.
390
391 function Is_On_LHS (Node : Node_Id) return Boolean;
392 -- Used to check if a node is on the left hand side of an assignment.
393 -- The following cases are handled:
394 --
395 -- Variable Node is a direct descendant of left hand side of an
396 -- assignment statement.
397 --
398 -- Prefix Of an indexed or selected component that is present in
399 -- a subtree rooted by an assignment statement. There is
400 -- no restriction of nesting of components, thus cases
401 -- such as A.B (C).D are handled properly. However a prefix
402 -- of a dereference (either implicit or explicit) is never
403 -- considered as on a LHS.
404 --
405 -- Out param Same as above cases, but OUT parameter
406
407 function OK_To_Set_Referenced return Boolean;
408 -- Returns True if the Referenced flag can be set. There are a few
409 -- exceptions where we do not want to set this flag, see body for
410 -- details of these exceptional cases.
411
412 ---------------------------
413 -- Get_Through_Renamings --
414 ---------------------------
415
416 function Get_Through_Renamings (E : Entity_Id) return Entity_Id is
417 Result : Entity_Id := E;
418 begin
419 while Present (Result)
420 and then Is_Object (Result)
421 and then Present (Renamed_Object (Result))
422 loop
423 Result := Get_Enclosing_Object (Renamed_Object (Result));
424 end loop;
425 return Result;
426 end Get_Through_Renamings;
427
428 ---------------
429 -- Is_On_LHS --
430 ---------------
431
432 -- ??? There are several routines here and there that perform a similar
433 -- (but subtly different) computation, which should be factored:
434
435 -- Sem_Util.May_Be_Lvalue
436 -- Sem_Util.Known_To_Be_Assigned
437 -- Exp_Ch2.Expand_Entry_Parameter.In_Assignment_Context
438 -- Exp_Smem.Is_Out_Actual
439
440 function Is_On_LHS (Node : Node_Id) return Boolean is
441 N : Node_Id;
442 P : Node_Id;
443 K : Node_Kind;
444
445 begin
446 -- Only identifiers are considered, is this necessary???
447
448 if Nkind (Node) /= N_Identifier then
449 return False;
450 end if;
451
452 -- Immediate return if appeared as OUT parameter
453
454 if Kind = E_Out_Parameter then
455 return True;
456 end if;
457
458 -- Search for assignment statement subtree root
459
460 N := Node;
461 loop
462 P := Parent (N);
463 K := Nkind (P);
464
465 if K = N_Assignment_Statement then
466 return Name (P) = N;
467
468 -- Check whether the parent is a component and the current node is
469 -- its prefix, but return False if the current node has an access
470 -- type, as in that case the selected or indexed component is an
471 -- implicit dereference, and the LHS is the designated object, not
472 -- the access object.
473
474 -- ??? case of a slice assignment?
475
476 -- ??? Note that in some cases this is called too early
477 -- (see comments in Sem_Ch8.Find_Direct_Name), at a point where
478 -- the tree is not fully typed yet. In that case we may lack
479 -- an Etype for N, and we must disable the check for an implicit
480 -- dereference. If the dereference is on an LHS, this causes a
481 -- false positive.
482
483 elsif (K = N_Selected_Component or else K = N_Indexed_Component)
484 and then Prefix (P) = N
485 and then not (Present (Etype (N))
486 and then
487 Is_Access_Type (Etype (N)))
488 then
489 N := P;
490
491 -- All other cases, definitely not on left side
492
493 else
494 return False;
495 end if;
496 end loop;
497 end Is_On_LHS;
498
499 ---------------------------
500 -- OK_To_Set_Referenced --
501 ---------------------------
502
503 function OK_To_Set_Referenced return Boolean is
504 P : Node_Id;
505
506 begin
507 -- A reference from a pragma Unreferenced or pragma Unmodified or
508 -- pragma Warnings does not cause the Referenced flag to be set.
509 -- This avoids silly warnings about things being referenced and
510 -- not assigned when the only reference is from the pragma.
511
512 if Nkind (N) = N_Identifier then
513 P := Parent (N);
514
515 if Nkind (P) = N_Pragma_Argument_Association then
516 P := Parent (P);
517
518 if Nkind (P) = N_Pragma then
519 if Pragma_Name (P) = Name_Warnings
520 or else
521 Pragma_Name (P) = Name_Unmodified
522 or else
523 Pragma_Name (P) = Name_Unreferenced
524 then
525 return False;
526 end if;
527 end if;
528
529 -- A reference to a formal in a named parameter association does
530 -- not make the formal referenced. Formals that are unused in the
531 -- subprogram body are properly flagged as such, even if calls
532 -- elsewhere use named notation.
533
534 elsif Nkind (P) = N_Parameter_Association
535 and then N = Selector_Name (P)
536 then
537 return False;
538 end if;
539 end if;
540
541 return True;
542 end OK_To_Set_Referenced;
543
544 -- Start of processing for Generate_Reference
545
546 begin
547 pragma Assert (Nkind (E) in N_Entity);
548 Find_Actual (N, Formal, Call);
549
550 if Present (Formal) then
551 Kind := Ekind (Formal);
552 else
553 Kind := E_Void;
554 end if;
555
556 -- Check for obsolescent reference to package ASCII. GNAT treats this
557 -- element of annex J specially since in practice, programs make a lot
558 -- of use of this feature, so we don't include it in the set of features
559 -- diagnosed when Warn_On_Obsolescent_Features mode is set. However we
560 -- are required to note it as a violation of the RM defined restriction.
561
562 if E = Standard_ASCII then
563 Check_Restriction (No_Obsolescent_Features, N);
564 end if;
565
566 -- Check for reference to entity marked with Is_Obsolescent
567
568 -- Note that we always allow obsolescent references in the compiler
569 -- itself and the run time, since we assume that we know what we are
570 -- doing in such cases. For example the calls in Ada.Characters.Handling
571 -- to its own obsolescent subprograms are just fine.
572
573 -- In any case we only generate warnings if we are in the extended main
574 -- source unit, and the entity itself is not in the extended main source
575 -- unit, since we assume the source unit itself knows what is going on
576 -- (and for sure we do not want silly warnings, e.g. on the end line of
577 -- an obsolescent procedure body).
578
579 if Is_Obsolescent (E)
580 and then not GNAT_Mode
581 and then not In_Extended_Main_Source_Unit (E)
582 and then In_Extended_Main_Source_Unit (N)
583 then
584 Check_Restriction (No_Obsolescent_Features, N);
585
586 if Warn_On_Obsolescent_Feature then
587 Output_Obsolescent_Entity_Warnings (N, E);
588 end if;
589 end if;
590
591 -- Warn if reference to Ada 2005 entity not in Ada 2005 mode. We only
592 -- detect real explicit references (modifications and references).
593
594 if Comes_From_Source (N)
595 and then Is_Ada_2005_Only (E)
596 and then Ada_Version < Ada_2005
597 and then Warn_On_Ada_2005_Compatibility
598 and then (Typ = 'm' or else Typ = 'r' or else Typ = 's')
599 then
600 Error_Msg_NE ("& is only defined in Ada 2005?", N, E);
601 end if;
602
603 -- Warn if reference to Ada 2012 entity not in Ada 2012 mode. We only
604 -- detect real explicit references (modifications and references).
605
606 if Comes_From_Source (N)
607 and then Is_Ada_2012_Only (E)
608 and then Ada_Version < Ada_2012
609 and then Warn_On_Ada_2012_Compatibility
610 and then (Typ = 'm' or else Typ = 'r')
611 then
612 Error_Msg_NE ("& is only defined in Ada 2012?", N, E);
613 end if;
614
615 -- Never collect references if not in main source unit. However, we omit
616 -- this test if Typ is 'e' or 'k', since these entries are structural,
617 -- and it is useful to have them in units that reference packages as
618 -- well as units that define packages. We also omit the test for the
619 -- case of 'p' since we want to include inherited primitive operations
620 -- from other packages.
621
622 -- We also omit this test is this is a body reference for a subprogram
623 -- instantiation. In this case the reference is to the generic body,
624 -- which clearly need not be in the main unit containing the instance.
625 -- For the same reason we accept an implicit reference generated for
626 -- a default in an instance.
627
628 if not In_Extended_Main_Source_Unit (N) then
629 if Typ = 'e'
630 or else Typ = 'I'
631 or else Typ = 'p'
632 or else Typ = 'i'
633 or else Typ = 'k'
634 or else (Typ = 'b' and then Is_Generic_Instance (E))
635
636 -- Allow the generation of references to reads, writes and calls
637 -- in Alfa mode when the related context comes from an instance.
638
639 or else
640 (Alfa_Mode
641 and then In_Extended_Main_Code_Unit (N)
642 and then (Typ = 'm' or else Typ = 'r' or else Typ = 's'))
643 then
644 null;
645 else
646 return;
647 end if;
648 end if;
649
650 -- For reference type p, the entity must be in main source unit
651
652 if Typ = 'p' and then not In_Extended_Main_Source_Unit (E) then
653 return;
654 end if;
655
656 -- Unless the reference is forced, we ignore references where the
657 -- reference itself does not come from source.
658
659 if not Force and then not Comes_From_Source (N) then
660 return;
661 end if;
662
663 -- Deal with setting entity as referenced, unless suppressed. Note that
664 -- we still do Set_Referenced on entities that do not come from source.
665 -- This situation arises when we have a source reference to a derived
666 -- operation, where the derived operation itself does not come from
667 -- source, but we still want to mark it as referenced, since we really
668 -- are referencing an entity in the corresponding package (this avoids
669 -- wrong complaints that the package contains no referenced entities).
670
671 if Set_Ref then
672
673 -- Assignable object appearing on left side of assignment or as
674 -- an out parameter.
675
676 if Is_Assignable (E)
677 and then Is_On_LHS (N)
678 and then Ekind (E) /= E_In_Out_Parameter
679 then
680 -- For objects that are renamings, just set as simply referenced
681 -- we do not try to do assignment type tracking in this case.
682
683 if Present (Renamed_Object (E)) then
684 Set_Referenced (E);
685
686 -- Out parameter case
687
688 elsif Kind = E_Out_Parameter then
689
690 -- If warning mode for all out parameters is set, or this is
691 -- the only warning parameter, then we want to mark this for
692 -- later warning logic by setting Referenced_As_Out_Parameter
693
694 if Warn_On_Modified_As_Out_Parameter (Formal) then
695 Set_Referenced_As_Out_Parameter (E, True);
696 Set_Referenced_As_LHS (E, False);
697
698 -- For OUT parameter not covered by the above cases, we simply
699 -- regard it as a normal reference (in this case we do not
700 -- want any of the warning machinery for out parameters).
701
702 else
703 Set_Referenced (E);
704 end if;
705
706 -- For the left hand of an assignment case, we do nothing here.
707 -- The processing for Analyze_Assignment_Statement will set the
708 -- Referenced_As_LHS flag.
709
710 else
711 null;
712 end if;
713
714 -- Check for a reference in a pragma that should not count as a
715 -- making the variable referenced for warning purposes.
716
717 elsif Is_Non_Significant_Pragma_Reference (N) then
718 null;
719
720 -- A reference in an attribute definition clause does not count as a
721 -- reference except for the case of Address. The reason that 'Address
722 -- is an exception is that it creates an alias through which the
723 -- variable may be referenced.
724
725 elsif Nkind (Parent (N)) = N_Attribute_Definition_Clause
726 and then Chars (Parent (N)) /= Name_Address
727 and then N = Name (Parent (N))
728 then
729 null;
730
731 -- Constant completion does not count as a reference
732
733 elsif Typ = 'c'
734 and then Ekind (E) = E_Constant
735 then
736 null;
737
738 -- Record representation clause does not count as a reference
739
740 elsif Nkind (N) = N_Identifier
741 and then Nkind (Parent (N)) = N_Record_Representation_Clause
742 then
743 null;
744
745 -- Discriminants do not need to produce a reference to record type
746
747 elsif Typ = 'd'
748 and then Nkind (Parent (N)) = N_Discriminant_Specification
749 then
750 null;
751
752 -- All other cases
753
754 else
755 -- Special processing for IN OUT parameters, where we have an
756 -- implicit assignment to a simple variable.
757
758 if Kind = E_In_Out_Parameter
759 and then Is_Assignable (E)
760 then
761 -- For sure this counts as a normal read reference
762
763 Set_Referenced (E);
764 Set_Last_Assignment (E, Empty);
765
766 -- We count it as being referenced as an out parameter if the
767 -- option is set to warn on all out parameters, except that we
768 -- have a special exclusion for an intrinsic subprogram, which
769 -- is most likely an instantiation of Unchecked_Deallocation
770 -- which we do not want to consider as an assignment since it
771 -- generates false positives. We also exclude the case of an
772 -- IN OUT parameter if the name of the procedure is Free,
773 -- since we suspect similar semantics.
774
775 if Warn_On_All_Unread_Out_Parameters
776 and then Is_Entity_Name (Name (Call))
777 and then not Is_Intrinsic_Subprogram (Entity (Name (Call)))
778 and then Chars (Name (Call)) /= Name_Free
779 then
780 Set_Referenced_As_Out_Parameter (E, True);
781 Set_Referenced_As_LHS (E, False);
782 end if;
783
784 -- Don't count a recursive reference within a subprogram as a
785 -- reference (that allows detection of a recursive subprogram
786 -- whose only references are recursive calls as unreferenced).
787
788 elsif Is_Subprogram (E)
789 and then E = Nearest_Dynamic_Scope (Current_Scope)
790 then
791 null;
792
793 -- Any other occurrence counts as referencing the entity
794
795 elsif OK_To_Set_Referenced then
796 Set_Referenced (E);
797
798 -- If variable, this is an OK reference after an assignment
799 -- so we can clear the Last_Assignment indication.
800
801 if Is_Assignable (E) then
802 Set_Last_Assignment (E, Empty);
803 end if;
804 end if;
805 end if;
806
807 -- Check for pragma Unreferenced given and reference is within
808 -- this source unit (occasion for possible warning to be issued).
809
810 if Has_Unreferenced (E)
811 and then In_Same_Extended_Unit (E, N)
812 then
813 -- A reference as a named parameter in a call does not count
814 -- as a violation of pragma Unreferenced for this purpose...
815
816 if Nkind (N) = N_Identifier
817 and then Nkind (Parent (N)) = N_Parameter_Association
818 and then Selector_Name (Parent (N)) = N
819 then
820 null;
821
822 -- ... Neither does a reference to a variable on the left side
823 -- of an assignment.
824
825 elsif Is_On_LHS (N) then
826 null;
827
828 -- For entry formals, we want to place the warning message on the
829 -- corresponding entity in the accept statement. The current scope
830 -- is the body of the accept, so we find the formal whose name
831 -- matches that of the entry formal (there is no link between the
832 -- two entities, and the one in the accept statement is only used
833 -- for conformance checking).
834
835 elsif Ekind (Scope (E)) = E_Entry then
836 declare
837 BE : Entity_Id;
838
839 begin
840 BE := First_Entity (Current_Scope);
841 while Present (BE) loop
842 if Chars (BE) = Chars (E) then
843 Error_Msg_NE -- CODEFIX
844 ("?pragma Unreferenced given for&!", N, BE);
845 exit;
846 end if;
847
848 Next_Entity (BE);
849 end loop;
850 end;
851
852 -- Here we issue the warning, since this is a real reference
853
854 else
855 Error_Msg_NE -- CODEFIX
856 ("?pragma Unreferenced given for&!", N, E);
857 end if;
858 end if;
859
860 -- If this is a subprogram instance, mark as well the internal
861 -- subprogram in the wrapper package, which may be a visible
862 -- compilation unit.
863
864 if Is_Overloadable (E)
865 and then Is_Generic_Instance (E)
866 and then Present (Alias (E))
867 then
868 Set_Referenced (Alias (E));
869 end if;
870 end if;
871
872 -- Generate reference if all conditions are met:
873
874 if
875 -- Cross referencing must be active
876
877 Opt.Xref_Active
878
879 -- The entity must be one for which we collect references
880
881 and then Xref_Entity_Letters (Ekind (E)) /= ' '
882
883 -- Both Sloc values must be set to something sensible
884
885 and then Sloc (E) > No_Location
886 and then Sloc (N) > No_Location
887
888 -- Ignore references from within an instance. The only exceptions to
889 -- this are default subprograms, for which we generate an implicit
890 -- reference and compilations in Alfa_Mode.
891
892 and then
893 (Instantiation_Location (Sloc (N)) = No_Location
894 or else Typ = 'i'
895 or else Alfa_Mode)
896
897 -- Ignore dummy references
898
899 and then Typ /= ' '
900 then
901 if Nkind_In (N, N_Identifier,
902 N_Defining_Identifier,
903 N_Defining_Operator_Symbol,
904 N_Operator_Symbol,
905 N_Defining_Character_Literal)
906 or else Nkind (N) in N_Op
907 or else (Nkind (N) = N_Character_Literal
908 and then Sloc (Entity (N)) /= Standard_Location)
909 then
910 Nod := N;
911
912 elsif Nkind_In (N, N_Expanded_Name, N_Selected_Component) then
913 Nod := Selector_Name (N);
914
915 else
916 return;
917 end if;
918
919 -- Normal case of source entity comes from source
920
921 if Comes_From_Source (E) then
922 Ent := E;
923
924 -- Entity does not come from source, but is a derived subprogram and
925 -- the derived subprogram comes from source (after one or more
926 -- derivations) in which case the reference is to parent subprogram.
927
928 elsif Is_Overloadable (E)
929 and then Present (Alias (E))
930 then
931 Ent := Alias (E);
932 while not Comes_From_Source (Ent) loop
933 if No (Alias (Ent)) then
934 return;
935 end if;
936
937 Ent := Alias (Ent);
938 end loop;
939
940 -- The internally created defining entity for a child subprogram
941 -- that has no previous spec has valid references.
942
943 elsif Is_Overloadable (E)
944 and then Is_Child_Unit (E)
945 then
946 Ent := E;
947
948 -- Record components of discriminated subtypes or derived types must
949 -- be treated as references to the original component.
950
951 elsif Ekind (E) = E_Component
952 and then Comes_From_Source (Original_Record_Component (E))
953 then
954 Ent := Original_Record_Component (E);
955
956 -- If this is an expanded reference to a discriminant, recover the
957 -- original discriminant, which gets the reference.
958
959 elsif Ekind (E) = E_In_Parameter
960 and then Present (Discriminal_Link (E))
961 then
962 Ent := Discriminal_Link (E);
963 Set_Referenced (Ent);
964
965 -- Ignore reference to any other entity that is not from source
966
967 else
968 return;
969 end if;
970
971 -- In Alfa mode, consider the underlying entity renamed instead of
972 -- the renaming, which is needed to compute a valid set of effects
973 -- (reads, writes) for the enclosing subprogram.
974
975 if Alfa_Mode then
976 Ent := Get_Through_Renamings (Ent);
977
978 -- If no enclosing object, then it could be a reference to any
979 -- location not tracked individually, like heap-allocated data.
980 -- Conservatively approximate this possibility by generating a
981 -- dereference, and return.
982
983 if No (Ent) then
984 if Actual_Typ = 'w' then
985 Alfa.Generate_Dereference (Nod, 'r');
986 Alfa.Generate_Dereference (Nod, 'w');
987 else
988 Alfa.Generate_Dereference (Nod, 'r');
989 end if;
990
991 return;
992 end if;
993 end if;
994
995 -- Record reference to entity
996
997 if Actual_Typ = 'p'
998 and then Is_Subprogram (Nod)
999 and then Present (Overridden_Operation (Nod))
1000 then
1001 Actual_Typ := 'P';
1002 end if;
1003
1004 if Alfa_Mode then
1005 Ref := Sloc (Nod);
1006 Def := Sloc (Ent);
1007
1008 Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (Nod);
1009 Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent);
1010
1011 -- Since we are reaching through renamings in Alfa mode, we may
1012 -- end up with standard constants. Ignore those.
1013
1014 if Sloc (Ent_Scope) <= Standard_Location
1015 or else Def <= Standard_Location
1016 then
1017 return;
1018 end if;
1019
1020 Add_Entry
1021 ((Ent => Ent,
1022 Loc => Ref,
1023 Typ => Actual_Typ,
1024 Eun => Get_Code_Unit (Def),
1025 Lun => Get_Code_Unit (Ref),
1026 Ref_Scope => Ref_Scope,
1027 Ent_Scope => Ent_Scope),
1028 Ent_Scope_File => Get_Code_Unit (Ent));
1029
1030 else
1031 Ref := Original_Location (Sloc (Nod));
1032 Def := Original_Location (Sloc (Ent));
1033
1034 Add_Entry
1035 ((Ent => Ent,
1036 Loc => Ref,
1037 Typ => Actual_Typ,
1038 Eun => Get_Source_Unit (Def),
1039 Lun => Get_Source_Unit (Ref),
1040 Ref_Scope => Empty,
1041 Ent_Scope => Empty),
1042 Ent_Scope_File => No_Unit);
1043 end if;
1044 end if;
1045 end Generate_Reference;
1046
1047 -----------------------------------
1048 -- Generate_Reference_To_Formals --
1049 -----------------------------------
1050
1051 procedure Generate_Reference_To_Formals (E : Entity_Id) is
1052 Formal : Entity_Id;
1053
1054 begin
1055 if Is_Generic_Subprogram (E) then
1056 Formal := First_Entity (E);
1057
1058 while Present (Formal)
1059 and then not Is_Formal (Formal)
1060 loop
1061 Next_Entity (Formal);
1062 end loop;
1063
1064 else
1065 Formal := First_Formal (E);
1066 end if;
1067
1068 while Present (Formal) loop
1069 if Ekind (Formal) = E_In_Parameter then
1070
1071 if Nkind (Parameter_Type (Parent (Formal)))
1072 = N_Access_Definition
1073 then
1074 Generate_Reference (E, Formal, '^', False);
1075 else
1076 Generate_Reference (E, Formal, '>', False);
1077 end if;
1078
1079 elsif Ekind (Formal) = E_In_Out_Parameter then
1080 Generate_Reference (E, Formal, '=', False);
1081
1082 else
1083 Generate_Reference (E, Formal, '<', False);
1084 end if;
1085
1086 Next_Formal (Formal);
1087 end loop;
1088 end Generate_Reference_To_Formals;
1089
1090 -------------------------------------------
1091 -- Generate_Reference_To_Generic_Formals --
1092 -------------------------------------------
1093
1094 procedure Generate_Reference_To_Generic_Formals (E : Entity_Id) is
1095 Formal : Entity_Id;
1096
1097 begin
1098 Formal := First_Entity (E);
1099 while Present (Formal) loop
1100 if Comes_From_Source (Formal) then
1101 Generate_Reference (E, Formal, 'z', False);
1102 end if;
1103
1104 Next_Entity (Formal);
1105 end loop;
1106 end Generate_Reference_To_Generic_Formals;
1107
1108 -------------
1109 -- Get_Key --
1110 -------------
1111
1112 function Get_Key (E : Xref_Entry_Number) return Xref_Entry_Number is
1113 begin
1114 return E;
1115 end Get_Key;
1116
1117 ----------
1118 -- Hash --
1119 ----------
1120
1121 function Hash (F : Xref_Entry_Number) return Header_Num is
1122 -- It is unlikely to have two references to the same entity at the same
1123 -- source location, so the hash function depends only on the Ent and Loc
1124 -- fields.
1125
1126 XE : Xref_Entry renames Xrefs.Table (F);
1127 type M is mod 2**32;
1128
1129 H : constant M := M (XE.Key.Ent) + 2 ** 7 * M (abs XE.Key.Loc);
1130 -- It would be more natural to write:
1131 --
1132 -- H : constant M := M'Mod (XE.Key.Ent) + 2**7 * M'Mod (XE.Key.Loc);
1133 --
1134 -- But we can't use M'Mod, because it prevents bootstrapping with older
1135 -- compilers. Loc can be negative, so we do "abs" before converting.
1136 -- One day this can be cleaned up ???
1137
1138 begin
1139 return Header_Num (H mod Num_Buckets);
1140 end Hash;
1141
1142 -----------------
1143 -- HT_Set_Next --
1144 -----------------
1145
1146 procedure HT_Set_Next (E : Xref_Entry_Number; Next : Xref_Entry_Number) is
1147 begin
1148 Xrefs.Table (E).HTable_Next := Next;
1149 end HT_Set_Next;
1150
1151 -------------
1152 -- HT_Next --
1153 -------------
1154
1155 function HT_Next (E : Xref_Entry_Number) return Xref_Entry_Number is
1156 begin
1157 return Xrefs.Table (E).HTable_Next;
1158 end HT_Next;
1159
1160 ----------------
1161 -- Initialize --
1162 ----------------
1163
1164 procedure Initialize is
1165 begin
1166 Xrefs.Init;
1167 end Initialize;
1168
1169 --------
1170 -- Lt --
1171 --------
1172
1173 function Lt (T1, T2 : Xref_Entry) return Boolean is
1174 begin
1175 -- First test: if entity is in different unit, sort by unit
1176
1177 if T1.Key.Eun /= T2.Key.Eun then
1178 return Dependency_Num (T1.Key.Eun) < Dependency_Num (T2.Key.Eun);
1179
1180 -- Second test: within same unit, sort by entity Sloc
1181
1182 elsif T1.Def /= T2.Def then
1183 return T1.Def < T2.Def;
1184
1185 -- Third test: sort definitions ahead of references
1186
1187 elsif T1.Key.Loc = No_Location then
1188 return True;
1189
1190 elsif T2.Key.Loc = No_Location then
1191 return False;
1192
1193 -- Fourth test: for same entity, sort by reference location unit
1194
1195 elsif T1.Key.Lun /= T2.Key.Lun then
1196 return Dependency_Num (T1.Key.Lun) < Dependency_Num (T2.Key.Lun);
1197
1198 -- Fifth test: order of location within referencing unit
1199
1200 elsif T1.Key.Loc /= T2.Key.Loc then
1201 return T1.Key.Loc < T2.Key.Loc;
1202
1203 -- Finally, for two locations at the same address, we prefer
1204 -- the one that does NOT have the type 'r' so that a modification
1205 -- or extension takes preference, when there are more than one
1206 -- reference at the same location. As a result, in the case of
1207 -- entities that are in-out actuals, the read reference follows
1208 -- the modify reference.
1209
1210 else
1211 return T2.Key.Typ = 'r';
1212 end if;
1213 end Lt;
1214
1215 -----------------------
1216 -- Output_References --
1217 -----------------------
1218
1219 procedure Output_References is
1220
1221 procedure Get_Type_Reference
1222 (Ent : Entity_Id;
1223 Tref : out Entity_Id;
1224 Left : out Character;
1225 Right : out Character);
1226 -- Given an Entity_Id Ent, determines whether a type reference is
1227 -- required. If so, Tref is set to the entity for the type reference
1228 -- and Left and Right are set to the left/right brackets to be output
1229 -- for the reference. If no type reference is required, then Tref is
1230 -- set to Empty, and Left/Right are set to space.
1231
1232 procedure Output_Import_Export_Info (Ent : Entity_Id);
1233 -- Output language and external name information for an interfaced
1234 -- entity, using the format <language, external_name>.
1235
1236 ------------------------
1237 -- Get_Type_Reference --
1238 ------------------------
1239
1240 procedure Get_Type_Reference
1241 (Ent : Entity_Id;
1242 Tref : out Entity_Id;
1243 Left : out Character;
1244 Right : out Character)
1245 is
1246 Sav : Entity_Id;
1247
1248 begin
1249 -- See if we have a type reference
1250
1251 Tref := Ent;
1252 Left := '{';
1253 Right := '}';
1254
1255 loop
1256 Sav := Tref;
1257
1258 -- Processing for types
1259
1260 if Is_Type (Tref) then
1261
1262 -- Case of base type
1263
1264 if Base_Type (Tref) = Tref then
1265
1266 -- If derived, then get first subtype
1267
1268 if Tref /= Etype (Tref) then
1269 Tref := First_Subtype (Etype (Tref));
1270
1271 -- Set brackets for derived type, but don't override
1272 -- pointer case since the fact that something is a
1273 -- pointer is more important.
1274
1275 if Left /= '(' then
1276 Left := '<';
1277 Right := '>';
1278 end if;
1279
1280 -- If non-derived ptr, get directly designated type.
1281 -- If the type has a full view, all references are on the
1282 -- partial view, that is seen first.
1283
1284 elsif Is_Access_Type (Tref) then
1285 Tref := Directly_Designated_Type (Tref);
1286 Left := '(';
1287 Right := ')';
1288
1289 elsif Is_Private_Type (Tref)
1290 and then Present (Full_View (Tref))
1291 then
1292 if Is_Access_Type (Full_View (Tref)) then
1293 Tref := Directly_Designated_Type (Full_View (Tref));
1294 Left := '(';
1295 Right := ')';
1296
1297 -- If the full view is an array type, we also retrieve
1298 -- the corresponding component type, because the ali
1299 -- entry already indicates that this is an array.
1300
1301 elsif Is_Array_Type (Full_View (Tref)) then
1302 Tref := Component_Type (Full_View (Tref));
1303 Left := '(';
1304 Right := ')';
1305 end if;
1306
1307 -- If non-derived array, get component type. Skip component
1308 -- type for case of String or Wide_String, saves worthwhile
1309 -- space.
1310
1311 elsif Is_Array_Type (Tref)
1312 and then Tref /= Standard_String
1313 and then Tref /= Standard_Wide_String
1314 then
1315 Tref := Component_Type (Tref);
1316 Left := '(';
1317 Right := ')';
1318
1319 -- For other non-derived base types, nothing
1320
1321 else
1322 exit;
1323 end if;
1324
1325 -- For a subtype, go to ancestor subtype
1326
1327 else
1328 Tref := Ancestor_Subtype (Tref);
1329
1330 -- If no ancestor subtype, go to base type
1331
1332 if No (Tref) then
1333 Tref := Base_Type (Sav);
1334 end if;
1335 end if;
1336
1337 -- For objects, functions, enum literals, just get type from
1338 -- Etype field.
1339
1340 elsif Is_Object (Tref)
1341 or else Ekind (Tref) = E_Enumeration_Literal
1342 or else Ekind (Tref) = E_Function
1343 or else Ekind (Tref) = E_Operator
1344 then
1345 Tref := Etype (Tref);
1346
1347 -- For anything else, exit
1348
1349 else
1350 exit;
1351 end if;
1352
1353 -- Exit if no type reference, or we are stuck in some loop trying
1354 -- to find the type reference, or if the type is standard void
1355 -- type (the latter is an implementation artifact that should not
1356 -- show up in the generated cross-references).
1357
1358 exit when No (Tref)
1359 or else Tref = Sav
1360 or else Tref = Standard_Void_Type;
1361
1362 -- If we have a usable type reference, return, otherwise keep
1363 -- looking for something useful (we are looking for something
1364 -- that either comes from source or standard)
1365
1366 if Sloc (Tref) = Standard_Location
1367 or else Comes_From_Source (Tref)
1368 then
1369 -- If the reference is a subtype created for a generic actual,
1370 -- go actual directly, the inner subtype is not user visible.
1371
1372 if Nkind (Parent (Tref)) = N_Subtype_Declaration
1373 and then not Comes_From_Source (Parent (Tref))
1374 and then
1375 (Is_Wrapper_Package (Scope (Tref))
1376 or else Is_Generic_Instance (Scope (Tref)))
1377 then
1378 Tref := First_Subtype (Base_Type (Tref));
1379 end if;
1380
1381 return;
1382 end if;
1383 end loop;
1384
1385 -- If we fall through the loop, no type reference
1386
1387 Tref := Empty;
1388 Left := ' ';
1389 Right := ' ';
1390 end Get_Type_Reference;
1391
1392 -------------------------------
1393 -- Output_Import_Export_Info --
1394 -------------------------------
1395
1396 procedure Output_Import_Export_Info (Ent : Entity_Id) is
1397 Language_Name : Name_Id;
1398 Conv : constant Convention_Id := Convention (Ent);
1399
1400 begin
1401 -- Generate language name from convention
1402
1403 if Conv = Convention_C then
1404 Language_Name := Name_C;
1405
1406 elsif Conv = Convention_CPP then
1407 Language_Name := Name_CPP;
1408
1409 elsif Conv = Convention_Ada then
1410 Language_Name := Name_Ada;
1411
1412 else
1413 -- For the moment we ignore all other cases ???
1414
1415 return;
1416 end if;
1417
1418 Write_Info_Char ('<');
1419 Get_Unqualified_Name_String (Language_Name);
1420
1421 for J in 1 .. Name_Len loop
1422 Write_Info_Char (Name_Buffer (J));
1423 end loop;
1424
1425 if Present (Interface_Name (Ent)) then
1426 Write_Info_Char (',');
1427 String_To_Name_Buffer (Strval (Interface_Name (Ent)));
1428
1429 for J in 1 .. Name_Len loop
1430 Write_Info_Char (Name_Buffer (J));
1431 end loop;
1432 end if;
1433
1434 Write_Info_Char ('>');
1435 end Output_Import_Export_Info;
1436
1437 -- Start of processing for Output_References
1438
1439 begin
1440 -- First we add references to the primitive operations of tagged types
1441 -- declared in the main unit.
1442
1443 Handle_Prim_Ops : declare
1444 Ent : Entity_Id;
1445
1446 begin
1447 for J in 1 .. Xrefs.Last loop
1448 Ent := Xrefs.Table (J).Key.Ent;
1449
1450 if Is_Type (Ent)
1451 and then Is_Tagged_Type (Ent)
1452 and then Is_Base_Type (Ent)
1453 and then In_Extended_Main_Source_Unit (Ent)
1454 then
1455 Generate_Prim_Op_References (Ent);
1456 end if;
1457 end loop;
1458 end Handle_Prim_Ops;
1459
1460 -- Before we go ahead and output the references we have a problem
1461 -- that needs dealing with. So far we have captured things that are
1462 -- definitely referenced by the main unit, or defined in the main
1463 -- unit. That's because we don't want to clutter up the ali file
1464 -- for this unit with definition lines for entities in other units
1465 -- that are not referenced.
1466
1467 -- But there is a glitch. We may reference an entity in another unit,
1468 -- and it may have a type reference to an entity that is not directly
1469 -- referenced in the main unit, which may mean that there is no xref
1470 -- entry for this entity yet in the list of references.
1471
1472 -- If we don't do something about this, we will end with an orphan type
1473 -- reference, i.e. it will point to an entity that does not appear
1474 -- within the generated references in the ali file. That is not good for
1475 -- tools using the xref information.
1476
1477 -- To fix this, we go through the references adding definition entries
1478 -- for any unreferenced entities that can be referenced in a type
1479 -- reference. There is a recursion problem here, and that is dealt with
1480 -- by making sure that this traversal also traverses any entries that
1481 -- get added by the traversal.
1482
1483 Handle_Orphan_Type_References : declare
1484 J : Nat;
1485 Tref : Entity_Id;
1486 Ent : Entity_Id;
1487
1488 L, R : Character;
1489 pragma Warnings (Off, L);
1490 pragma Warnings (Off, R);
1491
1492 procedure New_Entry (E : Entity_Id);
1493 -- Make an additional entry into the Xref table for a type entity
1494 -- that is related to the current entity (parent, type ancestor,
1495 -- progenitor, etc.).
1496
1497 ----------------
1498 -- New_Entry --
1499 ----------------
1500
1501 procedure New_Entry (E : Entity_Id) is
1502 begin
1503 pragma Assert (Present (E));
1504
1505 if not Has_Xref_Entry (Implementation_Base_Type (E))
1506 and then Sloc (E) > No_Location
1507 then
1508 Add_Entry
1509 ((Ent => E,
1510 Loc => No_Location,
1511 Typ => Character'First,
1512 Eun => Get_Source_Unit (Original_Location (Sloc (E))),
1513 Lun => No_Unit,
1514 Ref_Scope => Empty,
1515 Ent_Scope => Empty),
1516 Ent_Scope_File => No_Unit);
1517 end if;
1518 end New_Entry;
1519
1520 -- Start of processing for Handle_Orphan_Type_References
1521
1522 begin
1523 -- Note that this is not a for loop for a very good reason. The
1524 -- processing of items in the table can add new items to the table,
1525 -- and they must be processed as well.
1526
1527 J := 1;
1528 while J <= Xrefs.Last loop
1529 Ent := Xrefs.Table (J).Key.Ent;
1530 Get_Type_Reference (Ent, Tref, L, R);
1531
1532 if Present (Tref)
1533 and then not Has_Xref_Entry (Tref)
1534 and then Sloc (Tref) > No_Location
1535 then
1536 New_Entry (Tref);
1537
1538 if Is_Record_Type (Ent)
1539 and then Present (Interfaces (Ent))
1540 then
1541 -- Add an entry for each one of the given interfaces
1542 -- implemented by type Ent.
1543
1544 declare
1545 Elmt : Elmt_Id := First_Elmt (Interfaces (Ent));
1546 begin
1547 while Present (Elmt) loop
1548 New_Entry (Node (Elmt));
1549 Next_Elmt (Elmt);
1550 end loop;
1551 end;
1552 end if;
1553 end if;
1554
1555 -- Collect inherited primitive operations that may be declared in
1556 -- another unit and have no visible reference in the current one.
1557
1558 if Is_Type (Ent)
1559 and then Is_Tagged_Type (Ent)
1560 and then Is_Derived_Type (Ent)
1561 and then Is_Base_Type (Ent)
1562 and then In_Extended_Main_Source_Unit (Ent)
1563 then
1564 declare
1565 Op_List : constant Elist_Id := Primitive_Operations (Ent);
1566 Op : Elmt_Id;
1567 Prim : Entity_Id;
1568
1569 function Parent_Op (E : Entity_Id) return Entity_Id;
1570 -- Find original operation, which may be inherited through
1571 -- several derivations.
1572
1573 function Parent_Op (E : Entity_Id) return Entity_Id is
1574 Orig_Op : constant Entity_Id := Alias (E);
1575
1576 begin
1577 if No (Orig_Op) then
1578 return Empty;
1579
1580 elsif not Comes_From_Source (E)
1581 and then not Has_Xref_Entry (Orig_Op)
1582 and then Comes_From_Source (Orig_Op)
1583 then
1584 return Orig_Op;
1585 else
1586 return Parent_Op (Orig_Op);
1587 end if;
1588 end Parent_Op;
1589
1590 begin
1591 Op := First_Elmt (Op_List);
1592 while Present (Op) loop
1593 Prim := Parent_Op (Node (Op));
1594
1595 if Present (Prim) then
1596 Add_Entry
1597 ((Ent => Prim,
1598 Loc => No_Location,
1599 Typ => Character'First,
1600 Eun => Get_Source_Unit (Sloc (Prim)),
1601 Lun => No_Unit,
1602 Ref_Scope => Empty,
1603 Ent_Scope => Empty),
1604 Ent_Scope_File => No_Unit);
1605 end if;
1606
1607 Next_Elmt (Op);
1608 end loop;
1609 end;
1610 end if;
1611
1612 J := J + 1;
1613 end loop;
1614 end Handle_Orphan_Type_References;
1615
1616 -- Now we have all the references, including those for any embedded
1617 -- type references, so we can sort them, and output them.
1618
1619 Output_Refs : declare
1620
1621 Nrefs : constant Nat := Xrefs.Last;
1622 -- Number of references in table
1623
1624 Rnums : array (0 .. Nrefs) of Nat;
1625 -- This array contains numbers of references in the Xrefs table.
1626 -- This list is sorted in output order. The extra 0'th entry is
1627 -- convenient for the call to sort. When we sort the table, we
1628 -- move the entries in Rnums around, but we do not move the
1629 -- original table entries.
1630
1631 Curxu : Unit_Number_Type;
1632 -- Current xref unit
1633
1634 Curru : Unit_Number_Type;
1635 -- Current reference unit for one entity
1636
1637 Curent : Entity_Id;
1638 -- Current entity
1639
1640 Curnam : String (1 .. Name_Buffer'Length);
1641 Curlen : Natural;
1642 -- Simple name and length of current entity
1643
1644 Curdef : Source_Ptr;
1645 -- Original source location for current entity
1646
1647 Crloc : Source_Ptr;
1648 -- Current reference location
1649
1650 Ctyp : Character;
1651 -- Entity type character
1652
1653 Prevt : Character;
1654 -- reference kind of previous reference
1655
1656 Tref : Entity_Id;
1657 -- Type reference
1658
1659 Rref : Node_Id;
1660 -- Renaming reference
1661
1662 Trunit : Unit_Number_Type;
1663 -- Unit number for type reference
1664
1665 function Lt (Op1, Op2 : Natural) return Boolean;
1666 -- Comparison function for Sort call
1667
1668 function Name_Change (X : Entity_Id) return Boolean;
1669 -- Determines if entity X has a different simple name from Curent
1670
1671 procedure Move (From : Natural; To : Natural);
1672 -- Move procedure for Sort call
1673
1674 package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
1675
1676 --------
1677 -- Lt --
1678 --------
1679
1680 function Lt (Op1, Op2 : Natural) return Boolean is
1681 T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
1682 T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
1683
1684 begin
1685 return Lt (T1, T2);
1686 end Lt;
1687
1688 ----------
1689 -- Move --
1690 ----------
1691
1692 procedure Move (From : Natural; To : Natural) is
1693 begin
1694 Rnums (Nat (To)) := Rnums (Nat (From));
1695 end Move;
1696
1697 -----------------
1698 -- Name_Change --
1699 -----------------
1700
1701 -- Why a string comparison here??? Why not compare Name_Id values???
1702
1703 function Name_Change (X : Entity_Id) return Boolean is
1704 begin
1705 Get_Unqualified_Name_String (Chars (X));
1706
1707 if Name_Len /= Curlen then
1708 return True;
1709 else
1710 return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen);
1711 end if;
1712 end Name_Change;
1713
1714 -- Start of processing for Output_Refs
1715
1716 begin
1717 -- Capture the definition Sloc values. We delay doing this till now,
1718 -- since at the time the reference or definition is made, private
1719 -- types may be swapped, and the Sloc value may be incorrect. We
1720 -- also set up the pointer vector for the sort.
1721
1722 for J in 1 .. Nrefs loop
1723 Rnums (J) := J;
1724 Xrefs.Table (J).Def :=
1725 Original_Location (Sloc (Xrefs.Table (J).Key.Ent));
1726 end loop;
1727
1728 -- Sort the references
1729
1730 Sorting.Sort (Integer (Nrefs));
1731
1732 -- Initialize loop through references
1733
1734 Curxu := No_Unit;
1735 Curent := Empty;
1736 Curdef := No_Location;
1737 Curru := No_Unit;
1738 Crloc := No_Location;
1739 Prevt := 'm';
1740
1741 -- Loop to output references
1742
1743 for Refno in 1 .. Nrefs loop
1744 Output_One_Ref : declare
1745 Ent : Entity_Id;
1746
1747 XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
1748 -- The current entry to be accessed
1749
1750 Left : Character;
1751 Right : Character;
1752 -- Used for {} or <> or () for type reference
1753
1754 procedure Check_Type_Reference
1755 (Ent : Entity_Id;
1756 List_Interface : Boolean);
1757 -- Find whether there is a meaningful type reference for
1758 -- Ent, and display it accordingly. If List_Interface is
1759 -- true, then Ent is a progenitor interface of the current
1760 -- type entity being listed. In that case list it as is,
1761 -- without looking for a type reference for it.
1762
1763 procedure Output_Instantiation_Refs (Loc : Source_Ptr);
1764 -- Recursive procedure to output instantiation references for
1765 -- the given source ptr in [file|line[...]] form. No output
1766 -- if the given location is not a generic template reference.
1767
1768 procedure Output_Overridden_Op (Old_E : Entity_Id);
1769 -- For a subprogram that is overriding, display information
1770 -- about the inherited operation that it overrides.
1771
1772 --------------------------
1773 -- Check_Type_Reference --
1774 --------------------------
1775
1776 procedure Check_Type_Reference
1777 (Ent : Entity_Id;
1778 List_Interface : Boolean)
1779 is
1780 begin
1781 if List_Interface then
1782
1783 -- This is a progenitor interface of the type for which
1784 -- xref information is being generated.
1785
1786 Tref := Ent;
1787 Left := '<';
1788 Right := '>';
1789
1790 else
1791 Get_Type_Reference (Ent, Tref, Left, Right);
1792 end if;
1793
1794 if Present (Tref) then
1795
1796 -- Case of standard entity, output name
1797
1798 if Sloc (Tref) = Standard_Location then
1799 Write_Info_Char (Left);
1800 Write_Info_Name (Chars (Tref));
1801 Write_Info_Char (Right);
1802
1803 -- Case of source entity, output location
1804
1805 else
1806 Write_Info_Char (Left);
1807 Trunit := Get_Source_Unit (Sloc (Tref));
1808
1809 if Trunit /= Curxu then
1810 Write_Info_Nat (Dependency_Num (Trunit));
1811 Write_Info_Char ('|');
1812 end if;
1813
1814 Write_Info_Nat
1815 (Int (Get_Logical_Line_Number (Sloc (Tref))));
1816
1817 declare
1818 Ent : Entity_Id;
1819 Ctyp : Character;
1820
1821 begin
1822 Ent := Tref;
1823 Ctyp := Xref_Entity_Letters (Ekind (Ent));
1824
1825 if Ctyp = '+'
1826 and then Present (Full_View (Ent))
1827 then
1828 Ent := Underlying_Type (Ent);
1829
1830 if Present (Ent) then
1831 Ctyp := Xref_Entity_Letters (Ekind (Ent));
1832 end if;
1833 end if;
1834
1835 Write_Info_Char (Ctyp);
1836 end;
1837
1838 Write_Info_Nat
1839 (Int (Get_Column_Number (Sloc (Tref))));
1840
1841 -- If the type comes from an instantiation, add the
1842 -- corresponding info.
1843
1844 Output_Instantiation_Refs (Sloc (Tref));
1845 Write_Info_Char (Right);
1846 end if;
1847 end if;
1848 end Check_Type_Reference;
1849
1850 -------------------------------
1851 -- Output_Instantiation_Refs --
1852 -------------------------------
1853
1854 procedure Output_Instantiation_Refs (Loc : Source_Ptr) is
1855 Iloc : constant Source_Ptr := Instantiation_Location (Loc);
1856 Lun : Unit_Number_Type;
1857 Cu : constant Unit_Number_Type := Curru;
1858
1859 begin
1860 -- Nothing to do if this is not an instantiation
1861
1862 if Iloc = No_Location then
1863 return;
1864 end if;
1865
1866 -- Output instantiation reference
1867
1868 Write_Info_Char ('[');
1869 Lun := Get_Source_Unit (Iloc);
1870
1871 if Lun /= Curru then
1872 Curru := Lun;
1873 Write_Info_Nat (Dependency_Num (Curru));
1874 Write_Info_Char ('|');
1875 end if;
1876
1877 Write_Info_Nat (Int (Get_Logical_Line_Number (Iloc)));
1878
1879 -- Recursive call to get nested instantiations
1880
1881 Output_Instantiation_Refs (Iloc);
1882
1883 -- Output final ] after call to get proper nesting
1884
1885 Write_Info_Char (']');
1886 Curru := Cu;
1887 return;
1888 end Output_Instantiation_Refs;
1889
1890 --------------------------
1891 -- Output_Overridden_Op --
1892 --------------------------
1893
1894 procedure Output_Overridden_Op (Old_E : Entity_Id) is
1895 Op : Entity_Id;
1896
1897 begin
1898 -- The overridden operation has an implicit declaration
1899 -- at the point of derivation. What we want to display
1900 -- is the original operation, which has the actual body
1901 -- (or abstract declaration) that is being overridden.
1902 -- The overridden operation is not always set, e.g. when
1903 -- it is a predefined operator.
1904
1905 if No (Old_E) then
1906 return;
1907
1908 -- Follow alias chain if one is present
1909
1910 elsif Present (Alias (Old_E)) then
1911
1912 -- The subprogram may have been implicitly inherited
1913 -- through several levels of derivation, so find the
1914 -- ultimate (source) ancestor.
1915
1916 Op := Ultimate_Alias (Old_E);
1917
1918 -- Normal case of no alias present. We omit generated
1919 -- primitives like tagged equality, that have no source
1920 -- representation.
1921
1922 else
1923 Op := Old_E;
1924 end if;
1925
1926 if Present (Op)
1927 and then Sloc (Op) /= Standard_Location
1928 and then Comes_From_Source (Op)
1929 then
1930 declare
1931 Loc : constant Source_Ptr := Sloc (Op);
1932 Par_Unit : constant Unit_Number_Type :=
1933 Get_Source_Unit (Loc);
1934
1935 begin
1936 Write_Info_Char ('<');
1937
1938 if Par_Unit /= Curxu then
1939 Write_Info_Nat (Dependency_Num (Par_Unit));
1940 Write_Info_Char ('|');
1941 end if;
1942
1943 Write_Info_Nat (Int (Get_Logical_Line_Number (Loc)));
1944 Write_Info_Char ('p');
1945 Write_Info_Nat (Int (Get_Column_Number (Loc)));
1946 Write_Info_Char ('>');
1947 end;
1948 end if;
1949 end Output_Overridden_Op;
1950
1951 -- Start of processing for Output_One_Ref
1952
1953 begin
1954 Ent := XE.Key.Ent;
1955 Ctyp := Xref_Entity_Letters (Ekind (Ent));
1956
1957 -- Skip reference if it is the only reference to an entity,
1958 -- and it is an END line reference, and the entity is not in
1959 -- the current extended source. This prevents junk entries
1960 -- consisting only of packages with END lines, where no
1961 -- entity from the package is actually referenced.
1962
1963 if XE.Key.Typ = 'e'
1964 and then Ent /= Curent
1965 and then (Refno = Nrefs
1966 or else
1967 Ent /= Xrefs.Table (Rnums (Refno + 1)).Key.Ent)
1968 and then not In_Extended_Main_Source_Unit (Ent)
1969 then
1970 goto Continue;
1971 end if;
1972
1973 -- For private type, get full view type
1974
1975 if Ctyp = '+'
1976 and then Present (Full_View (XE.Key.Ent))
1977 then
1978 Ent := Underlying_Type (Ent);
1979
1980 if Present (Ent) then
1981 Ctyp := Xref_Entity_Letters (Ekind (Ent));
1982 end if;
1983 end if;
1984
1985 -- Special exception for Boolean
1986
1987 if Ctyp = 'E' and then Is_Boolean_Type (Ent) then
1988 Ctyp := 'B';
1989 end if;
1990
1991 -- For variable reference, get corresponding type
1992
1993 if Ctyp = '*' then
1994 Ent := Etype (XE.Key.Ent);
1995 Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
1996
1997 -- If variable is private type, get full view type
1998
1999 if Ctyp = '+'
2000 and then Present (Full_View (Etype (XE.Key.Ent)))
2001 then
2002 Ent := Underlying_Type (Etype (XE.Key.Ent));
2003
2004 if Present (Ent) then
2005 Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
2006 end if;
2007
2008 elsif Is_Generic_Type (Ent) then
2009
2010 -- If the type of the entity is a generic private type,
2011 -- there is no usable full view, so retain the indication
2012 -- that this is an object.
2013
2014 Ctyp := '*';
2015 end if;
2016
2017 -- Special handling for access parameters and objects of
2018 -- an anonymous access type.
2019
2020 if Ekind_In (Etype (XE.Key.Ent),
2021 E_Anonymous_Access_Type,
2022 E_Anonymous_Access_Subprogram_Type,
2023 E_Anonymous_Access_Protected_Subprogram_Type)
2024 then
2025 if Is_Formal (XE.Key.Ent)
2026 or else Ekind_In (XE.Key.Ent, E_Variable, E_Constant)
2027 then
2028 Ctyp := 'p';
2029 end if;
2030
2031 -- Special handling for Boolean
2032
2033 elsif Ctyp = 'e' and then Is_Boolean_Type (Ent) then
2034 Ctyp := 'b';
2035 end if;
2036 end if;
2037
2038 -- Special handling for abstract types and operations
2039
2040 if Is_Overloadable (XE.Key.Ent)
2041 and then Is_Abstract_Subprogram (XE.Key.Ent)
2042 then
2043 if Ctyp = 'U' then
2044 Ctyp := 'x'; -- Abstract procedure
2045
2046 elsif Ctyp = 'V' then
2047 Ctyp := 'y'; -- Abstract function
2048 end if;
2049
2050 elsif Is_Type (XE.Key.Ent)
2051 and then Is_Abstract_Type (XE.Key.Ent)
2052 then
2053 if Is_Interface (XE.Key.Ent) then
2054 Ctyp := 'h';
2055
2056 elsif Ctyp = 'R' then
2057 Ctyp := 'H'; -- Abstract type
2058 end if;
2059 end if;
2060
2061 -- Only output reference if interesting type of entity
2062
2063 if Ctyp = ' '
2064
2065 -- Suppress references to object definitions, used for local
2066 -- references.
2067
2068 or else XE.Key.Typ = 'D'
2069 or else XE.Key.Typ = 'I'
2070
2071 -- Suppress self references, except for bodies that act as
2072 -- specs.
2073
2074 or else (XE.Key.Loc = XE.Def
2075 and then
2076 (XE.Key.Typ /= 'b'
2077 or else not Is_Subprogram (XE.Key.Ent)))
2078
2079 -- Also suppress definitions of body formals (we only
2080 -- treat these as references, and the references were
2081 -- separately recorded).
2082
2083 or else (Is_Formal (XE.Key.Ent)
2084 and then Present (Spec_Entity (XE.Key.Ent)))
2085 then
2086 null;
2087
2088 else
2089 -- Start new Xref section if new xref unit
2090
2091 if XE.Key.Eun /= Curxu then
2092 if Write_Info_Col > 1 then
2093 Write_Info_EOL;
2094 end if;
2095
2096 Curxu := XE.Key.Eun;
2097
2098 Write_Info_Initiate ('X');
2099 Write_Info_Char (' ');
2100 Write_Info_Nat (Dependency_Num (XE.Key.Eun));
2101 Write_Info_Char (' ');
2102 Write_Info_Name
2103 (Reference_Name (Source_Index (XE.Key.Eun)));
2104 end if;
2105
2106 -- Start new Entity line if new entity. Note that we
2107 -- consider two entities the same if they have the same
2108 -- name and source location. This causes entities in
2109 -- instantiations to be treated as though they referred
2110 -- to the template.
2111
2112 if No (Curent)
2113 or else
2114 (XE.Key.Ent /= Curent
2115 and then
2116 (Name_Change (XE.Key.Ent) or else XE.Def /= Curdef))
2117 then
2118 Curent := XE.Key.Ent;
2119 Curdef := XE.Def;
2120
2121 Get_Unqualified_Name_String (Chars (XE.Key.Ent));
2122 Curlen := Name_Len;
2123 Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);
2124
2125 if Write_Info_Col > 1 then
2126 Write_Info_EOL;
2127 end if;
2128
2129 -- Write column number information
2130
2131 Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Def)));
2132 Write_Info_Char (Ctyp);
2133 Write_Info_Nat (Int (Get_Column_Number (XE.Def)));
2134
2135 -- Write level information
2136
2137 Write_Level_Info : declare
2138 function Is_Visible_Generic_Entity
2139 (E : Entity_Id) return Boolean;
2140 -- Check whether E is declared in the visible part
2141 -- of a generic package. For source navigation
2142 -- purposes, treat this as a visible entity.
2143
2144 function Is_Private_Record_Component
2145 (E : Entity_Id) return Boolean;
2146 -- Check whether E is a non-inherited component of a
2147 -- private extension. Even if the enclosing record is
2148 -- public, we want to treat the component as private
2149 -- for navigation purposes.
2150
2151 ---------------------------------
2152 -- Is_Private_Record_Component --
2153 ---------------------------------
2154
2155 function Is_Private_Record_Component
2156 (E : Entity_Id) return Boolean
2157 is
2158 S : constant Entity_Id := Scope (E);
2159 begin
2160 return
2161 Ekind (E) = E_Component
2162 and then Nkind (Declaration_Node (S)) =
2163 N_Private_Extension_Declaration
2164 and then Original_Record_Component (E) = E;
2165 end Is_Private_Record_Component;
2166
2167 -------------------------------
2168 -- Is_Visible_Generic_Entity --
2169 -------------------------------
2170
2171 function Is_Visible_Generic_Entity
2172 (E : Entity_Id) return Boolean
2173 is
2174 Par : Node_Id;
2175
2176 begin
2177 -- The Present check here is an error defense
2178
2179 if Present (Scope (E))
2180 and then Ekind (Scope (E)) /= E_Generic_Package
2181 then
2182 return False;
2183 end if;
2184
2185 Par := Parent (E);
2186 while Present (Par) loop
2187 if
2188 Nkind (Par) = N_Generic_Package_Declaration
2189 then
2190 -- Entity is a generic formal
2191
2192 return False;
2193
2194 elsif
2195 Nkind (Parent (Par)) = N_Package_Specification
2196 then
2197 return
2198 Is_List_Member (Par)
2199 and then List_Containing (Par) =
2200 Visible_Declarations (Parent (Par));
2201 else
2202 Par := Parent (Par);
2203 end if;
2204 end loop;
2205
2206 return False;
2207 end Is_Visible_Generic_Entity;
2208
2209 -- Start of processing for Write_Level_Info
2210
2211 begin
2212 if Is_Hidden (Curent)
2213 or else Is_Private_Record_Component (Curent)
2214 then
2215 Write_Info_Char (' ');
2216
2217 elsif
2218 Is_Public (Curent)
2219 or else Is_Visible_Generic_Entity (Curent)
2220 then
2221 Write_Info_Char ('*');
2222
2223 else
2224 Write_Info_Char (' ');
2225 end if;
2226 end Write_Level_Info;
2227
2228 -- Output entity name. We use the occurrence from the
2229 -- actual source program at the definition point.
2230
2231 declare
2232 Ent_Name : constant String :=
2233 Exact_Source_Name (Sloc (XE.Key.Ent));
2234 begin
2235 for C in Ent_Name'Range loop
2236 Write_Info_Char (Ent_Name (C));
2237 end loop;
2238 end;
2239
2240 -- See if we have a renaming reference
2241
2242 if Is_Object (XE.Key.Ent)
2243 and then Present (Renamed_Object (XE.Key.Ent))
2244 then
2245 Rref := Renamed_Object (XE.Key.Ent);
2246
2247 elsif Is_Overloadable (XE.Key.Ent)
2248 and then Nkind (Parent (Declaration_Node (XE.Key.Ent)))
2249 = N_Subprogram_Renaming_Declaration
2250 then
2251 Rref := Name (Parent (Declaration_Node (XE.Key.Ent)));
2252
2253 elsif Ekind (XE.Key.Ent) = E_Package
2254 and then Nkind (Declaration_Node (XE.Key.Ent)) =
2255 N_Package_Renaming_Declaration
2256 then
2257 Rref := Name (Declaration_Node (XE.Key.Ent));
2258
2259 else
2260 Rref := Empty;
2261 end if;
2262
2263 if Present (Rref) then
2264 if Nkind (Rref) = N_Expanded_Name then
2265 Rref := Selector_Name (Rref);
2266 end if;
2267
2268 if Nkind (Rref) = N_Identifier
2269 or else Nkind (Rref) = N_Operator_Symbol
2270 then
2271 null;
2272
2273 -- For renamed array components, use the array name
2274 -- for the renamed entity, which reflect the fact that
2275 -- in general the whole array is aliased.
2276
2277 elsif Nkind (Rref) = N_Indexed_Component then
2278 if Nkind (Prefix (Rref)) = N_Identifier then
2279 Rref := Prefix (Rref);
2280 elsif Nkind (Prefix (Rref)) = N_Expanded_Name then
2281 Rref := Selector_Name (Prefix (Rref));
2282 else
2283 Rref := Empty;
2284 end if;
2285
2286 else
2287 Rref := Empty;
2288 end if;
2289 end if;
2290
2291 -- Write out renaming reference if we have one
2292
2293 if Present (Rref) then
2294 Write_Info_Char ('=');
2295 Write_Info_Nat
2296 (Int (Get_Logical_Line_Number (Sloc (Rref))));
2297 Write_Info_Char (':');
2298 Write_Info_Nat
2299 (Int (Get_Column_Number (Sloc (Rref))));
2300 end if;
2301
2302 -- Indicate that the entity is in the unit of the current
2303 -- xref section.
2304
2305 Curru := Curxu;
2306
2307 -- Write out information about generic parent, if entity
2308 -- is an instance.
2309
2310 if Is_Generic_Instance (XE.Key.Ent) then
2311 declare
2312 Gen_Par : constant Entity_Id :=
2313 Generic_Parent
2314 (Specification
2315 (Unit_Declaration_Node
2316 (XE.Key.Ent)));
2317 Loc : constant Source_Ptr := Sloc (Gen_Par);
2318 Gen_U : constant Unit_Number_Type :=
2319 Get_Source_Unit (Loc);
2320
2321 begin
2322 Write_Info_Char ('[');
2323
2324 if Curru /= Gen_U then
2325 Write_Info_Nat (Dependency_Num (Gen_U));
2326 Write_Info_Char ('|');
2327 end if;
2328
2329 Write_Info_Nat
2330 (Int (Get_Logical_Line_Number (Loc)));
2331 Write_Info_Char (']');
2332 end;
2333 end if;
2334
2335 -- See if we have a type reference and if so output
2336
2337 Check_Type_Reference (XE.Key.Ent, False);
2338
2339 -- Additional information for types with progenitors
2340
2341 if Is_Record_Type (XE.Key.Ent)
2342 and then Present (Interfaces (XE.Key.Ent))
2343 then
2344 declare
2345 Elmt : Elmt_Id :=
2346 First_Elmt (Interfaces (XE.Key.Ent));
2347 begin
2348 while Present (Elmt) loop
2349 Check_Type_Reference (Node (Elmt), True);
2350 Next_Elmt (Elmt);
2351 end loop;
2352 end;
2353
2354 -- For array types, list index types as well. (This is
2355 -- not C, indexes have distinct types).
2356
2357 elsif Is_Array_Type (XE.Key.Ent) then
2358 declare
2359 Indx : Node_Id;
2360 begin
2361 Indx := First_Index (XE.Key.Ent);
2362 while Present (Indx) loop
2363 Check_Type_Reference
2364 (First_Subtype (Etype (Indx)), True);
2365 Next_Index (Indx);
2366 end loop;
2367 end;
2368 end if;
2369
2370 -- If the entity is an overriding operation, write info
2371 -- on operation that was overridden.
2372
2373 if Is_Subprogram (XE.Key.Ent)
2374 and then Present (Overridden_Operation (XE.Key.Ent))
2375 then
2376 Output_Overridden_Op
2377 (Overridden_Operation (XE.Key.Ent));
2378 end if;
2379
2380 -- End of processing for entity output
2381
2382 Crloc := No_Location;
2383 end if;
2384
2385 -- Output the reference if it is not as the same location
2386 -- as the previous one, or it is a read-reference that
2387 -- indicates that the entity is an in-out actual in a call.
2388
2389 if XE.Key.Loc /= No_Location
2390 and then
2391 (XE.Key.Loc /= Crloc
2392 or else (Prevt = 'm' and then XE.Key.Typ = 'r'))
2393 then
2394 Crloc := XE.Key.Loc;
2395 Prevt := XE.Key.Typ;
2396
2397 -- Start continuation if line full, else blank
2398
2399 if Write_Info_Col > 72 then
2400 Write_Info_EOL;
2401 Write_Info_Initiate ('.');
2402 end if;
2403
2404 Write_Info_Char (' ');
2405
2406 -- Output file number if changed
2407
2408 if XE.Key.Lun /= Curru then
2409 Curru := XE.Key.Lun;
2410 Write_Info_Nat (Dependency_Num (Curru));
2411 Write_Info_Char ('|');
2412 end if;
2413
2414 Write_Info_Nat
2415 (Int (Get_Logical_Line_Number (XE.Key.Loc)));
2416 Write_Info_Char (XE.Key.Typ);
2417
2418 if Is_Overloadable (XE.Key.Ent)
2419 and then Is_Imported (XE.Key.Ent)
2420 and then XE.Key.Typ = 'b'
2421 then
2422 Output_Import_Export_Info (XE.Key.Ent);
2423 end if;
2424
2425 Write_Info_Nat (Int (Get_Column_Number (XE.Key.Loc)));
2426
2427 Output_Instantiation_Refs (Sloc (XE.Key.Ent));
2428 end if;
2429 end if;
2430 end Output_One_Ref;
2431
2432 <<Continue>>
2433 null;
2434 end loop;
2435
2436 Write_Info_EOL;
2437 end Output_Refs;
2438 end Output_References;
2439
2440 -- Start of elaboration for Lib.Xref
2441
2442 begin
2443 -- Reset is necessary because Elmt_Ptr does not default to Null_Ptr,
2444 -- because it's not an access type.
2445
2446 Xref_Set.Reset;
2447 end Lib.Xref;