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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [lib-xref.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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