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