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