1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Csets
; use Csets
;
28 with Einfo
; use Einfo
;
29 with Einfo
.Utils
; use Einfo
.Utils
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Lib
.Util
; use Lib
.Util
;
33 with Nlists
; use Nlists
;
35 with Restrict
; use Restrict
;
36 with Rident
; use Rident
;
38 with Sem_Aux
; use Sem_Aux
;
39 with Sem_Prag
; use Sem_Prag
;
40 with Sem_Util
; use Sem_Util
;
41 with Sem_Warn
; use Sem_Warn
;
42 with Sinfo
; use Sinfo
;
43 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
44 with Sinfo
.Utils
; use Sinfo
.Utils
;
45 with Sinput
; use Sinput
;
46 with Snames
; use Snames
;
47 with Stringt
; use Stringt
;
48 with Stand
; use Stand
;
49 with Table
; use Table
;
50 with Warnsw
; use Warnsw
;
52 with GNAT
.Heap_Sort_G
;
55 package body Lib
.Xref
is
61 -- The Xref table is used to record references. The Loc field is set
62 -- to No_Location for a definition entry.
64 subtype Xref_Entry_Number
is Int
;
66 type Xref_Key
is record
67 -- These are the components of Xref_Entry that participate in hash
71 -- Entity referenced (E parameter to Generate_Reference)
74 -- Location of reference (Original_Location (Sloc field of N parameter
75 -- to Generate_Reference)). Set to No_Location for the case of a
76 -- defining occurrence.
79 -- Reference type (Typ param to Generate_Reference)
81 Eun
: Unit_Number_Type
;
82 -- Unit number corresponding to Ent
84 Lun
: Unit_Number_Type
;
85 -- Unit number corresponding to Loc. Value is undefined and not
86 -- referenced if Loc is set to No_Location.
88 -- The following components are only used for SPARK cross-references
90 Ref_Scope
: Entity_Id
;
91 -- Entity of the closest subprogram or package enclosing the reference
93 Ent_Scope
: Entity_Id
;
94 -- Entity of the closest subprogram or package enclosing the definition,
95 -- which should be located in the same file as the definition itself.
98 type Xref_Entry
is record
101 Ent_Scope_File
: Unit_Number_Type
;
102 -- File for entity Ent_Scope
105 -- Original source location for entity being referenced. Note that these
106 -- values are used only during the output process, they are not set when
107 -- the entries are originally built. This is because private entities
108 -- can be swapped when the initial call is made.
110 HTable_Next
: Xref_Entry_Number
;
111 -- For use only by Static_HTable
114 package Xrefs
is new Table
.Table
(
115 Table_Component_Type
=> Xref_Entry
,
116 Table_Index_Type
=> Xref_Entry_Number
,
117 Table_Low_Bound
=> 1,
118 Table_Initial
=> Alloc
.Xrefs_Initial
,
119 Table_Increment
=> Alloc
.Xrefs_Increment
,
120 Table_Name
=> "Xrefs");
126 -- We keep a set of xref entries, in order to avoid inserting duplicate
127 -- entries into the above Xrefs table. An entry is in Xref_Set if and only
128 -- if it is in Xrefs.
130 Num_Buckets
: constant := 2**16;
132 subtype Header_Num
is Integer range 0 .. Num_Buckets
- 1;
133 type Null_Type
is null record;
134 pragma Unreferenced
(Null_Type
);
136 function Hash
(F
: Xref_Entry_Number
) return Header_Num
;
138 function Equal
(F1
, F2
: Xref_Entry_Number
) return Boolean;
140 procedure HT_Set_Next
(E
: Xref_Entry_Number
; Next
: Xref_Entry_Number
);
142 function HT_Next
(E
: Xref_Entry_Number
) return Xref_Entry_Number
;
144 function Get_Key
(E
: Xref_Entry_Number
) return Xref_Entry_Number
;
146 pragma Inline
(Hash
, Equal
, HT_Set_Next
, HT_Next
, Get_Key
);
148 package Xref_Set
is new GNAT
.HTable
.Static_HTable
(
150 Element
=> Xref_Entry
,
151 Elmt_Ptr
=> Xref_Entry_Number
,
153 Set_Next
=> HT_Set_Next
,
155 Key
=> Xref_Entry_Number
,
160 -----------------------------
161 -- SPARK Xrefs Information --
162 -----------------------------
164 package body SPARK_Specific
is separate;
166 ------------------------
167 -- Local Subprograms --
168 ------------------------
170 procedure Add_Entry
(Key
: Xref_Key
; Ent_Scope_File
: Unit_Number_Type
);
171 -- Add an entry to the tables of Xref_Entries, avoiding duplicates
173 procedure Generate_Prim_Op_References
(Typ
: Entity_Id
);
174 -- For a tagged type, generate implicit references to its primitive
175 -- operations, for source navigation. This is done right before emitting
176 -- cross-reference information rather than at the freeze point of the type
177 -- in order to handle late bodies that are primitive operations.
179 function Lt
(T1
, T2
: Xref_Entry
) return Boolean;
180 -- Order cross-references
186 procedure Add_Entry
(Key
: Xref_Key
; Ent_Scope_File
: Unit_Number_Type
) is
188 Xrefs
.Increment_Last
; -- tentative
189 Xrefs
.Table
(Xrefs
.Last
).Key
:= Key
;
191 -- Set the entry in Xref_Set, and if newly set, keep the above
192 -- tentative increment.
194 if Xref_Set
.Set_If_Not_Present
(Xrefs
.Last
) then
195 Xrefs
.Table
(Xrefs
.Last
).Ent_Scope_File
:= Ent_Scope_File
;
196 -- Leave Def and HTable_Next uninitialized
198 Set_Has_Xref_Entry
(Key
.Ent
);
200 -- It was already in Xref_Set, so throw away the tentatively-added entry
203 Xrefs
.Decrement_Last
;
211 function Equal
(F1
, F2
: Xref_Entry_Number
) return Boolean is
212 Result
: constant Boolean :=
213 Xrefs
.Table
(F1
).Key
= Xrefs
.Table
(F2
).Key
;
218 -------------------------
219 -- Generate_Definition --
220 -------------------------
222 procedure Generate_Definition
(E
: Entity_Id
) is
224 pragma Assert
(Nkind
(E
) in N_Entity
);
226 -- Note that we do not test Xref_Entity_Letters here. It is too early
227 -- to do so, since we are often called before the entity is fully
228 -- constructed, so that the Ekind is still E_Void.
232 -- Definition must come from source
234 -- We make an exception for subprogram child units that have no spec.
235 -- For these we generate a subprogram declaration for library use,
236 -- and the corresponding entity does not come from source.
237 -- Nevertheless, all references will be attached to it and we have
238 -- to treat is as coming from user code.
240 and then (Comes_From_Source
(E
) or else Is_Child_Unit
(E
))
242 -- And must have a reasonable source location that is not
243 -- within an instance (all entities in instances are ignored)
245 and then Sloc
(E
) > No_Location
246 and then Instantiation_Location
(Sloc
(E
)) = No_Location
248 -- And must be a non-internal name from the main source unit
250 and then In_Extended_Main_Source_Unit
(E
)
251 and then not Is_Internal_Name
(Chars
(E
))
257 Eun
=> Get_Source_Unit
(Original_Location
(Sloc
(E
))),
261 Ent_Scope_File
=> No_Unit
);
263 if In_Inlined_Body
then
267 end Generate_Definition
;
269 ---------------------------------
270 -- Generate_Operator_Reference --
271 ---------------------------------
273 procedure Generate_Operator_Reference
278 if not In_Extended_Main_Source_Unit
(N
) then
282 -- If the operator is not a Standard operator, then we generate a real
283 -- reference to the user defined operator.
285 if Sloc
(Entity
(N
)) /= Standard_Location
then
286 Generate_Reference
(Entity
(N
), N
);
288 -- A reference to an implicit inequality operator is also a reference
289 -- to the user-defined equality.
291 if Nkind
(N
) = N_Op_Ne
292 and then not Comes_From_Source
(Entity
(N
))
293 and then Present
(Corresponding_Equality
(Entity
(N
)))
295 Generate_Reference
(Corresponding_Equality
(Entity
(N
)), N
);
298 -- For the case of Standard operators, we mark the result type as
299 -- referenced. This ensures that in the case where we are using a
300 -- derived operator, we mark an entity of the unit that implicitly
301 -- defines this operator as used. Otherwise we may think that no entity
302 -- of the unit is used. The actual entity marked as referenced is the
303 -- first subtype, which is the relevant user defined entity.
305 -- Note: we only do this for operators that come from source. The
306 -- generated code sometimes reaches for entities that do not need to be
307 -- explicitly visible (for example, when we expand the code for
308 -- comparing two record objects, the fields of the record may not be
311 elsif Comes_From_Source
(N
) then
312 Set_Referenced
(First_Subtype
(T
));
314 end Generate_Operator_Reference
;
316 ---------------------------------
317 -- Generate_Prim_Op_References --
318 ---------------------------------
320 procedure Generate_Prim_Op_References
(Typ
: Entity_Id
) is
323 Prim_List
: Elist_Id
;
326 -- Handle subtypes of synchronized types
328 if Ekind
(Typ
) = E_Protected_Subtype
329 or else Ekind
(Typ
) = E_Task_Subtype
331 Base_T
:= Etype
(Typ
);
336 -- References to primitive operations are only relevant for tagged types
338 if not Is_Tagged_Type
(Base_T
)
339 or else Is_Class_Wide_Type
(Base_T
)
344 -- Ada 2005 (AI-345): For synchronized types generate reference to the
345 -- wrapper that allow us to dispatch calls through their implemented
346 -- abstract interface types.
348 -- The check for Present here is to protect against previously reported
351 Prim_List
:= Primitive_Operations
(Base_T
);
353 if No
(Prim_List
) then
357 Prim
:= First_Elmt
(Prim_List
);
358 while Present
(Prim
) loop
360 -- If the operation is derived, get the original for cross-reference
361 -- reference purposes (it is the original for which we want the xref
362 -- and for which the comes_from_source test must be performed).
365 (Typ
, Ultimate_Alias
(Node
(Prim
)), 'p', Set_Ref
=> False);
368 end Generate_Prim_Op_References
;
370 ------------------------
371 -- Generate_Reference --
372 ------------------------
374 procedure Generate_Reference
377 Typ
: Character := 'r';
378 Set_Ref
: Boolean := True;
379 Force
: Boolean := False)
381 Actual_Typ
: Character := Typ
;
385 Ent_Scope
: Entity_Id
;
390 Ref_Scope
: Entity_Id
;
392 function Get_Through_Renamings
(E
: Entity_Id
) return Entity_Id
;
393 -- Get the enclosing entity through renamings, which may come from
394 -- source or from the translation of generic instantiations.
396 function OK_To_Set_Referenced
return Boolean;
397 -- Returns True if the Referenced flag can be set. There are a few
398 -- exceptions where we do not want to set this flag, see body for
399 -- details of these exceptional cases.
401 ---------------------------
402 -- Get_Through_Renamings --
403 ---------------------------
405 function Get_Through_Renamings
(E
: Entity_Id
) return Entity_Id
is
409 -- For subprograms we just need to check once if they are have a
410 -- Renamed_Entity, because Renamed_Entity is set transitively.
412 when Subprogram_Kind
=>
414 Renamed
: constant Entity_Id
:= Renamed_Entity
(E
);
417 if Present
(Renamed
) then
424 -- For objects we need to repeatedly call Renamed_Object, because
425 -- it is not transitive.
429 Obj
: Entity_Id
:= E
;
433 pragma Assert
(Present
(Obj
));
436 Renamed
: constant Entity_Id
:= Renamed_Object
(Obj
);
439 if Present
(Renamed
) then
440 Obj
:= Get_Enclosing_Object
(Renamed
);
442 -- The renamed expression denotes a non-object,
443 -- e.g. function call, slicing of a function call,
444 -- pointer dereference, etc.
447 or else Ekind
(Obj
) = E_Enumeration_Literal
462 end Get_Through_Renamings
;
464 ---------------------------
465 -- OK_To_Set_Referenced --
466 ---------------------------
468 function OK_To_Set_Referenced
return Boolean is
472 -- A reference from a pragma Unreferenced or pragma Unmodified or
473 -- pragma Warnings does not cause the Referenced flag to be set.
474 -- This avoids silly warnings about things being referenced and
475 -- not assigned when the only reference is from the pragma.
477 if Nkind
(N
) = N_Identifier
then
480 if Nkind
(P
) = N_Pragma_Argument_Association
then
483 if Nkind
(P
) = N_Pragma
then
484 if Pragma_Name_Unmapped
(P
) in Name_Warnings
492 -- A reference to a formal in a named parameter association does
493 -- not make the formal referenced. Formals that are unused in the
494 -- subprogram body are properly flagged as such, even if calls
495 -- elsewhere use named notation.
497 elsif Nkind
(P
) = N_Parameter_Association
498 and then N
= Selector_Name
(P
)
505 end OK_To_Set_Referenced
;
507 -- Start of processing for Generate_Reference
510 -- If Get_Ignore_Errors, then we are in Preanalyze_Without_Errors, and
511 -- we should not record cross references, because that will cause
512 -- duplicates when we call Analyze.
514 if Get_Ignore_Errors
then
518 -- May happen in case of severe errors
520 if Nkind
(E
) not in N_Entity
then
524 Find_Actual
(N
, Formal
, Call
);
526 if Present
(Formal
) then
527 Kind
:= Ekind
(Formal
);
532 -- Check for obsolescent reference to package ASCII. GNAT treats this
533 -- element of annex J specially since in practice, programs make a lot
534 -- of use of this feature, so we don't include it in the set of features
535 -- diagnosed when Warn_On_Obsolescent_Features mode is set. However we
536 -- are required to note it as a violation of the RM defined restriction.
538 if E
= Standard_ASCII
then
539 Check_Restriction
(No_Obsolescent_Features
, N
);
542 -- Check for reference to entity marked with Is_Obsolescent
544 -- Note that we always allow obsolescent references in the compiler
545 -- itself and the run time, since we assume that we know what we are
546 -- doing in such cases. For example the calls in Ada.Characters.Handling
547 -- to its own obsolescent subprograms are just fine.
549 -- In any case we only generate warnings if we are in the extended main
550 -- source unit, and the entity itself is not in the extended main source
551 -- unit, since we assume the source unit itself knows what is going on
552 -- (and for sure we do not want silly warnings, e.g. on the end line of
553 -- an obsolescent procedure body).
555 if Is_Obsolescent
(E
)
556 and then not GNAT_Mode
557 and then not In_Extended_Main_Source_Unit
(E
)
558 and then In_Extended_Main_Source_Unit
(N
)
560 Check_Restriction
(No_Obsolescent_Features
, N
);
562 if Warn_On_Obsolescent_Feature
then
563 Output_Obsolescent_Entity_Warnings
(N
, E
);
567 -- Warn if reference to Ada 2005 entity not in Ada 2005 mode. We only
568 -- detect real explicit references (modifications and references).
570 if Comes_From_Source
(N
)
571 and then Is_Ada_2005_Only
(E
)
572 and then Ada_Version
< Ada_2005
573 and then Warn_On_Ada_2005_Compatibility
574 and then (Typ
= 'm' or else Typ
= 'r' or else Typ
= 's')
576 Error_Msg_NE
("& is only defined in Ada 2005?y?", N
, E
);
579 -- Warn if reference to Ada 2012 entity not in Ada 2012 mode. We only
580 -- detect real explicit references (modifications and references).
582 if Comes_From_Source
(N
)
583 and then Is_Ada_2012_Only
(E
)
584 and then Ada_Version
< Ada_2012
585 and then Warn_On_Ada_2012_Compatibility
586 and then (Typ
= 'm' or else Typ
= 'r')
588 Error_Msg_NE
("& is only defined in Ada 2012?y?", N
, E
);
591 -- Warn if reference to Ada 2022 entity not in Ada 2022 mode. We only
592 -- detect real explicit references (modifications and references).
594 if Comes_From_Source
(N
)
595 and then Is_Ada_2022_Only
(E
)
596 and then not Is_Subprogram
(E
)
597 and then Ada_Version
< Ada_2022
598 and then Warn_On_Ada_2022_Compatibility
599 and then (Typ
= 'm' or else Typ
= 'r')
601 Error_Msg_NE
("& is only defined in Ada 2022?y?", N
, E
);
603 -- Error on static and dispatching calls to Ada 2022 subprograms that
604 -- require overriding if we are not in Ada 2022 mode (since overriding
605 -- was skipped); warn if the subprogram does not require overriding.
607 elsif Comes_From_Source
(N
)
608 and then Is_Ada_2022_Only
(E
)
609 and then Ada_Version
< Ada_2022
610 and then Is_Subprogram
(E
)
611 and then (Typ
= 'r' or else Typ
= 's' or else Typ
= 'R')
613 if Requires_Overriding
(E
) then
615 ("& is only defined in Ada 2022 and requires overriding", N
, E
);
617 elsif Warn_On_Ada_2022_Compatibility
then
618 Error_Msg_NE
("& is only defined in Ada 2022?y?", N
, E
);
622 -- Never collect references if not in main source unit. However, we omit
623 -- this test if Typ is 'e' or 'k', since these entries are structural,
624 -- and it is useful to have them in units that reference packages as
625 -- well as units that define packages. We also omit the test for the
626 -- case of 'p' since we want to include inherited primitive operations
627 -- from other packages.
629 -- We also omit this test is this is a body reference for a subprogram
630 -- instantiation. In this case the reference is to the generic body,
631 -- which clearly need not be in the main unit containing the instance.
632 -- For the same reason we accept an implicit reference generated for
633 -- a default in an instance.
635 -- We also set the referenced flag in a generic package that is not in
636 -- the main source unit, when the object is of a formal private type,
637 -- to warn in the instance if the corresponding type is not a fully
640 if not In_Extended_Main_Source_Unit
(N
) then
646 or else (Typ
= 'b' and then Is_Generic_Instance
(E
))
648 -- Allow the generation of references to reads, writes and calls
649 -- in SPARK mode when the related context comes from an instance.
653 and then In_Extended_Main_Code_Unit
(N
)
654 and then (Typ
= 'm' or else Typ
= 'r' or else Typ
= 's'))
658 elsif In_Instance_Body
659 and then In_Extended_Main_Code_Unit
(N
)
660 and then Is_Generic_Type
(Etype
(E
))
665 elsif Inside_A_Generic
666 and then Is_Object
(E
)
667 and then Is_Generic_Type
(Etype
(E
))
677 -- For reference type p, the entity must be in main source unit
679 if Typ
= 'p' and then not In_Extended_Main_Source_Unit
(E
) then
683 -- Unless the reference is forced, we ignore references where the
684 -- reference itself does not come from source.
686 if not Force
and then not Comes_From_Source
(N
) then
690 -- Deal with setting entity as referenced, unless suppressed. Note that
691 -- we still do Set_Referenced on entities that do not come from source.
692 -- This situation arises when we have a source reference to a derived
693 -- operation, where the derived operation itself does not come from
694 -- source, but we still want to mark it as referenced, since we really
695 -- are referencing an entity in the corresponding package (this avoids
696 -- wrong complaints that the package contains no referenced entities).
700 -- When E itself is an IN OUT parameter mark it referenced
703 and then Ekind
(E
) = E_In_Out_Parameter
704 and then Known_To_Be_Assigned
(N
)
708 -- For the case where the entity is on the left hand side of an
709 -- assignment statment, we do nothing here.
711 -- The processing for Analyze_Assignment_Statement will set the
712 -- Referenced_As_LHS flag.
714 elsif Is_Assignable
(E
)
715 and then Known_To_Be_Assigned
(N
, Only_LHS
=> True)
719 -- For objects that are renamings, just set as simply referenced.
720 -- We do not try to do assignment type tracking in this case.
722 elsif Is_Assignable
(E
)
723 and then Present
(Renamed_Object
(E
))
727 -- Check for a reference in a pragma that should not count as a
728 -- making the variable referenced for warning purposes.
730 elsif Is_Non_Significant_Pragma_Reference
(N
) then
733 -- A reference in an attribute definition clause does not count as a
734 -- reference except for the case of Address. The reason that 'Address
735 -- is an exception is that it creates an alias through which the
736 -- variable may be referenced.
738 elsif Nkind
(Parent
(N
)) = N_Attribute_Definition_Clause
739 and then Chars
(Parent
(N
)) /= Name_Address
740 and then N
= Name
(Parent
(N
))
744 -- Constant completion does not count as a reference
747 and then Ekind
(E
) = E_Constant
751 -- Record representation clause does not count as a reference
753 elsif Nkind
(N
) = N_Identifier
754 and then Nkind
(Parent
(N
)) = N_Record_Representation_Clause
758 -- Discriminants do not need to produce a reference to record type
761 and then Nkind
(Parent
(N
)) = N_Discriminant_Specification
765 -- Out parameter case
767 elsif Kind
= E_Out_Parameter
768 and then Is_Assignable
(E
)
770 -- If warning mode for all out parameters is set, or this is
771 -- the only warning parameter, then we want to mark this for
772 -- later warning logic by setting Referenced_As_Out_Parameter
774 if Warn_On_Modified_As_Out_Parameter
(Formal
) then
775 Set_Referenced_As_Out_Parameter
(E
, True);
776 Set_Referenced_As_LHS
(E
, False);
778 -- For OUT parameter not covered by the above cases, we simply
779 -- regard it as a reference.
782 Set_Referenced_As_Out_Parameter
(E
);
786 -- Special processing for IN OUT parameters, where we have an
787 -- implicit assignment to a simple variable.
789 elsif Kind
= E_In_Out_Parameter
790 and then Is_Assignable
(E
)
792 -- For sure this counts as a normal read reference
795 Set_Last_Assignment
(E
, Empty
);
797 -- We count it as being referenced as an out parameter if the
798 -- option is set to warn on all out parameters, except that we
799 -- have a special exclusion for an intrinsic subprogram, which
800 -- is most likely an instantiation of Unchecked_Deallocation
801 -- which we do not want to consider as an assignment since it
802 -- generates false positives. We also exclude the case of an
803 -- IN OUT parameter if the name of the procedure is Free,
804 -- since we suspect similar semantics.
806 if Warn_On_All_Unread_Out_Parameters
807 and then Is_Entity_Name
(Name
(Call
))
808 and then not Is_Intrinsic_Subprogram
(Entity
(Name
(Call
)))
809 and then Chars
(Name
(Call
)) /= Name_Free
811 Set_Referenced_As_Out_Parameter
(E
, True);
812 Set_Referenced_As_LHS
(E
, False);
815 -- Don't count a recursive reference within a subprogram as a
816 -- reference (that allows detection of a recursive subprogram
817 -- whose only references are recursive calls as unreferenced).
819 elsif Is_Subprogram
(E
)
820 and then E
= Nearest_Dynamic_Scope
(Current_Scope
)
824 -- Any other occurrence counts as referencing the entity
826 elsif OK_To_Set_Referenced
then
829 -- If variable, this is an OK reference after an assignment
830 -- so we can clear the Last_Assignment indication.
832 if Is_Assignable
(E
) then
833 Set_Last_Assignment
(E
, Empty
);
837 -- Check for pragma Unreferenced given and reference is within
838 -- this source unit (occasion for possible warning to be issued).
839 -- Note that the entity may be marked as unreferenced by pragma
842 if Has_Unreferenced
(E
)
843 and then In_Same_Extended_Unit
(E
, N
)
845 -- A reference as a named parameter in a call does not count as a
846 -- violation of pragma Unreferenced for this purpose.
848 if Nkind
(N
) = N_Identifier
849 and then Nkind
(Parent
(N
)) = N_Parameter_Association
850 and then Selector_Name
(Parent
(N
)) = N
854 -- Neither does a reference to a variable on the left side of
855 -- an assignment or use of an out parameter with warnings for
856 -- unread out parameters specified (via -gnatw.o).
858 -- The reason for treating unread out parameters in a special
859 -- way is so that when pragma Unreferenced is specified on such
860 -- an out parameter we do not want to issue a warning about the
861 -- pragma being unnecessary - because the purpose of the flag
862 -- is to warn about them not being read (e.g. unreferenced)
865 elsif (Known_To_Be_Assigned
(N
, Only_LHS
=> True)
866 or else (Present
(Formal
)
867 and then Ekind
(Formal
) = E_Out_Parameter
868 and then Warn_On_All_Unread_Out_Parameters
))
869 and then not (Ekind
(E
) = E_In_Out_Parameter
870 and then Known_To_Be_Assigned
(N
))
874 -- Do not consider F'Result as a violation of pragma Unreferenced
875 -- since the attribute acts as an anonymous alias of the function
876 -- result and not as a real reference to the function.
878 elsif Ekind
(E
) in E_Function | E_Generic_Function
879 and then Is_Entity_Name
(N
)
880 and then Is_Attribute_Result
(Parent
(N
))
884 -- No warning if the reference is in a call that does not come
885 -- from source (e.g. a call to a controlled type primitive).
887 elsif not Comes_From_Source
(Parent
(N
))
888 and then Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
892 -- For entry formals, we want to place the warning message on the
893 -- corresponding entity in the accept statement. The current scope
894 -- is the body of the accept, so we find the formal whose name
895 -- matches that of the entry formal (there is no link between the
896 -- two entities, and the one in the accept statement is only used
897 -- for conformance checking).
899 elsif Ekind
(Scope
(E
)) = E_Entry
then
904 BE
:= First_Entity
(Current_Scope
);
905 while Present
(BE
) loop
906 if Chars
(BE
) = Chars
(E
) then
907 if Has_Pragma_Unused
(E
) then
908 Error_Msg_NE
-- CODEFIX
909 ("??aspect Unused specified for&!", N
, BE
);
911 Error_Msg_NE
-- CODEFIX
912 ("??aspect Unreferenced specified for&!", N
, BE
);
921 -- Here we issue the warning, since this is a real reference
923 elsif Has_Pragma_Unused
(E
) then
924 Error_Msg_NE
-- CODEFIX
925 ("??aspect Unused specified for&!", N
, E
);
927 Error_Msg_NE
-- CODEFIX
928 ("??aspect Unreferenced specified for&!", N
, E
);
932 -- If this is a subprogram instance, mark as well the internal
933 -- subprogram in the wrapper package, which may be a visible
936 if Is_Overloadable
(E
)
937 and then Is_Generic_Instance
(E
)
938 and then Present
(Alias
(E
))
940 Set_Referenced
(Alias
(E
));
944 -- Generate reference if all conditions are met:
947 -- Cross referencing must be active
951 -- The entity must be one for which we collect references
953 and then Xref_Entity_Letters
(Ekind
(E
)) /= ' '
955 -- Both Sloc values must be set to something sensible
957 and then Sloc
(E
) > No_Location
958 and then Sloc
(N
) > No_Location
960 -- Ignore references from within an instance. The only exceptions to
961 -- this are default subprograms, for which we generate an implicit
962 -- reference and compilations in SPARK mode.
965 (Instantiation_Location
(Sloc
(N
)) = No_Location
967 or else GNATprove_Mode
)
969 -- Ignore dummy references
973 if Nkind
(N
) in N_Identifier
974 | N_Defining_Identifier
975 | N_Defining_Operator_Symbol
977 | N_Defining_Character_Literal
979 or else (Nkind
(N
) = N_Character_Literal
980 and then Sloc
(Entity
(N
)) /= Standard_Location
)
984 elsif Nkind
(N
) in N_Expanded_Name | N_Selected_Component
then
985 Nod
:= Selector_Name
(N
);
991 -- Normal case of source entity comes from source
993 if Comes_From_Source
(E
) then
996 -- Because a declaration may be generated for a subprogram body
997 -- without declaration in GNATprove mode, for inlining, some
998 -- parameters may end up being marked as not coming from source
999 -- although they are. Take these into account specially.
1001 elsif GNATprove_Mode
and then Is_Formal
(E
) then
1004 -- Entity does not come from source, but is a derived subprogram and
1005 -- the derived subprogram comes from source (after one or more
1006 -- derivations) in which case the reference is to parent subprogram.
1008 elsif Is_Overloadable
(E
)
1009 and then Present
(Alias
(E
))
1012 while not Comes_From_Source
(Ent
) loop
1013 if No
(Alias
(Ent
)) then
1020 -- The internally created defining entity for a child subprogram
1021 -- that has no previous spec has valid references.
1023 elsif Is_Overloadable
(E
)
1024 and then Is_Child_Unit
(E
)
1028 -- Ditto for the formals of such a subprogram
1030 elsif Is_Overloadable
(Scope
(E
))
1031 and then Is_Child_Unit
(Scope
(E
))
1035 -- Record components of discriminated subtypes or derived types must
1036 -- be treated as references to the original component.
1038 elsif Ekind
(E
) = E_Component
1039 and then Comes_From_Source
(Original_Record_Component
(E
))
1041 Ent
:= Original_Record_Component
(E
);
1043 -- If this is an expanded reference to a discriminant, recover the
1044 -- original discriminant, which gets the reference.
1046 elsif Ekind
(E
) = E_In_Parameter
1047 and then Present
(Discriminal_Link
(E
))
1049 Ent
:= Discriminal_Link
(E
);
1050 Set_Referenced
(Ent
);
1052 -- Ignore reference to any other entity that is not from source
1058 -- In SPARK mode, consider the underlying entity renamed instead of
1059 -- the renaming, which is needed to compute a valid set of effects
1060 -- (reads, writes) for the enclosing subprogram.
1062 if GNATprove_Mode
then
1063 Ent
:= Get_Through_Renamings
(Ent
);
1065 -- If no enclosing object, then it could be a reference to any
1066 -- location not tracked individually, like heap-allocated data.
1067 -- Conservatively approximate this possibility by generating a
1068 -- dereference, and return.
1071 if Actual_Typ
= 'w' then
1072 SPARK_Specific
.Generate_Dereference
(Nod
, 'r');
1073 SPARK_Specific
.Generate_Dereference
(Nod
, 'w');
1075 SPARK_Specific
.Generate_Dereference
(Nod
, 'r');
1082 -- Record reference to entity
1085 and then Is_Subprogram
(Nod
)
1086 and then Present
(Overridden_Operation
(Nod
))
1091 -- Comment needed here for special SPARK code ???
1093 if GNATprove_Mode
then
1095 -- Ignore references to an entity which is a Part_Of single
1096 -- concurrent object. Ideally we would prefer to add it as a
1097 -- reference to the corresponding concurrent type, but it is quite
1098 -- difficult (as such references are not currently added even for)
1099 -- reads/writes of private protected components) and not worth the
1102 if Ekind
(Ent
) in E_Abstract_State | E_Constant | E_Variable
1103 and then Present
(Encapsulating_State
(Ent
))
1104 and then Is_Single_Concurrent_Object
(Encapsulating_State
(Ent
))
1113 SPARK_Specific
.Enclosing_Subprogram_Or_Library_Package
(Nod
);
1115 SPARK_Specific
.Enclosing_Subprogram_Or_Library_Package
(Ent
);
1117 -- Since we are reaching through renamings in SPARK mode, we may
1118 -- end up with standard constants. Ignore those.
1120 if Sloc
(Ent_Scope
) <= Standard_Location
1121 or else Def
<= Standard_Location
1130 Eun
=> Get_Top_Level_Code_Unit
(Def
),
1131 Lun
=> Get_Top_Level_Code_Unit
(Ref
),
1132 Ref_Scope
=> Ref_Scope
,
1133 Ent_Scope
=> Ent_Scope
),
1134 Ent_Scope_File
=> Get_Top_Level_Code_Unit
(Ent
));
1137 Ref
:= Original_Location
(Sloc
(Nod
));
1138 Def
:= Original_Location
(Sloc
(Ent
));
1140 -- If this is an operator symbol, skip the initial quote for
1141 -- navigation purposes. This is not done for the end label,
1142 -- where we want the actual position after the closing quote.
1147 elsif Nkind
(N
) = N_Defining_Operator_Symbol
1148 or else Nkind
(Nod
) = N_Operator_Symbol
1157 Eun
=> Get_Source_Unit
(Def
),
1158 Lun
=> Get_Source_Unit
(Ref
),
1160 Ent_Scope
=> Empty
),
1161 Ent_Scope_File
=> No_Unit
);
1163 -- Generate reference to the first private entity
1166 and then Comes_From_Source
(E
)
1167 and then Nkind
(Ent
) = N_Defining_Identifier
1168 and then (Is_Package_Or_Generic_Package
(Ent
)
1169 or else Is_Concurrent_Type
(Ent
))
1170 and then Present
(First_Private_Entity
(E
))
1171 and then In_Extended_Main_Source_Unit
(N
)
1173 -- Handle case in which the full-view and partial-view of the
1174 -- first private entity are swapped.
1177 First_Private
: Entity_Id
:= First_Private_Entity
(E
);
1180 if Is_Private_Type
(First_Private
)
1181 and then Present
(Full_View
(First_Private
))
1183 First_Private
:= Full_View
(First_Private
);
1188 Loc
=> Sloc
(First_Private
),
1190 Eun
=> Get_Source_Unit
(Def
),
1191 Lun
=> Get_Source_Unit
(Ref
),
1193 Ent_Scope
=> Empty
),
1194 Ent_Scope_File
=> No_Unit
);
1199 end Generate_Reference
;
1201 -----------------------------------
1202 -- Generate_Reference_To_Formals --
1203 -----------------------------------
1205 procedure Generate_Reference_To_Formals
(E
: Entity_Id
) is
1209 if Is_Access_Subprogram_Type
(E
) then
1210 Formal
:= First_Formal
(Designated_Type
(E
));
1212 Formal
:= First_Formal
(E
);
1215 while Present
(Formal
) loop
1216 if Ekind
(Formal
) = E_In_Parameter
then
1218 if Nkind
(Parameter_Type
(Parent
(Formal
))) = N_Access_Definition
1220 Generate_Reference
(E
, Formal
, '^', False);
1222 Generate_Reference
(E
, Formal
, '>', False);
1225 elsif Ekind
(Formal
) = E_In_Out_Parameter
then
1226 Generate_Reference
(E
, Formal
, '=', False);
1229 Generate_Reference
(E
, Formal
, '<', False);
1232 Next_Formal
(Formal
);
1234 end Generate_Reference_To_Formals
;
1236 -------------------------------------------
1237 -- Generate_Reference_To_Generic_Formals --
1238 -------------------------------------------
1240 procedure Generate_Reference_To_Generic_Formals
(E
: Entity_Id
) is
1244 Formal
:= First_Entity
(E
);
1245 while Present
(Formal
) loop
1246 if Comes_From_Source
(Formal
) then
1247 Generate_Reference
(E
, Formal
, 'z', False);
1250 Next_Entity
(Formal
);
1252 end Generate_Reference_To_Generic_Formals
;
1258 function Get_Key
(E
: Xref_Entry_Number
) return Xref_Entry_Number
is
1267 function Hash
(F
: Xref_Entry_Number
) return Header_Num
is
1268 -- It is unlikely to have two references to the same entity at the same
1269 -- source location, so the hash function depends only on the Ent and Loc
1272 XE
: Xref_Entry
renames Xrefs
.Table
(F
);
1273 type M
is mod 2**32;
1275 H
: constant M
:= 3 * M
(XE
.Key
.Ent
) + 5 * M
(abs XE
.Key
.Loc
);
1276 -- It would be more natural to write:
1278 -- H : constant M := 3 * M'Mod (XE.Key.Ent) + 5 * M'Mod (XE.Key.Loc);
1280 -- But we can't use M'Mod, because it prevents bootstrapping with older
1281 -- compilers. Loc can be negative, so we do "abs" before converting.
1282 -- One day this can be cleaned up ???
1285 return Header_Num
(H
mod Num_Buckets
);
1292 procedure HT_Set_Next
(E
: Xref_Entry_Number
; Next
: Xref_Entry_Number
) is
1294 Xrefs
.Table
(E
).HTable_Next
:= Next
;
1301 function HT_Next
(E
: Xref_Entry_Number
) return Xref_Entry_Number
is
1303 return Xrefs
.Table
(E
).HTable_Next
;
1310 procedure Initialize
is
1319 function Lt
(T1
, T2
: Xref_Entry
) return Boolean is
1321 -- First test: if entity is in different unit, sort by unit
1323 if T1
.Key
.Eun
/= T2
.Key
.Eun
then
1324 return Dependency_Num
(T1
.Key
.Eun
) < Dependency_Num
(T2
.Key
.Eun
);
1326 -- Second test: within same unit, sort by entity Sloc
1328 elsif T1
.Def
/= T2
.Def
then
1329 return T1
.Def
< T2
.Def
;
1331 -- Third test: sort definitions ahead of references
1333 elsif T1
.Key
.Loc
= No_Location
then
1336 elsif T2
.Key
.Loc
= No_Location
then
1339 -- Fourth test: for same entity, sort by reference location unit
1341 elsif T1
.Key
.Lun
/= T2
.Key
.Lun
then
1342 return Dependency_Num
(T1
.Key
.Lun
) < Dependency_Num
(T2
.Key
.Lun
);
1344 -- Fifth test: order of location within referencing unit
1346 elsif T1
.Key
.Loc
/= T2
.Key
.Loc
then
1347 return T1
.Key
.Loc
< T2
.Key
.Loc
;
1349 -- Finally, for two locations at the same address, we prefer
1350 -- the one that does NOT have the type 'r' so that a modification
1351 -- or extension takes preference, when there are more than one
1352 -- reference at the same location. As a result, in the case of
1353 -- entities that are in-out actuals, the read reference follows
1354 -- the modify reference.
1357 return T2
.Key
.Typ
= 'r';
1361 -----------------------
1362 -- Output_References --
1363 -----------------------
1365 procedure Output_References
is
1367 procedure Get_Type_Reference
1369 Tref
: out Entity_Id
;
1370 Left
: out Character;
1371 Right
: out Character);
1372 -- Given an Entity_Id Ent, determines whether a type reference is
1373 -- required. If so, Tref is set to the entity for the type reference
1374 -- and Left and Right are set to the left/right brackets to be output
1375 -- for the reference. If no type reference is required, then Tref is
1376 -- set to Empty, and Left/Right are set to space.
1378 procedure Output_Import_Export_Info
(Ent
: Entity_Id
);
1379 -- Output language and external name information for an interfaced
1380 -- entity, using the format <language, external_name>.
1382 ------------------------
1383 -- Get_Type_Reference --
1384 ------------------------
1386 procedure Get_Type_Reference
1388 Tref
: out Entity_Id
;
1389 Left
: out Character;
1390 Right
: out Character)
1395 -- See if we have a type reference
1404 -- Processing for types
1406 if Is_Type
(Tref
) then
1408 -- Case of base type
1410 if Base_Type
(Tref
) = Tref
then
1412 -- If derived, then get first subtype
1414 if Tref
/= Etype
(Tref
) then
1415 Tref
:= First_Subtype
(Etype
(Tref
));
1417 -- Set brackets for derived type, but don't override
1418 -- pointer case since the fact that something is a
1419 -- pointer is more important.
1426 -- If the completion of a private type is itself a derived
1427 -- type, we need the parent of the full view.
1429 elsif Is_Private_Type
(Tref
)
1430 and then Present
(Full_View
(Tref
))
1431 and then Etype
(Full_View
(Tref
)) /= Full_View
(Tref
)
1433 Tref
:= Etype
(Full_View
(Tref
));
1440 -- If non-derived pointer, get directly designated type.
1441 -- If the type has a full view, all references are on the
1442 -- partial view that is seen first.
1444 elsif Is_Access_Type
(Tref
) then
1445 Tref
:= Directly_Designated_Type
(Tref
);
1449 elsif Is_Private_Type
(Tref
)
1450 and then Present
(Full_View
(Tref
))
1452 if Is_Access_Type
(Full_View
(Tref
)) then
1453 Tref
:= Directly_Designated_Type
(Full_View
(Tref
));
1457 -- If the full view is an array type, we also retrieve
1458 -- the corresponding component type, because the ali
1459 -- entry already indicates that this is an array.
1461 elsif Is_Array_Type
(Full_View
(Tref
)) then
1462 Tref
:= Component_Type
(Full_View
(Tref
));
1467 -- If non-derived array, get component type. Skip component
1468 -- type for case of String or Wide_String, saves worthwhile
1471 elsif Is_Array_Type
(Tref
)
1472 and then Tref
/= Standard_String
1473 and then Tref
/= Standard_Wide_String
1475 Tref
:= Component_Type
(Tref
);
1479 -- For other non-derived base types, nothing
1485 -- For a subtype, go to ancestor subtype
1488 Tref
:= Ancestor_Subtype
(Tref
);
1490 -- If no ancestor subtype, go to base type
1493 Tref
:= Base_Type
(Sav
);
1497 -- For objects, functions, enum literals, just get type from
1500 elsif Is_Object
(Tref
)
1501 or else Ekind
(Tref
) = E_Enumeration_Literal
1502 or else Ekind
(Tref
) = E_Function
1503 or else Ekind
(Tref
) = E_Operator
1505 Tref
:= Etype
(Tref
);
1507 -- Another special case: an object of a classwide type
1508 -- initialized with a tag-indeterminate call gets a subtype
1509 -- of the classwide type during expansion. See if the original
1510 -- type in the declaration is named, and return it instead
1511 -- of going to the root type. The expression may be a class-
1512 -- wide function call whose result is on the secondary stack,
1513 -- which forces the declaration to be rewritten as a renaming,
1514 -- so examine the source declaration.
1516 if Ekind
(Tref
) = E_Class_Wide_Subtype
then
1518 Decl
: constant Node_Id
:= Original_Node
(Parent
(Ent
));
1520 if Nkind
(Decl
) = N_Object_Declaration
1521 and then Is_Entity_Name
1522 (Original_Node
(Object_Definition
(Decl
)))
1525 Entity
(Original_Node
(Object_Definition
(Decl
)));
1529 -- For a function that returns a class-wide type, Tref is
1532 elsif Is_Overloadable
(Ent
)
1533 and then Is_Class_Wide_Type
(Tref
)
1538 -- For anything else, exit
1544 -- Exit if no type reference, or we are stuck in some loop trying
1545 -- to find the type reference, or if the type is standard void
1546 -- type (the latter is an implementation artifact that should not
1547 -- show up in the generated cross-references).
1551 or else Tref
= Standard_Void_Type
;
1553 -- If we have a usable type reference, return, otherwise keep
1554 -- looking for something useful (we are looking for something
1555 -- that either comes from source or standard)
1557 if Sloc
(Tref
) = Standard_Location
1558 or else Comes_From_Source
(Tref
)
1560 -- If the reference is a subtype created for a generic actual,
1561 -- go actual directly, the inner subtype is not user visible.
1563 if Nkind
(Parent
(Tref
)) = N_Subtype_Declaration
1564 and then not Comes_From_Source
(Parent
(Tref
))
1566 (Is_Wrapper_Package
(Scope
(Tref
))
1567 or else Is_Generic_Instance
(Scope
(Tref
)))
1569 Tref
:= First_Subtype
(Base_Type
(Tref
));
1576 -- If we fall through the loop, no type reference
1581 end Get_Type_Reference
;
1583 -------------------------------
1584 -- Output_Import_Export_Info --
1585 -------------------------------
1587 procedure Output_Import_Export_Info
(Ent
: Entity_Id
) is
1588 Language_Name
: Name_Id
;
1589 Conv
: constant Convention_Id
:= Convention
(Ent
);
1592 -- Generate language name from convention
1594 if Conv
= Convention_C
or else Conv
in Convention_C_Variadic
then
1595 Language_Name
:= Name_C
;
1597 elsif Conv
= Convention_CPP
then
1598 Language_Name
:= Name_CPP
;
1600 elsif Conv
= Convention_Ada
then
1601 Language_Name
:= Name_Ada
;
1604 -- For the moment we ignore all other cases ???
1609 Write_Info_Char
('<');
1610 Get_Unqualified_Name_String
(Language_Name
);
1612 for J
in 1 .. Name_Len
loop
1613 Write_Info_Char
(Name_Buffer
(J
));
1616 if Present
(Interface_Name
(Ent
)) then
1617 Write_Info_Char
(',');
1618 String_To_Name_Buffer
(Strval
(Interface_Name
(Ent
)));
1620 for J
in 1 .. Name_Len
loop
1621 Write_Info_Char
(Name_Buffer
(J
));
1625 Write_Info_Char
('>');
1626 end Output_Import_Export_Info
;
1628 -- Start of processing for Output_References
1631 -- First we add references to the primitive operations of tagged types
1632 -- declared in the main unit.
1634 Handle_Prim_Ops
: declare
1638 for J
in 1 .. Xrefs
.Last
loop
1639 Ent
:= Xrefs
.Table
(J
).Key
.Ent
;
1642 and then Is_Tagged_Type
(Ent
)
1643 and then Is_Base_Type
(Ent
)
1644 and then In_Extended_Main_Source_Unit
(Ent
)
1646 Generate_Prim_Op_References
(Ent
);
1649 end Handle_Prim_Ops
;
1651 -- Before we go ahead and output the references we have a problem
1652 -- that needs dealing with. So far we have captured things that are
1653 -- definitely referenced by the main unit, or defined in the main
1654 -- unit. That's because we don't want to clutter up the ali file
1655 -- for this unit with definition lines for entities in other units
1656 -- that are not referenced.
1658 -- But there is a glitch. We may reference an entity in another unit,
1659 -- and it may have a type reference to an entity that is not directly
1660 -- referenced in the main unit, which may mean that there is no xref
1661 -- entry for this entity yet in the list of references.
1663 -- If we don't do something about this, we will end with an orphan type
1664 -- reference, i.e. it will point to an entity that does not appear
1665 -- within the generated references in the ali file. That is not good for
1666 -- tools using the xref information.
1668 -- To fix this, we go through the references adding definition entries
1669 -- for any unreferenced entities that can be referenced in a type
1670 -- reference. There is a recursion problem here, and that is dealt with
1671 -- by making sure that this traversal also traverses any entries that
1672 -- get added by the traversal.
1674 Handle_Orphan_Type_References
: declare
1680 pragma Warnings
(Off
, L
);
1681 pragma Warnings
(Off
, R
);
1683 procedure New_Entry
(E
: Entity_Id
);
1684 -- Make an additional entry into the Xref table for a type entity
1685 -- that is related to the current entity (parent, type ancestor,
1686 -- progenitor, etc.).
1692 procedure New_Entry
(E
: Entity_Id
) is
1694 pragma Assert
(Present
(E
));
1696 if not Has_Xref_Entry
(Implementation_Base_Type
(E
))
1697 and then Sloc
(E
) > No_Location
1702 Typ
=> Character'First,
1703 Eun
=> Get_Source_Unit
(Original_Location
(Sloc
(E
))),
1706 Ent_Scope
=> Empty
),
1707 Ent_Scope_File
=> No_Unit
);
1711 -- Start of processing for Handle_Orphan_Type_References
1714 -- Note that this is not a for loop for a very good reason. The
1715 -- processing of items in the table can add new items to the table,
1716 -- and they must be processed as well.
1719 while J
<= Xrefs
.Last
loop
1720 Ent
:= Xrefs
.Table
(J
).Key
.Ent
;
1722 -- Do not generate reference information for an ignored Ghost
1723 -- entity because neither the entity nor its references will
1724 -- appear in the final tree.
1726 if Is_Ignored_Ghost_Entity
(Ent
) then
1727 goto Orphan_Continue
;
1730 Get_Type_Reference
(Ent
, Tref
, L
, R
);
1733 and then not Has_Xref_Entry
(Tref
)
1734 and then Sloc
(Tref
) > No_Location
1738 if Is_Record_Type
(Ent
)
1739 and then Present
(Interfaces
(Ent
))
1741 -- Add an entry for each one of the given interfaces
1742 -- implemented by type Ent.
1745 Elmt
: Elmt_Id
:= First_Elmt
(Interfaces
(Ent
));
1747 while Present
(Elmt
) loop
1748 New_Entry
(Node
(Elmt
));
1755 -- Collect inherited primitive operations that may be declared in
1756 -- another unit and have no visible reference in the current one.
1759 and then Is_Tagged_Type
(Ent
)
1760 and then Is_Derived_Type
(Ent
)
1761 and then Is_Base_Type
(Ent
)
1762 and then In_Extended_Main_Source_Unit
(Ent
)
1765 Op_List
: constant Elist_Id
:= Primitive_Operations
(Ent
);
1769 function Parent_Op
(E
: Entity_Id
) return Entity_Id
;
1770 -- Find original operation, which may be inherited through
1771 -- several derivations.
1773 function Parent_Op
(E
: Entity_Id
) return Entity_Id
is
1774 Orig_Op
: constant Entity_Id
:= Alias
(E
);
1777 if No
(Orig_Op
) then
1780 elsif not Comes_From_Source
(E
)
1781 and then not Has_Xref_Entry
(Orig_Op
)
1782 and then Comes_From_Source
(Orig_Op
)
1786 return Parent_Op
(Orig_Op
);
1791 Op
:= First_Elmt
(Op_List
);
1792 while Present
(Op
) loop
1793 Prim
:= Parent_Op
(Node
(Op
));
1795 if Present
(Prim
) then
1799 Typ
=> Character'First,
1800 Eun
=> Get_Source_Unit
(Sloc
(Prim
)),
1803 Ent_Scope
=> Empty
),
1804 Ent_Scope_File
=> No_Unit
);
1815 end Handle_Orphan_Type_References
;
1817 -- Now we have all the references, including those for any embedded type
1818 -- references, so we can sort them, and output them.
1820 Output_Refs
: declare
1821 Nrefs
: constant Nat
:= Xrefs
.Last
;
1822 -- Number of references in table
1824 Rnums
: array (0 .. Nrefs
) of Nat
;
1825 -- This array contains numbers of references in the Xrefs table.
1826 -- This list is sorted in output order. The extra 0'th entry is
1827 -- convenient for the call to sort. When we sort the table, we
1828 -- move the entries in Rnums around, but we do not move the
1829 -- original table entries.
1831 Curxu
: Unit_Number_Type
;
1832 -- Current xref unit
1834 Curru
: Unit_Number_Type
;
1835 -- Current reference unit for one entity
1840 Curnam
: String (1 .. Name_Buffer
'Length);
1842 -- Simple name and length of current entity
1844 Curdef
: Source_Ptr
;
1845 -- Original source location for current entity
1848 -- Current reference location
1851 -- Entity type character
1854 -- reference kind of previous reference
1860 -- Renaming reference
1862 Trunit
: Unit_Number_Type
;
1863 -- Unit number for type reference
1865 function Lt
(Op1
, Op2
: Natural) return Boolean;
1866 -- Comparison function for Sort call
1868 function Name_Change
(X
: Entity_Id
) return Boolean;
1869 -- Determines if entity X has a different simple name from Curent
1871 procedure Move
(From
: Natural; To
: Natural);
1872 -- Move procedure for Sort call
1874 package Sorting
is new GNAT
.Heap_Sort_G
(Move
, Lt
);
1880 function Lt
(Op1
, Op2
: Natural) return Boolean is
1881 T1
: Xref_Entry
renames Xrefs
.Table
(Rnums
(Nat
(Op1
)));
1882 T2
: Xref_Entry
renames Xrefs
.Table
(Rnums
(Nat
(Op2
)));
1892 procedure Move
(From
: Natural; To
: Natural) is
1894 Rnums
(Nat
(To
)) := Rnums
(Nat
(From
));
1901 -- Why a string comparison here??? Why not compare Name_Id values???
1903 function Name_Change
(X
: Entity_Id
) return Boolean is
1905 Get_Unqualified_Name_String
(Chars
(X
));
1907 if Name_Len
/= Curlen
then
1910 return Name_Buffer
(1 .. Curlen
) /= Curnam
(1 .. Curlen
);
1914 -- Start of processing for Output_Refs
1917 -- Capture the definition Sloc values. We delay doing this till now,
1918 -- since at the time the reference or definition is made, private
1919 -- types may be swapped, and the Sloc value may be incorrect. We
1920 -- also set up the pointer vector for the sort.
1922 -- For user-defined operators we need to skip the initial quote and
1923 -- point to the first character of the name, for navigation purposes.
1925 for J
in 1 .. Nrefs
loop
1927 E
: constant Entity_Id
:= Xrefs
.Table
(J
).Key
.Ent
;
1928 Loc
: constant Source_Ptr
:= Original_Location
(Sloc
(E
));
1933 if Nkind
(E
) = N_Defining_Operator_Symbol
then
1934 Xrefs
.Table
(J
).Def
:= Loc
+ 1;
1936 Xrefs
.Table
(J
).Def
:= Loc
;
1941 -- Sort the references
1943 Sorting
.Sort
(Integer (Nrefs
));
1945 -- Initialize loop through references
1949 Curdef
:= No_Location
;
1951 Crloc
:= No_Location
;
1954 -- Loop to output references
1956 for Refno
in 1 .. Nrefs
loop
1957 Output_One_Ref
: declare
1960 XE
: Xref_Entry
renames Xrefs
.Table
(Rnums
(Refno
));
1961 -- The current entry to be accessed
1965 -- Used for {} or <> or () for type reference
1967 procedure Check_Type_Reference
1969 List_Interface
: Boolean;
1970 Is_Component
: Boolean := False);
1971 -- Find whether there is a meaningful type reference for
1972 -- Ent, and display it accordingly. If List_Interface is
1973 -- true, then Ent is a progenitor interface of the current
1974 -- type entity being listed. In that case list it as is,
1975 -- without looking for a type reference for it. Flag is also
1976 -- used for index types of an array type, where the caller
1977 -- supplies the intended type reference. Is_Component serves
1978 -- the same purpose, to display the component type of a
1979 -- derived array type, for which only the parent type has
1980 -- ben displayed so far.
1982 procedure Output_Instantiation_Refs
(Loc
: Source_Ptr
);
1983 -- Recursive procedure to output instantiation references for
1984 -- the given source ptr in [file|line[...]] form. No output
1985 -- if the given location is not a generic template reference.
1987 procedure Output_Overridden_Op
(Old_E
: Entity_Id
);
1988 -- For a subprogram that is overriding, display information
1989 -- about the inherited operation that it overrides.
1991 --------------------------
1992 -- Check_Type_Reference --
1993 --------------------------
1995 procedure Check_Type_Reference
1997 List_Interface
: Boolean;
1998 Is_Component
: Boolean := False)
2001 if List_Interface
then
2003 -- This is a progenitor interface of the type for which
2004 -- xref information is being generated.
2010 -- The following is not documented in lib-xref.ads ???
2012 elsif Is_Component
then
2018 Get_Type_Reference
(Ent
, Tref
, Left
, Right
);
2021 if Present
(Tref
) then
2023 -- Case of standard entity, output name
2025 if Sloc
(Tref
) = Standard_Location
then
2026 Write_Info_Char
(Left
);
2027 Write_Info_Name
(Chars
(Tref
));
2028 Write_Info_Char
(Right
);
2030 -- Case of source entity, output location
2033 Write_Info_Char
(Left
);
2034 Trunit
:= Get_Source_Unit
(Sloc
(Tref
));
2036 if Trunit
/= Curxu
then
2037 Write_Info_Nat
(Dependency_Num
(Trunit
));
2038 Write_Info_Char
('|');
2042 (Int
(Get_Logical_Line_Number
(Sloc
(Tref
))));
2050 Ctyp
:= Xref_Entity_Letters
(Ekind
(Ent
));
2053 and then Present
(Full_View
(Ent
))
2055 Ent
:= Underlying_Type
(Ent
);
2057 if Present
(Ent
) then
2058 Ctyp
:= Xref_Entity_Letters
(Ekind
(Ent
));
2062 Write_Info_Char
(Ctyp
);
2066 (Int
(Get_Column_Number
(Sloc
(Tref
))));
2068 -- If the type comes from an instantiation, add the
2069 -- corresponding info.
2071 Output_Instantiation_Refs
(Sloc
(Tref
));
2072 Write_Info_Char
(Right
);
2075 end Check_Type_Reference
;
2077 -------------------------------
2078 -- Output_Instantiation_Refs --
2079 -------------------------------
2081 procedure Output_Instantiation_Refs
(Loc
: Source_Ptr
) is
2082 Iloc
: constant Source_Ptr
:= Instantiation_Location
(Loc
);
2083 Lun
: Unit_Number_Type
;
2084 Cu
: constant Unit_Number_Type
:= Curru
;
2087 -- Nothing to do if this is not an instantiation
2089 if Iloc
= No_Location
then
2093 -- Output instantiation reference
2095 Write_Info_Char
('[');
2096 Lun
:= Get_Source_Unit
(Iloc
);
2098 if Lun
/= Curru
then
2100 Write_Info_Nat
(Dependency_Num
(Curru
));
2101 Write_Info_Char
('|');
2104 Write_Info_Nat
(Int
(Get_Logical_Line_Number
(Iloc
)));
2106 -- Recursive call to get nested instantiations
2108 Output_Instantiation_Refs
(Iloc
);
2110 -- Output final ] after call to get proper nesting
2112 Write_Info_Char
(']');
2115 end Output_Instantiation_Refs
;
2117 --------------------------
2118 -- Output_Overridden_Op --
2119 --------------------------
2121 procedure Output_Overridden_Op
(Old_E
: Entity_Id
) is
2125 -- The overridden operation has an implicit declaration
2126 -- at the point of derivation. What we want to display
2127 -- is the original operation, which has the actual body
2128 -- (or abstract declaration) that is being overridden.
2129 -- The overridden operation is not always set, e.g. when
2130 -- it is a predefined operator.
2135 -- Follow alias chain if one is present
2137 elsif Present
(Alias
(Old_E
)) then
2139 -- The subprogram may have been implicitly inherited
2140 -- through several levels of derivation, so find the
2141 -- ultimate (source) ancestor.
2143 Op
:= Ultimate_Alias
(Old_E
);
2145 -- Normal case of no alias present. We omit generated
2146 -- primitives like tagged equality, that have no source
2154 and then Sloc
(Op
) /= Standard_Location
2155 and then Comes_From_Source
(Op
)
2158 Loc
: constant Source_Ptr
:= Sloc
(Op
);
2159 Par_Unit
: constant Unit_Number_Type
:=
2160 Get_Source_Unit
(Loc
);
2163 Write_Info_Char
('<');
2165 if Par_Unit
/= Curxu
then
2166 Write_Info_Nat
(Dependency_Num
(Par_Unit
));
2167 Write_Info_Char
('|');
2170 Write_Info_Nat
(Int
(Get_Logical_Line_Number
(Loc
)));
2171 Write_Info_Char
('p');
2172 Write_Info_Nat
(Int
(Get_Column_Number
(Loc
)));
2173 Write_Info_Char
('>');
2176 end Output_Overridden_Op
;
2178 -- Start of processing for Output_One_Ref
2183 -- Do not generate reference information for an ignored Ghost
2184 -- entity because neither the entity nor its references will
2185 -- appear in the final tree.
2187 if Is_Ignored_Ghost_Entity
(Ent
) then
2191 Ctyp
:= Xref_Entity_Letters
(Ekind
(Ent
));
2193 -- Skip reference if it is the only reference to an entity,
2194 -- and it is an END line reference, and the entity is not in
2195 -- the current extended source. This prevents junk entries
2196 -- consisting only of packages with END lines, where no
2197 -- entity from the package is actually referenced.
2200 and then Ent
/= Curent
2201 and then (Refno
= Nrefs
2203 Ent
/= Xrefs
.Table
(Rnums
(Refno
+ 1)).Key
.Ent
)
2204 and then not In_Extended_Main_Source_Unit
(Ent
)
2209 -- For private type, get full view type
2212 and then Present
(Full_View
(XE
.Key
.Ent
))
2214 Ent
:= Underlying_Type
(Ent
);
2216 if Present
(Ent
) then
2217 Ctyp
:= Xref_Entity_Letters
(Ekind
(Ent
));
2221 -- Special exception for Boolean
2223 if Ctyp
= 'E' and then Is_Boolean_Type
(Ent
) then
2227 -- For variable reference, get corresponding type
2230 Ent
:= Etype
(XE
.Key
.Ent
);
2231 Ctyp
:= Fold_Lower
(Xref_Entity_Letters
(Ekind
(Ent
)));
2233 -- If variable is private type, get full view type
2236 and then Present
(Full_View
(Etype
(XE
.Key
.Ent
)))
2238 Ent
:= Underlying_Type
(Etype
(XE
.Key
.Ent
));
2240 if Present
(Ent
) then
2241 Ctyp
:= Fold_Lower
(Xref_Entity_Letters
(Ekind
(Ent
)));
2244 elsif Is_Generic_Type
(Ent
) then
2246 -- If the type of the entity is a generic private type,
2247 -- there is no usable full view, so retain the indication
2248 -- that this is an object.
2253 -- Special handling for access parameters and objects and
2254 -- components of an anonymous access type.
2256 if Ekind
(Etype
(XE
.Key
.Ent
)) in
2257 E_Anonymous_Access_Type
2258 | E_Anonymous_Access_Subprogram_Type
2259 | E_Anonymous_Access_Protected_Subprogram_Type
2261 if Is_Formal
(XE
.Key
.Ent
)
2263 Ekind
(XE
.Key
.Ent
) in
2264 E_Variable | E_Constant | E_Component
2269 -- Special handling for Boolean
2271 elsif Ctyp
= 'e' and then Is_Boolean_Type
(Ent
) then
2276 -- Special handling for abstract types and operations
2278 if Is_Overloadable
(XE
.Key
.Ent
)
2279 and then Is_Abstract_Subprogram
(XE
.Key
.Ent
)
2282 Ctyp
:= 'x'; -- Abstract procedure
2284 elsif Ctyp
= 'V' then
2285 Ctyp
:= 'y'; -- Abstract function
2288 elsif Is_Type
(XE
.Key
.Ent
)
2289 and then Is_Abstract_Type
(XE
.Key
.Ent
)
2291 if Is_Interface
(XE
.Key
.Ent
) then
2294 elsif Ctyp
= 'R' then
2295 Ctyp
:= 'H'; -- Abstract type
2299 -- Only output reference if interesting type of entity
2303 -- Suppress references to object definitions, used for local
2306 or else XE
.Key
.Typ
= 'D'
2307 or else XE
.Key
.Typ
= 'I'
2309 -- Suppress self references, except for bodies that act as
2312 or else (XE
.Key
.Loc
= XE
.Def
2315 or else not Is_Subprogram
(XE
.Key
.Ent
)))
2317 -- Also suppress definitions of body formals (we only
2318 -- treat these as references, and the references were
2319 -- separately recorded).
2321 or else (Is_Formal
(XE
.Key
.Ent
)
2322 and then Present
(Spec_Entity
(XE
.Key
.Ent
)))
2327 -- Start new Xref section if new xref unit
2329 if XE
.Key
.Eun
/= Curxu
then
2330 if Write_Info_Col
> 1 then
2334 Curxu
:= XE
.Key
.Eun
;
2336 Write_Info_Initiate
('X');
2337 Write_Info_Char
(' ');
2338 Write_Info_Nat
(Dependency_Num
(XE
.Key
.Eun
));
2339 Write_Info_Char
(' ');
2341 (Reference_Name
(Source_Index
(XE
.Key
.Eun
)));
2344 -- Start new Entity line if new entity. Note that we
2345 -- consider two entities the same if they have the same
2346 -- name and source location. This causes entities in
2347 -- instantiations to be treated as though they referred
2352 (XE
.Key
.Ent
/= Curent
2354 (Name_Change
(XE
.Key
.Ent
) or else XE
.Def
/= Curdef
))
2356 Curent
:= XE
.Key
.Ent
;
2359 Get_Unqualified_Name_String
(Chars
(XE
.Key
.Ent
));
2361 Curnam
(1 .. Curlen
) := Name_Buffer
(1 .. Curlen
);
2363 if Write_Info_Col
> 1 then
2367 -- Write column number information
2369 Write_Info_Nat
(Int
(Get_Logical_Line_Number
(XE
.Def
)));
2370 Write_Info_Char
(Ctyp
);
2371 Write_Info_Nat
(Int
(Get_Column_Number
(XE
.Def
)));
2373 -- Write level information
2375 Write_Level_Info
: declare
2376 function Is_Visible_Generic_Entity
2377 (E
: Entity_Id
) return Boolean;
2378 -- Check whether E is declared in the visible part
2379 -- of a generic package. For source navigation
2380 -- purposes, treat this as a visible entity.
2382 function Is_Private_Record_Component
2383 (E
: Entity_Id
) return Boolean;
2384 -- Check whether E is a non-inherited component of a
2385 -- private extension. Even if the enclosing record is
2386 -- public, we want to treat the component as private
2387 -- for navigation purposes.
2389 ---------------------------------
2390 -- Is_Private_Record_Component --
2391 ---------------------------------
2393 function Is_Private_Record_Component
2394 (E
: Entity_Id
) return Boolean
2396 S
: constant Entity_Id
:= Scope
(E
);
2399 Ekind
(E
) = E_Component
2400 and then Nkind
(Declaration_Node
(S
)) =
2401 N_Private_Extension_Declaration
2402 and then Original_Record_Component
(E
) = E
;
2403 end Is_Private_Record_Component
;
2405 -------------------------------
2406 -- Is_Visible_Generic_Entity --
2407 -------------------------------
2409 function Is_Visible_Generic_Entity
2410 (E
: Entity_Id
) return Boolean
2415 -- The Present check here is an error defense
2417 if Present
(Scope
(E
))
2418 and then Ekind
(Scope
(E
)) /= E_Generic_Package
2424 while Present
(Par
) loop
2426 Nkind
(Par
) = N_Generic_Package_Declaration
2428 -- Entity is a generic formal
2433 Nkind
(Parent
(Par
)) = N_Package_Specification
2436 Is_List_Member
(Par
)
2437 and then List_Containing
(Par
) =
2438 Visible_Declarations
(Parent
(Par
));
2440 Par
:= Parent
(Par
);
2445 end Is_Visible_Generic_Entity
;
2447 -- Start of processing for Write_Level_Info
2450 if Is_Hidden
(Curent
)
2451 or else Is_Private_Record_Component
(Curent
)
2453 Write_Info_Char
(' ');
2457 or else Is_Visible_Generic_Entity
(Curent
)
2459 Write_Info_Char
('*');
2462 Write_Info_Char
(' ');
2464 end Write_Level_Info
;
2466 -- Output entity name. We use the occurrence from the
2467 -- actual source program at the definition point.
2470 Ent_Name
: constant String :=
2471 Exact_Source_Name
(Sloc
(XE
.Key
.Ent
));
2473 for C
in Ent_Name
'Range loop
2474 Write_Info_Char
(Ent_Name
(C
));
2478 -- See if we have a renaming reference
2480 if Is_Object
(XE
.Key
.Ent
)
2481 and then Present
(Renamed_Object
(XE
.Key
.Ent
))
2483 Rref
:= Renamed_Object
(XE
.Key
.Ent
);
2485 elsif Is_Overloadable
(XE
.Key
.Ent
)
2486 and then Nkind
(Parent
(Declaration_Node
(XE
.Key
.Ent
)))
2487 = N_Subprogram_Renaming_Declaration
2489 Rref
:= Name
(Parent
(Declaration_Node
(XE
.Key
.Ent
)));
2491 elsif Ekind
(XE
.Key
.Ent
) = E_Package
2492 and then Nkind
(Declaration_Node
(XE
.Key
.Ent
)) =
2493 N_Package_Renaming_Declaration
2495 Rref
:= Name
(Declaration_Node
(XE
.Key
.Ent
));
2501 if Present
(Rref
) then
2502 if Nkind
(Rref
) = N_Expanded_Name
then
2503 Rref
:= Selector_Name
(Rref
);
2506 if Nkind
(Rref
) = N_Identifier
2507 or else Nkind
(Rref
) = N_Operator_Symbol
2511 -- For renamed array components, use the array name
2512 -- for the renamed entity, which reflect the fact that
2513 -- in general the whole array is aliased.
2515 elsif Nkind
(Rref
) = N_Indexed_Component
then
2516 if Nkind
(Prefix
(Rref
)) = N_Identifier
then
2517 Rref
:= Prefix
(Rref
);
2518 elsif Nkind
(Prefix
(Rref
)) = N_Expanded_Name
then
2519 Rref
:= Selector_Name
(Prefix
(Rref
));
2529 -- Write out renaming reference if we have one
2531 if Present
(Rref
) then
2532 Write_Info_Char
('=');
2534 (Int
(Get_Logical_Line_Number
(Sloc
(Rref
))));
2535 Write_Info_Char
(':');
2537 (Int
(Get_Column_Number
(Sloc
(Rref
))));
2540 -- Indicate that the entity is in the unit of the current
2545 -- Write out information about generic parent, if entity
2548 if Is_Generic_Instance
(XE
.Key
.Ent
) then
2550 Gen_Par
: constant Entity_Id
:=
2553 (Unit_Declaration_Node
2555 Loc
: constant Source_Ptr
:= Sloc
(Gen_Par
);
2556 Gen_U
: constant Unit_Number_Type
:=
2557 Get_Source_Unit
(Loc
);
2560 Write_Info_Char
('[');
2562 if Curru
/= Gen_U
then
2563 Write_Info_Nat
(Dependency_Num
(Gen_U
));
2564 Write_Info_Char
('|');
2568 (Int
(Get_Logical_Line_Number
(Loc
)));
2569 Write_Info_Char
(']');
2573 -- See if we have a type reference and if so output
2575 Check_Type_Reference
(XE
.Key
.Ent
, False);
2577 -- Additional information for types with progenitors,
2578 -- including synchronized tagged types.
2581 Typ
: constant Entity_Id
:= XE
.Key
.Ent
;
2585 if Is_Record_Type
(Typ
)
2586 and then Present
(Interfaces
(Typ
))
2588 Elmt
:= First_Elmt
(Interfaces
(Typ
));
2590 elsif Is_Concurrent_Type
(Typ
)
2591 and then Present
(Corresponding_Record_Type
(Typ
))
2593 Interfaces
(Corresponding_Record_Type
(Typ
)))
2597 Interfaces
(Corresponding_Record_Type
(Typ
)));
2603 while Present
(Elmt
) loop
2604 Check_Type_Reference
(Node
(Elmt
), True);
2609 -- For array types, list index types as well. (This is
2610 -- not C, indexes have distinct types).
2612 if Is_Array_Type
(XE
.Key
.Ent
) then
2614 A_Typ
: constant Entity_Id
:= XE
.Key
.Ent
;
2618 -- If this is a derived array type, we have
2619 -- output the parent type, so add the component
2622 if Is_Derived_Type
(A_Typ
) then
2623 Check_Type_Reference
2624 (Component_Type
(A_Typ
), False, True);
2627 -- Add references to index types.
2629 Indx
:= First_Index
(XE
.Key
.Ent
);
2630 while Present
(Indx
) loop
2631 Check_Type_Reference
2632 (First_Subtype
(Etype
(Indx
)), True);
2638 -- If the entity is an overriding operation, write info
2639 -- on operation that was overridden.
2641 if Is_Subprogram
(XE
.Key
.Ent
)
2642 and then Present
(Overridden_Operation
(XE
.Key
.Ent
))
2644 Output_Overridden_Op
2645 (Overridden_Operation
(XE
.Key
.Ent
));
2648 -- End of processing for entity output
2650 Crloc
:= No_Location
;
2653 -- Output the reference if it is not as the same location
2654 -- as the previous one, or it is a read-reference that
2655 -- indicates that the entity is an in-out actual in a call.
2657 if XE
.Key
.Loc
/= No_Location
2659 (XE
.Key
.Loc
/= Crloc
2660 or else (Prevt
= 'm' and then XE
.Key
.Typ
= 'r'))
2662 Crloc
:= XE
.Key
.Loc
;
2663 Prevt
:= XE
.Key
.Typ
;
2665 -- Start continuation if line full, else blank
2667 if Write_Info_Col
> 72 then
2669 Write_Info_Initiate
('.');
2672 Write_Info_Char
(' ');
2674 -- Output file number if changed
2676 if XE
.Key
.Lun
/= Curru
then
2677 Curru
:= XE
.Key
.Lun
;
2678 Write_Info_Nat
(Dependency_Num
(Curru
));
2679 Write_Info_Char
('|');
2683 (Int
(Get_Logical_Line_Number
(XE
.Key
.Loc
)));
2684 Write_Info_Char
(XE
.Key
.Typ
);
2686 if Is_Overloadable
(XE
.Key
.Ent
) then
2687 if (Is_Imported
(XE
.Key
.Ent
) and then XE
.Key
.Typ
= 'b')
2689 (Is_Exported
(XE
.Key
.Ent
) and then XE
.Key
.Typ
= 'i')
2691 Output_Import_Export_Info
(XE
.Key
.Ent
);
2695 Write_Info_Nat
(Int
(Get_Column_Number
(XE
.Key
.Loc
)));
2697 Output_Instantiation_Refs
(Sloc
(XE
.Key
.Ent
));
2708 end Output_References
;
2710 -- Start of elaboration for Lib.Xref
2713 -- Reset is necessary because Elmt_Ptr does not default to Null_Ptr,
2714 -- because it's not an access type.