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