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