1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- L I B . L O A D -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Debug; use Debug; 28with Einfo; use Einfo; 29with Errout; use Errout; 30with Fname; use Fname; 31with Fname.UF; use Fname.UF; 32with Nlists; use Nlists; 33with Nmake; use Nmake; 34with Opt; use Opt; 35with Osint; use Osint; 36with Osint.C; use Osint.C; 37with Output; use Output; 38with Par; 39with Restrict; use Restrict; 40with Scn; use Scn; 41with Sinfo; use Sinfo; 42with Sinput; use Sinput; 43with Sinput.L; use Sinput.L; 44with Stand; use Stand; 45with Tbuild; use Tbuild; 46with Uname; use Uname; 47 48package body Lib.Load is 49 50 ----------------------- 51 -- Local Subprograms -- 52 ----------------------- 53 54 function From_Limited_With_Chain return Boolean; 55 -- Check whether a possible circular dependence includes units that 56 -- have been loaded through limited_with clauses, in which case there 57 -- is no real circularity. 58 59 function Spec_Is_Irrelevant 60 (Spec_Unit : Unit_Number_Type; 61 Body_Unit : Unit_Number_Type) return Boolean; 62 -- The Spec_Unit and Body_Unit parameters are the unit numbers of the 63 -- spec file that corresponds to the main unit which is a body. This 64 -- function determines if the spec file is irrelevant and will be 65 -- overridden by the body as described in RM 10.1.4(4). See description 66 -- in "Special Handling of Subprogram Bodies" for further details. 67 68 procedure Write_Dependency_Chain; 69 -- This procedure is used to generate error message info lines that 70 -- trace the current dependency chain when a load error occurs. 71 72 ------------------------------ 73 -- Change_Main_Unit_To_Spec -- 74 ------------------------------ 75 76 procedure Change_Main_Unit_To_Spec is 77 U : Unit_Record renames Units.Table (Main_Unit); 78 N : File_Name_Type; 79 X : Source_File_Index; 80 81 begin 82 -- Get name of unit body 83 84 Get_Name_String (U.Unit_File_Name); 85 86 -- Note: for the following we should really generalize and consult the 87 -- file name pattern data, but for now we just deal with the common 88 -- naming cases, which is probably good enough in practice ??? 89 90 -- Change .adb to .ads 91 92 if Name_Len >= 5 93 and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" 94 then 95 Name_Buffer (Name_Len) := 's'; 96 97 -- Change .2.ada to .1.ada (Rational convention) 98 99 elsif Name_Len >= 7 100 and then Name_Buffer (Name_Len - 5 .. Name_Len) = ".2.ada" 101 then 102 Name_Buffer (Name_Len - 4) := '1'; 103 104 -- Change .ada to _.ada (DEC convention) 105 106 elsif Name_Len >= 5 107 and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".ada" 108 then 109 Name_Buffer (Name_Len - 3 .. Name_Len + 1) := "_.ada"; 110 Name_Len := Name_Len + 1; 111 112 -- No match, don't make the change 113 114 else 115 return; 116 end if; 117 118 -- Try loading the spec 119 120 N := Name_Find; 121 X := Load_Source_File (N); 122 123 -- No change if we did not find the spec 124 125 if X = No_Source_File then 126 return; 127 end if; 128 129 -- Otherwise modify Main_Unit entry to point to spec 130 131 U.Unit_File_Name := N; 132 U.Source_Index := X; 133 end Change_Main_Unit_To_Spec; 134 135 ------------------------------- 136 -- Create_Dummy_Package_Unit -- 137 ------------------------------- 138 139 function Create_Dummy_Package_Unit 140 (With_Node : Node_Id; 141 Spec_Name : Unit_Name_Type) return Unit_Number_Type 142 is 143 Unum : Unit_Number_Type; 144 Cunit_Entity : Entity_Id; 145 Cunit : Node_Id; 146 Du_Name : Node_Or_Entity_Id; 147 End_Lab : Node_Id; 148 Save_CS : constant Boolean := Get_Comes_From_Source_Default; 149 150 begin 151 -- The created dummy package unit does not come from source 152 153 Set_Comes_From_Source_Default (False); 154 155 -- Normal package 156 157 if Nkind (Name (With_Node)) = N_Identifier then 158 Cunit_Entity := 159 Make_Defining_Identifier (No_Location, 160 Chars => Chars (Name (With_Node))); 161 Du_Name := Cunit_Entity; 162 End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location); 163 164 -- Child package 165 166 else 167 Cunit_Entity := 168 Make_Defining_Identifier (No_Location, 169 Chars => Chars (Selector_Name (Name (With_Node)))); 170 Du_Name := 171 Make_Defining_Program_Unit_Name (No_Location, 172 Name => Copy_Separate_Tree (Prefix (Name (With_Node))), 173 Defining_Identifier => Cunit_Entity); 174 175 Set_Is_Child_Unit (Cunit_Entity); 176 177 End_Lab := 178 Make_Designator (No_Location, 179 Name => Copy_Separate_Tree (Prefix (Name (With_Node))), 180 Identifier => New_Occurrence_Of (Cunit_Entity, No_Location)); 181 end if; 182 183 Set_Scope (Cunit_Entity, Standard_Standard); 184 185 Cunit := 186 Make_Compilation_Unit (No_Location, 187 Context_Items => Empty_List, 188 Unit => 189 Make_Package_Declaration (No_Location, 190 Specification => 191 Make_Package_Specification (No_Location, 192 Defining_Unit_Name => Du_Name, 193 Visible_Declarations => Empty_List, 194 End_Label => End_Lab)), 195 Aux_Decls_Node => 196 Make_Compilation_Unit_Aux (No_Location)); 197 198 -- Mark the dummy package as analyzed to prevent analysis of this 199 -- (non-existent) unit in -gnatQ mode because at the moment the 200 -- structure and attributes of this dummy package does not allow 201 -- a normal analysis of this unit 202 203 Set_Analyzed (Cunit); 204 205 Units.Increment_Last; 206 Unum := Units.Last; 207 208 Units.Table (Unum) := ( 209 Cunit => Cunit, 210 Cunit_Entity => Cunit_Entity, 211 Dependency_Num => 0, 212 Dynamic_Elab => False, 213 Error_Location => Sloc (With_Node), 214 Expected_Unit => Spec_Name, 215 Fatal_Error => True, 216 Generate_Code => False, 217 Has_Allocator => False, 218 Has_RACW => False, 219 Is_Compiler_Unit => False, 220 Ident_String => Empty, 221 Loading => False, 222 Main_Priority => Default_Main_Priority, 223 Main_CPU => Default_Main_CPU, 224 Munit_Index => 0, 225 Serial_Number => 0, 226 Source_Index => No_Source_File, 227 Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False), 228 Unit_Name => Spec_Name, 229 Version => 0, 230 OA_Setting => 'O'); 231 232 Set_Comes_From_Source_Default (Save_CS); 233 Set_Error_Posted (Cunit_Entity); 234 Set_Error_Posted (Cunit); 235 return Unum; 236 end Create_Dummy_Package_Unit; 237 238 ----------------------------- 239 -- From_Limited_With_Chain -- 240 ----------------------------- 241 242 function From_Limited_With_Chain return Boolean is 243 Curr_Num : constant Unit_Number_Type := 244 Load_Stack.Table (Load_Stack.Last).Unit_Number; 245 246 begin 247 -- True if the current load operation is through a limited_with clause 248 -- and we are not within a loop of regular with_clauses. 249 250 for U in reverse Load_Stack.First .. Load_Stack.Last - 1 loop 251 if Load_Stack.Table (U).Unit_Number = Curr_Num then 252 return False; 253 254 elsif Present (Load_Stack.Table (U).With_Node) 255 and then Limited_Present (Load_Stack.Table (U).With_Node) 256 then 257 return True; 258 end if; 259 end loop; 260 261 return False; 262 end From_Limited_With_Chain; 263 264 ---------------- 265 -- Initialize -- 266 ---------------- 267 268 procedure Initialize is 269 begin 270 Units.Init; 271 Load_Stack.Init; 272 end Initialize; 273 274 ------------------------ 275 -- Initialize_Version -- 276 ------------------------ 277 278 procedure Initialize_Version (U : Unit_Number_Type) is 279 begin 280 Units.Table (U).Version := Source_Checksum (Source_Index (U)); 281 end Initialize_Version; 282 283 ---------------------- 284 -- Load_Main_Source -- 285 ---------------------- 286 287 procedure Load_Main_Source is 288 Fname : File_Name_Type; 289 Version : Word := 0; 290 291 begin 292 Load_Stack.Increment_Last; 293 Load_Stack.Table (Load_Stack.Last) := (Main_Unit, Empty); 294 295 -- Initialize unit table entry for Main_Unit. Note that we don't know 296 -- the unit name yet, that gets filled in when the parser parses the 297 -- main unit, at which time a check is made that it matches the main 298 -- file name, and then the Unit_Name field is set. The Cunit and 299 -- Cunit_Entity fields also get filled in later by the parser. 300 301 Units.Increment_Last; 302 Fname := Next_Main_Source; 303 304 Units.Table (Main_Unit).Unit_File_Name := Fname; 305 306 if Fname /= No_File then 307 Main_Source_File := Load_Source_File (Fname); 308 Current_Error_Source_File := Main_Source_File; 309 310 if Main_Source_File /= No_Source_File then 311 Version := Source_Checksum (Main_Source_File); 312 end if; 313 314 Units.Table (Main_Unit) := ( 315 Cunit => Empty, 316 Cunit_Entity => Empty, 317 Dependency_Num => 0, 318 Dynamic_Elab => False, 319 Error_Location => No_Location, 320 Expected_Unit => No_Unit_Name, 321 Fatal_Error => False, 322 Generate_Code => False, 323 Has_Allocator => False, 324 Has_RACW => False, 325 Is_Compiler_Unit => False, 326 Ident_String => Empty, 327 Loading => True, 328 Main_Priority => Default_Main_Priority, 329 Main_CPU => Default_Main_CPU, 330 Munit_Index => 0, 331 Serial_Number => 0, 332 Source_Index => Main_Source_File, 333 Unit_File_Name => Fname, 334 Unit_Name => No_Unit_Name, 335 Version => Version, 336 OA_Setting => 'O'); 337 end if; 338 end Load_Main_Source; 339 340 --------------- 341 -- Load_Unit -- 342 --------------- 343 344 function Load_Unit 345 (Load_Name : Unit_Name_Type; 346 Required : Boolean; 347 Error_Node : Node_Id; 348 Subunit : Boolean; 349 Corr_Body : Unit_Number_Type := No_Unit; 350 Renamings : Boolean := False; 351 With_Node : Node_Id := Empty; 352 PMES : Boolean := False) return Unit_Number_Type 353 is 354 Calling_Unit : Unit_Number_Type; 355 Uname_Actual : Unit_Name_Type; 356 Unum : Unit_Number_Type; 357 Unump : Unit_Number_Type; 358 Fname : File_Name_Type; 359 Src_Ind : Source_File_Index; 360 Save_PMES : constant Boolean := Parsing_Main_Extended_Source; 361 362 Save_Cunit_Restrictions : constant Save_Cunit_Boolean_Restrictions := 363 Cunit_Boolean_Restrictions_Save; 364 -- Save current restrictions for restore at end 365 366 begin 367 Parsing_Main_Extended_Source := PMES; 368 369 -- Initialize restrictions to config restrictions for unit to load if 370 -- it is part of the main extended source, otherwise reset them. 371 372 -- Note: it's a bit odd but PMES is False for subunits, which is why 373 -- we have the OR here. Should be investigated some time??? 374 375 if PMES or Subunit then 376 Restore_Config_Cunit_Boolean_Restrictions; 377 else 378 Reset_Cunit_Boolean_Restrictions; 379 end if; 380 381 -- If renamings are allowed and we have a child unit name, then we 382 -- must first load the parent to deal with finding the real name. 383 -- Retain the with_clause that names the child, so that if it is 384 -- limited, the parent is loaded under the same condition. 385 386 if Renamings and then Is_Child_Name (Load_Name) then 387 Unump := 388 Load_Unit 389 (Load_Name => Get_Parent_Spec_Name (Load_Name), 390 Required => Required, 391 Subunit => False, 392 Renamings => True, 393 Error_Node => Error_Node, 394 With_Node => With_Node); 395 396 if Unump = No_Unit then 397 Parsing_Main_Extended_Source := Save_PMES; 398 return No_Unit; 399 end if; 400 401 -- If parent is a renaming, then we use the renamed package as 402 -- the actual parent for the subsequent load operation. 403 404 if Nkind (Unit (Cunit (Unump))) = N_Package_Renaming_Declaration then 405 Uname_Actual := 406 New_Child 407 (Load_Name, Get_Unit_Name (Name (Unit (Cunit (Unump))))); 408 409 -- If the load is for a with_clause, for visibility purposes both 410 -- the renamed entity and renaming one must be available in the 411 -- current unit: the renamed one in order to retrieve the child 412 -- unit, and the original one because it may be used as a prefix 413 -- in the body of the current unit. We add an explicit with_clause 414 -- for the original parent so that the renaming declaration is 415 -- properly loaded and analyzed. 416 417 if Present (With_Node) then 418 Insert_After (With_Node, 419 Make_With_Clause (Sloc (With_Node), 420 Name => Copy_Separate_Tree (Prefix (Name (With_Node))))); 421 end if; 422 423 -- Save the renaming entity, to establish its visibility when 424 -- installing the context. The implicit with is on this entity, 425 -- not on the package it renames. This is somewhat redundant given 426 -- the with_clause just created, but it simplifies subsequent 427 -- expansion of the current with_clause. Optimizable ??? 428 429 if Nkind (Error_Node) = N_With_Clause 430 and then Nkind (Name (Error_Node)) = N_Selected_Component 431 then 432 declare 433 Par : Node_Id := Name (Error_Node); 434 435 begin 436 while Nkind (Par) = N_Selected_Component 437 and then Chars (Selector_Name (Par)) /= 438 Chars (Cunit_Entity (Unump)) 439 loop 440 Par := Prefix (Par); 441 end loop; 442 443 -- Case of some intermediate parent is a renaming 444 445 if Nkind (Par) = N_Selected_Component then 446 Set_Entity (Selector_Name (Par), Cunit_Entity (Unump)); 447 448 -- Case where the ultimate parent is a renaming 449 450 else 451 Set_Entity (Par, Cunit_Entity (Unump)); 452 end if; 453 end; 454 end if; 455 456 -- If the parent is not a renaming, then get its name (this may 457 -- be different from the parent spec name obtained above because 458 -- of renamings higher up in the hierarchy). 459 460 else 461 Uname_Actual := New_Child (Load_Name, Unit_Name (Unump)); 462 end if; 463 464 -- Here if unit to be loaded is not a child unit 465 466 else 467 Uname_Actual := Load_Name; 468 end if; 469 470 Fname := Get_File_Name (Uname_Actual, Subunit); 471 472 if Debug_Flag_L then 473 Write_Eol; 474 Write_Str ("*** Load request for unit: "); 475 Write_Unit_Name (Load_Name); 476 477 if Required then 478 Write_Str (" (Required = True)"); 479 else 480 Write_Str (" (Required = False)"); 481 end if; 482 483 Write_Eol; 484 485 if Uname_Actual /= Load_Name then 486 Write_Str ("*** Actual unit loaded: "); 487 Write_Unit_Name (Uname_Actual); 488 end if; 489 end if; 490 491 -- Capture error location if it is for the main unit. The idea is to 492 -- post errors on the main unit location, not the most recent unit. 493 -- Note: Unit_Name (Main_Unit) is not set if we are parsing gnat.adc. 494 495 if Present (Error_Node) 496 and then Unit_Name (Main_Unit) /= No_Unit_Name 497 then 498 -- It seems like In_Extended_Main_Source_Unit (Error_Node) would 499 -- do the trick here, but that's wrong, it is much too early to 500 -- call this routine. We are still in the parser, and the required 501 -- semantic information is not established yet. So we base the 502 -- judgment on unit names. 503 504 Get_External_Unit_Name_String (Unit_Name (Main_Unit)); 505 506 declare 507 Main_Unit_Name : constant String := Name_Buffer (1 .. Name_Len); 508 509 begin 510 Get_External_Unit_Name_String 511 (Unit_Name (Get_Source_Unit (Error_Node))); 512 513 -- If the two names are identical, then for sure we are part 514 -- of the extended main unit 515 516 if Main_Unit_Name = Name_Buffer (1 .. Name_Len) then 517 Load_Msg_Sloc := Sloc (Error_Node); 518 519 -- If the load is called from a with_type clause, the error 520 -- node is correct. 521 522 -- Otherwise, check for the subunit case, and if so, consider 523 -- we have a match if one name is a prefix of the other name. 524 525 else 526 if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit 527 or else 528 Nkind (Unit (Cunit (Get_Source_Unit (Error_Node)))) = 529 N_Subunit 530 then 531 Name_Len := Integer'Min (Name_Len, Main_Unit_Name'Length); 532 533 if Name_Buffer (1 .. Name_Len) 534 = 535 Main_Unit_Name (1 .. Name_Len) 536 then 537 Load_Msg_Sloc := Sloc (Error_Node); 538 end if; 539 end if; 540 end if; 541 end; 542 end if; 543 544 -- If we are generating error messages, then capture calling unit 545 546 if Present (Error_Node) then 547 Calling_Unit := Get_Source_Unit (Error_Node); 548 else 549 Calling_Unit := No_Unit; 550 end if; 551 552 -- See if we already have an entry for this unit 553 554 Unum := Main_Unit; 555 while Unum <= Units.Last loop 556 exit when Uname_Actual = Units.Table (Unum).Unit_Name; 557 Unum := Unum + 1; 558 end loop; 559 560 -- Whether or not the entry was found, Unum is now the right value, 561 -- since it is one more than Units.Last (i.e. the index of the new 562 -- entry we will create) in the not found case. 563 564 -- A special check is necessary in the unit not found case. If the unit 565 -- is not found, but the file in which it lives has already been loaded, 566 -- then we have the problem that the file does not contain the unit that 567 -- is needed. We simply treat this as a file not found condition. 568 569 -- We skip this test in multiple unit per file mode since in this 570 -- case we can have multiple units from the same source file. 571 572 if Unum > Units.Last and then Get_Unit_Index (Uname_Actual) = 0 then 573 for J in Units.First .. Units.Last loop 574 if Fname = Units.Table (J).Unit_File_Name then 575 if Debug_Flag_L then 576 Write_Str (" file does not contain unit, Unit_Number = "); 577 Write_Int (Int (Unum)); 578 Write_Eol; 579 Write_Eol; 580 end if; 581 582 if Present (Error_Node) then 583 if Is_Predefined_File_Name (Fname) then 584 Error_Msg_Unit_1 := Uname_Actual; 585 Error_Msg 586 ("$$ is not a language defined unit", Load_Msg_Sloc); 587 else 588 Error_Msg_File_1 := Fname; 589 Error_Msg_Unit_1 := Uname_Actual; 590 Error_Msg ("File{ does not contain unit$", Load_Msg_Sloc); 591 end if; 592 593 Write_Dependency_Chain; 594 Unum := No_Unit; 595 goto Done; 596 597 else 598 Unum := No_Unit; 599 goto Done; 600 end if; 601 end if; 602 end loop; 603 end if; 604 605 -- If we are proceeding with load, then make load stack entry, 606 -- and indicate the kind of with_clause responsible for the load. 607 608 Load_Stack.Increment_Last; 609 Load_Stack.Table (Load_Stack.Last) := (Unum, With_Node); 610 611 -- Case of entry already in table 612 613 if Unum <= Units.Last then 614 615 -- Here is where we check for a circular dependency, which is 616 -- an attempt to load a unit which is currently in the process 617 -- of being loaded. We do *not* care about a circular chain that 618 -- leads back to a body, because this kind of circular dependence 619 -- legitimately occurs (e.g. two package bodies that contain 620 -- inlined subprogram referenced by the other). 621 622 -- Ada 2005 (AI-50217): We also ignore limited_with clauses, because 623 -- their purpose is precisely to create legal circular structures. 624 625 if Loading (Unum) 626 and then (Is_Spec_Name (Units.Table (Unum).Unit_Name) 627 or else Acts_As_Spec (Units.Table (Unum).Cunit)) 628 and then (Nkind (Error_Node) /= N_With_Clause 629 or else not Limited_Present (Error_Node)) 630 and then not From_Limited_With_Chain 631 then 632 if Debug_Flag_L then 633 Write_Str (" circular dependency encountered"); 634 Write_Eol; 635 end if; 636 637 if Present (Error_Node) then 638 Error_Msg ("circular unit dependency", Load_Msg_Sloc); 639 Write_Dependency_Chain; 640 else 641 Load_Stack.Decrement_Last; 642 end if; 643 644 Unum := No_Unit; 645 goto Done; 646 end if; 647 648 if Debug_Flag_L then 649 Write_Str (" unit already in file table, Unit_Number = "); 650 Write_Int (Int (Unum)); 651 Write_Eol; 652 end if; 653 654 Load_Stack.Decrement_Last; 655 goto Done; 656 657 -- Unit is not already in table, so try to open the file 658 659 else 660 if Debug_Flag_L then 661 Write_Str (" attempt unit load, Unit_Number = "); 662 Write_Int (Int (Unum)); 663 Write_Eol; 664 end if; 665 666 Src_Ind := Load_Source_File (Fname); 667 668 -- Make a partial entry in the file table, used even in the file not 669 -- found case to print the dependency chain including the last entry 670 671 Units.Increment_Last; 672 Units.Table (Unum).Unit_Name := Uname_Actual; 673 674 -- File was found 675 676 if Src_Ind /= No_Source_File then 677 Units.Table (Unum) := ( 678 Cunit => Empty, 679 Cunit_Entity => Empty, 680 Dependency_Num => 0, 681 Dynamic_Elab => False, 682 Error_Location => Sloc (Error_Node), 683 Expected_Unit => Uname_Actual, 684 Fatal_Error => False, 685 Generate_Code => False, 686 Has_Allocator => False, 687 Has_RACW => False, 688 Is_Compiler_Unit => False, 689 Ident_String => Empty, 690 Loading => True, 691 Main_Priority => Default_Main_Priority, 692 Main_CPU => Default_Main_CPU, 693 Munit_Index => 0, 694 Serial_Number => 0, 695 Source_Index => Src_Ind, 696 Unit_File_Name => Fname, 697 Unit_Name => Uname_Actual, 698 Version => Source_Checksum (Src_Ind), 699 OA_Setting => 'O'); 700 701 -- Parse the new unit 702 703 declare 704 Save_Index : constant Nat := Multiple_Unit_Index; 705 Save_PMES : constant Boolean := Parsing_Main_Extended_Source; 706 707 begin 708 Multiple_Unit_Index := Get_Unit_Index (Uname_Actual); 709 Units.Table (Unum).Munit_Index := Multiple_Unit_Index; 710 Initialize_Scanner (Unum, Source_Index (Unum)); 711 712 if Calling_Unit = Main_Unit and then Subunit then 713 Parsing_Main_Extended_Source := True; 714 end if; 715 716 Discard_List (Par (Configuration_Pragmas => False)); 717 718 Parsing_Main_Extended_Source := Save_PMES; 719 720 Multiple_Unit_Index := Save_Index; 721 Set_Loading (Unum, False); 722 end; 723 724 -- If spec is irrelevant, then post errors and quit 725 726 if Corr_Body /= No_Unit 727 and then Spec_Is_Irrelevant (Unum, Corr_Body) 728 then 729 Error_Msg_File_1 := Unit_File_Name (Corr_Body); 730 Error_Msg 731 ("cannot compile subprogram in file {!", Load_Msg_Sloc); 732 Error_Msg_File_1 := Unit_File_Name (Unum); 733 Error_Msg 734 ("\incorrect spec in file { must be removed first!", 735 Load_Msg_Sloc); 736 Unum := No_Unit; 737 goto Done; 738 end if; 739 740 -- If loaded unit had a fatal error, then caller inherits it! 741 742 if Units.Table (Unum).Fatal_Error 743 and then Present (Error_Node) 744 then 745 Units.Table (Calling_Unit).Fatal_Error := True; 746 end if; 747 748 -- Remove load stack entry and return the entry in the file table 749 750 Load_Stack.Decrement_Last; 751 752 -- All done, return unit number 753 754 goto Done; 755 756 -- Case of file not found 757 758 else 759 if Debug_Flag_L then 760 Write_Str (" file was not found, load failed"); 761 Write_Eol; 762 end if; 763 764 -- Generate message if unit required 765 766 if Required and then Present (Error_Node) then 767 if Is_Predefined_File_Name (Fname) then 768 769 -- This is a predefined library unit which is not present 770 -- in the run time. If a predefined unit is not available 771 -- it may very likely be the case that there is also pragma 772 -- Restriction forbidding its usage. This is typically the 773 -- case when building a configurable run time, where the 774 -- usage of certain run-time units is restricted by means 775 -- of both the corresponding pragma Restriction (such as 776 -- No_Calendar), and by not including the unit. Hence, we 777 -- check whether this predefined unit is forbidden, so that 778 -- the message about the restriction violation is generated, 779 -- if needed. 780 781 Check_Restricted_Unit (Load_Name, Error_Node); 782 783 Error_Msg_Unit_1 := Uname_Actual; 784 Error_Msg -- CODEFIX 785 ("$$ is not a predefined library unit", Load_Msg_Sloc); 786 787 else 788 Error_Msg_File_1 := Fname; 789 Error_Msg ("file{ not found", Load_Msg_Sloc); 790 end if; 791 792 Write_Dependency_Chain; 793 794 -- Remove unit from stack, to avoid cascaded errors on 795 -- subsequent missing files. 796 797 Load_Stack.Decrement_Last; 798 Units.Decrement_Last; 799 800 -- If unit not required, remove load stack entry and the junk 801 -- file table entry, and return No_Unit to indicate not found, 802 803 else 804 Load_Stack.Decrement_Last; 805 Units.Decrement_Last; 806 end if; 807 808 Unum := No_Unit; 809 goto Done; 810 end if; 811 end if; 812 813 -- Here to exit, with result in Unum 814 815 <<Done>> 816 Parsing_Main_Extended_Source := Save_PMES; 817 Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions); 818 return Unum; 819 end Load_Unit; 820 821 -------------------------- 822 -- Make_Child_Decl_Unit -- 823 -------------------------- 824 825 procedure Make_Child_Decl_Unit (N : Node_Id) is 826 Unit_Decl : constant Node_Id := Library_Unit (N); 827 828 begin 829 Units.Increment_Last; 830 Units.Table (Units.Last) := Units.Table (Get_Cunit_Unit_Number (N)); 831 Units.Table (Units.Last).Unit_Name := 832 Get_Spec_Name (Unit_Name (Get_Cunit_Unit_Number (N))); 833 Units.Table (Units.Last).Cunit := Unit_Decl; 834 Units.Table (Units.Last).Cunit_Entity := 835 Defining_Identifier 836 (Defining_Unit_Name (Specification (Unit (Unit_Decl)))); 837 838 -- The library unit created for of a child subprogram unit plays no 839 -- role in code generation and binding, so label it accordingly. 840 841 Units.Table (Units.Last).Generate_Code := False; 842 Set_Has_No_Elaboration_Code (Unit_Decl); 843 end Make_Child_Decl_Unit; 844 845 ------------------------ 846 -- Make_Instance_Unit -- 847 ------------------------ 848 849 -- If the unit is an instance, it appears as a package declaration, but 850 -- contains both declaration and body of the instance. The body becomes 851 -- the main unit of the compilation, and the declaration is inserted 852 -- at the end of the unit table. The main unit now has the name of a 853 -- body, which is constructed from the name of the original spec, 854 -- and is attached to the compilation node of the original unit. The 855 -- declaration has been attached to a new compilation unit node, and 856 -- code will have to be generated for it. 857 858 procedure Make_Instance_Unit (N : Node_Id; In_Main : Boolean) is 859 Sind : constant Source_File_Index := Source_Index (Main_Unit); 860 861 begin 862 Units.Increment_Last; 863 864 if In_Main then 865 Units.Table (Units.Last) := Units.Table (Main_Unit); 866 Units.Table (Units.Last).Cunit := Library_Unit (N); 867 Units.Table (Units.Last).Generate_Code := True; 868 Units.Table (Main_Unit).Cunit := N; 869 Units.Table (Main_Unit).Unit_Name := 870 Get_Body_Name 871 (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N)))); 872 Units.Table (Main_Unit).Version := Source_Checksum (Sind); 873 874 else 875 -- Duplicate information from instance unit, for the body. The unit 876 -- node N has been rewritten as a body, but it was placed in the 877 -- units table when first loaded as a declaration. 878 879 Units.Table (Units.Last) := Units.Table (Get_Cunit_Unit_Number (N)); 880 Units.Table (Units.Last).Cunit := Library_Unit (N); 881 end if; 882 end Make_Instance_Unit; 883 884 ------------------------ 885 -- Spec_Is_Irrelevant -- 886 ------------------------ 887 888 function Spec_Is_Irrelevant 889 (Spec_Unit : Unit_Number_Type; 890 Body_Unit : Unit_Number_Type) return Boolean 891 is 892 Sunit : constant Node_Id := Cunit (Spec_Unit); 893 Bunit : constant Node_Id := Cunit (Body_Unit); 894 895 begin 896 -- The spec is irrelevant if the body is a subprogram body, and the spec 897 -- is other than a subprogram spec or generic subprogram spec. Note that 898 -- the names must be the same, we don't need to check that, because we 899 -- already know that from the fact that the file names are the same. 900 901 return 902 Nkind (Unit (Bunit)) = N_Subprogram_Body 903 and then Nkind (Unit (Sunit)) /= N_Subprogram_Declaration 904 and then Nkind (Unit (Sunit)) /= N_Generic_Subprogram_Declaration; 905 end Spec_Is_Irrelevant; 906 907 -------------------- 908 -- Version_Update -- 909 -------------------- 910 911 procedure Version_Update (U : Node_Id; From : Node_Id) is 912 Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (U); 913 Fnum : constant Unit_Number_Type := Get_Cunit_Unit_Number (From); 914 begin 915 if Source_Index (Fnum) /= No_Source_File then 916 Units.Table (Unum).Version := 917 Units.Table (Unum).Version 918 xor 919 Source_Checksum (Source_Index (Fnum)); 920 end if; 921 end Version_Update; 922 923 ---------------------------- 924 -- Write_Dependency_Chain -- 925 ---------------------------- 926 927 procedure Write_Dependency_Chain is 928 begin 929 -- The dependency chain is only written if it is at least two entries 930 -- deep, otherwise it is trivial (the main unit depending on a unit 931 -- that it obviously directly depends on). 932 933 if Load_Stack.Last - 1 > Load_Stack.First then 934 for U in Load_Stack.First .. Load_Stack.Last - 1 loop 935 Error_Msg_Unit_1 := 936 Unit_Name (Load_Stack.Table (U).Unit_Number); 937 Error_Msg_Unit_2 := 938 Unit_Name (Load_Stack.Table (U + 1).Unit_Number); 939 Error_Msg ("$ depends on $!", Load_Msg_Sloc); 940 end loop; 941 end if; 942 end Write_Dependency_Chain; 943 944end Lib.Load; 945