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 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
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 Nlists; use Nlists;
34 with Restrict; use Restrict;
35 with Rident; use Rident;
37 with Sem_Prag; use Sem_Prag;
38 with Sem_Util; use Sem_Util;
39 with Sem_Warn; use Sem_Warn;
40 with Sinfo; use Sinfo;
41 with Sinput; use Sinput;
42 with Snames; use Snames;
43 with Stringt; use Stringt;
44 with Stand; use Stand;
45 with Table; use Table;
46 with Widechar; use Widechar;
48 with GNAT.Heap_Sort_A;
50 package body Lib.Xref is
56 -- The Xref table is used to record references. The Loc field is set
57 -- to No_Location for a definition entry.
59 subtype Xref_Entry_Number is Int;
61 type Xref_Entry is record
63 -- Entity referenced (E parameter to Generate_Reference)
66 -- Original source location for entity being referenced. Note that
67 -- these values are used only during the output process, they are
68 -- not set when the entries are originally built. This is because
69 -- private entities can be swapped when the initial call is made.
72 -- Location of reference (Original_Location (Sloc field of N parameter
73 -- to Generate_Reference). Set to No_Location for the case of a
74 -- defining occurrence.
77 -- Reference type (Typ param to Generate_Reference)
79 Eun : Unit_Number_Type;
80 -- Unit number corresponding to Ent
82 Lun : Unit_Number_Type;
83 -- Unit number corresponding to Loc. Value is undefined and not
84 -- referenced if Loc is set to No_Location.
88 package Xrefs is new Table.Table (
89 Table_Component_Type => Xref_Entry,
90 Table_Index_Type => Xref_Entry_Number,
92 Table_Initial => Alloc.Xrefs_Initial,
93 Table_Increment => Alloc.Xrefs_Increment,
94 Table_Name => "Xrefs");
96 -------------------------
97 -- Generate_Definition --
98 -------------------------
100 procedure Generate_Definition (E : Entity_Id) is
105 pragma Assert (Nkind (E) in N_Entity);
107 -- Note that we do not test Xref_Entity_Letters here. It is too
108 -- early to do so, since we are often called before the entity
109 -- is fully constructed, so that the Ekind is still E_Void.
113 -- Definition must come from source
115 -- We make an exception for subprogram child units that have no
116 -- spec. For these we generate a subprogram declaration for library
117 -- use, and the corresponding entity does not come from source.
118 -- Nevertheless, all references will be attached to it and we have
119 -- to treat is as coming from user code.
121 and then (Comes_From_Source (E) or else Is_Child_Unit (E))
123 -- And must have a reasonable source location that is not
124 -- within an instance (all entities in instances are ignored)
126 and then Sloc (E) > No_Location
127 and then Instantiation_Location (Sloc (E)) = No_Location
129 -- And must be a non-internal name from the main source unit
131 and then In_Extended_Main_Source_Unit (E)
132 and then not Is_Internal_Name (Chars (E))
134 Xrefs.Increment_Last;
136 Loc := Original_Location (Sloc (E));
138 Xrefs.Table (Indx).Ent := E;
139 Xrefs.Table (Indx).Def := No_Location;
140 Xrefs.Table (Indx).Loc := No_Location;
141 Xrefs.Table (Indx).Typ := ' ';
142 Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
143 Xrefs.Table (Indx).Lun := No_Unit;
144 Set_Has_Xref_Entry (E);
146 if In_Inlined_Body then
150 end Generate_Definition;
152 ---------------------------------
153 -- Generate_Operator_Reference --
154 ---------------------------------
156 procedure Generate_Operator_Reference
161 if not In_Extended_Main_Source_Unit (N) then
165 -- If the operator is not a Standard operator, then we generate
166 -- a real reference to the user defined operator.
168 if Sloc (Entity (N)) /= Standard_Location then
169 Generate_Reference (Entity (N), N);
171 -- A reference to an implicit inequality operator is a also a
172 -- reference to the user-defined equality.
174 if Nkind (N) = N_Op_Ne
175 and then not Comes_From_Source (Entity (N))
176 and then Present (Corresponding_Equality (Entity (N)))
178 Generate_Reference (Corresponding_Equality (Entity (N)), N);
181 -- For the case of Standard operators, we mark the result type
182 -- as referenced. This ensures that in the case where we are
183 -- using a derived operator, we mark an entity of the unit that
184 -- implicitly defines this operator as used. Otherwise we may
185 -- think that no entity of the unit is used. The actual entity
186 -- marked as referenced is the first subtype, which is the user
187 -- defined entity that is relevant.
189 -- Note: we only do this for operators that come from source.
190 -- The generated code sometimes reaches for entities that do
191 -- not need to be explicitly visible (for example, when we
192 -- expand the code for comparing two record types, the fields
193 -- of the record may not be visible).
195 elsif Comes_From_Source (N) then
196 Set_Referenced (First_Subtype (T));
198 end Generate_Operator_Reference;
200 ------------------------
201 -- Generate_Reference --
202 ------------------------
204 procedure Generate_Reference
207 Typ : Character := 'r';
208 Set_Ref : Boolean := True;
209 Force : Boolean := False)
217 function Is_On_LHS (Node : Node_Id) return Boolean;
218 -- Used to check if a node is on the left hand side of an assignment.
219 -- The following cases are handled:
221 -- Variable Node is a direct descendant of an assignment statement.
223 -- Prefix Of an indexed or selected component that is present in a
224 -- subtree rooted by an assignment statement. There is no
225 -- restriction of nesting of components, thus cases such as
226 -- A.B(C).D are handled properly.
232 -- Couldn't we use Is_Lvalue or whatever it is called ???
234 function Is_On_LHS (Node : Node_Id) return Boolean is
238 -- Only identifiers are considered, is this necessary???
240 if Nkind (N) /= N_Identifier then
244 -- Reach the assignment statement subtree root. In the case of a
245 -- variable being a direct descendant of an assignment statement,
246 -- the loop is skiped.
248 while Nkind (Parent (N)) /= N_Assignment_Statement loop
250 -- Check whether the parent is a component and the
251 -- current node is its prefix.
253 if (Nkind (Parent (N)) = N_Selected_Component
255 Nkind (Parent (N)) = N_Indexed_Component)
256 and then Prefix (Parent (N)) = N
264 -- Parent (N) is assignment statement, check whether N is its name
266 return Name (Parent (N)) = N;
269 -- Start of processing for Generate_Reference
272 pragma Assert (Nkind (E) in N_Entity);
274 -- Check for obsolescent reference to package ASCII. GNAT treats this
275 -- element of annex J specially since in practice, programs make a lot
276 -- of use of this feature, so we don't include it in the set of features
277 -- diagnosed when Warn_On_Obsolescent_Features mode is set. However we
278 -- are required to note it as a violation of the RM defined restriction.
280 if E = Standard_ASCII then
281 Check_Restriction (No_Obsolescent_Features, N);
284 -- Check for reference to entity marked with Is_Obsolescent
286 -- Note that we always allow obsolescent references in the compiler
287 -- itself and the run time, since we assume that we know what we are
288 -- doing in such cases. For example the calls in Ada.Characters.Handling
289 -- to its own obsolescent subprograms are just fine.
291 -- In any case we do not generate warnings within the extended source
292 -- unit of the entity in question, since we assume the source unit
293 -- itself knows what is going on (and for sure we do not want silly
294 -- warnings, e.g. on the end line of an obsolescent procedure body).
296 if Is_Obsolescent (E)
297 and then not GNAT_Mode
298 and then not In_Extended_Main_Source_Unit (E)
300 Check_Restriction (No_Obsolescent_Features, N);
302 if Warn_On_Obsolescent_Feature then
303 Output_Obsolescent_Entity_Warnings (N, E);
307 -- Warn if reference to Ada 2005 entity not in Ada 2005 mode. We only
308 -- detect real explicit references (modifications and references).
310 if Comes_From_Source (N)
311 and then Is_Ada_2005_Only (E)
312 and then Ada_Version < Ada_05
313 and then Warn_On_Ada_2005_Compatibility
314 and then (Typ = 'm' or else Typ = 'r')
316 Error_Msg_NE ("& is only defined in Ada 2005?", N, E);
319 -- Never collect references if not in main source unit. However, we omit
320 -- this test if Typ is 'e' or 'k', since these entries are structural,
321 -- and it is useful to have them in units that reference packages as
322 -- well as units that define packages. We also omit the test for the
323 -- case of 'p' since we want to include inherited primitive operations
324 -- from other packages.
326 -- We also omit this test is this is a body reference for a subprogram
327 -- instantiation. In this case the reference is to the generic body,
328 -- which clearly need not be in the main unit containing the instance.
329 -- For the same reason we accept an implicit reference generated for
330 -- a default in an instance.
332 if not In_Extended_Main_Source_Unit (N) then
337 or else (Typ = 'b' and then Is_Generic_Instance (E))
345 -- For reference type p, the entity must be in main source unit
347 if Typ = 'p' and then not In_Extended_Main_Source_Unit (E) then
351 -- Unless the reference is forced, we ignore references where the
352 -- reference itself does not come from Source.
354 if not Force and then not Comes_From_Source (N) then
358 -- Deal with setting entity as referenced, unless suppressed. Note that
359 -- we still do Set_Referenced on entities that do not come from source.
360 -- This situation arises when we have a source reference to a derived
361 -- operation, where the derived operation itself does not come from
362 -- source, but we still want to mark it as referenced, since we really
363 -- are referencing an entity in the corresponding package (this avoids
364 -- wrong complaints that the package contains no referenced entities).
368 -- For a variable that appears on the left side of an assignment
369 -- statement, we set the Referenced_As_LHS flag since this is indeed
370 -- a left hand side. We also set the Referenced_As_LHS flag of a
371 -- prefix of selected or indexed component.
373 if Ekind (E) = E_Variable
374 and then Is_On_LHS (N)
376 Set_Referenced_As_LHS (E);
378 -- Check for a reference in a pragma that should not count as a
379 -- making the variable referenced for warning purposes.
381 elsif Is_Non_Significant_Pragma_Reference (N) then
384 -- A reference in an attribute definition clause does not count as a
385 -- reference except for the case of Address. The reason that 'Address
386 -- is an exception is that it creates an alias through which the
387 -- variable may be referenced.
389 elsif Nkind (Parent (N)) = N_Attribute_Definition_Clause
390 and then Chars (Parent (N)) /= Name_Address
391 and then N = Name (Parent (N))
395 -- Constant completion does not count as a reference
398 and then Ekind (E) = E_Constant
402 -- Record representation clause does not count as a reference
404 elsif Nkind (N) = N_Identifier
405 and then Nkind (Parent (N)) = N_Record_Representation_Clause
409 -- Discriminants do not need to produce a reference to record type
412 and then Nkind (Parent (N)) = N_Discriminant_Specification
416 -- Any other occurrence counts as referencing the entity
421 if Ekind (E) = E_Variable then
422 Set_Last_Assignment (E, Empty);
426 -- Check for pragma Unreferenced given and reference is within
427 -- this source unit (occasion for possible warning to be issued)
429 if Has_Pragma_Unreferenced (E)
430 and then In_Same_Extended_Unit (E, N)
432 -- A reference as a named parameter in a call does not count
433 -- as a violation of pragma Unreferenced for this purpose.
435 if Nkind (N) = N_Identifier
436 and then Nkind (Parent (N)) = N_Parameter_Association
437 and then Selector_Name (Parent (N)) = N
441 -- Neither does a reference to a variable on the left side
444 elsif Is_On_LHS (N) then
447 -- For entry formals, we want to place the warning message on the
448 -- corresponding entity in the accept statement. The current scope
449 -- is the body of the accept, so we find the formal whose name
450 -- matches that of the entry formal (there is no link between the
451 -- two entities, and the one in the accept statement is only used
452 -- for conformance checking).
454 elsif Ekind (Scope (E)) = E_Entry then
459 BE := First_Entity (Current_Scope);
460 while Present (BE) loop
461 if Chars (BE) = Chars (E) then
463 ("?pragma Unreferenced given for&", N, BE);
471 -- Here we issue the warning, since this is a real reference
474 Error_Msg_NE ("?pragma Unreferenced given for&", N, E);
478 -- If this is a subprogram instance, mark as well the internal
479 -- subprogram in the wrapper package, which may be a visible
482 if Is_Overloadable (E)
483 and then Is_Generic_Instance (E)
484 and then Present (Alias (E))
486 Set_Referenced (Alias (E));
490 -- Generate reference if all conditions are met:
493 -- Cross referencing must be active
497 -- The entity must be one for which we collect references
499 and then Xref_Entity_Letters (Ekind (E)) /= ' '
501 -- Both Sloc values must be set to something sensible
503 and then Sloc (E) > No_Location
504 and then Sloc (N) > No_Location
506 -- We ignore references from within an instance
508 and then Instantiation_Location (Sloc (N)) = No_Location
510 -- Ignore dummy references
514 if Nkind (N) = N_Identifier
516 Nkind (N) = N_Defining_Identifier
520 Nkind (N) = N_Defining_Operator_Symbol
522 Nkind (N) = N_Operator_Symbol
524 (Nkind (N) = N_Character_Literal
525 and then Sloc (Entity (N)) /= Standard_Location)
527 Nkind (N) = N_Defining_Character_Literal
531 elsif Nkind (N) = N_Expanded_Name
533 Nkind (N) = N_Selected_Component
535 Nod := Selector_Name (N);
541 -- Normal case of source entity comes from source
543 if Comes_From_Source (E) then
546 -- Entity does not come from source, but is a derived subprogram
547 -- and the derived subprogram comes from source (after one or more
548 -- derivations) in which case the reference is to parent subprogram.
550 elsif Is_Overloadable (E)
551 and then Present (Alias (E))
554 while not Comes_From_Source (Ent) loop
555 if No (Alias (Ent)) then
562 -- The internally created defining entity for a child subprogram
563 -- that has no previous spec has valid references.
565 elsif Is_Overloadable (E)
566 and then Is_Child_Unit (E)
570 -- Record components of discriminated subtypes or derived types
571 -- must be treated as references to the original component.
573 elsif Ekind (E) = E_Component
574 and then Comes_From_Source (Original_Record_Component (E))
576 Ent := Original_Record_Component (E);
578 -- Ignore reference to any other entity that is not from source
584 -- Record reference to entity
586 Ref := Original_Location (Sloc (Nod));
587 Def := Original_Location (Sloc (Ent));
589 Xrefs.Increment_Last;
592 Xrefs.Table (Indx).Loc := Ref;
594 -- Overriding operations are marked with 'P'
597 and then Is_Subprogram (N)
598 and then Is_Overriding_Operation (N)
600 Xrefs.Table (Indx).Typ := 'P';
602 Xrefs.Table (Indx).Typ := Typ;
605 Xrefs.Table (Indx).Eun := Get_Source_Unit (Def);
606 Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref);
607 Xrefs.Table (Indx).Ent := Ent;
608 Set_Has_Xref_Entry (Ent);
610 end Generate_Reference;
612 -----------------------------------
613 -- Generate_Reference_To_Formals --
614 -----------------------------------
616 procedure Generate_Reference_To_Formals (E : Entity_Id) is
620 if Is_Generic_Subprogram (E) then
621 Formal := First_Entity (E);
623 while Present (Formal)
624 and then not Is_Formal (Formal)
626 Next_Entity (Formal);
630 Formal := First_Formal (E);
633 while Present (Formal) loop
634 if Ekind (Formal) = E_In_Parameter then
636 if Nkind (Parameter_Type (Parent (Formal)))
637 = N_Access_Definition
639 Generate_Reference (E, Formal, '^', False);
641 Generate_Reference (E, Formal, '>', False);
644 elsif Ekind (Formal) = E_In_Out_Parameter then
645 Generate_Reference (E, Formal, '=', False);
648 Generate_Reference (E, Formal, '<', False);
651 Next_Formal (Formal);
653 end Generate_Reference_To_Formals;
655 -------------------------------------------
656 -- Generate_Reference_To_Generic_Formals --
657 -------------------------------------------
659 procedure Generate_Reference_To_Generic_Formals (E : Entity_Id) is
663 Formal := First_Entity (E);
664 while Present (Formal) loop
665 if Comes_From_Source (Formal) then
666 Generate_Reference (E, Formal, 'z', False);
669 Next_Entity (Formal);
671 end Generate_Reference_To_Generic_Formals;
677 procedure Initialize is
682 -----------------------
683 -- Output_References --
684 -----------------------
686 procedure Output_References is
688 procedure Get_Type_Reference
690 Tref : out Entity_Id;
691 Left : out Character;
692 Right : out Character);
693 -- Given an entity id Ent, determines whether a type reference is
694 -- required. If so, Tref is set to the entity for the type reference
695 -- and Left and Right are set to the left/right brackets to be
696 -- output for the reference. If no type reference is required, then
697 -- Tref is set to Empty, and Left/Right are set to space.
699 procedure Output_Import_Export_Info (Ent : Entity_Id);
700 -- Ouput language and external name information for an interfaced
701 -- entity, using the format <language, external_name>,
703 ------------------------
704 -- Get_Type_Reference --
705 ------------------------
707 procedure Get_Type_Reference
709 Tref : out Entity_Id;
710 Left : out Character;
711 Right : out Character)
716 -- See if we have a type reference
725 -- Processing for types
727 if Is_Type (Tref) then
731 if Base_Type (Tref) = Tref then
733 -- If derived, then get first subtype
735 if Tref /= Etype (Tref) then
736 Tref := First_Subtype (Etype (Tref));
738 -- Set brackets for derived type, but don't
739 -- override pointer case since the fact that
740 -- something is a pointer is more important
747 -- If non-derived ptr, get directly designated type.
748 -- If the type has a full view, all references are
749 -- on the partial view, that is seen first.
751 elsif Is_Access_Type (Tref) then
752 Tref := Directly_Designated_Type (Tref);
756 elsif Is_Private_Type (Tref)
757 and then Present (Full_View (Tref))
759 if Is_Access_Type (Full_View (Tref)) then
760 Tref := Directly_Designated_Type (Full_View (Tref));
764 -- If the full view is an array type, we also retrieve
765 -- the corresponding component type, because the ali
766 -- entry already indicates that this is an array.
768 elsif Is_Array_Type (Full_View (Tref)) then
769 Tref := Component_Type (Full_View (Tref));
774 -- If non-derived array, get component type. Skip component
775 -- type for case of String or Wide_String, saves worthwhile
778 elsif Is_Array_Type (Tref)
779 and then Tref /= Standard_String
780 and then Tref /= Standard_Wide_String
782 Tref := Component_Type (Tref);
786 -- For other non-derived base types, nothing
792 -- For a subtype, go to ancestor subtype
795 Tref := Ancestor_Subtype (Tref);
797 -- If no ancestor subtype, go to base type
800 Tref := Base_Type (Sav);
804 -- For objects, functions, enum literals,
805 -- just get type from Etype field.
807 elsif Is_Object (Tref)
808 or else Ekind (Tref) = E_Enumeration_Literal
809 or else Ekind (Tref) = E_Function
810 or else Ekind (Tref) = E_Operator
812 Tref := Etype (Tref);
814 -- For anything else, exit
820 -- Exit if no type reference, or we are stuck in
821 -- some loop trying to find the type reference, or
822 -- if the type is standard void type (the latter is
823 -- an implementation artifact that should not show
824 -- up in the generated cross-references).
828 or else Tref = Standard_Void_Type;
830 -- If we have a usable type reference, return, otherwise
831 -- keep looking for something useful (we are looking for
832 -- something that either comes from source or standard)
834 if Sloc (Tref) = Standard_Location
835 or else Comes_From_Source (Tref)
837 -- If the reference is a subtype created for a generic
838 -- actual, go to actual directly, the inner subtype is
841 if Nkind (Parent (Tref)) = N_Subtype_Declaration
842 and then not Comes_From_Source (Parent (Tref))
844 (Is_Wrapper_Package (Scope (Tref))
845 or else Is_Generic_Instance (Scope (Tref)))
847 Tref := First_Subtype (Base_Type (Tref));
854 -- If we fall through the loop, no type reference
859 end Get_Type_Reference;
861 -------------------------------
862 -- Output_Import_Export_Info --
863 -------------------------------
865 procedure Output_Import_Export_Info (Ent : Entity_Id) is
866 Language_Name : Name_Id;
867 Conv : constant Convention_Id := Convention (Ent);
870 -- Generate language name from convention
872 if Conv = Convention_C then
873 Language_Name := Name_C;
875 elsif Conv = Convention_CPP then
876 Language_Name := Name_CPP;
878 elsif Conv = Convention_Ada then
879 Language_Name := Name_Ada;
882 -- For the moment we ignore all other cases ???
887 Write_Info_Char ('<');
888 Get_Unqualified_Name_String (Language_Name);
890 for J in 1 .. Name_Len loop
891 Write_Info_Char (Name_Buffer (J));
894 if Present (Interface_Name (Ent)) then
895 Write_Info_Char (',');
896 String_To_Name_Buffer (Strval (Interface_Name (Ent)));
898 for J in 1 .. Name_Len loop
899 Write_Info_Char (Name_Buffer (J));
903 Write_Info_Char ('>');
904 end Output_Import_Export_Info;
906 -- Start of processing for Output_References
909 if not Opt.Xref_Active then
913 -- Before we go ahead and output the references we have a problem
914 -- that needs dealing with. So far we have captured things that are
915 -- definitely referenced by the main unit, or defined in the main
916 -- unit. That's because we don't want to clutter up the ali file
917 -- for this unit with definition lines for entities in other units
918 -- that are not referenced.
920 -- But there is a glitch. We may reference an entity in another unit,
921 -- and it may have a type reference to an entity that is not directly
922 -- referenced in the main unit, which may mean that there is no xref
923 -- entry for this entity yet in the list of references.
925 -- If we don't do something about this, we will end with an orphan type
926 -- reference, i.e. it will point to an entity that does not appear
927 -- within the generated references in the ali file. That is not good for
928 -- tools using the xref information.
930 -- To fix this, we go through the references adding definition entries
931 -- for any unreferenced entities that can be referenced in a type
932 -- reference. There is a recursion problem here, and that is dealt with
933 -- by making sure that this traversal also traverses any entries that
934 -- get added by the traversal.
936 Handle_Orphan_Type_References : declare
944 procedure New_Entry (E : Entity_Id);
945 -- Make an additional entry into the Xref table for a type entity
946 -- that is related to the current entity (parent, type. ancestor,
947 -- progenitor, etc.).
953 procedure New_Entry (E : Entity_Id) is
956 and then not Has_Xref_Entry (E)
957 and then Sloc (E) > No_Location
959 Xrefs.Increment_Last;
961 Loc := Original_Location (Sloc (E));
962 Xrefs.Table (Indx).Ent := E;
963 Xrefs.Table (Indx).Loc := No_Location;
964 Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
965 Xrefs.Table (Indx).Lun := No_Unit;
966 Set_Has_Xref_Entry (E);
970 -- Start of processing for Handle_Orphan_Type_References
973 -- Note that this is not a for loop for a very good reason. The
974 -- processing of items in the table can add new items to the table,
975 -- and they must be processed as well
978 while J <= Xrefs.Last loop
979 Ent := Xrefs.Table (J).Ent;
980 Get_Type_Reference (Ent, Tref, L, R);
983 and then not Has_Xref_Entry (Tref)
984 and then Sloc (Tref) > No_Location
988 if Is_Record_Type (Ent)
989 and then Present (Abstract_Interfaces (Ent))
991 -- Add an entry for each one of the given interfaces
992 -- implemented by type Ent.
998 Elmt := First_Elmt (Abstract_Interfaces (Ent));
999 while Present (Elmt) loop
1000 New_Entry (Node (Elmt));
1007 -- Collect inherited primitive operations that may be
1008 -- declared in another unit and have no visible reference
1009 -- in the current one.
1012 and then Is_Tagged_Type (Ent)
1013 and then Is_Derived_Type (Ent)
1014 and then Ent = Base_Type (Ent)
1015 and then In_Extended_Main_Source_Unit (Ent)
1018 Op_List : constant Elist_Id := Primitive_Operations (Ent);
1022 function Parent_Op (E : Entity_Id) return Entity_Id;
1023 -- Find original operation, which may be inherited
1024 -- through several derivations.
1026 function Parent_Op (E : Entity_Id) return Entity_Id is
1027 Orig_Op : constant Entity_Id := Alias (E);
1029 if No (Orig_Op) then
1031 elsif not Comes_From_Source (E)
1032 and then not Has_Xref_Entry (Orig_Op)
1033 and then Comes_From_Source (Orig_Op)
1037 return Parent_Op (Orig_Op);
1042 Op := First_Elmt (Op_List);
1043 while Present (Op) loop
1044 Prim := Parent_Op (Node (Op));
1046 if Present (Prim) then
1047 Xrefs.Increment_Last;
1049 Loc := Original_Location (Sloc (Prim));
1050 Xrefs.Table (Indx).Ent := Prim;
1051 Xrefs.Table (Indx).Loc := No_Location;
1052 Xrefs.Table (Indx).Eun :=
1053 Get_Source_Unit (Sloc (Prim));
1054 Xrefs.Table (Indx).Lun := No_Unit;
1055 Set_Has_Xref_Entry (Prim);
1065 end Handle_Orphan_Type_References;
1067 -- Now we have all the references, including those for any embedded
1068 -- type references, so we can sort them, and output them.
1070 Output_Refs : declare
1072 Nrefs : Nat := Xrefs.Last;
1073 -- Number of references in table. This value may get reset
1074 -- (reduced) when we eliminate duplicate reference entries.
1076 Rnums : array (0 .. Nrefs) of Nat;
1077 -- This array contains numbers of references in the Xrefs table.
1078 -- This list is sorted in output order. The extra 0'th entry is
1079 -- convenient for the call to sort. When we sort the table, we
1080 -- move the entries in Rnums around, but we do not move the
1081 -- original table entries.
1083 Curxu : Unit_Number_Type;
1084 -- Current xref unit
1086 Curru : Unit_Number_Type;
1087 -- Current reference unit for one entity
1089 Cursrc : Source_Buffer_Ptr;
1090 -- Current xref unit source text
1095 Curnam : String (1 .. Name_Buffer'Length);
1097 -- Simple name and length of current entity
1099 Curdef : Source_Ptr;
1100 -- Original source location for current entity
1103 -- Current reference location
1106 -- Entity type character
1112 -- Renaming reference
1114 Trunit : Unit_Number_Type;
1115 -- Unit number for type reference
1117 function Lt (Op1, Op2 : Natural) return Boolean;
1118 -- Comparison function for Sort call
1120 function Name_Change (X : Entity_Id) return Boolean;
1121 -- Determines if entity X has a different simple name from Curent
1123 procedure Move (From : Natural; To : Natural);
1124 -- Move procedure for Sort call
1130 function Lt (Op1, Op2 : Natural) return Boolean is
1131 T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
1132 T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
1135 -- First test. If entity is in different unit, sort by unit
1137 if T1.Eun /= T2.Eun then
1138 return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun);
1140 -- Second test, within same unit, sort by entity Sloc
1142 elsif T1.Def /= T2.Def then
1143 return T1.Def < T2.Def;
1145 -- Third test, sort definitions ahead of references
1147 elsif T1.Loc = No_Location then
1150 elsif T2.Loc = No_Location then
1153 -- Fourth test, for same entity, sort by reference location unit
1155 elsif T1.Lun /= T2.Lun then
1156 return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
1158 -- Fifth test order of location within referencing unit
1160 elsif T1.Loc /= T2.Loc then
1161 return T1.Loc < T2.Loc;
1163 -- Finally, for two locations at the same address, we prefer
1164 -- the one that does NOT have the type 'r' so that a modification
1165 -- or extension takes preference, when there are more than one
1166 -- reference at the same location.
1169 return T2.Typ = 'r';
1177 procedure Move (From : Natural; To : Natural) is
1179 Rnums (Nat (To)) := Rnums (Nat (From));
1186 -- Why a string comparison here??? Why not compare Name_Id values???
1188 function Name_Change (X : Entity_Id) return Boolean is
1190 Get_Unqualified_Name_String (Chars (X));
1192 if Name_Len /= Curlen then
1196 return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen);
1200 -- Start of processing for Output_Refs
1203 -- Capture the definition Sloc values. We delay doing this till now,
1204 -- since at the time the reference or definition is made, private
1205 -- types may be swapped, and the Sloc value may be incorrect. We
1206 -- also set up the pointer vector for the sort.
1208 for J in 1 .. Nrefs loop
1210 Xrefs.Table (J).Def :=
1211 Original_Location (Sloc (Xrefs.Table (J).Ent));
1214 -- Sort the references
1216 GNAT.Heap_Sort_A.Sort
1218 Move'Unrestricted_Access,
1219 Lt'Unrestricted_Access);
1221 -- Eliminate duplicate entries
1224 NR : constant Nat := Nrefs;
1227 -- We need this test for NR because if we force ALI file
1228 -- generation in case of errors detected, it may be the case
1229 -- that Nrefs is 0, so we should not reset it here
1234 for J in 2 .. NR loop
1235 if Xrefs.Table (Rnums (J)) /=
1236 Xrefs.Table (Rnums (Nrefs))
1239 Rnums (Nrefs) := Rnums (J);
1245 -- Initialize loop through references
1249 Curdef := No_Location;
1251 Crloc := No_Location;
1253 -- Loop to output references
1255 for Refno in 1 .. Nrefs loop
1256 Output_One_Ref : declare
1262 XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
1263 -- The current entry to be accessed
1266 -- Used to index into source buffer to get entity name
1270 -- Used for {} or <> or () for type reference
1272 procedure Check_Type_Reference
1274 List_Interface : Boolean);
1275 -- Find whether there is a meaningful type reference for
1276 -- Ent, and display it accordingly. If List_Interface is
1277 -- true, then Ent is a progenitor interface of the current
1278 -- type entity being listed. In that case list it as is,
1279 -- without looking for a type reference for it.
1281 procedure Output_Instantiation_Refs (Loc : Source_Ptr);
1282 -- Recursive procedure to output instantiation references for
1283 -- the given source ptr in [file|line[...]] form. No output
1284 -- if the given location is not a generic template reference.
1286 procedure Output_Overridden_Op (Old_E : Entity_Id);
1287 -- For a subprogram that is overriding, display information
1288 -- about the inherited operation that it overrides.
1290 --------------------------
1291 -- Check_Type_Reference --
1292 --------------------------
1294 procedure Check_Type_Reference
1296 List_Interface : Boolean)
1299 if List_Interface then
1301 -- This is a progenitor interface of the type for
1302 -- which xref information is being generated.
1309 Get_Type_Reference (Ent, Tref, Left, Right);
1312 if Present (Tref) then
1314 -- Case of standard entity, output name
1316 if Sloc (Tref) = Standard_Location then
1317 Write_Info_Char (Left);
1318 Write_Info_Name (Chars (Tref));
1319 Write_Info_Char (Right);
1321 -- Case of source entity, output location
1324 Write_Info_Char (Left);
1325 Trunit := Get_Source_Unit (Sloc (Tref));
1327 if Trunit /= Curxu then
1328 Write_Info_Nat (Dependency_Num (Trunit));
1329 Write_Info_Char ('|');
1333 (Int (Get_Logical_Line_Number (Sloc (Tref))));
1336 Ent : Entity_Id := Tref;
1337 Kind : constant Entity_Kind := Ekind (Ent);
1338 Ctyp : Character := Xref_Entity_Letters (Kind);
1342 and then Present (Full_View (Ent))
1344 Ent := Underlying_Type (Ent);
1346 if Present (Ent) then
1347 Ctyp := Xref_Entity_Letters (Ekind (Ent));
1351 Write_Info_Char (Ctyp);
1355 (Int (Get_Column_Number (Sloc (Tref))));
1357 -- If the type comes from an instantiation,
1358 -- add the corresponding info.
1360 Output_Instantiation_Refs (Sloc (Tref));
1361 Write_Info_Char (Right);
1364 end Check_Type_Reference;
1366 -------------------------------
1367 -- Output_Instantiation_Refs --
1368 -------------------------------
1370 procedure Output_Instantiation_Refs (Loc : Source_Ptr) is
1371 Iloc : constant Source_Ptr := Instantiation_Location (Loc);
1372 Lun : Unit_Number_Type;
1373 Cu : constant Unit_Number_Type := Curru;
1376 -- Nothing to do if this is not an instantiation
1378 if Iloc = No_Location then
1382 -- Output instantiation reference
1384 Write_Info_Char ('[');
1385 Lun := Get_Source_Unit (Iloc);
1387 if Lun /= Curru then
1389 Write_Info_Nat (Dependency_Num (Curru));
1390 Write_Info_Char ('|');
1393 Write_Info_Nat (Int (Get_Logical_Line_Number (Iloc)));
1395 -- Recursive call to get nested instantiations
1397 Output_Instantiation_Refs (Iloc);
1399 -- Output final ] after call to get proper nesting
1401 Write_Info_Char (']');
1404 end Output_Instantiation_Refs;
1406 --------------------------
1407 -- Output_Overridden_Op --
1408 --------------------------
1410 procedure Output_Overridden_Op (Old_E : Entity_Id) is
1413 and then Sloc (Old_E) /= Standard_Location
1416 Loc : constant Source_Ptr := Sloc (Old_E);
1417 Par_Unit : constant Unit_Number_Type :=
1418 Get_Source_Unit (Loc);
1420 Write_Info_Char ('<');
1422 if Par_Unit /= Curxu then
1423 Write_Info_Nat (Dependency_Num (Par_Unit));
1424 Write_Info_Char ('|');
1427 Write_Info_Nat (Int (Get_Logical_Line_Number (Loc)));
1428 Write_Info_Char ('p');
1429 Write_Info_Nat (Int (Get_Column_Number (Loc)));
1430 Write_Info_Char ('>');
1433 end Output_Overridden_Op;
1435 -- Start of processing for Output_One_Ref
1439 Ctyp := Xref_Entity_Letters (Ekind (Ent));
1441 -- Skip reference if it is the only reference to an entity,
1442 -- and it is an end-line reference, and the entity is not in
1443 -- the current extended source. This prevents junk entries
1444 -- consisting only of packages with end lines, where no
1445 -- entity from the package is actually referenced.
1448 and then Ent /= Curent
1449 and then (Refno = Nrefs or else
1450 Ent /= Xrefs.Table (Rnums (Refno + 1)).Ent)
1452 not In_Extended_Main_Source_Unit (Ent)
1457 -- For private type, get full view type
1460 and then Present (Full_View (XE.Ent))
1462 Ent := Underlying_Type (Ent);
1464 if Present (Ent) then
1465 Ctyp := Xref_Entity_Letters (Ekind (Ent));
1469 -- Special exception for Boolean
1471 if Ctyp = 'E' and then Is_Boolean_Type (Ent) then
1475 -- For variable reference, get corresponding type
1478 Ent := Etype (XE.Ent);
1479 Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
1481 -- If variable is private type, get full view type
1484 and then Present (Full_View (Etype (XE.Ent)))
1486 Ent := Underlying_Type (Etype (XE.Ent));
1488 if Present (Ent) then
1489 Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
1492 elsif Is_Generic_Type (Ent) then
1494 -- If the type of the entity is a generic private type
1495 -- there is no usable full view, so retain the indication
1496 -- that this is an object.
1501 -- Special handling for access parameter
1504 K : constant Entity_Kind := Ekind (Etype (XE.Ent));
1507 if (K = E_Anonymous_Access_Type
1509 K = E_Anonymous_Access_Subprogram_Type
1511 E_Anonymous_Access_Protected_Subprogram_Type)
1512 and then Is_Formal (XE.Ent)
1516 -- Special handling for Boolean
1518 elsif Ctyp = 'e' and then Is_Boolean_Type (Ent) then
1524 -- Special handling for abstract types and operations
1526 if Is_Overloadable (XE.Ent)
1527 and then Is_Abstract_Subprogram (XE.Ent)
1530 Ctyp := 'x'; -- abstract procedure
1532 elsif Ctyp = 'V' then
1533 Ctyp := 'y'; -- abstract function
1536 elsif Is_Type (XE.Ent)
1537 and then Is_Abstract_Type (XE.Ent)
1539 if Is_Interface (XE.Ent) then
1542 elsif Ctyp = 'R' then
1543 Ctyp := 'H'; -- abstract type
1547 -- Only output reference if interesting type of entity, and
1548 -- suppress self references, except for bodies that act as
1549 -- specs. Also suppress definitions of body formals (we only
1550 -- treat these as references, and the references were
1551 -- separately recorded).
1554 or else (XE.Loc = XE.Def
1557 or else not Is_Subprogram (XE.Ent)))
1558 or else (Is_Formal (XE.Ent)
1559 and then Present (Spec_Entity (XE.Ent)))
1564 -- Start new Xref section if new xref unit
1566 if XE.Eun /= Curxu then
1567 if Write_Info_Col > 1 then
1572 Cursrc := Source_Text (Source_Index (Curxu));
1574 Write_Info_Initiate ('X');
1575 Write_Info_Char (' ');
1576 Write_Info_Nat (Dependency_Num (XE.Eun));
1577 Write_Info_Char (' ');
1578 Write_Info_Name (Reference_Name (Source_Index (XE.Eun)));
1581 -- Start new Entity line if new entity. Note that we
1582 -- consider two entities the same if they have the same
1583 -- name and source location. This causes entities in
1584 -- instantiations to be treated as though they referred
1591 (Name_Change (XE.Ent) or else XE.Def /= Curdef))
1596 Get_Unqualified_Name_String (Chars (XE.Ent));
1598 Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);
1600 if Write_Info_Col > 1 then
1604 -- Write column number information
1606 Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Def)));
1607 Write_Info_Char (Ctyp);
1608 Write_Info_Nat (Int (Get_Column_Number (XE.Def)));
1610 -- Write level information
1612 Write_Level_Info : declare
1613 function Is_Visible_Generic_Entity
1614 (E : Entity_Id) return Boolean;
1615 -- Check whether E is declared in the visible part
1616 -- of a generic package. For source navigation
1617 -- purposes, treat this as a visible entity.
1619 function Is_Private_Record_Component
1620 (E : Entity_Id) return Boolean;
1621 -- Check whether E is a non-inherited component of a
1622 -- private extension. Even if the enclosing record is
1623 -- public, we want to treat the component as private
1624 -- for navigation purposes.
1626 ---------------------------------
1627 -- Is_Private_Record_Component --
1628 ---------------------------------
1630 function Is_Private_Record_Component
1631 (E : Entity_Id) return Boolean
1633 S : constant Entity_Id := Scope (E);
1636 Ekind (E) = E_Component
1637 and then Nkind (Declaration_Node (S)) =
1638 N_Private_Extension_Declaration
1639 and then Original_Record_Component (E) = E;
1640 end Is_Private_Record_Component;
1642 -------------------------------
1643 -- Is_Visible_Generic_Entity --
1644 -------------------------------
1646 function Is_Visible_Generic_Entity
1647 (E : Entity_Id) return Boolean
1652 if Ekind (Scope (E)) /= E_Generic_Package then
1657 while Present (Par) loop
1659 Nkind (Par) = N_Generic_Package_Declaration
1661 -- Entity is a generic formal
1666 Nkind (Parent (Par)) = N_Package_Specification
1669 Is_List_Member (Par)
1670 and then List_Containing (Par) =
1671 Visible_Declarations (Parent (Par));
1673 Par := Parent (Par);
1678 end Is_Visible_Generic_Entity;
1680 -- Start of processing for Write_Level_Info
1683 if Is_Hidden (Curent)
1684 or else Is_Private_Record_Component (Curent)
1686 Write_Info_Char (' ');
1690 or else Is_Visible_Generic_Entity (Curent)
1692 Write_Info_Char ('*');
1695 Write_Info_Char (' ');
1697 end Write_Level_Info;
1699 -- Output entity name. We use the occurrence from the
1700 -- actual source program at the definition point
1702 P := Original_Location (Sloc (XE.Ent));
1704 -- Entity is character literal
1706 if Cursrc (P) = ''' then
1707 Write_Info_Char (Cursrc (P));
1708 Write_Info_Char (Cursrc (P + 1));
1709 Write_Info_Char (Cursrc (P + 2));
1711 -- Entity is operator symbol
1713 elsif Cursrc (P) = '"' or else Cursrc (P) = '%' then
1714 Write_Info_Char (Cursrc (P));
1719 Write_Info_Char (Cursrc (P2));
1720 exit when Cursrc (P2) = Cursrc (P);
1723 -- Entity is identifier
1727 if Is_Start_Of_Wide_Char (Cursrc, P) then
1728 Scan_Wide (Cursrc, P, WC, Err);
1729 elsif not Identifier_Char (Cursrc (P)) then
1736 -- Write out the identifier by copying the exact
1737 -- source characters used in its declaration. Note
1738 -- that this means wide characters will be in their
1739 -- original encoded form.
1742 Original_Location (Sloc (XE.Ent)) .. P - 1
1744 Write_Info_Char (Cursrc (J));
1748 -- See if we have a renaming reference
1750 if Is_Object (XE.Ent)
1751 and then Present (Renamed_Object (XE.Ent))
1753 Rref := Renamed_Object (XE.Ent);
1755 elsif Is_Overloadable (XE.Ent)
1756 and then Nkind (Parent (Declaration_Node (XE.Ent))) =
1757 N_Subprogram_Renaming_Declaration
1759 Rref := Name (Parent (Declaration_Node (XE.Ent)));
1761 elsif Ekind (XE.Ent) = E_Package
1762 and then Nkind (Declaration_Node (XE.Ent)) =
1763 N_Package_Renaming_Declaration
1765 Rref := Name (Declaration_Node (XE.Ent));
1771 if Present (Rref) then
1772 if Nkind (Rref) = N_Expanded_Name then
1773 Rref := Selector_Name (Rref);
1776 if Nkind (Rref) = N_Identifier
1777 or else Nkind (Rref) = N_Operator_Symbol
1781 -- For renamed array components, use the array name
1782 -- for the renamed entity, which reflect the fact that
1783 -- in general the whole array is aliased.
1785 elsif Nkind (Rref) = N_Indexed_Component then
1786 if Nkind (Prefix (Rref)) = N_Identifier then
1787 Rref := Prefix (Rref);
1788 elsif Nkind (Prefix (Rref)) = N_Expanded_Name then
1789 Rref := Selector_Name (Prefix (Rref));
1799 -- Write out renaming reference if we have one
1801 if Present (Rref) then
1802 Write_Info_Char ('=');
1804 (Int (Get_Logical_Line_Number (Sloc (Rref))));
1805 Write_Info_Char (':');
1807 (Int (Get_Column_Number (Sloc (Rref))));
1810 -- Indicate that the entity is in the unit of the current
1815 -- Write out information about generic parent, if entity
1818 if Is_Generic_Instance (XE.Ent) then
1820 Gen_Par : constant Entity_Id :=
1823 (Unit_Declaration_Node (XE.Ent)));
1824 Loc : constant Source_Ptr := Sloc (Gen_Par);
1825 Gen_U : constant Unit_Number_Type :=
1826 Get_Source_Unit (Loc);
1829 Write_Info_Char ('[');
1830 if Curru /= Gen_U then
1831 Write_Info_Nat (Dependency_Num (Gen_U));
1832 Write_Info_Char ('|');
1836 (Int (Get_Logical_Line_Number (Loc)));
1837 Write_Info_Char (']');
1841 -- See if we have a type reference and if so output
1843 Check_Type_Reference (XE.Ent, False);
1845 if Is_Record_Type (XE.Ent)
1846 and then Present (Abstract_Interfaces (XE.Ent))
1852 Elmt := First_Elmt (Abstract_Interfaces (XE.Ent));
1853 while Present (Elmt) loop
1854 Check_Type_Reference (Node (Elmt), True);
1860 -- If the entity is an overriding operation, write
1861 -- info on operation that was overridden.
1863 if Is_Subprogram (XE.Ent)
1864 and then Is_Overriding_Operation (XE.Ent)
1866 Output_Overridden_Op (Overridden_Operation (XE.Ent));
1869 -- End of processing for entity output
1871 Crloc := No_Location;
1874 -- Output the reference
1876 if XE.Loc /= No_Location
1877 and then XE.Loc /= Crloc
1881 -- Start continuation if line full, else blank
1883 if Write_Info_Col > 72 then
1885 Write_Info_Initiate ('.');
1888 Write_Info_Char (' ');
1890 -- Output file number if changed
1892 if XE.Lun /= Curru then
1894 Write_Info_Nat (Dependency_Num (Curru));
1895 Write_Info_Char ('|');
1898 Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Loc)));
1899 Write_Info_Char (XE.Typ);
1901 if Is_Overloadable (XE.Ent)
1902 and then Is_Imported (XE.Ent)
1903 and then XE.Typ = 'b'
1905 Output_Import_Export_Info (XE.Ent);
1908 Write_Info_Nat (Int (Get_Column_Number (XE.Loc)));
1910 Output_Instantiation_Refs (Sloc (XE.Ent));
1921 end Output_References;