1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- R T S F I N D -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2003, 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Casing; use Casing; 29with Csets; use Csets; 30with Debug; use Debug; 31with Einfo; use Einfo; 32with Elists; use Elists; 33with Errout; use Errout; 34with Fname; use Fname; 35with Fname.UF; use Fname.UF; 36with Lib; use Lib; 37with Lib.Load; use Lib.Load; 38with Namet; use Namet; 39with Nlists; use Nlists; 40with Nmake; use Nmake; 41with Output; use Output; 42with Opt; use Opt; 43with Sem; use Sem; 44with Sem_Ch7; use Sem_Ch7; 45with Sem_Util; use Sem_Util; 46with Sinfo; use Sinfo; 47with Stand; use Stand; 48with Snames; use Snames; 49with Tbuild; use Tbuild; 50with Uname; use Uname; 51 52package body Rtsfind is 53 54 RTE_Available_Call : Boolean := False; 55 -- Set True during call to RTE from RTE_Available. Tells RTE to set 56 -- RTE_Is_Available to False rather than generating an error message. 57 58 RTE_Is_Available : Boolean; 59 -- Set True by RTE_Available on entry. When RTE_Available_Call is set 60 -- True, set False if RTE would otherwise generate an error message. 61 62 ---------------- 63 -- Unit table -- 64 ---------------- 65 66 -- The unit table has one entry for each unit included in the definition 67 -- of the type RTU_Id in the spec. The table entries are initialized in 68 -- Initialize to set the Entity field to Empty, indicating that the 69 -- corresponding unit has not yet been loaded. The fields are set when 70 -- a unit is loaded to contain the defining entity for the unit, the 71 -- unit name, and the unit number. 72 73 type RT_Unit_Table_Record is record 74 Entity : Entity_Id; 75 Uname : Unit_Name_Type; 76 Unum : Unit_Number_Type; 77 Withed : Boolean; 78 end record; 79 80 RT_Unit_Table : array (RTU_Id) of RT_Unit_Table_Record; 81 82 -------------------------- 83 -- Runtime Entity Table -- 84 -------------------------- 85 86 -- There is one entry in the runtime entity table for each entity that is 87 -- included in the definition of the RE_Id type in the spec. The entries 88 -- are set by Initialize_Rtsfind to contain Empty, indicating that the 89 -- entity has not yet been located. Once the entity is located for the 90 -- first time, its ID is stored in this array, so that subsequent calls 91 -- for the same entity can be satisfied immediately. 92 93 RE_Table : array (RE_Id) of Entity_Id; 94 95 -------------------------- 96 -- Generation of WITH's -- 97 -------------------------- 98 99 -- When a unit is implicitly loaded as a result of a call to RTE, it 100 -- is necessary to create an implicit WITH to ensure that the object 101 -- is correctly loaded by the binder. Such WITH statements are only 102 -- required when the request is from the extended main unit (if a 103 -- client needs a WITH, that will be taken care of when the client 104 -- is compiled). 105 106 -- We always attach the WITH to the main unit. This is not perfectly 107 -- accurate in terms of elaboration requirements, but it is close 108 -- enough, since the units that are accessed using rtsfind do not 109 -- have delicate elaboration requirements. 110 111 -- The flag Withed in the unit table record is initially set to False. 112 -- It is set True if a WITH has been generated for the main unit for 113 -- the corresponding unit. 114 115 ----------------------- 116 -- Local Subprograms -- 117 ----------------------- 118 119 procedure Entity_Not_Defined (Id : RE_Id); 120 -- Outputs error messages for an entity that is not defined in the 121 -- run-time library (the form of the error message is tailored for 122 -- no run time/configurable run time mode as required). 123 124 procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id); 125 -- Internal procedure called if we can't sucessfully locate or 126 -- process a run-time unit. The parameters give information about 127 -- the error message to be given. S is a reason for failing to 128 -- compile the file and U_Id is the unit id. RE_Id is the RE_Id 129 -- originally passed to RTE. The message in S is one of the 130 -- following: 131 -- 132 -- "not found" 133 -- "had parser errors" 134 -- "had semantic errors" 135 -- 136 -- The "not found" case is treated specially in that it is considered 137 -- a normal situation in configurable run-time mode (and the message in 138 -- this case is suppressed unless we are operating in All_Errors_Mode). 139 140 function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type; 141 -- Retrieves the Unit Name given a unit id represented by its 142 -- enumaration value in RTU_Id. 143 144 procedure Load_RTU 145 (U_Id : RTU_Id; 146 Id : RE_Id := RE_Null; 147 Use_Setting : Boolean := False); 148 -- Load the unit whose Id is given if not already loaded. The unit is 149 -- loaded, analyzed, and added to the WITH list, and the entry in 150 -- RT_Unit_Table is updated to reflect the load. The second parameter 151 -- indicates the initial setting for the Is_Potentially_Use_Visible 152 -- flag of the entity for the loaded unit (if it is indeed loaded). 153 -- A value of False means nothing special need be done. A value of 154 -- True indicates that this flag must be set to True. It is needed 155 -- only in the Text_IO_Kludge procedure, which may materialize an 156 -- entity of Text_IO (or Wide_Text_IO) that was previously unknown. 157 -- Id is the RE_Id value of the entity which was originally requested. 158 -- Id is used only for error message detail, and if it is RE_Null, then 159 -- the attempt to output the entity name is ignored. 160 161 procedure Output_Entity_Name (Id : RE_Id; Msg : String); 162 -- Output continuation error message giving qualified name of entity 163 -- corresponding to Id, appending the string given by Msg. This call 164 -- is only effective in All_Errors mode. 165 166 function RE_Chars (E : RE_Id) return Name_Id; 167 -- Given a RE_Id value returns the Chars of the corresponding entity. 168 169 procedure RTE_Error_Msg (Msg : String); 170 -- Generates a message by calling Error_Msg_N specifying Current_Error_Node 171 -- as the node location using the given Msg text. Special processing in the 172 -- case where RTE_Available_Call is set. In this case, no message is output 173 -- and instead RTE_Is_Available is set to False. Note that this can only be 174 -- used if you are sure that the message comes directly or indirectly from 175 -- a call to the RTE function. 176 177 ------------------- 178 -- Get_Unit_Name -- 179 ------------------- 180 181 function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type is 182 Uname_Chars : constant String := RTU_Id'Image (U_Id); 183 184 begin 185 Name_Len := Uname_Chars'Length; 186 Name_Buffer (1 .. Name_Len) := Uname_Chars; 187 Set_Casing (All_Lower_Case); 188 189 if U_Id in Ada_Child then 190 Name_Buffer (4) := '.'; 191 192 if U_Id in Ada_Calendar_Child then 193 Name_Buffer (13) := '.'; 194 195 elsif U_Id in Ada_Finalization_Child then 196 Name_Buffer (17) := '.'; 197 198 elsif U_Id in Ada_Interrupts_Child then 199 Name_Buffer (15) := '.'; 200 201 elsif U_Id in Ada_Real_Time_Child then 202 Name_Buffer (14) := '.'; 203 204 elsif U_Id in Ada_Streams_Child then 205 Name_Buffer (12) := '.'; 206 207 elsif U_Id in Ada_Text_IO_Child then 208 Name_Buffer (12) := '.'; 209 210 elsif U_Id in Ada_Wide_Text_IO_Child then 211 Name_Buffer (17) := '.'; 212 end if; 213 214 elsif U_Id in Interfaces_Child then 215 Name_Buffer (11) := '.'; 216 217 elsif U_Id in System_Child then 218 Name_Buffer (7) := '.'; 219 220 if U_Id in System_Tasking_Child then 221 Name_Buffer (15) := '.'; 222 end if; 223 224 if U_Id in System_Tasking_Restricted_Child then 225 Name_Buffer (26) := '.'; 226 end if; 227 228 if U_Id in System_Tasking_Protected_Objects_Child then 229 Name_Buffer (33) := '.'; 230 end if; 231 232 if U_Id in System_Tasking_Async_Delays_Child then 233 Name_Buffer (28) := '.'; 234 end if; 235 end if; 236 237 -- Add %s at end for spec 238 239 Name_Buffer (Name_Len + 1) := '%'; 240 Name_Buffer (Name_Len + 2) := 's'; 241 Name_Len := Name_Len + 2; 242 243 return Name_Find; 244 end Get_Unit_Name; 245 246 ---------------- 247 -- Initialize -- 248 ---------------- 249 250 procedure Initialize is 251 begin 252 -- Initialize the unit table 253 254 for J in RTU_Id loop 255 RT_Unit_Table (J).Entity := Empty; 256 end loop; 257 258 for J in RE_Id loop 259 RE_Table (J) := Empty; 260 end loop; 261 262 RTE_Is_Available := False; 263 end Initialize; 264 265 ------------ 266 -- Is_RTE -- 267 ------------ 268 269 function Is_RTE (Ent : Entity_Id; E : RE_Id) return Boolean is 270 E_Unit_Name : Unit_Name_Type; 271 Ent_Unit_Name : Unit_Name_Type; 272 273 S : Entity_Id; 274 E1 : Entity_Id; 275 E2 : Entity_Id; 276 277 begin 278 if No (Ent) then 279 return False; 280 281 -- If E has already a corresponding entity, check it directly, 282 -- going to full views if they exist to deal with the incomplete 283 -- and private type cases properly. 284 285 elsif Present (RE_Table (E)) then 286 E1 := Ent; 287 288 if Is_Type (E1) and then Present (Full_View (E1)) then 289 E1 := Full_View (E1); 290 end if; 291 292 E2 := RE_Table (E); 293 294 if Is_Type (E2) and then Present (Full_View (E2)) then 295 E2 := Full_View (E2); 296 end if; 297 298 return E1 = E2; 299 end if; 300 301 -- If the unit containing E is not loaded, we already know that 302 -- the entity we have cannot have come from this unit. 303 304 E_Unit_Name := Get_Unit_Name (RE_Unit_Table (E)); 305 306 if not Is_Loaded (E_Unit_Name) then 307 return False; 308 end if; 309 310 -- Here the unit containing the entity is loaded. We have not made 311 -- an explicit call to RTE to get the entity in question, but we may 312 -- have obtained a reference to it indirectly from some other entity 313 -- in the same unit, or some other unit that references it. 314 315 -- Get the defining unit of the entity 316 317 S := Scope (Ent); 318 319 if Ekind (S) /= E_Package then 320 return False; 321 end if; 322 323 Ent_Unit_Name := Get_Unit_Name (Unit_Declaration_Node (S)); 324 325 -- If the defining unit of the entity we are testing is not the 326 -- unit containing E, then they cannot possibly match. 327 328 if Ent_Unit_Name /= E_Unit_Name then 329 return False; 330 end if; 331 332 -- If the units match, then compare the names (remember that no 333 -- overloading is permitted in entities fetched using Rtsfind). 334 335 if RE_Chars (E) = Chars (Ent) then 336 RE_Table (E) := Ent; 337 338 -- If front-end inlining is enabled, we may be within a body that 339 -- contains inlined functions, which has not been retrieved through 340 -- rtsfind, and therefore is not yet recorded in the RT_Unit_Table. 341 -- Add the unit information now, it must be fully available. 342 343 declare 344 U : RT_Unit_Table_Record 345 renames RT_Unit_Table (RE_Unit_Table (E)); 346 begin 347 if No (U.Entity) then 348 U.Entity := S; 349 U.Uname := E_Unit_Name; 350 U.Unum := Get_Source_Unit (S); 351 end if; 352 end; 353 354 return True; 355 else 356 return False; 357 end if; 358 end Is_RTE; 359 360 ------------ 361 -- Is_RTU -- 362 ------------ 363 364 function Is_RTU (Ent : Entity_Id; U : RTU_Id) return Boolean is 365 E : constant Entity_Id := RT_Unit_Table (U).Entity; 366 begin 367 return Present (E) and then E = Ent; 368 end Is_RTU; 369 370 ---------------------------- 371 -- Is_Text_IO_Kludge_Unit -- 372 ---------------------------- 373 374 function Is_Text_IO_Kludge_Unit (Nam : Node_Id) return Boolean is 375 Prf : Node_Id; 376 Sel : Node_Id; 377 378 begin 379 if Nkind (Nam) /= N_Expanded_Name then 380 return False; 381 end if; 382 383 Prf := Prefix (Nam); 384 Sel := Selector_Name (Nam); 385 386 if Nkind (Sel) /= N_Expanded_Name 387 or else Nkind (Prf) /= N_Identifier 388 or else Chars (Prf) /= Name_Ada 389 then 390 return False; 391 end if; 392 393 Prf := Prefix (Sel); 394 Sel := Selector_Name (Sel); 395 396 return 397 Nkind (Prf) = N_Identifier 398 and then 399 (Chars (Prf) = Name_Text_IO or else Chars (Prf) = Name_Wide_Text_IO) 400 and then 401 Nkind (Sel) = N_Identifier 402 and then 403 Chars (Sel) in Text_IO_Package_Name; 404 end Is_Text_IO_Kludge_Unit; 405 406 ------------------------ 407 -- Entity_Not_Defined -- 408 ------------------------ 409 410 procedure Entity_Not_Defined (Id : RE_Id) is 411 begin 412 if No_Run_Time_Mode then 413 RTE_Error_Msg ("|construct not allowed in no run time mode"); 414 elsif Configurable_Run_Time_Mode then 415 RTE_Error_Msg ("|construct not allowed in this configuration>"); 416 else 417 RTE_Error_Msg ("run-time configuration error"); 418 end if; 419 420 Output_Entity_Name (Id, "not defined"); 421 end Entity_Not_Defined; 422 423 --------------- 424 -- Load_Fail -- 425 --------------- 426 427 procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id) is 428 M : String (1 .. 100); 429 P : Natural := 0; 430 431 begin 432 -- Output header message 433 434 if Configurable_Run_Time_Mode then 435 RTE_Error_Msg ("construct not allowed in configurable run-time mode"); 436 else 437 RTE_Error_Msg ("run-time library configuration error"); 438 end if; 439 440 -- Output file name and reason string 441 442 if S /= "not found" 443 or else not Configurable_Run_Time_Mode 444 or else All_Errors_Mode 445 then 446 M (1 .. 6) := "\file "; 447 P := 6; 448 449 Get_Name_String 450 (Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False)); 451 M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); 452 P := P + Name_Len; 453 454 M (P + 1) := ' '; 455 P := P + 1; 456 457 M (P + 1 .. P + S'Length) := S; 458 P := P + S'Length; 459 460 RTE_Error_Msg (M (1 .. P)); 461 462 -- Output entity name 463 464 Output_Entity_Name (Id, "not available"); 465 end if; 466 467 raise RE_Not_Available; 468 end Load_Fail; 469 470 -------------- 471 -- Load_RTU -- 472 -------------- 473 474 procedure Load_RTU 475 (U_Id : RTU_Id; 476 Id : RE_Id := RE_Null; 477 Use_Setting : Boolean := False) 478 is 479 U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); 480 Priv_Par : constant Elist_Id := New_Elmt_List; 481 Lib_Unit : Node_Id; 482 483 procedure Save_Private_Visibility; 484 -- If the current unit is the body of child unit or the spec of a 485 -- private child unit, the private declarations of the parent (s) 486 -- are visible. If the unit to be loaded is another public sibling, 487 -- its compilation will affect the visibility of the common ancestors. 488 -- Indicate those that must be restored. 489 490 procedure Restore_Private_Visibility; 491 -- Restore the visibility of ancestors after compiling RTU. 492 493 -------------------------------- 494 -- Restore_Private_Visibility -- 495 -------------------------------- 496 497 procedure Restore_Private_Visibility is 498 E_Par : Elmt_Id; 499 500 begin 501 E_Par := First_Elmt (Priv_Par); 502 503 while Present (E_Par) loop 504 if not In_Private_Part (Node (E_Par)) then 505 Install_Private_Declarations (Node (E_Par)); 506 end if; 507 508 Next_Elmt (E_Par); 509 end loop; 510 end Restore_Private_Visibility; 511 512 ----------------------------- 513 -- Save_Private_Visibility -- 514 ----------------------------- 515 516 procedure Save_Private_Visibility is 517 Par : Entity_Id; 518 519 begin 520 Par := Scope (Current_Scope); 521 522 while Present (Par) 523 and then Par /= Standard_Standard 524 loop 525 if Ekind (Par) = E_Package 526 and then Is_Compilation_Unit (Par) 527 and then In_Private_Part (Par) 528 then 529 Append_Elmt (Par, Priv_Par); 530 end if; 531 532 Par := Scope (Par); 533 end loop; 534 end Save_Private_Visibility; 535 536 -- Start of processing for Load_RTU 537 538 begin 539 -- Nothing to do if unit is already loaded 540 541 if Present (U.Entity) then 542 return; 543 end if; 544 545 -- Note if secondary stack is used 546 547 if U_Id = System_Secondary_Stack then 548 Opt.Sec_Stack_Used := True; 549 end if; 550 551 -- Otherwise we need to load the unit, First build unit name 552 -- from the enumeration literal name in type RTU_Id. 553 554 U.Uname := Get_Unit_Name (U_Id); 555 U.Withed := False; 556 557 declare 558 Loaded : Boolean; 559 pragma Warnings (Off, Loaded); 560 begin 561 Loaded := Is_Loaded (U.Uname); 562 end; 563 564 -- Now do the load call, note that setting Error_Node to Empty is 565 -- a signal to Load_Unit that we will regard a failure to find the 566 -- file as a fatal error, and that it should not output any kind 567 -- of diagnostics, since we will take care of it here. 568 569 U.Unum := 570 Load_Unit 571 (Load_Name => U.Uname, 572 Required => False, 573 Subunit => False, 574 Error_Node => Empty); 575 576 if U.Unum = No_Unit then 577 Load_Fail ("not found", U_Id, Id); 578 elsif Fatal_Error (U.Unum) then 579 Load_Fail ("had parser errors", U_Id, Id); 580 end if; 581 582 -- Make sure that the unit is analyzed 583 584 declare 585 Was_Analyzed : constant Boolean := 586 Analyzed (Cunit (Current_Sem_Unit)); 587 588 begin 589 -- Pretend that the current unit is analyzed, in case it is System 590 -- or some such. This allows us to put some declarations, such as 591 -- exceptions and packed arrays of Boolean, into System even though 592 -- expanding them requires System... 593 594 -- This is a bit odd but works fine. If the RTS unit does not depend 595 -- in any way on the current unit, then it never gets back into the 596 -- current unit's tree, and the change we make to the current unit 597 -- tree is never noticed by anyone (it is undone in a moment). That 598 -- is the normal situation. 599 600 -- If the RTS Unit *does* depend on the current unit, for instance, 601 -- when you are compiling System, then you had better have finished 602 -- analyzing the part of System that is depended on before you try 603 -- to load the RTS Unit. This means having the System ordered in an 604 -- appropriate manner. 605 606 Set_Analyzed (Cunit (Current_Sem_Unit), True); 607 608 if not Analyzed (Cunit (U.Unum)) then 609 Save_Private_Visibility; 610 Semantics (Cunit (U.Unum)); 611 Restore_Private_Visibility; 612 613 if Fatal_Error (U.Unum) then 614 Load_Fail ("had semantic errors", U_Id, Id); 615 end if; 616 end if; 617 618 -- Undo the pretence 619 620 Set_Analyzed (Cunit (Current_Sem_Unit), Was_Analyzed); 621 end; 622 623 Lib_Unit := Unit (Cunit (U.Unum)); 624 U.Entity := Defining_Entity (Lib_Unit); 625 626 if Use_Setting then 627 Set_Is_Potentially_Use_Visible (U.Entity, True); 628 end if; 629 end Load_RTU; 630 631 ----------------------- 632 -- Output_Entity_Name -- 633 ------------------------ 634 635 procedure Output_Entity_Name (Id : RE_Id; Msg : String) is 636 M : String (1 .. 2048); 637 P : Natural := 0; 638 -- M (1 .. P) is current message to be output 639 640 RE_Image : constant String := RE_Id'Image (Id); 641 642 begin 643 if Id = RE_Null or else not All_Errors_Mode then 644 return; 645 end if; 646 647 M (1 .. 9) := "\entity """; 648 P := 9; 649 650 -- Add unit name to message, excluding %s or %b at end 651 652 Get_Name_String (Get_Unit_Name (RE_Unit_Table (Id))); 653 Name_Len := Name_Len - 2; 654 Set_Casing (Mixed_Case); 655 M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); 656 P := P + Name_Len; 657 658 -- Add a qualifying period 659 660 M (P + 1) := '.'; 661 P := P + 1; 662 663 -- Add entity name and closing quote to message 664 665 Name_Len := RE_Image'Length - 3; 666 Name_Buffer (1 .. Name_Len) := RE_Image (4 .. RE_Image'Length); 667 Set_Casing (Mixed_Case); 668 M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); 669 P := P + Name_Len; 670 M (P + 1) := '"'; 671 P := P + 1; 672 673 -- Add message 674 675 M (P + 1) := ' '; 676 P := P + 1; 677 M (P + 1 .. P + Msg'Length) := Msg; 678 P := P + Msg'Length; 679 680 -- Output message at current error node location 681 682 RTE_Error_Msg (M (1 .. P)); 683 end Output_Entity_Name; 684 685 -------------- 686 -- RE_Chars -- 687 -------------- 688 689 function RE_Chars (E : RE_Id) return Name_Id is 690 RE_Name_Chars : constant String := RE_Id'Image (E); 691 692 begin 693 -- Copy name skipping initial RE_ or RO_XX characters 694 695 if RE_Name_Chars (1 .. 2) = "RE" then 696 for J in 4 .. RE_Name_Chars'Last loop 697 Name_Buffer (J - 3) := Fold_Lower (RE_Name_Chars (J)); 698 end loop; 699 700 Name_Len := RE_Name_Chars'Length - 3; 701 702 else 703 for J in 7 .. RE_Name_Chars'Last loop 704 Name_Buffer (J - 6) := Fold_Lower (RE_Name_Chars (J)); 705 end loop; 706 707 Name_Len := RE_Name_Chars'Length - 6; 708 end if; 709 710 return Name_Find; 711 end RE_Chars; 712 713 --------- 714 -- RTE -- 715 --------- 716 717 function RTE (E : RE_Id) return Entity_Id is 718 U_Id : constant RTU_Id := RE_Unit_Table (E); 719 U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); 720 721 Lib_Unit : Node_Id; 722 Pkg_Ent : Entity_Id; 723 Ename : Name_Id; 724 725 -- The following flag is used to disable front-end inlining when RTE 726 -- is invoked. This prevents the analysis of other runtime bodies when 727 -- a particular spec is loaded through Rtsfind. This is both efficient, 728 -- and it prevents spurious visibility conflicts between use-visible 729 -- user entities, and entities in run-time packages. 730 731 -- In configurable run-time mode, subprograms marked Inlined_Always must 732 -- be inlined, so in the case we retain the Front_End_Inlining mode. 733 734 Save_Front_End_Inlining : Boolean; 735 736 function Check_CRT (Eid : Entity_Id) return Entity_Id; 737 -- Check entity Eid to ensure that configurable run-time restrictions 738 -- are met. May generate an error message and raise RE_Not_Available 739 -- if the entity E does not exist (i.e. Eid is Empty) 740 741 procedure Check_RPC; 742 -- Reject programs that make use of distribution features not supported 743 -- on the current target. On such targets (VMS, Vxworks, others?) we 744 -- only provide a minimal body for System.Rpc that only supplies an 745 -- implementation of partition_id. 746 747 function Find_Local_Entity (E : RE_Id) return Entity_Id; 748 -- This function is used when entity E is in this compilation's main 749 -- unit. It gets the value from the already compiled declaration. 750 751 function Make_Unit_Name (N : Node_Id) return Node_Id; 752 -- If the unit is a child unit, build fully qualified name for use 753 -- in With_Clause. 754 755 --------------- 756 -- Check_CRT -- 757 --------------- 758 759 function Check_CRT (Eid : Entity_Id) return Entity_Id is 760 begin 761 if No (Eid) then 762 Entity_Not_Defined (E); 763 raise RE_Not_Available; 764 765 -- Entity is available 766 767 else 768 -- If in No_Run_Time mode and entity is not in one of the 769 -- specially permitted units, raise the exception. 770 771 if No_Run_Time_Mode 772 and then not OK_No_Run_Time_Unit (U_Id) 773 then 774 Entity_Not_Defined (E); 775 raise RE_Not_Available; 776 end if; 777 778 -- Otherwise entity is accessible 779 780 return Eid; 781 end if; 782 end Check_CRT; 783 784 --------------- 785 -- Check_RPC -- 786 --------------- 787 788 procedure Check_RPC is 789 Body_Name : Unit_Name_Type; 790 Unum : Unit_Number_Type; 791 792 begin 793 -- Bypass this check if debug flag -gnatdR set 794 795 if Debug_Flag_RR then 796 return; 797 end if; 798 799 -- Otherwise we need the check if we are going after one of 800 -- the critical entities in System.RPC in stubs mode. 801 802 if (Distribution_Stub_Mode = Generate_Receiver_Stub_Body 803 or else 804 Distribution_Stub_Mode = Generate_Caller_Stub_Body) 805 and then (E = RE_Do_Rpc 806 or else E = RE_Do_Apc 807 or else E = RE_Params_Stream_Type 808 or else E = RE_RPC_Receiver) 809 then 810 -- Load body of System.Rpc, and abort if this is the body that is 811 -- provided by GNAT, for which these features are not supported 812 -- on current target. We identify the gnat body by the presence 813 -- of a local entity called Gnat in the first declaration. 814 815 Lib_Unit := Unit (Cunit (U.Unum)); 816 Body_Name := Get_Body_Name (Get_Unit_Name (Lib_Unit)); 817 Unum := 818 Load_Unit 819 (Load_Name => Body_Name, 820 Required => False, 821 Subunit => False, 822 Error_Node => Empty, 823 Renamings => True); 824 825 if Unum /= No_Unit then 826 declare 827 Decls : constant List_Id := 828 Declarations (Unit (Cunit (Unum))); 829 830 begin 831 if Present (Decls) 832 and then Nkind (First (Decls)) = N_Object_Declaration 833 and then 834 Chars (Defining_Identifier (First (Decls))) = Name_Gnat 835 then 836 Set_Standard_Error; 837 Write_Str ("distribution feature not supported"); 838 Write_Eol; 839 raise Unrecoverable_Error; 840 end if; 841 end; 842 end if; 843 end if; 844 end Check_RPC; 845 846 ------------------------ 847 -- Find_System_Entity -- 848 ------------------------ 849 850 function Find_Local_Entity (E : RE_Id) return Entity_Id is 851 RE_Str : String renames RE_Id'Image (E); 852 Ent : Entity_Id; 853 854 Save_Nam : constant String := Name_Buffer (1 .. Name_Len); 855 -- Save name buffer and length over call 856 857 begin 858 Name_Len := Natural'Max (0, RE_Str'Length - 3); 859 Name_Buffer (1 .. Name_Len) := 860 RE_Str (RE_Str'First + 3 .. RE_Str'Last); 861 862 Ent := Entity_Id (Get_Name_Table_Info (Name_Find)); 863 864 Name_Len := Save_Nam'Length; 865 Name_Buffer (1 .. Name_Len) := Save_Nam; 866 867 return Ent; 868 end Find_Local_Entity; 869 870 -------------------- 871 -- Make_Unit_Name -- 872 -------------------- 873 874 function Make_Unit_Name (N : Node_Id) return Node_Id is 875 Nam : Node_Id; 876 Scop : Entity_Id; 877 878 begin 879 Nam := New_Reference_To (U.Entity, Standard_Location); 880 Scop := Scope (U.Entity); 881 882 if Nkind (N) = N_Defining_Program_Unit_Name then 883 while Scop /= Standard_Standard loop 884 Nam := 885 Make_Expanded_Name (Standard_Location, 886 Chars => Chars (U.Entity), 887 Prefix => New_Reference_To (Scop, Standard_Location), 888 Selector_Name => Nam); 889 Set_Entity (Nam, U.Entity); 890 891 Scop := Scope (Scop); 892 end loop; 893 end if; 894 895 return Nam; 896 end Make_Unit_Name; 897 898 -- Start of processing for RTE 899 900 begin 901 -- Doing a rtsfind in system.ads is special, as we cannot do this 902 -- when compiling System itself. So if we are compiling system then 903 -- we should already have acquired and processed the declaration 904 -- of the entity. The test is to see if this compilation's main unit 905 -- is System. If so, return the value from the already compiled 906 -- declaration and otherwise do a regular find. 907 908 -- Not pleasant, but these kinds of annoying recursion when 909 -- writing an Ada compiler in Ada have to be broken somewhere! 910 911 if Present (Main_Unit_Entity) 912 and then Chars (Main_Unit_Entity) = Name_System 913 and then Analyzed (Main_Unit_Entity) 914 and then not Is_Child_Unit (Main_Unit_Entity) 915 then 916 return Check_CRT (Find_Local_Entity (E)); 917 end if; 918 919 Save_Front_End_Inlining := Front_End_Inlining; 920 Front_End_Inlining := Configurable_Run_Time_Mode; 921 922 -- Load unit if unit not previously loaded 923 924 if No (RE_Table (E)) then 925 Load_RTU (U_Id, Id => E); 926 Lib_Unit := Unit (Cunit (U.Unum)); 927 928 -- In the subprogram case, we are all done, the entity we want 929 -- is the entity for the subprogram itself. Note that we do not 930 -- bother to check that it is the entity that was requested. 931 -- the only way that could fail to be the case is if runtime is 932 -- hopelessly misconfigured, and it isn't worth testing for this. 933 934 if Nkind (Lib_Unit) = N_Subprogram_Declaration then 935 RE_Table (E) := U.Entity; 936 937 -- Otherwise we must have the package case. First check package 938 -- entity itself (e.g. RTE_Name for System.Interrupts.Name) 939 940 else 941 pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration); 942 Ename := RE_Chars (E); 943 944 -- First we search the package entity chain 945 946 Pkg_Ent := First_Entity (U.Entity); 947 while Present (Pkg_Ent) loop 948 if Ename = Chars (Pkg_Ent) then 949 RE_Table (E) := Pkg_Ent; 950 Check_RPC; 951 goto Found; 952 end if; 953 954 Next_Entity (Pkg_Ent); 955 end loop; 956 957 -- If we did not find the entity in the package entity chain, 958 -- then check if the package entity itself matches. Note that 959 -- we do this check after searching the entity chain, since 960 -- the rule is that in case of ambiguity, we prefer the entity 961 -- defined within the package, rather than the package itself. 962 963 if Ename = Chars (U.Entity) then 964 RE_Table (E) := U.Entity; 965 end if; 966 967 -- If we didn't find the entity we want, something is wrong. 968 -- We just leave RE_Table (E) set to Empty and the appropriate 969 -- action will be taken by Check_CRT when we exit. 970 971 end if; 972 end if; 973 974 -- See if we have to generate a WITH for this entity. We generate 975 -- a WITH if the current unit is part of the extended main code 976 -- unit, and if we have not already added the with. The WITH is 977 -- added to the appropriate unit (the current one). We do not need 978 -- to generate a WITH for an 979 980 <<Found>> 981 if (not U.Withed) 982 and then 983 In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit)) 984 and then not RTE_Available_Call 985 then 986 U.Withed := True; 987 988 declare 989 Withn : Node_Id; 990 Lib_Unit : Node_Id; 991 992 begin 993 Lib_Unit := Unit (Cunit (U.Unum)); 994 Withn := 995 Make_With_Clause (Standard_Location, 996 Name => 997 Make_Unit_Name 998 (Defining_Unit_Name (Specification (Lib_Unit)))); 999 Set_Library_Unit (Withn, Cunit (U.Unum)); 1000 Set_Corresponding_Spec (Withn, U.Entity); 1001 Set_First_Name (Withn, True); 1002 Set_Implicit_With (Withn, True); 1003 1004 Mark_Rewrite_Insertion (Withn); 1005 Append (Withn, Context_Items (Cunit (Current_Sem_Unit))); 1006 end; 1007 end if; 1008 1009 Front_End_Inlining := Save_Front_End_Inlining; 1010 return Check_CRT (RE_Table (E)); 1011 end RTE; 1012 1013 ------------------- 1014 -- RTE_Available -- 1015 ------------------- 1016 1017 function RTE_Available (E : RE_Id) return Boolean is 1018 Dummy : Entity_Id; 1019 pragma Warnings (Off, Dummy); 1020 1021 Result : Boolean; 1022 1023 Save_RTE_Available_Call : constant Boolean := RTE_Available_Call; 1024 Save_RTE_Is_Available : constant Boolean := RTE_Is_Available; 1025 -- These are saved recursively because the call to load a unit 1026 -- caused by an upper level call may perform a recursive call 1027 -- to this routine during analysis of the corresponding unit. 1028 1029 begin 1030 RTE_Available_Call := True; 1031 RTE_Is_Available := True; 1032 Dummy := RTE (E); 1033 Result := RTE_Is_Available; 1034 RTE_Available_Call := Save_RTE_Available_Call; 1035 RTE_Is_Available := Save_RTE_Is_Available; 1036 return Result; 1037 1038 exception 1039 when RE_Not_Available => 1040 RTE_Available_Call := Save_RTE_Available_Call; 1041 RTE_Is_Available := Save_RTE_Is_Available; 1042 return False; 1043 end RTE_Available; 1044 1045 ------------------- 1046 -- RTE_Error_Msg -- 1047 ------------------- 1048 1049 procedure RTE_Error_Msg (Msg : String) is 1050 begin 1051 if RTE_Available_Call then 1052 RTE_Is_Available := False; 1053 else 1054 Error_Msg_N (Msg, Current_Error_Node); 1055 1056 -- Bump count of violations if we are in configurable run-time 1057 -- mode and this is not a continuation message. 1058 1059 if Configurable_Run_Time_Mode and then Msg (1) /= '\' then 1060 Configurable_Run_Time_Violations := 1061 Configurable_Run_Time_Violations + 1; 1062 end if; 1063 end if; 1064 end RTE_Error_Msg; 1065 1066 -------------------- 1067 -- Text_IO_Kludge -- 1068 -------------------- 1069 1070 procedure Text_IO_Kludge (Nam : Node_Id) is 1071 Chrs : Name_Id; 1072 1073 type Name_Map_Type is array (Text_IO_Package_Name) of RTU_Id; 1074 1075 Name_Map : constant Name_Map_Type := Name_Map_Type'( 1076 Name_Decimal_IO => Ada_Text_IO_Decimal_IO, 1077 Name_Enumeration_IO => Ada_Text_IO_Enumeration_IO, 1078 Name_Fixed_IO => Ada_Text_IO_Fixed_IO, 1079 Name_Float_IO => Ada_Text_IO_Float_IO, 1080 Name_Integer_IO => Ada_Text_IO_Integer_IO, 1081 Name_Modular_IO => Ada_Text_IO_Modular_IO); 1082 1083 Wide_Name_Map : constant Name_Map_Type := Name_Map_Type'( 1084 Name_Decimal_IO => Ada_Wide_Text_IO_Decimal_IO, 1085 Name_Enumeration_IO => Ada_Wide_Text_IO_Enumeration_IO, 1086 Name_Fixed_IO => Ada_Wide_Text_IO_Fixed_IO, 1087 Name_Float_IO => Ada_Wide_Text_IO_Float_IO, 1088 Name_Integer_IO => Ada_Wide_Text_IO_Integer_IO, 1089 Name_Modular_IO => Ada_Wide_Text_IO_Modular_IO); 1090 1091 begin 1092 -- Nothing to do if name is not identifier or a selected component 1093 -- whose selector_name is not an identifier. 1094 1095 if Nkind (Nam) = N_Identifier then 1096 Chrs := Chars (Nam); 1097 1098 elsif Nkind (Nam) = N_Selected_Component 1099 and then Nkind (Selector_Name (Nam)) = N_Identifier 1100 then 1101 Chrs := Chars (Selector_Name (Nam)); 1102 1103 else 1104 return; 1105 end if; 1106 1107 -- Nothing to do if name is not one of the Text_IO subpackages 1108 -- Otherwise look through loaded units, and if we find Text_IO 1109 -- or Wide_Text_IO already loaded, then load the proper child. 1110 1111 if Chrs in Text_IO_Package_Name then 1112 for U in Main_Unit .. Last_Unit loop 1113 Get_Name_String (Unit_File_Name (U)); 1114 1115 if Name_Len = 12 then 1116 1117 -- Here is where we do the loads if we find one of the 1118 -- units Ada.Text_IO or Ada.Wide_Text_IO. An interesting 1119 -- detail is that these units may already be used (i.e. 1120 -- their In_Use flags may be set). Normally when the In_Use 1121 -- flag is set, the Is_Potentially_Use_Visible flag of all 1122 -- entities in the package is set, but the new entity we 1123 -- are mysteriously adding was not there to have its flag 1124 -- set at the time. So that's why we pass the extra parameter 1125 -- to RTU_Find, to make sure the flag does get set now. 1126 -- Given that those generic packages are in fact child units, 1127 -- we must indicate that they are visible. 1128 1129 if Name_Buffer (1 .. 12) = "a-textio.ads" then 1130 Load_RTU 1131 (Name_Map (Chrs), 1132 Use_Setting => In_Use (Cunit_Entity (U))); 1133 Set_Is_Visible_Child_Unit 1134 (RT_Unit_Table (Name_Map (Chrs)).Entity); 1135 1136 elsif Name_Buffer (1 .. 12) = "a-witeio.ads" then 1137 Load_RTU 1138 (Wide_Name_Map (Chrs), 1139 Use_Setting => In_Use (Cunit_Entity (U))); 1140 Set_Is_Visible_Child_Unit 1141 (RT_Unit_Table (Wide_Name_Map (Chrs)).Entity); 1142 end if; 1143 end if; 1144 end loop; 1145 end if; 1146 end Text_IO_Kludge; 1147 1148end Rtsfind; 1149