1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- L I B -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-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. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32pragma Style_Checks (All_Checks); 33-- Subprogram ordering not enforced in this unit 34-- (because of some logical groupings). 35 36with Atree; use Atree; 37with Csets; use Csets; 38with Einfo; use Einfo; 39with Fname; use Fname; 40with Nlists; use Nlists; 41with Output; use Output; 42with Sinfo; use Sinfo; 43with Sinput; use Sinput; 44with Stand; use Stand; 45with Stringt; use Stringt; 46with Tree_IO; use Tree_IO; 47with Uname; use Uname; 48with Widechar; use Widechar; 49 50package body Lib is 51 52 Switch_Storing_Enabled : Boolean := True; 53 -- Controlled by Enable_Switch_Storing/Disable_Switch_Storing 54 55 ----------------------- 56 -- Local Subprograms -- 57 ----------------------- 58 59 type SEU_Result is ( 60 Yes_Before, -- S1 is in same extended unit as S2 and appears before it 61 Yes_Same, -- S1 is in same extended unit as S2, Slocs are the same 62 Yes_After, -- S1 is in same extended unit as S2, and appears after it 63 No); -- S2 is not in same extended unit as S2 64 65 function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result; 66 -- Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns 67 -- value as described above. 68 69 function Get_Code_Or_Source_Unit 70 (S : Source_Ptr; 71 Unwind_Instances : Boolean) return Unit_Number_Type; 72 -- Common code for Get_Code_Unit (get unit of instantiation for location) 73 -- and Get_Source_Unit (get unit of template for location). 74 75 -------------------------------------------- 76 -- Access Functions for Unit Table Fields -- 77 -------------------------------------------- 78 79 function Cunit (U : Unit_Number_Type) return Node_Id is 80 begin 81 return Units.Table (U).Cunit; 82 end Cunit; 83 84 function Cunit_Entity (U : Unit_Number_Type) return Entity_Id is 85 begin 86 return Units.Table (U).Cunit_Entity; 87 end Cunit_Entity; 88 89 function Dependency_Num (U : Unit_Number_Type) return Nat is 90 begin 91 return Units.Table (U).Dependency_Num; 92 end Dependency_Num; 93 94 function Dynamic_Elab (U : Unit_Number_Type) return Boolean is 95 begin 96 return Units.Table (U).Dynamic_Elab; 97 end Dynamic_Elab; 98 99 function Error_Location (U : Unit_Number_Type) return Source_Ptr is 100 begin 101 return Units.Table (U).Error_Location; 102 end Error_Location; 103 104 function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type is 105 begin 106 return Units.Table (U).Expected_Unit; 107 end Expected_Unit; 108 109 function Fatal_Error (U : Unit_Number_Type) return Fatal_Type is 110 begin 111 return Units.Table (U).Fatal_Error; 112 end Fatal_Error; 113 114 function Generate_Code (U : Unit_Number_Type) return Boolean is 115 begin 116 return Units.Table (U).Generate_Code; 117 end Generate_Code; 118 119 function Has_RACW (U : Unit_Number_Type) return Boolean is 120 begin 121 return Units.Table (U).Has_RACW; 122 end Has_RACW; 123 124 function Ident_String (U : Unit_Number_Type) return Node_Id is 125 begin 126 return Units.Table (U).Ident_String; 127 end Ident_String; 128 129 function Loading (U : Unit_Number_Type) return Boolean is 130 begin 131 return Units.Table (U).Loading; 132 end Loading; 133 134 function Main_CPU (U : Unit_Number_Type) return Int is 135 begin 136 return Units.Table (U).Main_CPU; 137 end Main_CPU; 138 139 function Main_Priority (U : Unit_Number_Type) return Int is 140 begin 141 return Units.Table (U).Main_Priority; 142 end Main_Priority; 143 144 function Munit_Index (U : Unit_Number_Type) return Nat is 145 begin 146 return Units.Table (U).Munit_Index; 147 end Munit_Index; 148 149 function No_Elab_Code_All (U : Unit_Number_Type) return Boolean is 150 begin 151 return Units.Table (U).No_Elab_Code_All; 152 end No_Elab_Code_All; 153 154 function OA_Setting (U : Unit_Number_Type) return Character is 155 begin 156 return Units.Table (U).OA_Setting; 157 end OA_Setting; 158 159 function Source_Index (U : Unit_Number_Type) return Source_File_Index is 160 begin 161 return Units.Table (U).Source_Index; 162 end Source_Index; 163 164 function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type is 165 begin 166 return Units.Table (U).Unit_File_Name; 167 end Unit_File_Name; 168 169 function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type is 170 begin 171 return Units.Table (U).Unit_Name; 172 end Unit_Name; 173 174 ------------------------------------------ 175 -- Subprograms to Set Unit Table Fields -- 176 ------------------------------------------ 177 178 procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id) is 179 begin 180 Units.Table (U).Cunit := N; 181 end Set_Cunit; 182 183 procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id) is 184 begin 185 Units.Table (U).Cunit_Entity := E; 186 Set_Is_Compilation_Unit (E); 187 end Set_Cunit_Entity; 188 189 procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True) is 190 begin 191 Units.Table (U).Dynamic_Elab := B; 192 end Set_Dynamic_Elab; 193 194 procedure Set_Error_Location (U : Unit_Number_Type; W : Source_Ptr) is 195 begin 196 Units.Table (U).Error_Location := W; 197 end Set_Error_Location; 198 199 procedure Set_Fatal_Error (U : Unit_Number_Type; V : Fatal_Type) is 200 begin 201 Units.Table (U).Fatal_Error := V; 202 end Set_Fatal_Error; 203 204 procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True) is 205 begin 206 Units.Table (U).Generate_Code := B; 207 end Set_Generate_Code; 208 209 procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True) is 210 begin 211 Units.Table (U).Has_RACW := B; 212 end Set_Has_RACW; 213 214 procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id) is 215 begin 216 Units.Table (U).Ident_String := N; 217 end Set_Ident_String; 218 219 procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True) is 220 begin 221 Units.Table (U).Loading := B; 222 end Set_Loading; 223 224 procedure Set_Main_CPU (U : Unit_Number_Type; P : Int) is 225 begin 226 Units.Table (U).Main_CPU := P; 227 end Set_Main_CPU; 228 229 procedure Set_Main_Priority (U : Unit_Number_Type; P : Int) is 230 begin 231 Units.Table (U).Main_Priority := P; 232 end Set_Main_Priority; 233 234 procedure Set_No_Elab_Code_All 235 (U : Unit_Number_Type; 236 B : Boolean := True) 237 is 238 begin 239 Units.Table (U).No_Elab_Code_All := B; 240 end Set_No_Elab_Code_All; 241 242 procedure Set_OA_Setting (U : Unit_Number_Type; C : Character) is 243 begin 244 Units.Table (U).OA_Setting := C; 245 end Set_OA_Setting; 246 247 procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is 248 begin 249 Units.Table (U).Unit_Name := N; 250 end Set_Unit_Name; 251 252 ------------------------------ 253 -- Check_Same_Extended_Unit -- 254 ------------------------------ 255 256 function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result is 257 Sloc1 : Source_Ptr; 258 Sloc2 : Source_Ptr; 259 Sind1 : Source_File_Index; 260 Sind2 : Source_File_Index; 261 Inst1 : Source_Ptr; 262 Inst2 : Source_Ptr; 263 Unum1 : Unit_Number_Type; 264 Unum2 : Unit_Number_Type; 265 Unit1 : Node_Id; 266 Unit2 : Node_Id; 267 Depth1 : Nat; 268 Depth2 : Nat; 269 270 begin 271 if S1 = No_Location or else S2 = No_Location then 272 return No; 273 274 elsif S1 = Standard_Location then 275 if S2 = Standard_Location then 276 return Yes_Same; 277 else 278 return No; 279 end if; 280 281 elsif S2 = Standard_Location then 282 return No; 283 end if; 284 285 Sloc1 := S1; 286 Sloc2 := S2; 287 288 Unum1 := Get_Source_Unit (Sloc1); 289 Unum2 := Get_Source_Unit (Sloc2); 290 291 loop 292 -- Step 1: Check whether the two locations are in the same source 293 -- file. 294 295 Sind1 := Get_Source_File_Index (Sloc1); 296 Sind2 := Get_Source_File_Index (Sloc2); 297 298 if Sind1 = Sind2 then 299 if Sloc1 < Sloc2 then 300 return Yes_Before; 301 elsif Sloc1 > Sloc2 then 302 return Yes_After; 303 else 304 return Yes_Same; 305 end if; 306 end if; 307 308 -- Step 2: Check subunits. If a subunit is instantiated, follow the 309 -- instantiation chain rather than the stub chain. 310 311 Unit1 := Unit (Cunit (Unum1)); 312 Unit2 := Unit (Cunit (Unum2)); 313 Inst1 := Instantiation (Sind1); 314 Inst2 := Instantiation (Sind2); 315 316 if Nkind (Unit1) = N_Subunit 317 and then Present (Corresponding_Stub (Unit1)) 318 and then Inst1 = No_Location 319 then 320 if Nkind (Unit2) = N_Subunit 321 and then Present (Corresponding_Stub (Unit2)) 322 and then Inst2 = No_Location 323 then 324 -- Both locations refer to subunits which may have a common 325 -- ancestor. If they do, the deeper subunit must have a longer 326 -- unit name. Replace the deeper one with its corresponding 327 -- stub in order to find the nearest ancestor. 328 329 if Length_Of_Name (Unit_Name (Unum1)) < 330 Length_Of_Name (Unit_Name (Unum2)) 331 then 332 Sloc2 := Sloc (Corresponding_Stub (Unit2)); 333 Unum2 := Get_Source_Unit (Sloc2); 334 goto Continue; 335 336 else 337 Sloc1 := Sloc (Corresponding_Stub (Unit1)); 338 Unum1 := Get_Source_Unit (Sloc1); 339 goto Continue; 340 end if; 341 342 -- Sloc1 in subunit, Sloc2 not 343 344 else 345 Sloc1 := Sloc (Corresponding_Stub (Unit1)); 346 Unum1 := Get_Source_Unit (Sloc1); 347 goto Continue; 348 end if; 349 350 -- Sloc2 in subunit, Sloc1 not 351 352 elsif Nkind (Unit2) = N_Subunit 353 and then Present (Corresponding_Stub (Unit2)) 354 and then Inst2 = No_Location 355 then 356 Sloc2 := Sloc (Corresponding_Stub (Unit2)); 357 Unum2 := Get_Source_Unit (Sloc2); 358 goto Continue; 359 end if; 360 361 -- Step 3: Check instances. The two locations may yield a common 362 -- ancestor. 363 364 if Inst1 /= No_Location then 365 if Inst2 /= No_Location then 366 367 -- Both locations denote instantiations 368 369 Depth1 := Instantiation_Depth (Sloc1); 370 Depth2 := Instantiation_Depth (Sloc2); 371 372 if Depth1 < Depth2 then 373 Sloc2 := Inst2; 374 Unum2 := Get_Source_Unit (Sloc2); 375 goto Continue; 376 377 elsif Depth1 > Depth2 then 378 Sloc1 := Inst1; 379 Unum1 := Get_Source_Unit (Sloc1); 380 goto Continue; 381 382 else 383 Sloc1 := Inst1; 384 Sloc2 := Inst2; 385 Unum1 := Get_Source_Unit (Sloc1); 386 Unum2 := Get_Source_Unit (Sloc2); 387 goto Continue; 388 end if; 389 390 -- Sloc1 is an instantiation 391 392 else 393 Sloc1 := Inst1; 394 Unum1 := Get_Source_Unit (Sloc1); 395 goto Continue; 396 end if; 397 398 -- Sloc2 is an instantiation 399 400 elsif Inst2 /= No_Location then 401 Sloc2 := Inst2; 402 Unum2 := Get_Source_Unit (Sloc2); 403 goto Continue; 404 end if; 405 406 -- Step 4: One location in the spec, the other in the corresponding 407 -- body of the same unit. The location in the spec is considered 408 -- earlier. 409 410 if Nkind (Unit1) = N_Subprogram_Body 411 or else 412 Nkind (Unit1) = N_Package_Body 413 then 414 if Library_Unit (Cunit (Unum1)) = Cunit (Unum2) then 415 return Yes_After; 416 end if; 417 418 elsif Nkind (Unit2) = N_Subprogram_Body 419 or else 420 Nkind (Unit2) = N_Package_Body 421 then 422 if Library_Unit (Cunit (Unum2)) = Cunit (Unum1) then 423 return Yes_Before; 424 end if; 425 end if; 426 427 -- At this point it is certain that the two locations denote two 428 -- entirely separate units. 429 430 return No; 431 432 <<Continue>> 433 null; 434 end loop; 435 end Check_Same_Extended_Unit; 436 437 ------------------------------- 438 -- Compilation_Switches_Last -- 439 ------------------------------- 440 441 function Compilation_Switches_Last return Nat is 442 begin 443 return Compilation_Switches.Last; 444 end Compilation_Switches_Last; 445 446 --------------------------- 447 -- Enable_Switch_Storing -- 448 --------------------------- 449 450 procedure Enable_Switch_Storing is 451 begin 452 Switch_Storing_Enabled := True; 453 end Enable_Switch_Storing; 454 455 ---------------------------- 456 -- Disable_Switch_Storing -- 457 ---------------------------- 458 459 procedure Disable_Switch_Storing is 460 begin 461 Switch_Storing_Enabled := False; 462 end Disable_Switch_Storing; 463 464 ------------------------------ 465 -- Earlier_In_Extended_Unit -- 466 ------------------------------ 467 468 function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is 469 begin 470 return Check_Same_Extended_Unit (S1, S2) = Yes_Before; 471 end Earlier_In_Extended_Unit; 472 473 ----------------------- 474 -- Exact_Source_Name -- 475 ----------------------- 476 477 function Exact_Source_Name (Loc : Source_Ptr) return String is 478 U : constant Unit_Number_Type := Get_Source_Unit (Loc); 479 Buf : constant Source_Buffer_Ptr := Source_Text (Source_Index (U)); 480 Orig : constant Source_Ptr := Original_Location (Loc); 481 P : Source_Ptr; 482 483 WC : Char_Code; 484 Err : Boolean; 485 pragma Warnings (Off, WC); 486 pragma Warnings (Off, Err); 487 488 begin 489 -- Entity is character literal 490 491 if Buf (Orig) = ''' then 492 return String (Buf (Orig .. Orig + 2)); 493 494 -- Entity is operator symbol 495 496 elsif Buf (Orig) = '"' or else Buf (Orig) = '%' then 497 P := Orig; 498 499 loop 500 P := P + 1; 501 exit when Buf (P) = Buf (Orig); 502 end loop; 503 504 return String (Buf (Orig .. P)); 505 506 -- Entity is identifier 507 508 else 509 P := Orig; 510 511 loop 512 if Is_Start_Of_Wide_Char (Buf, P) then 513 Scan_Wide (Buf, P, WC, Err); 514 elsif not Identifier_Char (Buf (P)) then 515 exit; 516 else 517 P := P + 1; 518 end if; 519 end loop; 520 521 -- Write out the identifier by copying the exact source characters 522 -- used in its declaration. Note that this means wide characters will 523 -- be in their original encoded form. 524 525 return String (Buf (Orig .. P - 1)); 526 end if; 527 end Exact_Source_Name; 528 529 ---------------------------- 530 -- Entity_Is_In_Main_Unit -- 531 ---------------------------- 532 533 function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean is 534 S : Entity_Id; 535 536 begin 537 S := Scope (E); 538 539 while S /= Standard_Standard loop 540 if S = Main_Unit_Entity then 541 return True; 542 elsif Ekind (S) = E_Package and then Is_Child_Unit (S) then 543 return False; 544 else 545 S := Scope (S); 546 end if; 547 end loop; 548 549 return False; 550 end Entity_Is_In_Main_Unit; 551 552 -------------------------- 553 -- Generic_May_Lack_ALI -- 554 -------------------------- 555 556 function Generic_May_Lack_ALI (Sfile : File_Name_Type) return Boolean is 557 begin 558 -- We allow internal generic units to be used without having a 559 -- corresponding ALI files to help bootstrapping with older compilers 560 -- that did not support generating ALIs for such generics. It is safe 561 -- to do so because the only thing the generated code would contain 562 -- is the elaboration boolean, and we are careful to elaborate all 563 -- predefined units first anyway. 564 565 return Is_Internal_File_Name 566 (Fname => Sfile, 567 Renamings_Included => True); 568 end Generic_May_Lack_ALI; 569 570 ----------------------------- 571 -- Get_Code_Or_Source_Unit -- 572 ----------------------------- 573 574 function Get_Code_Or_Source_Unit 575 (S : Source_Ptr; 576 Unwind_Instances : Boolean) return Unit_Number_Type 577 is 578 begin 579 -- Search table unless we have No_Location, which can happen if the 580 -- relevant location has not been set yet. Happens for example when 581 -- we obtain Sloc (Cunit (Main_Unit)) before it is set. 582 583 if S /= No_Location then 584 declare 585 Source_File : Source_File_Index; 586 Source_Unit : Unit_Number_Type; 587 588 begin 589 Source_File := Get_Source_File_Index (S); 590 591 if Unwind_Instances then 592 while Template (Source_File) /= No_Source_File loop 593 Source_File := Template (Source_File); 594 end loop; 595 end if; 596 597 Source_Unit := Unit (Source_File); 598 599 if Source_Unit /= No_Unit then 600 return Source_Unit; 601 end if; 602 end; 603 end if; 604 605 -- If S was No_Location, or was not in the table, we must be in the main 606 -- source unit (and the value has not been placed in the table yet), 607 -- or in one of the configuration pragma files. 608 609 return Main_Unit; 610 end Get_Code_Or_Source_Unit; 611 612 ------------------- 613 -- Get_Code_Unit -- 614 ------------------- 615 616 function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type is 617 begin 618 return Get_Code_Or_Source_Unit (Top_Level_Location (S), 619 Unwind_Instances => False); 620 end Get_Code_Unit; 621 622 function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is 623 begin 624 return Get_Code_Unit (Sloc (N)); 625 end Get_Code_Unit; 626 627 ---------------------------- 628 -- Get_Compilation_Switch -- 629 ---------------------------- 630 631 function Get_Compilation_Switch (N : Pos) return String_Ptr is 632 begin 633 if N <= Compilation_Switches.Last then 634 return Compilation_Switches.Table (N); 635 636 else 637 return null; 638 end if; 639 end Get_Compilation_Switch; 640 641 ---------------------------------- 642 -- Get_Cunit_Entity_Unit_Number -- 643 ---------------------------------- 644 645 function Get_Cunit_Entity_Unit_Number 646 (E : Entity_Id) return Unit_Number_Type 647 is 648 begin 649 for U in Units.First .. Units.Last loop 650 if Cunit_Entity (U) = E then 651 return U; 652 end if; 653 end loop; 654 655 -- If not in the table, must be the main source unit, and we just 656 -- have not got it put into the table yet. 657 658 return Main_Unit; 659 end Get_Cunit_Entity_Unit_Number; 660 661 --------------------------- 662 -- Get_Cunit_Unit_Number -- 663 --------------------------- 664 665 function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type is 666 begin 667 for U in Units.First .. Units.Last loop 668 if Cunit (U) = N then 669 return U; 670 end if; 671 end loop; 672 673 -- If not in the table, must be a spec created for a main unit that is a 674 -- child subprogram body which we have not inserted into the table yet. 675 676 if N = Library_Unit (Cunit (Main_Unit)) then 677 return Main_Unit; 678 679 -- If it is anything else, something is seriously wrong, and we really 680 -- don't want to proceed, even if assertions are off, so we explicitly 681 -- raise an exception in this case to terminate compilation. 682 683 else 684 raise Program_Error; 685 end if; 686 end Get_Cunit_Unit_Number; 687 688 --------------------- 689 -- Get_Source_Unit -- 690 --------------------- 691 692 function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type is 693 begin 694 return Get_Code_Or_Source_Unit (S, Unwind_Instances => True); 695 end Get_Source_Unit; 696 697 function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is 698 begin 699 return Get_Source_Unit (Sloc (N)); 700 end Get_Source_Unit; 701 702 -------------------------------- 703 -- In_Extended_Main_Code_Unit -- 704 -------------------------------- 705 706 function In_Extended_Main_Code_Unit 707 (N : Node_Or_Entity_Id) return Boolean 708 is 709 begin 710 if Sloc (N) = Standard_Location then 711 return False; 712 713 elsif Sloc (N) = No_Location then 714 return False; 715 716 -- Special case Itypes to test the Sloc of the associated node. The 717 -- reason we do this is for possible calls from gigi after -gnatD 718 -- processing is complete in sprint. This processing updates the 719 -- sloc fields of all nodes in the tree, but itypes are not in the 720 -- tree so their slocs do not get updated. 721 722 elsif Nkind (N) = N_Defining_Identifier 723 and then Is_Itype (N) 724 then 725 return In_Extended_Main_Code_Unit (Associated_Node_For_Itype (N)); 726 727 -- Otherwise see if we are in the main unit 728 729 elsif Get_Code_Unit (Sloc (N)) = Get_Code_Unit (Cunit (Main_Unit)) then 730 return True; 731 732 -- Node may be in spec (or subunit etc) of main unit 733 734 else 735 return 736 In_Same_Extended_Unit (N, Cunit (Main_Unit)); 737 end if; 738 end In_Extended_Main_Code_Unit; 739 740 function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean is 741 begin 742 if Loc = Standard_Location then 743 return False; 744 745 elsif Loc = No_Location then 746 return False; 747 748 -- Otherwise see if we are in the main unit 749 750 elsif Get_Code_Unit (Loc) = Get_Code_Unit (Cunit (Main_Unit)) then 751 return True; 752 753 -- Location may be in spec (or subunit etc) of main unit 754 755 else 756 return 757 In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit))); 758 end if; 759 end In_Extended_Main_Code_Unit; 760 761 ---------------------------------- 762 -- In_Extended_Main_Source_Unit -- 763 ---------------------------------- 764 765 function In_Extended_Main_Source_Unit 766 (N : Node_Or_Entity_Id) return Boolean 767 is 768 Nloc : constant Source_Ptr := Sloc (N); 769 Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit)); 770 771 begin 772 -- If parsing, then use the global flag to indicate result 773 774 if Compiler_State = Parsing then 775 return Parsing_Main_Extended_Source; 776 777 -- Special value cases 778 779 elsif Nloc = Standard_Location then 780 return False; 781 782 elsif Nloc = No_Location then 783 return False; 784 785 -- Special case Itypes to test the Sloc of the associated node. The 786 -- reason we do this is for possible calls from gigi after -gnatD 787 -- processing is complete in sprint. This processing updates the 788 -- sloc fields of all nodes in the tree, but itypes are not in the 789 -- tree so their slocs do not get updated. 790 791 elsif Nkind (N) = N_Defining_Identifier 792 and then Is_Itype (N) 793 then 794 return In_Extended_Main_Source_Unit (Associated_Node_For_Itype (N)); 795 796 -- Otherwise compare original locations to see if in same unit 797 798 else 799 return 800 In_Same_Extended_Unit 801 (Original_Location (Nloc), Original_Location (Mloc)); 802 end if; 803 end In_Extended_Main_Source_Unit; 804 805 function In_Extended_Main_Source_Unit 806 (Loc : Source_Ptr) return Boolean 807 is 808 Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit)); 809 810 begin 811 -- If parsing, then use the global flag to indicate result 812 813 if Compiler_State = Parsing then 814 return Parsing_Main_Extended_Source; 815 816 -- Special value cases 817 818 elsif Loc = Standard_Location then 819 return False; 820 821 elsif Loc = No_Location then 822 return False; 823 824 -- Otherwise compare original locations to see if in same unit 825 826 else 827 return 828 In_Same_Extended_Unit 829 (Original_Location (Loc), Original_Location (Mloc)); 830 end if; 831 end In_Extended_Main_Source_Unit; 832 833 ------------------------ 834 -- In_Predefined_Unit -- 835 ------------------------ 836 837 function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean is 838 begin 839 return In_Predefined_Unit (Sloc (N)); 840 end In_Predefined_Unit; 841 842 function In_Predefined_Unit (S : Source_Ptr) return Boolean is 843 Unit : constant Unit_Number_Type := Get_Source_Unit (S); 844 File : constant File_Name_Type := Unit_File_Name (Unit); 845 begin 846 return Is_Predefined_File_Name (File); 847 end In_Predefined_Unit; 848 849 ----------------------- 850 -- In_Same_Code_Unit -- 851 ----------------------- 852 853 function In_Same_Code_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is 854 S1 : constant Source_Ptr := Sloc (N1); 855 S2 : constant Source_Ptr := Sloc (N2); 856 857 begin 858 if S1 = No_Location or else S2 = No_Location then 859 return False; 860 861 elsif S1 = Standard_Location then 862 return S2 = Standard_Location; 863 864 elsif S2 = Standard_Location then 865 return False; 866 end if; 867 868 return Get_Code_Unit (N1) = Get_Code_Unit (N2); 869 end In_Same_Code_Unit; 870 871 --------------------------- 872 -- In_Same_Extended_Unit -- 873 --------------------------- 874 875 function In_Same_Extended_Unit 876 (N1, N2 : Node_Or_Entity_Id) return Boolean 877 is 878 begin 879 return Check_Same_Extended_Unit (Sloc (N1), Sloc (N2)) /= No; 880 end In_Same_Extended_Unit; 881 882 function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is 883 begin 884 return Check_Same_Extended_Unit (S1, S2) /= No; 885 end In_Same_Extended_Unit; 886 887 ------------------------- 888 -- In_Same_Source_Unit -- 889 ------------------------- 890 891 function In_Same_Source_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is 892 S1 : constant Source_Ptr := Sloc (N1); 893 S2 : constant Source_Ptr := Sloc (N2); 894 895 begin 896 if S1 = No_Location or else S2 = No_Location then 897 return False; 898 899 elsif S1 = Standard_Location then 900 return S2 = Standard_Location; 901 902 elsif S2 = Standard_Location then 903 return False; 904 end if; 905 906 return Get_Source_Unit (N1) = Get_Source_Unit (N2); 907 end In_Same_Source_Unit; 908 909 ----------------------------- 910 -- Increment_Serial_Number -- 911 ----------------------------- 912 913 function Increment_Serial_Number return Nat is 914 TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number; 915 begin 916 TSN := TSN + 1; 917 return TSN; 918 end Increment_Serial_Number; 919 920 ---------------- 921 -- Initialize -- 922 ---------------- 923 924 procedure Initialize is 925 begin 926 Linker_Option_Lines.Init; 927 Notes.Init; 928 Load_Stack.Init; 929 Units.Init; 930 Compilation_Switches.Init; 931 end Initialize; 932 933 --------------- 934 -- Is_Loaded -- 935 --------------- 936 937 function Is_Loaded (Uname : Unit_Name_Type) return Boolean is 938 begin 939 for Unum in Units.First .. Units.Last loop 940 if Uname = Unit_Name (Unum) then 941 return True; 942 end if; 943 end loop; 944 945 return False; 946 end Is_Loaded; 947 948 --------------- 949 -- Last_Unit -- 950 --------------- 951 952 function Last_Unit return Unit_Number_Type is 953 begin 954 return Units.Last; 955 end Last_Unit; 956 957 ---------- 958 -- List -- 959 ---------- 960 961 procedure List (File_Names_Only : Boolean := False) is separate; 962 963 ---------- 964 -- Lock -- 965 ---------- 966 967 procedure Lock is 968 begin 969 Linker_Option_Lines.Locked := True; 970 Load_Stack.Locked := True; 971 Units.Locked := True; 972 Linker_Option_Lines.Release; 973 Load_Stack.Release; 974 Units.Release; 975 end Lock; 976 977 --------------- 978 -- Num_Units -- 979 --------------- 980 981 function Num_Units return Nat is 982 begin 983 return Int (Units.Last) - Int (Main_Unit) + 1; 984 end Num_Units; 985 986 ----------------- 987 -- Remove_Unit -- 988 ----------------- 989 990 procedure Remove_Unit (U : Unit_Number_Type) is 991 begin 992 if U = Units.Last then 993 Units.Decrement_Last; 994 end if; 995 end Remove_Unit; 996 997 ---------------------------------- 998 -- Replace_Linker_Option_String -- 999 ---------------------------------- 1000 1001 procedure Replace_Linker_Option_String 1002 (S : String_Id; Match_String : String) 1003 is 1004 begin 1005 if Match_String'Length > 0 then 1006 for J in 1 .. Linker_Option_Lines.Last loop 1007 String_To_Name_Buffer (Linker_Option_Lines.Table (J).Option); 1008 1009 if Match_String = Name_Buffer (1 .. Match_String'Length) then 1010 Linker_Option_Lines.Table (J).Option := S; 1011 return; 1012 end if; 1013 end loop; 1014 end if; 1015 1016 Store_Linker_Option_String (S); 1017 end Replace_Linker_Option_String; 1018 1019 ---------- 1020 -- Sort -- 1021 ---------- 1022 1023 procedure Sort (Tbl : in out Unit_Ref_Table) is separate; 1024 1025 ------------------------------ 1026 -- Store_Compilation_Switch -- 1027 ------------------------------ 1028 1029 procedure Store_Compilation_Switch (Switch : String) is 1030 begin 1031 if Switch_Storing_Enabled then 1032 Compilation_Switches.Increment_Last; 1033 Compilation_Switches.Table (Compilation_Switches.Last) := 1034 new String'(Switch); 1035 1036 -- Fix up --RTS flag which has been transformed by the gcc driver 1037 -- into -fRTS 1038 1039 if Switch'Last >= Switch'First + 4 1040 and then Switch (Switch'First .. Switch'First + 4) = "-fRTS" 1041 then 1042 Compilation_Switches.Table 1043 (Compilation_Switches.Last) (Switch'First + 1) := '-'; 1044 end if; 1045 end if; 1046 end Store_Compilation_Switch; 1047 1048 -------------------------------- 1049 -- Store_Linker_Option_String -- 1050 -------------------------------- 1051 1052 procedure Store_Linker_Option_String (S : String_Id) is 1053 begin 1054 Linker_Option_Lines.Append ((Option => S, Unit => Current_Sem_Unit)); 1055 end Store_Linker_Option_String; 1056 1057 ---------------- 1058 -- Store_Note -- 1059 ---------------- 1060 1061 procedure Store_Note (N : Node_Id) is 1062 Sfile : constant Source_File_Index := Get_Source_File_Index (Sloc (N)); 1063 1064 begin 1065 -- Notes for a generic are emitted when processing the template, never 1066 -- in instances. 1067 1068 if In_Extended_Main_Code_Unit (N) 1069 and then Instance (Sfile) = No_Instance_Id 1070 then 1071 Notes.Append (N); 1072 end if; 1073 end Store_Note; 1074 1075 ------------------------------- 1076 -- Synchronize_Serial_Number -- 1077 ------------------------------- 1078 1079 procedure Synchronize_Serial_Number is 1080 TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number; 1081 begin 1082 TSN := TSN + 1; 1083 end Synchronize_Serial_Number; 1084 1085 --------------- 1086 -- Tree_Read -- 1087 --------------- 1088 1089 procedure Tree_Read is 1090 N : Nat; 1091 S : String_Ptr; 1092 1093 begin 1094 Units.Tree_Read; 1095 1096 -- Read Compilation_Switches table. First release the memory occupied 1097 -- by the previously loaded switches. 1098 1099 for J in Compilation_Switches.First .. Compilation_Switches.Last loop 1100 Free (Compilation_Switches.Table (J)); 1101 end loop; 1102 1103 Tree_Read_Int (N); 1104 Compilation_Switches.Set_Last (N); 1105 1106 for J in 1 .. N loop 1107 Tree_Read_Str (S); 1108 Compilation_Switches.Table (J) := S; 1109 end loop; 1110 end Tree_Read; 1111 1112 ---------------- 1113 -- Tree_Write -- 1114 ---------------- 1115 1116 procedure Tree_Write is 1117 begin 1118 Units.Tree_Write; 1119 1120 -- Write Compilation_Switches table 1121 1122 Tree_Write_Int (Compilation_Switches.Last); 1123 1124 for J in 1 .. Compilation_Switches.Last loop 1125 Tree_Write_Str (Compilation_Switches.Table (J)); 1126 end loop; 1127 end Tree_Write; 1128 1129 ------------ 1130 -- Unlock -- 1131 ------------ 1132 1133 procedure Unlock is 1134 begin 1135 Linker_Option_Lines.Locked := False; 1136 Load_Stack.Locked := False; 1137 Units.Locked := False; 1138 end Unlock; 1139 1140 ----------------- 1141 -- Version_Get -- 1142 ----------------- 1143 1144 function Version_Get (U : Unit_Number_Type) return Word_Hex_String is 1145 begin 1146 return Get_Hex_String (Units.Table (U).Version); 1147 end Version_Get; 1148 1149 ------------------------ 1150 -- Version_Referenced -- 1151 ------------------------ 1152 1153 procedure Version_Referenced (S : String_Id) is 1154 begin 1155 Version_Ref.Append (S); 1156 end Version_Referenced; 1157 1158 --------------------- 1159 -- Write_Unit_Info -- 1160 --------------------- 1161 1162 procedure Write_Unit_Info 1163 (Unit_Num : Unit_Number_Type; 1164 Item : Node_Id; 1165 Prefix : String := ""; 1166 Withs : Boolean := False) 1167 is 1168 begin 1169 Write_Str (Prefix); 1170 Write_Unit_Name (Unit_Name (Unit_Num)); 1171 Write_Str (", unit "); 1172 Write_Int (Int (Unit_Num)); 1173 Write_Str (", "); 1174 Write_Int (Int (Item)); 1175 Write_Str ("="); 1176 Write_Str (Node_Kind'Image (Nkind (Item))); 1177 1178 if Item /= Original_Node (Item) then 1179 Write_Str (", orig = "); 1180 Write_Int (Int (Original_Node (Item))); 1181 Write_Str ("="); 1182 Write_Str (Node_Kind'Image (Nkind (Original_Node (Item)))); 1183 end if; 1184 1185 Write_Eol; 1186 1187 -- Skip the rest if we're not supposed to print the withs 1188 1189 if not Withs then 1190 return; 1191 end if; 1192 1193 declare 1194 Context_Item : Node_Id; 1195 1196 begin 1197 Context_Item := First (Context_Items (Cunit (Unit_Num))); 1198 while Present (Context_Item) 1199 and then (Nkind (Context_Item) /= N_With_Clause 1200 or else Limited_Present (Context_Item)) 1201 loop 1202 Context_Item := Next (Context_Item); 1203 end loop; 1204 1205 if Present (Context_Item) then 1206 Indent; 1207 Write_Line ("withs:"); 1208 Indent; 1209 1210 while Present (Context_Item) loop 1211 if Nkind (Context_Item) = N_With_Clause 1212 and then not Limited_Present (Context_Item) 1213 then 1214 pragma Assert (Present (Library_Unit (Context_Item))); 1215 Write_Unit_Name 1216 (Unit_Name 1217 (Get_Cunit_Unit_Number (Library_Unit (Context_Item)))); 1218 1219 if Implicit_With (Context_Item) then 1220 Write_Str (" -- implicit"); 1221 end if; 1222 1223 Write_Eol; 1224 end if; 1225 1226 Context_Item := Next (Context_Item); 1227 end loop; 1228 1229 Outdent; 1230 Write_Line ("end withs"); 1231 Outdent; 1232 end if; 1233 end; 1234 end Write_Unit_Info; 1235 1236end Lib; 1237