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