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