1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2007, 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 Elists; use Elists;
29 with Errout; use Errout;
30 with Lib.Util; use Lib.Util;
31 with Nlists; use Nlists;
33 with Restrict; use Restrict;
34 with Rident; use Rident;
36 with Sem_Prag; use Sem_Prag;
37 with Sem_Util; use Sem_Util;
38 with Sem_Warn; use Sem_Warn;
39 with Sinfo; use Sinfo;
40 with Sinput; use Sinput;
41 with Snames; use Snames;
42 with Stringt; use Stringt;
43 with Stand; use Stand;
44 with Table; use Table;
45 with Widechar; use Widechar;
47 with GNAT.Heap_Sort_A;
49 package body Lib.Xref is
55 -- The Xref table is used to record references. The Loc field is set
56 -- to No_Location for a definition entry.
58 subtype Xref_Entry_Number is Int;
60 type Xref_Entry is record
62 -- Entity referenced (E parameter to Generate_Reference)
65 -- Original source location for entity being referenced. Note that these
66 -- values are used only during the output process, they are not set when
67 -- the entries are originally built. This is because private entities
68 -- can be swapped when the initial call is made.
71 -- Location of reference (Original_Location (Sloc field of N parameter
72 -- to Generate_Reference). Set to No_Location for the case of a
73 -- defining occurrence.
76 -- Reference type (Typ param to Generate_Reference)
78 Eun : Unit_Number_Type;
79 -- Unit number corresponding to Ent
81 Lun : Unit_Number_Type;
82 -- Unit number corresponding to Loc. Value is undefined and not
83 -- referenced if Loc is set to No_Location.
87 package Xrefs is new Table.Table (
88 Table_Component_Type => Xref_Entry,
89 Table_Index_Type => Xref_Entry_Number,
91 Table_Initial => Alloc.Xrefs_Initial,
92 Table_Increment => Alloc.Xrefs_Increment,
93 Table_Name => "Xrefs");
95 -------------------------
96 -- Generate_Definition --
97 -------------------------
99 procedure Generate_Definition (E : Entity_Id) is
104 pragma Assert (Nkind (E) in N_Entity);
106 -- Note that we do not test Xref_Entity_Letters here. It is too early
107 -- to do so, since we are often called before the entity is fully
108 -- constructed, so that the Ekind is still E_Void.
112 -- Definition must come from source
114 -- We make an exception for subprogram child units that have no spec.
115 -- For these we generate a subprogram declaration for library use,
116 -- and the corresponding entity does not come from source.
117 -- Nevertheless, all references will be attached to it and we have
118 -- to treat is as coming from user code.
120 and then (Comes_From_Source (E) or else Is_Child_Unit (E))
122 -- And must have a reasonable source location that is not
123 -- within an instance (all entities in instances are ignored)
125 and then Sloc (E) > No_Location
126 and then Instantiation_Location (Sloc (E)) = No_Location
128 -- And must be a non-internal name from the main source unit
130 and then In_Extended_Main_Source_Unit (E)
131 and then not Is_Internal_Name (Chars (E))
133 Xrefs.Increment_Last;
135 Loc := Original_Location (Sloc (E));
137 Xrefs.Table (Indx).Ent := E;
138 Xrefs.Table (Indx).Def := No_Location;
139 Xrefs.Table (Indx).Loc := No_Location;
140 Xrefs.Table (Indx).Typ := ' ';
141 Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
142 Xrefs.Table (Indx).Lun := No_Unit;
143 Set_Has_Xref_Entry (E);
145 if In_Inlined_Body then
149 end Generate_Definition;
151 ---------------------------------
152 -- Generate_Operator_Reference --
153 ---------------------------------
155 procedure Generate_Operator_Reference
160 if not In_Extended_Main_Source_Unit (N) then
164 -- If the operator is not a Standard operator, then we generate a real
165 -- reference to the user defined operator.
167 if Sloc (Entity (N)) /= Standard_Location then
168 Generate_Reference (Entity (N), N);
170 -- A reference to an implicit inequality operator is a also a
171 -- reference to the user-defined equality.
173 if Nkind (N) = N_Op_Ne
174 and then not Comes_From_Source (Entity (N))
175 and then Present (Corresponding_Equality (Entity (N)))
177 Generate_Reference (Corresponding_Equality (Entity (N)), N);
180 -- For the case of Standard operators, we mark the result type as
181 -- referenced. This ensures that in the case where we are using a
182 -- derived operator, we mark an entity of the unit that implicitly
183 -- defines this operator as used. Otherwise we may think that no entity
184 -- of the unit is used. The actual entity marked as referenced is the
185 -- first subtype, which is the relevant user defined entity.
187 -- Note: we only do this for operators that come from source. The
188 -- generated code sometimes reaches for entities that do not need to be
189 -- explicitly visible (for example, when we expand the code for
190 -- comparing two record objects, the fields of the record may not be
193 elsif Comes_From_Source (N) then
194 Set_Referenced (First_Subtype (T));
196 end Generate_Operator_Reference;
198 ------------------------
199 -- Generate_Reference --
200 ------------------------
202 procedure Generate_Reference
205 Typ : Character := 'r';
206 Set_Ref : Boolean := True;
207 Force : Boolean := False)
215 function Is_On_LHS (Node : Node_Id) return Boolean;
216 -- Used to check if a node is on the left hand side of an assignment.
217 -- The following cases are handled:
219 -- Variable Node is a direct descendant of an assignment statement.
221 -- Prefix Of an indexed or selected component that is present in a
222 -- subtree rooted by an assignment statement. There is no
223 -- restriction of nesting of components, thus cases such as
224 -- A.B (C).D are handled properly.
225 -- However a prefix of a dereference (either implicit or
226 -- explicit) is never considered as on a LHS.
232 -- ??? There are several routines here and there that perform a similar
233 -- (but subtly different) computation, which should be factored:
235 -- Sem_Util.May_Be_Lvalue
236 -- Sem_Util.Known_To_Be_Assigned
237 -- Exp_Ch2.Expand_Entry_Parameter.In_Assignment_Context
239 function Is_On_LHS (Node : Node_Id) return Boolean is
243 -- Only identifiers are considered, is this necessary???
245 if Nkind (N) /= N_Identifier then
249 -- Reach the assignment statement subtree root. In the case of a
250 -- variable being a direct descendant of an assignment statement,
251 -- the loop is skiped.
253 while Nkind (Parent (N)) /= N_Assignment_Statement loop
255 -- Check whether the parent is a component and the current node
256 -- is its prefix, but return False if the current node has an
257 -- access type, as in that case the selected or indexed component
258 -- is an implicit dereference, and the LHS is the designated
259 -- object, not the access object.
261 -- ??? case of a slice assignment?
263 -- ??? Note that in some cases this is called too early
264 -- (see comments in Sem_Ch8.Find_Direct_Name), at a point where
265 -- the tree is not fully typed yet. In that case we may lack
266 -- an Etype for N, and we must disable the check for an implicit
267 -- dereference. If the dereference is on an LHS, this causes a
270 if (Nkind (Parent (N)) = N_Selected_Component
272 Nkind (Parent (N)) = N_Indexed_Component)
273 and then Prefix (Parent (N)) = N
274 and then not (Present (Etype (N))
276 Is_Access_Type (Etype (N)))
284 -- Parent (N) is assignment statement, check whether N is its name
286 return Name (Parent (N)) = N;
289 -- Start of processing for Generate_Reference
292 pragma Assert (Nkind (E) in N_Entity);
294 -- Check for obsolescent reference to package ASCII. GNAT treats this
295 -- element of annex J specially since in practice, programs make a lot
296 -- of use of this feature, so we don't include it in the set of features
297 -- diagnosed when Warn_On_Obsolescent_Features mode is set. However we
298 -- are required to note it as a violation of the RM defined restriction.
300 if E = Standard_ASCII then
301 Check_Restriction (No_Obsolescent_Features, N);
304 -- Check for reference to entity marked with Is_Obsolescent
306 -- Note that we always allow obsolescent references in the compiler
307 -- itself and the run time, since we assume that we know what we are
308 -- doing in such cases. For example the calls in Ada.Characters.Handling
309 -- to its own obsolescent subprograms are just fine.
311 -- In any case we do not generate warnings within the extended source
312 -- unit of the entity in question, since we assume the source unit
313 -- itself knows what is going on (and for sure we do not want silly
314 -- warnings, e.g. on the end line of an obsolescent procedure body).
316 if Is_Obsolescent (E)
317 and then not GNAT_Mode
318 and then not In_Extended_Main_Source_Unit (E)
320 Check_Restriction (No_Obsolescent_Features, N);
322 if Warn_On_Obsolescent_Feature then
323 Output_Obsolescent_Entity_Warnings (N, E);
327 -- Warn if reference to Ada 2005 entity not in Ada 2005 mode. We only
328 -- detect real explicit references (modifications and references).
330 if Comes_From_Source (N)
331 and then Is_Ada_2005_Only (E)
332 and then Ada_Version < Ada_05
333 and then Warn_On_Ada_2005_Compatibility
334 and then (Typ = 'm' or else Typ = 'r')
336 Error_Msg_NE ("& is only defined in Ada 2005?", N, E);
339 -- Never collect references if not in main source unit. However, we omit
340 -- this test if Typ is 'e' or 'k', since these entries are structural,
341 -- and it is useful to have them in units that reference packages as
342 -- well as units that define packages. We also omit the test for the
343 -- case of 'p' since we want to include inherited primitive operations
344 -- from other packages.
346 -- We also omit this test is this is a body reference for a subprogram
347 -- instantiation. In this case the reference is to the generic body,
348 -- which clearly need not be in the main unit containing the instance.
349 -- For the same reason we accept an implicit reference generated for
350 -- a default in an instance.
352 if not In_Extended_Main_Source_Unit (N) then
357 or else (Typ = 'b' and then Is_Generic_Instance (E))
365 -- For reference type p, the entity must be in main source unit
367 if Typ = 'p' and then not In_Extended_Main_Source_Unit (E) then
371 -- Unless the reference is forced, we ignore references where the
372 -- reference itself does not come from source.
374 if not Force and then not Comes_From_Source (N) then
378 -- Deal with setting entity as referenced, unless suppressed. Note that
379 -- we still do Set_Referenced on entities that do not come from source.
380 -- This situation arises when we have a source reference to a derived
381 -- operation, where the derived operation itself does not come from
382 -- source, but we still want to mark it as referenced, since we really
383 -- are referencing an entity in the corresponding package (this avoids
384 -- wrong complaints that the package contains no referenced entities).
388 -- For a variable that appears on the left side of an assignment
389 -- statement, we set the Referenced_As_LHS flag since this is indeed
390 -- a left hand side. We also set the Referenced_As_LHS flag of a
391 -- prefix of selected or indexed component.
393 if (Ekind (E) = E_Variable or else Is_Formal (E))
394 and then Is_On_LHS (N)
396 Set_Referenced_As_LHS (E);
398 -- Check for a reference in a pragma that should not count as a
399 -- making the variable referenced for warning purposes.
401 elsif Is_Non_Significant_Pragma_Reference (N) then
404 -- A reference in an attribute definition clause does not count as a
405 -- reference except for the case of Address. The reason that 'Address
406 -- is an exception is that it creates an alias through which the
407 -- variable may be referenced.
409 elsif Nkind (Parent (N)) = N_Attribute_Definition_Clause
410 and then Chars (Parent (N)) /= Name_Address
411 and then N = Name (Parent (N))
415 -- Constant completion does not count as a reference
418 and then Ekind (E) = E_Constant
422 -- Record representation clause does not count as a reference
424 elsif Nkind (N) = N_Identifier
425 and then Nkind (Parent (N)) = N_Record_Representation_Clause
429 -- Discriminants do not need to produce a reference to record type
432 and then Nkind (Parent (N)) = N_Discriminant_Specification
436 -- Any other occurrence counts as referencing the entity
441 if Ekind (E) = E_Variable then
442 Set_Last_Assignment (E, Empty);
446 -- Check for pragma Unreferenced given and reference is within
447 -- this source unit (occasion for possible warning to be issued).
449 if Has_Pragma_Unreferenced (E)
450 and then In_Same_Extended_Unit (E, N)
452 -- A reference as a named parameter in a call does not count
453 -- as a violation of pragma Unreferenced for this purpose...
455 if Nkind (N) = N_Identifier
456 and then Nkind (Parent (N)) = N_Parameter_Association
457 and then Selector_Name (Parent (N)) = N
461 -- ... Neither does a reference to a variable on the left side
464 elsif Is_On_LHS (N) then
467 -- For entry formals, we want to place the warning message on the
468 -- corresponding entity in the accept statement. The current scope
469 -- is the body of the accept, so we find the formal whose name
470 -- matches that of the entry formal (there is no link between the
471 -- two entities, and the one in the accept statement is only used
472 -- for conformance checking).
474 elsif Ekind (Scope (E)) = E_Entry then
479 BE := First_Entity (Current_Scope);
480 while Present (BE) loop
481 if Chars (BE) = Chars (E) then
483 ("?pragma Unreferenced given for&", N, BE);
491 -- Here we issue the warning, since this is a real reference
494 Error_Msg_NE ("?pragma Unreferenced given for&", N, E);
498 -- If this is a subprogram instance, mark as well the internal
499 -- subprogram in the wrapper package, which may be a visible
502 if Is_Overloadable (E)
503 and then Is_Generic_Instance (E)
504 and then Present (Alias (E))
506 Set_Referenced (Alias (E));
510 -- Generate reference if all conditions are met:
513 -- Cross referencing must be active
517 -- The entity must be one for which we collect references
519 and then Xref_Entity_Letters (Ekind (E)) /= ' '
521 -- Both Sloc values must be set to something sensible
523 and then Sloc (E) > No_Location
524 and then Sloc (N) > No_Location
526 -- We ignore references from within an instance
528 and then Instantiation_Location (Sloc (N)) = No_Location
530 -- Ignore dummy references
534 if Nkind (N) = N_Identifier
536 Nkind (N) = N_Defining_Identifier
540 Nkind (N) = N_Defining_Operator_Symbol
542 Nkind (N) = N_Operator_Symbol
544 (Nkind (N) = N_Character_Literal
545 and then Sloc (Entity (N)) /= Standard_Location)
547 Nkind (N) = N_Defining_Character_Literal
551 elsif Nkind (N) = N_Expanded_Name
553 Nkind (N) = N_Selected_Component
555 Nod := Selector_Name (N);
561 -- Normal case of source entity comes from source
563 if Comes_From_Source (E) then
566 -- Entity does not come from source, but is a derived subprogram and
567 -- the derived subprogram comes from source (after one or more
568 -- derivations) in which case the reference is to parent subprogram.
570 elsif Is_Overloadable (E)
571 and then Present (Alias (E))
574 while not Comes_From_Source (Ent) loop
575 if No (Alias (Ent)) then
582 -- The internally created defining entity for a child subprogram
583 -- that has no previous spec has valid references.
585 elsif Is_Overloadable (E)
586 and then Is_Child_Unit (E)
590 -- Record components of discriminated subtypes or derived types must
591 -- be treated as references to the original component.
593 elsif Ekind (E) = E_Component
594 and then Comes_From_Source (Original_Record_Component (E))
596 Ent := Original_Record_Component (E);
598 -- Ignore reference to any other entity that is not from source
604 -- Record reference to entity
606 Ref := Original_Location (Sloc (Nod));
607 Def := Original_Location (Sloc (Ent));
609 Xrefs.Increment_Last;
612 Xrefs.Table (Indx).Loc := Ref;
614 -- Overriding operations are marked with 'P'
617 and then Is_Subprogram (N)
618 and then Is_Overriding_Operation (N)
620 Xrefs.Table (Indx).Typ := 'P';
622 Xrefs.Table (Indx).Typ := Typ;
625 Xrefs.Table (Indx).Eun := Get_Source_Unit (Def);
626 Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref);
627 Xrefs.Table (Indx).Ent := Ent;
628 Set_Has_Xref_Entry (Ent);
630 end Generate_Reference;
632 -----------------------------------
633 -- Generate_Reference_To_Formals --
634 -----------------------------------
636 procedure Generate_Reference_To_Formals (E : Entity_Id) is
640 if Is_Generic_Subprogram (E) then
641 Formal := First_Entity (E);
643 while Present (Formal)
644 and then not Is_Formal (Formal)
646 Next_Entity (Formal);
650 Formal := First_Formal (E);
653 while Present (Formal) loop
654 if Ekind (Formal) = E_In_Parameter then
656 if Nkind (Parameter_Type (Parent (Formal)))
657 = N_Access_Definition
659 Generate_Reference (E, Formal, '^', False);
661 Generate_Reference (E, Formal, '>', False);
664 elsif Ekind (Formal) = E_In_Out_Parameter then
665 Generate_Reference (E, Formal, '=', False);
668 Generate_Reference (E, Formal, '<', False);
671 Next_Formal (Formal);
673 end Generate_Reference_To_Formals;
675 -------------------------------------------
676 -- Generate_Reference_To_Generic_Formals --
677 -------------------------------------------
679 procedure Generate_Reference_To_Generic_Formals (E : Entity_Id) is
683 Formal := First_Entity (E);
684 while Present (Formal) loop
685 if Comes_From_Source (Formal) then
686 Generate_Reference (E, Formal, 'z', False);
689 Next_Entity (Formal);
691 end Generate_Reference_To_Generic_Formals;
697 procedure Initialize is
702 -----------------------
703 -- Output_References --
704 -----------------------
706 procedure Output_References is
708 procedure Get_Type_Reference
710 Tref : out Entity_Id;
711 Left : out Character;
712 Right : out Character);
713 -- Given an Entity_Id Ent, determines whether a type reference is
714 -- required. If so, Tref is set to the entity for the type reference
715 -- and Left and Right are set to the left/right brackets to be output
716 -- for the reference. If no type reference is required, then Tref is
717 -- set to Empty, and Left/Right are set to space.
719 procedure Output_Import_Export_Info (Ent : Entity_Id);
720 -- Ouput language and external name information for an interfaced
721 -- entity, using the format <language, external_name>,
723 ------------------------
724 -- Get_Type_Reference --
725 ------------------------
727 procedure Get_Type_Reference
729 Tref : out Entity_Id;
730 Left : out Character;
731 Right : out Character)
736 -- See if we have a type reference
745 -- Processing for types
747 if Is_Type (Tref) then
751 if Base_Type (Tref) = Tref then
753 -- If derived, then get first subtype
755 if Tref /= Etype (Tref) then
756 Tref := First_Subtype (Etype (Tref));
758 -- Set brackets for derived type, but don't override
759 -- pointer case since the fact that something is a
760 -- pointer is more important.
767 -- If non-derived ptr, get directly designated type.
768 -- If the type has a full view, all references are on the
769 -- partial view, that is seen first.
771 elsif Is_Access_Type (Tref) then
772 Tref := Directly_Designated_Type (Tref);
776 elsif Is_Private_Type (Tref)
777 and then Present (Full_View (Tref))
779 if Is_Access_Type (Full_View (Tref)) then
780 Tref := Directly_Designated_Type (Full_View (Tref));
784 -- If the full view is an array type, we also retrieve
785 -- the corresponding component type, because the ali
786 -- entry already indicates that this is an array.
788 elsif Is_Array_Type (Full_View (Tref)) then
789 Tref := Component_Type (Full_View (Tref));
794 -- If non-derived array, get component type. Skip component
795 -- type for case of String or Wide_String, saves worthwhile
798 elsif Is_Array_Type (Tref)
799 and then Tref /= Standard_String
800 and then Tref /= Standard_Wide_String
802 Tref := Component_Type (Tref);
806 -- For other non-derived base types, nothing
812 -- For a subtype, go to ancestor subtype
815 Tref := Ancestor_Subtype (Tref);
817 -- If no ancestor subtype, go to base type
820 Tref := Base_Type (Sav);
824 -- For objects, functions, enum literals, just get type from
827 elsif Is_Object (Tref)
828 or else Ekind (Tref) = E_Enumeration_Literal
829 or else Ekind (Tref) = E_Function
830 or else Ekind (Tref) = E_Operator
832 Tref := Etype (Tref);
834 -- For anything else, exit
840 -- Exit if no type reference, or we are stuck in some loop trying
841 -- to find the type reference, or if the type is standard void
842 -- type (the latter is an implementation artifact that should not
843 -- show up in the generated cross-references).
847 or else Tref = Standard_Void_Type;
849 -- If we have a usable type reference, return, otherwise keep
850 -- looking for something useful (we are looking for something
851 -- that either comes from source or standard)
853 if Sloc (Tref) = Standard_Location
854 or else Comes_From_Source (Tref)
856 -- If the reference is a subtype created for a generic actual,
857 -- go actual directly, the inner subtype is not user visible.
859 if Nkind (Parent (Tref)) = N_Subtype_Declaration
860 and then not Comes_From_Source (Parent (Tref))
862 (Is_Wrapper_Package (Scope (Tref))
863 or else Is_Generic_Instance (Scope (Tref)))
865 Tref := First_Subtype (Base_Type (Tref));
872 -- If we fall through the loop, no type reference
877 end Get_Type_Reference;
879 -------------------------------
880 -- Output_Import_Export_Info --
881 -------------------------------
883 procedure Output_Import_Export_Info (Ent : Entity_Id) is
884 Language_Name : Name_Id;
885 Conv : constant Convention_Id := Convention (Ent);
888 -- Generate language name from convention
890 if Conv = Convention_C then
891 Language_Name := Name_C;
893 elsif Conv = Convention_CPP then
894 Language_Name := Name_CPP;
896 elsif Conv = Convention_Ada then
897 Language_Name := Name_Ada;
900 -- For the moment we ignore all other cases ???
905 Write_Info_Char ('<');
906 Get_Unqualified_Name_String (Language_Name);
908 for J in 1 .. Name_Len loop
909 Write_Info_Char (Name_Buffer (J));
912 if Present (Interface_Name (Ent)) then
913 Write_Info_Char (',');
914 String_To_Name_Buffer (Strval (Interface_Name (Ent)));
916 for J in 1 .. Name_Len loop
917 Write_Info_Char (Name_Buffer (J));
921 Write_Info_Char ('>');
922 end Output_Import_Export_Info;
924 -- Start of processing for Output_References
927 if not Opt.Xref_Active then
931 -- Before we go ahead and output the references we have a problem
932 -- that needs dealing with. So far we have captured things that are
933 -- definitely referenced by the main unit, or defined in the main
934 -- unit. That's because we don't want to clutter up the ali file
935 -- for this unit with definition lines for entities in other units
936 -- that are not referenced.
938 -- But there is a glitch. We may reference an entity in another unit,
939 -- and it may have a type reference to an entity that is not directly
940 -- referenced in the main unit, which may mean that there is no xref
941 -- entry for this entity yet in the list of references.
943 -- If we don't do something about this, we will end with an orphan type
944 -- reference, i.e. it will point to an entity that does not appear
945 -- within the generated references in the ali file. That is not good for
946 -- tools using the xref information.
948 -- To fix this, we go through the references adding definition entries
949 -- for any unreferenced entities that can be referenced in a type
950 -- reference. There is a recursion problem here, and that is dealt with
951 -- by making sure that this traversal also traverses any entries that
952 -- get added by the traversal.
954 Handle_Orphan_Type_References : declare
962 procedure New_Entry (E : Entity_Id);
963 -- Make an additional entry into the Xref table for a type entity
964 -- that is related to the current entity (parent, type ancestor,
965 -- progenitor, etc.).
971 procedure New_Entry (E : Entity_Id) is
974 and then not Has_Xref_Entry (E)
975 and then Sloc (E) > No_Location
977 Xrefs.Increment_Last;
979 Loc := Original_Location (Sloc (E));
980 Xrefs.Table (Indx).Ent := E;
981 Xrefs.Table (Indx).Loc := No_Location;
982 Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
983 Xrefs.Table (Indx).Lun := No_Unit;
984 Set_Has_Xref_Entry (E);
988 -- Start of processing for Handle_Orphan_Type_References
991 -- Note that this is not a for loop for a very good reason. The
992 -- processing of items in the table can add new items to the table,
993 -- and they must be processed as well.
996 while J <= Xrefs.Last loop
997 Ent := Xrefs.Table (J).Ent;
998 Get_Type_Reference (Ent, Tref, L, R);
1001 and then not Has_Xref_Entry (Tref)
1002 and then Sloc (Tref) > No_Location
1006 if Is_Record_Type (Ent)
1007 and then Present (Abstract_Interfaces (Ent))
1009 -- Add an entry for each one of the given interfaces
1010 -- implemented by type Ent.
1016 Elmt := First_Elmt (Abstract_Interfaces (Ent));
1017 while Present (Elmt) loop
1018 New_Entry (Node (Elmt));
1025 -- Collect inherited primitive operations that may be declared in
1026 -- another unit and have no visible reference in the current one.
1029 and then Is_Tagged_Type (Ent)
1030 and then Is_Derived_Type (Ent)
1031 and then Ent = Base_Type (Ent)
1032 and then In_Extended_Main_Source_Unit (Ent)
1035 Op_List : constant Elist_Id := Primitive_Operations (Ent);
1039 function Parent_Op (E : Entity_Id) return Entity_Id;
1040 -- Find original operation, which may be inherited through
1041 -- several derivations.
1043 function Parent_Op (E : Entity_Id) return Entity_Id is
1044 Orig_Op : constant Entity_Id := Alias (E);
1046 if No (Orig_Op) then
1048 elsif not Comes_From_Source (E)
1049 and then not Has_Xref_Entry (Orig_Op)
1050 and then Comes_From_Source (Orig_Op)
1054 return Parent_Op (Orig_Op);
1059 Op := First_Elmt (Op_List);
1060 while Present (Op) loop
1061 Prim := Parent_Op (Node (Op));
1063 if Present (Prim) then
1064 Xrefs.Increment_Last;
1066 Loc := Original_Location (Sloc (Prim));
1067 Xrefs.Table (Indx).Ent := Prim;
1068 Xrefs.Table (Indx).Loc := No_Location;
1069 Xrefs.Table (Indx).Eun :=
1070 Get_Source_Unit (Sloc (Prim));
1071 Xrefs.Table (Indx).Lun := No_Unit;
1072 Set_Has_Xref_Entry (Prim);
1082 end Handle_Orphan_Type_References;
1084 -- Now we have all the references, including those for any embedded
1085 -- type references, so we can sort them, and output them.
1087 Output_Refs : declare
1089 Nrefs : Nat := Xrefs.Last;
1090 -- Number of references in table. This value may get reset (reduced)
1091 -- when we eliminate duplicate reference entries.
1093 Rnums : array (0 .. Nrefs) of Nat;
1094 -- This array contains numbers of references in the Xrefs table.
1095 -- This list is sorted in output order. The extra 0'th entry is
1096 -- convenient for the call to sort. When we sort the table, we
1097 -- move the entries in Rnums around, but we do not move the
1098 -- original table entries.
1100 Curxu : Unit_Number_Type;
1101 -- Current xref unit
1103 Curru : Unit_Number_Type;
1104 -- Current reference unit for one entity
1106 Cursrc : Source_Buffer_Ptr;
1107 -- Current xref unit source text
1112 Curnam : String (1 .. Name_Buffer'Length);
1114 -- Simple name and length of current entity
1116 Curdef : Source_Ptr;
1117 -- Original source location for current entity
1120 -- Current reference location
1123 -- Entity type character
1129 -- Renaming reference
1131 Trunit : Unit_Number_Type;
1132 -- Unit number for type reference
1134 function Lt (Op1, Op2 : Natural) return Boolean;
1135 -- Comparison function for Sort call
1137 function Name_Change (X : Entity_Id) return Boolean;
1138 -- Determines if entity X has a different simple name from Curent
1140 procedure Move (From : Natural; To : Natural);
1141 -- Move procedure for Sort call
1147 function Lt (Op1, Op2 : Natural) return Boolean is
1148 T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
1149 T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
1152 -- First test: if entity is in different unit, sort by unit
1154 if T1.Eun /= T2.Eun then
1155 return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun);
1157 -- Second test: within same unit, sort by entity Sloc
1159 elsif T1.Def /= T2.Def then
1160 return T1.Def < T2.Def;
1162 -- Third test: sort definitions ahead of references
1164 elsif T1.Loc = No_Location then
1167 elsif T2.Loc = No_Location then
1170 -- Fourth test: for same entity, sort by reference location unit
1172 elsif T1.Lun /= T2.Lun then
1173 return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
1175 -- Fifth test: order of location within referencing unit
1177 elsif T1.Loc /= T2.Loc then
1178 return T1.Loc < T2.Loc;
1180 -- Finally, for two locations at the same address, we prefer
1181 -- the one that does NOT have the type 'r' so that a modification
1182 -- or extension takes preference, when there are more than one
1183 -- reference at the same location.
1186 return T2.Typ = 'r';
1194 procedure Move (From : Natural; To : Natural) is
1196 Rnums (Nat (To)) := Rnums (Nat (From));
1203 -- Why a string comparison here??? Why not compare Name_Id values???
1205 function Name_Change (X : Entity_Id) return Boolean is
1207 Get_Unqualified_Name_String (Chars (X));
1209 if Name_Len /= Curlen then
1213 return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen);
1217 -- Start of processing for Output_Refs
1220 -- Capture the definition Sloc values. We delay doing this till now,
1221 -- since at the time the reference or definition is made, private
1222 -- types may be swapped, and the Sloc value may be incorrect. We
1223 -- also set up the pointer vector for the sort.
1225 for J in 1 .. Nrefs loop
1227 Xrefs.Table (J).Def :=
1228 Original_Location (Sloc (Xrefs.Table (J).Ent));
1231 -- Sort the references
1233 GNAT.Heap_Sort_A.Sort
1235 Move'Unrestricted_Access,
1236 Lt'Unrestricted_Access);
1238 -- Eliminate duplicate entries
1241 NR : constant Nat := Nrefs;
1244 -- We need this test for NR because if we force ALI file
1245 -- generation in case of errors detected, it may be the case
1246 -- that Nrefs is 0, so we should not reset it here
1251 for J in 2 .. NR loop
1252 if Xrefs.Table (Rnums (J)) /=
1253 Xrefs.Table (Rnums (Nrefs))
1256 Rnums (Nrefs) := Rnums (J);
1262 -- Initialize loop through references
1266 Curdef := No_Location;
1268 Crloc := No_Location;
1270 -- Loop to output references
1272 for Refno in 1 .. Nrefs loop
1273 Output_One_Ref : declare
1279 XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
1280 -- The current entry to be accessed
1283 -- Used to index into source buffer to get entity name
1287 -- Used for {} or <> or () for type reference
1289 procedure Check_Type_Reference
1291 List_Interface : Boolean);
1292 -- Find whether there is a meaningful type reference for
1293 -- Ent, and display it accordingly. If List_Interface is
1294 -- true, then Ent is a progenitor interface of the current
1295 -- type entity being listed. In that case list it as is,
1296 -- without looking for a type reference for it.
1298 procedure Output_Instantiation_Refs (Loc : Source_Ptr);
1299 -- Recursive procedure to output instantiation references for
1300 -- the given source ptr in [file|line[...]] form. No output
1301 -- if the given location is not a generic template reference.
1303 procedure Output_Overridden_Op (Old_E : Entity_Id);
1304 -- For a subprogram that is overriding, display information
1305 -- about the inherited operation that it overrides.
1307 --------------------------
1308 -- Check_Type_Reference --
1309 --------------------------
1311 procedure Check_Type_Reference
1313 List_Interface : Boolean)
1316 if List_Interface then
1318 -- This is a progenitor interface of the type for which
1319 -- xref information is being generated.
1326 Get_Type_Reference (Ent, Tref, Left, Right);
1329 if Present (Tref) then
1331 -- Case of standard entity, output name
1333 if Sloc (Tref) = Standard_Location then
1334 Write_Info_Char (Left);
1335 Write_Info_Name (Chars (Tref));
1336 Write_Info_Char (Right);
1338 -- Case of source entity, output location
1341 Write_Info_Char (Left);
1342 Trunit := Get_Source_Unit (Sloc (Tref));
1344 if Trunit /= Curxu then
1345 Write_Info_Nat (Dependency_Num (Trunit));
1346 Write_Info_Char ('|');
1350 (Int (Get_Logical_Line_Number (Sloc (Tref))));
1353 Ent : Entity_Id := Tref;
1354 Kind : constant Entity_Kind := Ekind (Ent);
1355 Ctyp : Character := Xref_Entity_Letters (Kind);
1359 and then Present (Full_View (Ent))
1361 Ent := Underlying_Type (Ent);
1363 if Present (Ent) then
1364 Ctyp := Xref_Entity_Letters (Ekind (Ent));
1368 Write_Info_Char (Ctyp);
1372 (Int (Get_Column_Number (Sloc (Tref))));
1374 -- If the type comes from an instantiation, add the
1375 -- corresponding info.
1377 Output_Instantiation_Refs (Sloc (Tref));
1378 Write_Info_Char (Right);
1381 end Check_Type_Reference;
1383 -------------------------------
1384 -- Output_Instantiation_Refs --
1385 -------------------------------
1387 procedure Output_Instantiation_Refs (Loc : Source_Ptr) is
1388 Iloc : constant Source_Ptr := Instantiation_Location (Loc);
1389 Lun : Unit_Number_Type;
1390 Cu : constant Unit_Number_Type := Curru;
1393 -- Nothing to do if this is not an instantiation
1395 if Iloc = No_Location then
1399 -- Output instantiation reference
1401 Write_Info_Char ('[');
1402 Lun := Get_Source_Unit (Iloc);
1404 if Lun /= Curru then
1406 Write_Info_Nat (Dependency_Num (Curru));
1407 Write_Info_Char ('|');
1410 Write_Info_Nat (Int (Get_Logical_Line_Number (Iloc)));
1412 -- Recursive call to get nested instantiations
1414 Output_Instantiation_Refs (Iloc);
1416 -- Output final ] after call to get proper nesting
1418 Write_Info_Char (']');
1421 end Output_Instantiation_Refs;
1423 --------------------------
1424 -- Output_Overridden_Op --
1425 --------------------------
1427 procedure Output_Overridden_Op (Old_E : Entity_Id) is
1430 and then Sloc (Old_E) /= Standard_Location
1433 Loc : constant Source_Ptr := Sloc (Old_E);
1434 Par_Unit : constant Unit_Number_Type :=
1435 Get_Source_Unit (Loc);
1437 Write_Info_Char ('<');
1439 if Par_Unit /= Curxu then
1440 Write_Info_Nat (Dependency_Num (Par_Unit));
1441 Write_Info_Char ('|');
1444 Write_Info_Nat (Int (Get_Logical_Line_Number (Loc)));
1445 Write_Info_Char ('p');
1446 Write_Info_Nat (Int (Get_Column_Number (Loc)));
1447 Write_Info_Char ('>');
1450 end Output_Overridden_Op;
1452 -- Start of processing for Output_One_Ref
1456 Ctyp := Xref_Entity_Letters (Ekind (Ent));
1458 -- Skip reference if it is the only reference to an entity,
1459 -- and it is an END line reference, and the entity is not in
1460 -- the current extended source. This prevents junk entries
1461 -- consisting only of packages with END lines, where no
1462 -- entity from the package is actually referenced.
1465 and then Ent /= Curent
1466 and then (Refno = Nrefs or else
1467 Ent /= Xrefs.Table (Rnums (Refno + 1)).Ent)
1469 not In_Extended_Main_Source_Unit (Ent)
1474 -- For private type, get full view type
1477 and then Present (Full_View (XE.Ent))
1479 Ent := Underlying_Type (Ent);
1481 if Present (Ent) then
1482 Ctyp := Xref_Entity_Letters (Ekind (Ent));
1486 -- Special exception for Boolean
1488 if Ctyp = 'E' and then Is_Boolean_Type (Ent) then
1492 -- For variable reference, get corresponding type
1495 Ent := Etype (XE.Ent);
1496 Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
1498 -- If variable is private type, get full view type
1501 and then Present (Full_View (Etype (XE.Ent)))
1503 Ent := Underlying_Type (Etype (XE.Ent));
1505 if Present (Ent) then
1506 Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
1509 elsif Is_Generic_Type (Ent) then
1511 -- If the type of the entity is a generic private type,
1512 -- there is no usable full view, so retain the indication
1513 -- that this is an object.
1518 -- Special handling for access parameter
1521 K : constant Entity_Kind := Ekind (Etype (XE.Ent));
1524 if (K = E_Anonymous_Access_Type
1526 K = E_Anonymous_Access_Subprogram_Type
1528 E_Anonymous_Access_Protected_Subprogram_Type)
1529 and then Is_Formal (XE.Ent)
1533 -- Special handling for Boolean
1535 elsif Ctyp = 'e' and then Is_Boolean_Type (Ent) then
1541 -- Special handling for abstract types and operations
1543 if Is_Overloadable (XE.Ent)
1544 and then Is_Abstract_Subprogram (XE.Ent)
1547 Ctyp := 'x'; -- Abstract procedure
1549 elsif Ctyp = 'V' then
1550 Ctyp := 'y'; -- Abstract function
1553 elsif Is_Type (XE.Ent)
1554 and then Is_Abstract_Type (XE.Ent)
1556 if Is_Interface (XE.Ent) then
1559 elsif Ctyp = 'R' then
1560 Ctyp := 'H'; -- Abstract type
1564 -- Only output reference if interesting type of entity, and
1565 -- suppress self references, except for bodies that act as
1566 -- specs. Also suppress definitions of body formals (we only
1567 -- treat these as references, and the references were
1568 -- separately recorded).
1571 or else (XE.Loc = XE.Def
1574 or else not Is_Subprogram (XE.Ent)))
1575 or else (Is_Formal (XE.Ent)
1576 and then Present (Spec_Entity (XE.Ent)))
1581 -- Start new Xref section if new xref unit
1583 if XE.Eun /= Curxu then
1584 if Write_Info_Col > 1 then
1589 Cursrc := Source_Text (Source_Index (Curxu));
1591 Write_Info_Initiate ('X');
1592 Write_Info_Char (' ');
1593 Write_Info_Nat (Dependency_Num (XE.Eun));
1594 Write_Info_Char (' ');
1595 Write_Info_Name (Reference_Name (Source_Index (XE.Eun)));
1598 -- Start new Entity line if new entity. Note that we
1599 -- consider two entities the same if they have the same
1600 -- name and source location. This causes entities in
1601 -- instantiations to be treated as though they referred
1608 (Name_Change (XE.Ent) or else XE.Def /= Curdef))
1613 Get_Unqualified_Name_String (Chars (XE.Ent));
1615 Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);
1617 if Write_Info_Col > 1 then
1621 -- Write column number information
1623 Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Def)));
1624 Write_Info_Char (Ctyp);
1625 Write_Info_Nat (Int (Get_Column_Number (XE.Def)));
1627 -- Write level information
1629 Write_Level_Info : declare
1630 function Is_Visible_Generic_Entity
1631 (E : Entity_Id) return Boolean;
1632 -- Check whether E is declared in the visible part
1633 -- of a generic package. For source navigation
1634 -- purposes, treat this as a visible entity.
1636 function Is_Private_Record_Component
1637 (E : Entity_Id) return Boolean;
1638 -- Check whether E is a non-inherited component of a
1639 -- private extension. Even if the enclosing record is
1640 -- public, we want to treat the component as private
1641 -- for navigation purposes.
1643 ---------------------------------
1644 -- Is_Private_Record_Component --
1645 ---------------------------------
1647 function Is_Private_Record_Component
1648 (E : Entity_Id) return Boolean
1650 S : constant Entity_Id := Scope (E);
1653 Ekind (E) = E_Component
1654 and then Nkind (Declaration_Node (S)) =
1655 N_Private_Extension_Declaration
1656 and then Original_Record_Component (E) = E;
1657 end Is_Private_Record_Component;
1659 -------------------------------
1660 -- Is_Visible_Generic_Entity --
1661 -------------------------------
1663 function Is_Visible_Generic_Entity
1664 (E : Entity_Id) return Boolean
1669 if Ekind (Scope (E)) /= E_Generic_Package then
1674 while Present (Par) loop
1676 Nkind (Par) = N_Generic_Package_Declaration
1678 -- Entity is a generic formal
1683 Nkind (Parent (Par)) = N_Package_Specification
1686 Is_List_Member (Par)
1687 and then List_Containing (Par) =
1688 Visible_Declarations (Parent (Par));
1690 Par := Parent (Par);
1695 end Is_Visible_Generic_Entity;
1697 -- Start of processing for Write_Level_Info
1700 if Is_Hidden (Curent)
1701 or else Is_Private_Record_Component (Curent)
1703 Write_Info_Char (' ');
1707 or else Is_Visible_Generic_Entity (Curent)
1709 Write_Info_Char ('*');
1712 Write_Info_Char (' ');
1714 end Write_Level_Info;
1716 -- Output entity name. We use the occurrence from the
1717 -- actual source program at the definition point.
1719 P := Original_Location (Sloc (XE.Ent));
1721 -- Entity is character literal
1723 if Cursrc (P) = ''' then
1724 Write_Info_Char (Cursrc (P));
1725 Write_Info_Char (Cursrc (P + 1));
1726 Write_Info_Char (Cursrc (P + 2));
1728 -- Entity is operator symbol
1730 elsif Cursrc (P) = '"' or else Cursrc (P) = '%' then
1731 Write_Info_Char (Cursrc (P));
1736 Write_Info_Char (Cursrc (P2));
1737 exit when Cursrc (P2) = Cursrc (P);
1740 -- Entity is identifier
1744 if Is_Start_Of_Wide_Char (Cursrc, P) then
1745 Scan_Wide (Cursrc, P, WC, Err);
1746 elsif not Identifier_Char (Cursrc (P)) then
1753 -- Write out the identifier by copying the exact
1754 -- source characters used in its declaration. Note
1755 -- that this means wide characters will be in their
1756 -- original encoded form.
1759 Original_Location (Sloc (XE.Ent)) .. P - 1
1761 Write_Info_Char (Cursrc (J));
1765 -- See if we have a renaming reference
1767 if Is_Object (XE.Ent)
1768 and then Present (Renamed_Object (XE.Ent))
1770 Rref := Renamed_Object (XE.Ent);
1772 elsif Is_Overloadable (XE.Ent)
1773 and then Nkind (Parent (Declaration_Node (XE.Ent))) =
1774 N_Subprogram_Renaming_Declaration
1776 Rref := Name (Parent (Declaration_Node (XE.Ent)));
1778 elsif Ekind (XE.Ent) = E_Package
1779 and then Nkind (Declaration_Node (XE.Ent)) =
1780 N_Package_Renaming_Declaration
1782 Rref := Name (Declaration_Node (XE.Ent));
1788 if Present (Rref) then
1789 if Nkind (Rref) = N_Expanded_Name then
1790 Rref := Selector_Name (Rref);
1793 if Nkind (Rref) = N_Identifier
1794 or else Nkind (Rref) = N_Operator_Symbol
1798 -- For renamed array components, use the array name
1799 -- for the renamed entity, which reflect the fact that
1800 -- in general the whole array is aliased.
1802 elsif Nkind (Rref) = N_Indexed_Component then
1803 if Nkind (Prefix (Rref)) = N_Identifier then
1804 Rref := Prefix (Rref);
1805 elsif Nkind (Prefix (Rref)) = N_Expanded_Name then
1806 Rref := Selector_Name (Prefix (Rref));
1816 -- Write out renaming reference if we have one
1818 if Present (Rref) then
1819 Write_Info_Char ('=');
1821 (Int (Get_Logical_Line_Number (Sloc (Rref))));
1822 Write_Info_Char (':');
1824 (Int (Get_Column_Number (Sloc (Rref))));
1827 -- Indicate that the entity is in the unit of the current
1832 -- Write out information about generic parent, if entity
1835 if Is_Generic_Instance (XE.Ent) then
1837 Gen_Par : constant Entity_Id :=
1840 (Unit_Declaration_Node (XE.Ent)));
1841 Loc : constant Source_Ptr := Sloc (Gen_Par);
1842 Gen_U : constant Unit_Number_Type :=
1843 Get_Source_Unit (Loc);
1846 Write_Info_Char ('[');
1847 if Curru /= Gen_U then
1848 Write_Info_Nat (Dependency_Num (Gen_U));
1849 Write_Info_Char ('|');
1853 (Int (Get_Logical_Line_Number (Loc)));
1854 Write_Info_Char (']');
1858 -- See if we have a type reference and if so output
1860 Check_Type_Reference (XE.Ent, False);
1862 -- Additional information for types with progenitors
1864 if Is_Record_Type (XE.Ent)
1865 and then Present (Abstract_Interfaces (XE.Ent))
1871 Elmt := First_Elmt (Abstract_Interfaces (XE.Ent));
1872 while Present (Elmt) loop
1873 Check_Type_Reference (Node (Elmt), True);
1878 -- For array types, list index types as well.
1879 -- (This is not C, indices have distinct types).
1881 elsif Is_Array_Type (XE.Ent) then
1885 Indx := First_Index (XE.Ent);
1886 while Present (Indx) loop
1887 Check_Type_Reference
1888 (First_Subtype (Etype (Indx)), True);
1894 -- If the entity is an overriding operation, write info
1895 -- on operation that was overridden.
1897 if Is_Subprogram (XE.Ent)
1898 and then Is_Overriding_Operation (XE.Ent)
1900 Output_Overridden_Op (Overridden_Operation (XE.Ent));
1903 -- End of processing for entity output
1905 Crloc := No_Location;
1908 -- Output the reference
1910 if XE.Loc /= No_Location
1911 and then XE.Loc /= Crloc
1915 -- Start continuation if line full, else blank
1917 if Write_Info_Col > 72 then
1919 Write_Info_Initiate ('.');
1922 Write_Info_Char (' ');
1924 -- Output file number if changed
1926 if XE.Lun /= Curru then
1928 Write_Info_Nat (Dependency_Num (Curru));
1929 Write_Info_Char ('|');
1932 Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Loc)));
1933 Write_Info_Char (XE.Typ);
1935 if Is_Overloadable (XE.Ent)
1936 and then Is_Imported (XE.Ent)
1937 and then XE.Typ = 'b'
1939 Output_Import_Export_Info (XE.Ent);
1942 Write_Info_Nat (Int (Get_Column_Number (XE.Loc)));
1944 Output_Instantiation_Refs (Sloc (XE.Ent));
1955 end Output_References;