1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2003, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Csets
; use Csets
;
29 with Elists
; use Elists
;
30 with Errout
; use Errout
;
31 with Lib
.Util
; use Lib
.Util
;
32 with Namet
; use Namet
;
33 with Nlists
; use Nlists
;
35 with Sem_Prag
; use Sem_Prag
;
36 with Sinfo
; use Sinfo
;
37 with Sinput
; use Sinput
;
38 with Snames
; use Snames
;
39 with Stringt
; use Stringt
;
40 with Stand
; use Stand
;
41 with Table
; use Table
;
42 with Widechar
; use Widechar
;
44 with GNAT
.Heap_Sort_A
;
46 package body Lib
.Xref
is
52 -- The Xref table is used to record references. The Loc field is set
53 -- to No_Location for a definition entry.
55 subtype Xref_Entry_Number
is Int
;
57 type Xref_Entry
is record
59 -- Entity referenced (E parameter to Generate_Reference)
62 -- Original source location for entity being referenced. Note that
63 -- these values are used only during the output process, they are
64 -- not set when the entries are originally built. This is because
65 -- private entities can be swapped when the initial call is made.
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.
73 -- Reference type (Typ param to Generate_Reference)
75 Eun
: Unit_Number_Type
;
76 -- Unit number corresponding to Ent
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.
84 package Xrefs
is new Table
.Table
(
85 Table_Component_Type
=> Xref_Entry
,
86 Table_Index_Type
=> Xref_Entry_Number
,
88 Table_Initial
=> Alloc
.Xrefs_Initial
,
89 Table_Increment
=> Alloc
.Xrefs_Increment
,
90 Table_Name
=> "Xrefs");
92 -------------------------
93 -- Generate_Definition --
94 -------------------------
96 procedure Generate_Definition
(E
: Entity_Id
) is
101 pragma Assert
(Nkind
(E
) in N_Entity
);
103 -- Note that we do not test Xref_Entity_Letters here. It is too
104 -- early to do so, since we are often called before the entity
105 -- is fully constructed, so that the Ekind is still E_Void.
109 -- Definition must come from source
111 and then Comes_From_Source
(E
)
113 -- And must have a reasonable source location that is not
114 -- within an instance (all entities in instances are ignored)
116 and then Sloc
(E
) > No_Location
117 and then Instantiation_Location
(Sloc
(E
)) = No_Location
119 -- And must be a non-internal name from the main source unit
121 and then In_Extended_Main_Source_Unit
(E
)
122 and then not Is_Internal_Name
(Chars
(E
))
124 Xrefs
.Increment_Last
;
126 Loc
:= Original_Location
(Sloc
(E
));
128 Xrefs
.Table
(Indx
).Ent
:= E
;
129 Xrefs
.Table
(Indx
).Loc
:= No_Location
;
130 Xrefs
.Table
(Indx
).Eun
:= Get_Source_Unit
(Loc
);
131 Xrefs
.Table
(Indx
).Lun
:= No_Unit
;
132 Set_Has_Xref_Entry
(E
);
134 end Generate_Definition
;
136 ---------------------------------
137 -- Generate_Operator_Reference --
138 ---------------------------------
140 procedure Generate_Operator_Reference
145 if not In_Extended_Main_Source_Unit
(N
) then
149 -- If the operator is not a Standard operator, then we generate
150 -- a real reference to the user defined operator.
152 if Sloc
(Entity
(N
)) /= Standard_Location
then
153 Generate_Reference
(Entity
(N
), N
);
155 -- A reference to an implicit inequality operator is a also a
156 -- reference to the user-defined equality.
158 if Nkind
(N
) = N_Op_Ne
159 and then not Comes_From_Source
(Entity
(N
))
160 and then Present
(Corresponding_Equality
(Entity
(N
)))
162 Generate_Reference
(Corresponding_Equality
(Entity
(N
)), N
);
165 -- For the case of Standard operators, we mark the result type
166 -- as referenced. This ensures that in the case where we are
167 -- using a derived operator, we mark an entity of the unit that
168 -- implicitly defines this operator as used. Otherwise we may
169 -- think that no entity of the unit is used. The actual entity
170 -- marked as referenced is the first subtype, which is the user
171 -- defined entity that is relevant.
173 -- Note: we only do this for operators that come from source.
174 -- The generated code sometimes reaches for entities that do
175 -- not need to be explicitly visible (for example, when we
176 -- expand the code for comparing two record types, the fields
177 -- of the record may not be visible).
179 elsif Comes_From_Source
(N
) then
180 Set_Referenced
(First_Subtype
(T
));
182 end Generate_Operator_Reference
;
184 ------------------------
185 -- Generate_Reference --
186 ------------------------
188 procedure Generate_Reference
191 Typ
: Character := 'r';
192 Set_Ref
: Boolean := True;
193 Force
: Boolean := False)
202 pragma Assert
(Nkind
(E
) in N_Entity
);
204 -- Never collect references if not in main source unit. However,
205 -- we omit this test if Typ is 'e' or 'k', since these entries are
206 -- really structural, and it is useful to have them in units
207 -- that reference packages as well as units that define packages.
208 -- We also omit the test for the case of 'p' since we want to
209 -- include inherited primitive operations from other packages.
211 if not In_Extended_Main_Source_Unit
(N
)
219 -- For reference type p, the entity must be in main source unit
221 if Typ
= 'p' and then not In_Extended_Main_Source_Unit
(E
) then
225 -- Unless the reference is forced, we ignore references where
226 -- the reference itself does not come from Source.
228 if not Force
and then not Comes_From_Source
(N
) then
232 -- Deal with setting entity as referenced, unless suppressed.
233 -- Note that we still do Set_Referenced on entities that do not
234 -- come from source. This situation arises when we have a source
235 -- reference to a derived operation, where the derived operation
236 -- itself does not come from source, but we still want to mark it
237 -- as referenced, since we really are referencing an entity in the
238 -- corresponding package (this avoids incorrect complaints that the
239 -- package contains no referenced entities).
243 -- For a variable that appears on the left side of an
244 -- assignment statement, we set the Referenced_As_LHS
245 -- flag since this is indeed a left hand side.
247 if Ekind
(E
) = E_Variable
248 and then Nkind
(Parent
(N
)) = N_Assignment_Statement
249 and then Name
(Parent
(N
)) = N
250 and then No
(Renamed_Object
(E
))
252 Set_Referenced_As_LHS
(E
);
254 -- Check for a reference in a pragma that should not count as a
255 -- making the variable referenced for warning purposes.
257 elsif Is_Non_Significant_Pragma_Reference
(N
) then
260 -- A reference in an attribute definition clause does not
261 -- count as a reference except for the case of Address.
262 -- The reason that 'Address is an exception is that it
263 -- creates an alias through which the variable may be
266 elsif Nkind
(Parent
(N
)) = N_Attribute_Definition_Clause
267 and then Chars
(Parent
(N
)) /= Name_Address
268 and then N
= Name
(Parent
(N
))
272 -- Any other occurrence counts as referencing the entity
278 -- Check for pragma Unreferenced given
280 if Has_Pragma_Unreferenced
(E
) then
282 -- A reference as a named parameter in a call does not count
283 -- as a violation of pragma Unreferenced for this purpose.
285 if Nkind
(N
) = N_Identifier
286 and then Nkind
(Parent
(N
)) = N_Parameter_Association
287 and then Selector_Name
(Parent
(N
)) = N
291 -- Neither does a reference to a variable on the left side
294 elsif Ekind
(E
) = E_Variable
295 and then Nkind
(Parent
(N
)) = N_Assignment_Statement
296 and then Name
(Parent
(N
)) = N
300 -- Here we issue the warning, since this is a real reference
303 Error_Msg_NE
("?pragma Unreferenced given for&", N
, E
);
307 -- If this is a subprogram instance, mark as well the internal
308 -- subprogram in the wrapper package, which may be a visible
311 if Is_Overloadable
(E
)
312 and then Is_Generic_Instance
(E
)
313 and then Present
(Alias
(E
))
315 Set_Referenced
(Alias
(E
));
319 -- Generate reference if all conditions are met:
322 -- Cross referencing must be active
326 -- The entity must be one for which we collect references
328 and then Xref_Entity_Letters
(Ekind
(E
)) /= ' '
330 -- Both Sloc values must be set to something sensible
332 and then Sloc
(E
) > No_Location
333 and then Sloc
(N
) > No_Location
335 -- We ignore references from within an instance
337 and then Instantiation_Location
(Sloc
(N
)) = No_Location
339 -- Ignore dummy references
343 if Nkind
(N
) = N_Identifier
345 Nkind
(N
) = N_Defining_Identifier
349 Nkind
(N
) = N_Defining_Operator_Symbol
351 Nkind
(N
) = N_Operator_Symbol
353 (Nkind
(N
) = N_Character_Literal
354 and then Sloc
(Entity
(N
)) /= Standard_Location
)
356 Nkind
(N
) = N_Defining_Character_Literal
360 elsif Nkind
(N
) = N_Expanded_Name
362 Nkind
(N
) = N_Selected_Component
364 Nod
:= Selector_Name
(N
);
370 -- Normal case of source entity comes from source
372 if Comes_From_Source
(E
) then
375 -- Entity does not come from source, but is a derived subprogram
376 -- and the derived subprogram comes from source (after one or more
377 -- derivations) in which case the reference is to parent subprogram.
379 elsif Is_Overloadable
(E
)
380 and then Present
(Alias
(E
))
385 if Comes_From_Source
(Ent
) then
387 elsif No
(Alias
(Ent
)) then
394 -- Record components of discriminated subtypes or derived types
395 -- must be treated as references to the original component.
397 elsif Ekind
(E
) = E_Component
398 and then Comes_From_Source
(Original_Record_Component
(E
))
400 Ent
:= Original_Record_Component
(E
);
402 -- Ignore reference to any other entity that is not from source
408 -- Record reference to entity
410 Ref
:= Original_Location
(Sloc
(Nod
));
411 Def
:= Original_Location
(Sloc
(Ent
));
413 Xrefs
.Increment_Last
;
416 Xrefs
.Table
(Indx
).Loc
:= Ref
;
418 -- Overriding operations are marked with 'P'.
421 and then Is_Subprogram
(N
)
422 and then Is_Overriding_Operation
(N
)
424 Xrefs
.Table
(Indx
).Typ
:= 'P';
426 Xrefs
.Table
(Indx
).Typ
:= Typ
;
429 Xrefs
.Table
(Indx
).Eun
:= Get_Source_Unit
(Def
);
430 Xrefs
.Table
(Indx
).Lun
:= Get_Source_Unit
(Ref
);
431 Xrefs
.Table
(Indx
).Ent
:= Ent
;
432 Set_Has_Xref_Entry
(Ent
);
434 end Generate_Reference
;
436 -----------------------------------
437 -- Generate_Reference_To_Formals --
438 -----------------------------------
440 procedure Generate_Reference_To_Formals
(E
: Entity_Id
) is
444 if Is_Generic_Subprogram
(E
) then
445 Formal
:= First_Entity
(E
);
447 while Present
(Formal
)
448 and then not Is_Formal
(Formal
)
450 Next_Entity
(Formal
);
454 Formal
:= First_Formal
(E
);
457 while Present
(Formal
) loop
458 if Ekind
(Formal
) = E_In_Parameter
then
460 if Nkind
(Parameter_Type
(Parent
(Formal
)))
461 = N_Access_Definition
463 Generate_Reference
(E
, Formal
, '^', False);
465 Generate_Reference
(E
, Formal
, '>', False);
468 elsif Ekind
(Formal
) = E_In_Out_Parameter
then
469 Generate_Reference
(E
, Formal
, '=', False);
472 Generate_Reference
(E
, Formal
, '<', False);
475 Next_Formal
(Formal
);
477 end Generate_Reference_To_Formals
;
479 -------------------------------------------
480 -- Generate_Reference_To_Generic_Formals --
481 -------------------------------------------
483 procedure Generate_Reference_To_Generic_Formals
(E
: Entity_Id
) is
487 Formal
:= First_Entity
(E
);
489 while Present
(Formal
) loop
490 if Comes_From_Source
(Formal
) then
491 Generate_Reference
(E
, Formal
, 'z', False);
494 Next_Entity
(Formal
);
496 end Generate_Reference_To_Generic_Formals
;
502 procedure Initialize
is
507 -----------------------
508 -- Output_References --
509 -----------------------
511 procedure Output_References
is
513 procedure Get_Type_Reference
515 Tref
: out Entity_Id
;
516 Left
: out Character;
517 Right
: out Character);
518 -- Given an entity id Ent, determines whether a type reference is
519 -- required. If so, Tref is set to the entity for the type reference
520 -- and Left and Right are set to the left/right brackets to be
521 -- output for the reference. If no type reference is required, then
522 -- Tref is set to Empty, and Left/Right are set to space.
524 procedure Output_Import_Export_Info
(Ent
: Entity_Id
);
525 -- Ouput language and external name information for an interfaced
526 -- entity, using the format <language, external_name>,
528 ------------------------
529 -- Get_Type_Reference --
530 ------------------------
532 procedure Get_Type_Reference
534 Tref
: out Entity_Id
;
535 Left
: out Character;
536 Right
: out Character)
541 -- See if we have a type reference
550 -- Processing for types
552 if Is_Type
(Tref
) then
556 if Base_Type
(Tref
) = Tref
then
558 -- If derived, then get first subtype
560 if Tref
/= Etype
(Tref
) then
561 Tref
:= First_Subtype
(Etype
(Tref
));
563 -- Set brackets for derived type, but don't
564 -- override pointer case since the fact that
565 -- something is a pointer is more important
572 -- If non-derived ptr, get directly designated type.
573 -- If the type has a full view, all references are
574 -- on the partial view, that is seen first.
576 elsif Is_Access_Type
(Tref
) then
577 Tref
:= Directly_Designated_Type
(Tref
);
581 elsif Is_Private_Type
(Tref
)
582 and then Present
(Full_View
(Tref
))
583 and then Is_Access_Type
(Full_View
(Tref
))
585 Tref
:= Directly_Designated_Type
(Full_View
(Tref
));
589 -- If non-derived array, get component type.
590 -- Skip component type for case of String
591 -- or Wide_String, saves worthwhile space.
593 elsif Is_Array_Type
(Tref
)
594 and then Tref
/= Standard_String
595 and then Tref
/= Standard_Wide_String
597 Tref
:= Component_Type
(Tref
);
601 -- For other non-derived base types, nothing
607 -- For a subtype, go to ancestor subtype. If it is a
608 -- subtype created for a generic actual, not clear yet
609 -- what is the right type to use ???
612 Tref
:= Ancestor_Subtype
(Tref
);
614 -- If no ancestor subtype, go to base type
617 Tref
:= Base_Type
(Sav
);
621 -- For objects, functions, enum literals,
622 -- just get type from Etype field.
624 elsif Is_Object
(Tref
)
625 or else Ekind
(Tref
) = E_Enumeration_Literal
626 or else Ekind
(Tref
) = E_Function
627 or else Ekind
(Tref
) = E_Operator
629 Tref
:= Etype
(Tref
);
631 -- For anything else, exit
637 -- Exit if no type reference, or we are stuck in
638 -- some loop trying to find the type reference, or
639 -- if the type is standard void type (the latter is
640 -- an implementation artifact that should not show
641 -- up in the generated cross-references).
645 or else Tref
= Standard_Void_Type
;
647 -- If we have a usable type reference, return, otherwise
648 -- keep looking for something useful (we are looking for
649 -- something that either comes from source or standard)
651 if Sloc
(Tref
) = Standard_Location
652 or else Comes_From_Source
(Tref
)
658 -- If we fall through the loop, no type reference
663 end Get_Type_Reference
;
665 -------------------------------
666 -- Output_Import_Export_Info --
667 -------------------------------
669 procedure Output_Import_Export_Info
(Ent
: Entity_Id
) is
670 Language_Name
: Name_Id
;
671 Conv
: constant Convention_Id
:= Convention
(Ent
);
673 if Conv
= Convention_C
then
674 Language_Name
:= Name_C
;
676 elsif Conv
= Convention_CPP
then
677 Language_Name
:= Name_CPP
;
679 elsif Conv
= Convention_Ada
then
680 Language_Name
:= Name_Ada
;
683 -- These are the only languages that GPS knows about.
688 Write_Info_Char
('<');
689 Get_Unqualified_Name_String
(Language_Name
);
691 for J
in 1 .. Name_Len
loop
692 Write_Info_Char
(Name_Buffer
(J
));
695 if Present
(Interface_Name
(Ent
)) then
696 Write_Info_Char
(',');
697 String_To_Name_Buffer
(Strval
(Interface_Name
(Ent
)));
699 for J
in 1 .. Name_Len
loop
700 Write_Info_Char
(Name_Buffer
(J
));
704 Write_Info_Char
('>');
705 end Output_Import_Export_Info
;
707 -- Start of processing for Output_References
710 if not Opt
.Xref_Active
then
714 -- Before we go ahead and output the references we have a problem
715 -- that needs dealing with. So far we have captured things that are
716 -- definitely referenced by the main unit, or defined in the main
717 -- unit. That's because we don't want to clutter up the ali file
718 -- for this unit with definition lines for entities in other units
719 -- that are not referenced.
721 -- But there is a glitch. We may reference an entity in another unit,
722 -- and it may have a type reference to an entity that is not directly
723 -- referenced in the main unit, which may mean that there is no xref
724 -- entry for this entity yet in the list of references.
726 -- If we don't do something about this, we will end with an orphan
727 -- type reference, i.e. it will point to an entity that does not
728 -- appear within the generated references in the ali file. That is
729 -- not good for tools using the xref information.
731 -- To fix this, we go through the references adding definition
732 -- entries for any unreferenced entities that can be referenced
733 -- in a type reference. There is a recursion problem here, and
734 -- that is dealt with by making sure that this traversal also
735 -- traverses any entries that get added by the traversal.
746 -- Note that this is not a for loop for a very good reason. The
747 -- processing of items in the table can add new items to the
748 -- table, and they must be processed as well
751 while J
<= Xrefs
.Last
loop
752 Ent
:= Xrefs
.Table
(J
).Ent
;
753 Get_Type_Reference
(Ent
, Tref
, L
, R
);
756 and then not Has_Xref_Entry
(Tref
)
757 and then Sloc
(Tref
) > No_Location
759 Xrefs
.Increment_Last
;
761 Loc
:= Original_Location
(Sloc
(Tref
));
762 Xrefs
.Table
(Indx
).Ent
:= Tref
;
763 Xrefs
.Table
(Indx
).Loc
:= No_Location
;
764 Xrefs
.Table
(Indx
).Eun
:= Get_Source_Unit
(Loc
);
765 Xrefs
.Table
(Indx
).Lun
:= No_Unit
;
766 Set_Has_Xref_Entry
(Tref
);
769 -- Collect inherited primitive operations that may be
770 -- declared in another unit and have no visible reference
771 -- in the current one.
774 and then Is_Tagged_Type
(Ent
)
775 and then Is_Derived_Type
(Ent
)
776 and then Ent
= Base_Type
(Ent
)
777 and then In_Extended_Main_Source_Unit
(Ent
)
781 Op_List
: Elist_Id
:= Primitive_Operations
(Ent
);
785 function Parent_Op
(E
: Entity_Id
) return Entity_Id
;
786 -- Find original operation, which may be inherited
787 -- through several derivations.
789 function Parent_Op
(E
: Entity_Id
) return Entity_Id
is
790 Orig_Op
: Entity_Id
:= Alias
(E
);
795 elsif not Comes_From_Source
(E
)
796 and then not Has_Xref_Entry
(Orig_Op
)
797 and then Comes_From_Source
(Orig_Op
)
801 return Parent_Op
(Orig_Op
);
806 Op
:= First_Elmt
(Op_List
);
808 while Present
(Op
) loop
810 Prim
:= Parent_Op
(Node
(Op
));
812 if Present
(Prim
) then
813 Xrefs
.Increment_Last
;
815 Loc
:= Original_Location
(Sloc
(Prim
));
816 Xrefs
.Table
(Indx
).Ent
:= Prim
;
817 Xrefs
.Table
(Indx
).Loc
:= No_Location
;
818 Xrefs
.Table
(Indx
).Eun
:=
819 Get_Source_Unit
(Sloc
(Prim
));
820 Xrefs
.Table
(Indx
).Lun
:= No_Unit
;
821 Set_Has_Xref_Entry
(Prim
);
833 -- Now we have all the references, including those for any embedded
834 -- type references, so we can sort them, and output them.
836 Output_Refs
: declare
838 Nrefs
: Nat
:= Xrefs
.Last
;
839 -- Number of references in table. This value may get reset
840 -- (reduced) when we eliminate duplicate reference entries.
842 Rnums
: array (0 .. Nrefs
) of Nat
;
843 -- This array contains numbers of references in the Xrefs table.
844 -- This list is sorted in output order. The extra 0'th entry is
845 -- convenient for the call to sort. When we sort the table, we
846 -- move the entries in Rnums around, but we do not move the
847 -- original table entries.
849 Curxu
: Unit_Number_Type
;
852 Curru
: Unit_Number_Type
;
853 -- Current reference unit for one entity
855 Cursrc
: Source_Buffer_Ptr
;
856 -- Current xref unit source text
861 Curnam
: String (1 .. Name_Buffer
'Length);
863 -- Simple name and length of current entity
866 -- Original source location for current entity
869 -- Current reference location
872 -- Entity type character
878 -- Renaming reference
880 Trunit
: Unit_Number_Type
;
881 -- Unit number for type reference
883 function Lt
(Op1
, Op2
: Natural) return Boolean;
884 -- Comparison function for Sort call
886 function Name_Change
(X
: Entity_Id
) return Boolean;
887 -- Determines if entity X has a different simple name from Curent
889 procedure Move
(From
: Natural; To
: Natural);
890 -- Move procedure for Sort call
896 function Lt
(Op1
, Op2
: Natural) return Boolean is
897 T1
: Xref_Entry
renames Xrefs
.Table
(Rnums
(Nat
(Op1
)));
898 T2
: Xref_Entry
renames Xrefs
.Table
(Rnums
(Nat
(Op2
)));
901 -- First test. If entity is in different unit, sort by unit
903 if T1
.Eun
/= T2
.Eun
then
904 return Dependency_Num
(T1
.Eun
) < Dependency_Num
(T2
.Eun
);
906 -- Second test, within same unit, sort by entity Sloc
908 elsif T1
.Def
/= T2
.Def
then
909 return T1
.Def
< T2
.Def
;
911 -- Third test, sort definitions ahead of references
913 elsif T1
.Loc
= No_Location
then
916 elsif T2
.Loc
= No_Location
then
919 -- Fourth test, for same entity, sort by reference location unit
921 elsif T1
.Lun
/= T2
.Lun
then
922 return Dependency_Num
(T1
.Lun
) < Dependency_Num
(T2
.Lun
);
924 -- Fifth test order of location within referencing unit
926 elsif T1
.Loc
/= T2
.Loc
then
927 return T1
.Loc
< T2
.Loc
;
929 -- Finally, for two locations at the same address, we prefer
930 -- the one that does NOT have the type 'r' so that a modification
931 -- or extension takes preference, when there are more than one
932 -- reference at the same location.
943 procedure Move
(From
: Natural; To
: Natural) is
945 Rnums
(Nat
(To
)) := Rnums
(Nat
(From
));
952 function Name_Change
(X
: Entity_Id
) return Boolean is
954 Get_Unqualified_Name_String
(Chars
(X
));
956 if Name_Len
/= Curlen
then
960 return Name_Buffer
(1 .. Curlen
) /= Curnam
(1 .. Curlen
);
964 -- Start of processing for Output_Refs
967 -- Capture the definition Sloc values. We delay doing this till now,
968 -- since at the time the reference or definition is made, private
969 -- types may be swapped, and the Sloc value may be incorrect. We
970 -- also set up the pointer vector for the sort.
972 for J
in 1 .. Nrefs
loop
974 Xrefs
.Table
(J
).Def
:=
975 Original_Location
(Sloc
(Xrefs
.Table
(J
).Ent
));
978 -- Sort the references
980 GNAT
.Heap_Sort_A
.Sort
982 Move
'Unrestricted_Access,
983 Lt
'Unrestricted_Access);
985 -- Eliminate duplicate entries
988 NR
: constant Nat
:= Nrefs
;
991 -- We need this test for NR because if we force ALI file
992 -- generation in case of errors detected, it may be the case
993 -- that Nrefs is 0, so we should not reset it here
998 for J
in 2 .. NR
loop
999 if Xrefs
.Table
(Rnums
(J
)) /=
1000 Xrefs
.Table
(Rnums
(Nrefs
))
1003 Rnums
(Nrefs
) := Rnums
(J
);
1009 -- Initialize loop through references
1013 Curdef
:= No_Location
;
1015 Crloc
:= No_Location
;
1017 -- Loop to output references
1019 for Refno
in 1 .. Nrefs
loop
1020 Output_One_Ref
: declare
1026 XE
: Xref_Entry
renames Xrefs
.Table
(Rnums
(Refno
));
1027 -- The current entry to be accessed
1030 -- Used to index into source buffer to get entity name
1034 -- Used for {} or <> or () for type reference
1036 procedure Output_Instantiation_Refs
(Loc
: Source_Ptr
);
1037 -- Recursive procedure to output instantiation references for
1038 -- the given source ptr in [file|line[...]] form. No output
1039 -- if the given location is not a generic template reference.
1041 -------------------------------
1042 -- Output_Instantiation_Refs --
1043 -------------------------------
1045 procedure Output_Instantiation_Refs
(Loc
: Source_Ptr
) is
1046 Iloc
: constant Source_Ptr
:= Instantiation_Location
(Loc
);
1047 Lun
: Unit_Number_Type
;
1048 Cu
: constant Unit_Number_Type
:= Curru
;
1051 -- Nothing to do if this is not an instantiation
1053 if Iloc
= No_Location
then
1057 -- Output instantiation reference
1059 Write_Info_Char
('[');
1060 Lun
:= Get_Source_Unit
(Iloc
);
1062 if Lun
/= Curru
then
1064 Write_Info_Nat
(Dependency_Num
(Curru
));
1065 Write_Info_Char
('|');
1068 Write_Info_Nat
(Int
(Get_Logical_Line_Number
(Iloc
)));
1070 -- Recursive call to get nested instantiations
1072 Output_Instantiation_Refs
(Iloc
);
1074 -- Output final ] after call to get proper nesting
1076 Write_Info_Char
(']');
1079 end Output_Instantiation_Refs
;
1081 -- Start of processing for Output_One_Ref
1085 Ctyp
:= Xref_Entity_Letters
(Ekind
(Ent
));
1087 -- Skip reference if it is the only reference to an entity,
1088 -- and it is an end-line reference, and the entity is not in
1089 -- the current extended source. This prevents junk entries
1090 -- consisting only of packages with end lines, where no
1091 -- entity from the package is actually referenced.
1094 and then Ent
/= Curent
1095 and then (Refno
= Nrefs
or else
1096 Ent
/= Xrefs
.Table
(Rnums
(Refno
+ 1)).Ent
)
1098 not In_Extended_Main_Source_Unit
(Ent
)
1103 -- For private type, get full view type
1106 and then Present
(Full_View
(XE
.Ent
))
1108 Ent
:= Underlying_Type
(Ent
);
1110 if Present
(Ent
) then
1111 Ctyp
:= Xref_Entity_Letters
(Ekind
(Ent
));
1115 -- Special exception for Boolean
1117 if Ctyp
= 'E' and then Is_Boolean_Type
(Ent
) then
1121 -- For variable reference, get corresponding type
1124 Ent
:= Etype
(XE
.Ent
);
1125 Ctyp
:= Fold_Lower
(Xref_Entity_Letters
(Ekind
(Ent
)));
1127 -- If variable is private type, get full view type
1130 and then Present
(Full_View
(Etype
(XE
.Ent
)))
1132 Ent
:= Underlying_Type
(Etype
(XE
.Ent
));
1134 if Present
(Ent
) then
1135 Ctyp
:= Fold_Lower
(Xref_Entity_Letters
(Ekind
(Ent
)));
1139 -- Special handling for access parameter
1141 if Ekind
(Etype
(XE
.Ent
)) = E_Anonymous_Access_Type
1142 and then Is_Formal
(XE
.Ent
)
1146 -- Special handling for Boolean
1148 elsif Ctyp
= 'e' and then Is_Boolean_Type
(Ent
) then
1153 -- Special handling for abstract types and operations.
1155 if Is_Abstract
(XE
.Ent
) then
1158 Ctyp
:= 'x'; -- abstract procedure
1160 elsif Ctyp
= 'V' then
1161 Ctyp
:= 'y'; -- abstract function
1163 elsif Ctyp
= 'R' then
1164 Ctyp
:= 'H'; -- abstract type
1168 -- Only output reference if interesting type of entity,
1169 -- and suppress self references, except for bodies that
1170 -- act as specs. Also suppress definitions of body formals
1171 -- (we only treat these as references, and the references
1172 -- were separately recorded).
1175 or else (XE
.Loc
= XE
.Def
1178 or else not Is_Subprogram
(XE
.Ent
)))
1179 or else (Is_Formal
(XE
.Ent
)
1180 and then Present
(Spec_Entity
(XE
.Ent
)))
1185 -- Start new Xref section if new xref unit
1187 if XE
.Eun
/= Curxu
then
1188 if Write_Info_Col
> 1 then
1193 Cursrc
:= Source_Text
(Source_Index
(Curxu
));
1195 Write_Info_Initiate
('X');
1196 Write_Info_Char
(' ');
1197 Write_Info_Nat
(Dependency_Num
(XE
.Eun
));
1198 Write_Info_Char
(' ');
1199 Write_Info_Name
(Reference_Name
(Source_Index
(XE
.Eun
)));
1202 -- Start new Entity line if new entity. Note that we
1203 -- consider two entities the same if they have the same
1204 -- name and source location. This causes entities in
1205 -- instantiations to be treated as though they referred
1212 (Name_Change
(XE
.Ent
) or else XE
.Def
/= Curdef
))
1217 Get_Unqualified_Name_String
(Chars
(XE
.Ent
));
1219 Curnam
(1 .. Curlen
) := Name_Buffer
(1 .. Curlen
);
1221 if Write_Info_Col
> 1 then
1225 -- Write column number information
1227 Write_Info_Nat
(Int
(Get_Logical_Line_Number
(XE
.Def
)));
1228 Write_Info_Char
(Ctyp
);
1229 Write_Info_Nat
(Int
(Get_Column_Number
(XE
.Def
)));
1231 -- Write level information
1233 Write_Level_Info
: declare
1234 function Is_Visible_Generic_Entity
1235 (E
: Entity_Id
) return Boolean;
1236 -- Check whether E is declared in the visible part
1237 -- of a generic package. For source navigation
1238 -- purposes, treat this as a visible entity.
1240 function Is_Private_Record_Component
1241 (E
: Entity_Id
) return Boolean;
1242 -- Check whether E is a non-inherited component of a
1243 -- private extension. Even if the enclosing record is
1244 -- public, we want to treat the component as private
1245 -- for navigation purposes.
1247 ---------------------------------
1248 -- Is_Private_Record_Component --
1249 ---------------------------------
1251 function Is_Private_Record_Component
1252 (E
: Entity_Id
) return Boolean
1254 S
: constant Entity_Id
:= Scope
(E
);
1257 Ekind
(E
) = E_Component
1258 and then Nkind
(Declaration_Node
(S
)) =
1259 N_Private_Extension_Declaration
1260 and then Original_Record_Component
(E
) = E
;
1261 end Is_Private_Record_Component
;
1263 -------------------------------
1264 -- Is_Visible_Generic_Entity --
1265 -------------------------------
1267 function Is_Visible_Generic_Entity
1268 (E
: Entity_Id
) return Boolean
1273 if Ekind
(Scope
(E
)) /= E_Generic_Package
then
1278 while Present
(Par
) loop
1280 Nkind
(Par
) = N_Generic_Package_Declaration
1282 -- Entity is a generic formal
1287 Nkind
(Parent
(Par
)) = N_Package_Specification
1290 Is_List_Member
(Par
)
1291 and then List_Containing
(Par
) =
1292 Visible_Declarations
(Parent
(Par
));
1294 Par
:= Parent
(Par
);
1299 end Is_Visible_Generic_Entity
;
1301 -- Start of processing for Write_Level_Info
1304 if Is_Hidden
(Curent
)
1305 or else Is_Private_Record_Component
(Curent
)
1307 Write_Info_Char
(' ');
1311 or else Is_Visible_Generic_Entity
(Curent
)
1313 Write_Info_Char
('*');
1316 Write_Info_Char
(' ');
1318 end Write_Level_Info
;
1320 -- Output entity name. We use the occurrence from the
1321 -- actual source program at the definition point
1323 P
:= Original_Location
(Sloc
(XE
.Ent
));
1325 -- Entity is character literal
1327 if Cursrc
(P
) = ''' then
1328 Write_Info_Char
(Cursrc
(P
));
1329 Write_Info_Char
(Cursrc
(P
+ 1));
1330 Write_Info_Char
(Cursrc
(P
+ 2));
1332 -- Entity is operator symbol
1334 elsif Cursrc
(P
) = '"' or else Cursrc
(P
) = '%' then
1335 Write_Info_Char
(Cursrc
(P
));
1340 Write_Info_Char
(Cursrc
(P2
));
1341 exit when Cursrc
(P2
) = Cursrc
(P
);
1344 -- Entity is identifier
1348 if Is_Start_Of_Wide_Char
(Cursrc
, P
) then
1349 Scan_Wide
(Cursrc
, P
, WC
, Err
);
1350 elsif not Identifier_Char
(Cursrc
(P
)) then
1358 Original_Location
(Sloc
(XE
.Ent
)) .. P
- 1
1360 Write_Info_Char
(Cursrc
(J
));
1364 -- See if we have a renaming reference
1366 if Is_Object
(XE
.Ent
)
1367 and then Present
(Renamed_Object
(XE
.Ent
))
1369 Rref
:= Renamed_Object
(XE
.Ent
);
1371 elsif Is_Overloadable
(XE
.Ent
)
1372 and then Nkind
(Parent
(Declaration_Node
(XE
.Ent
))) =
1373 N_Subprogram_Renaming_Declaration
1375 Rref
:= Name
(Parent
(Declaration_Node
(XE
.Ent
)));
1377 elsif Ekind
(XE
.Ent
) = E_Package
1378 and then Nkind
(Declaration_Node
(XE
.Ent
)) =
1379 N_Package_Renaming_Declaration
1381 Rref
:= Name
(Declaration_Node
(XE
.Ent
));
1387 if Present
(Rref
) then
1388 if Nkind
(Rref
) = N_Expanded_Name
then
1389 Rref
:= Selector_Name
(Rref
);
1392 if Nkind
(Rref
) /= N_Identifier
then
1397 -- Write out renaming reference if we have one
1399 if Present
(Rref
) then
1400 Write_Info_Char
('=');
1402 (Int
(Get_Logical_Line_Number
(Sloc
(Rref
))));
1403 Write_Info_Char
(':');
1405 (Int
(Get_Column_Number
(Sloc
(Rref
))));
1408 -- Indicate that the entity is in the unit
1409 -- of the current xref xection.
1413 -- See if we have a type reference and if so output
1415 Get_Type_Reference
(XE
.Ent
, Tref
, Left
, Right
);
1417 if Present
(Tref
) then
1419 -- Case of standard entity, output name
1421 if Sloc
(Tref
) = Standard_Location
then
1422 Write_Info_Char
(Left
);
1423 Write_Info_Name
(Chars
(Tref
));
1424 Write_Info_Char
(Right
);
1426 -- Case of source entity, output location
1429 Write_Info_Char
(Left
);
1430 Trunit
:= Get_Source_Unit
(Sloc
(Tref
));
1432 if Trunit
/= Curxu
then
1433 Write_Info_Nat
(Dependency_Num
(Trunit
));
1434 Write_Info_Char
('|');
1438 (Int
(Get_Logical_Line_Number
(Sloc
(Tref
))));
1441 Ent
: Entity_Id
:= Tref
;
1442 Kind
: constant Entity_Kind
:= Ekind
(Ent
);
1443 Ctyp
: Character := Xref_Entity_Letters
(Kind
);
1447 and then Present
(Full_View
(Ent
))
1449 Ent
:= Underlying_Type
(Ent
);
1451 if Present
(Ent
) then
1452 Ctyp
:= Xref_Entity_Letters
(Ekind
(Ent
));
1456 Write_Info_Char
(Ctyp
);
1460 (Int
(Get_Column_Number
(Sloc
(Tref
))));
1462 -- If the type comes from an instantiation,
1463 -- add the corresponding info.
1465 Output_Instantiation_Refs
(Sloc
(Tref
));
1466 Write_Info_Char
(Right
);
1470 -- End of processing for entity output
1472 Crloc
:= No_Location
;
1475 -- Output the reference
1477 if XE
.Loc
/= No_Location
1478 and then XE
.Loc
/= Crloc
1482 -- Start continuation if line full, else blank
1484 if Write_Info_Col
> 72 then
1486 Write_Info_Initiate
('.');
1489 Write_Info_Char
(' ');
1491 -- Output file number if changed
1493 if XE
.Lun
/= Curru
then
1495 Write_Info_Nat
(Dependency_Num
(Curru
));
1496 Write_Info_Char
('|');
1499 Write_Info_Nat
(Int
(Get_Logical_Line_Number
(XE
.Loc
)));
1500 Write_Info_Char
(XE
.Typ
);
1502 if Is_Overloadable
(XE
.Ent
)
1503 and then Is_Imported
(XE
.Ent
)
1504 and then XE
.Typ
= 'b'
1506 Output_Import_Export_Info
(XE
.Ent
);
1509 Write_Info_Nat
(Int
(Get_Column_Number
(XE
.Loc
)));
1511 Output_Instantiation_Refs
(Sloc
(XE
.Ent
));
1522 end Output_References
;