OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [lib-xref.adb] - Blame information for rev 826

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.