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