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-2013, 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 Casing; use Casing; 28with Csets; use Csets; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Elists; use Elists; 32with Errout; use Errout; 33with Exp_Dist; use Exp_Dist; 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 Restrict; use Restrict; 44with Sem; use Sem; 45with Sem_Aux; use Sem_Aux; 46with Sem_Ch7; use Sem_Ch7; 47with Sem_Dist; use Sem_Dist; 48with Sem_Util; use Sem_Util; 49with Sinfo; use Sinfo; 50with Stand; use Stand; 51with Snames; use Snames; 52with Tbuild; use Tbuild; 53with Uname; use Uname; 54 55package body Rtsfind is 56 57 RTE_Available_Call : Boolean := False; 58 -- Set True during call to RTE from RTE_Available (or from call to 59 -- RTE_Record_Component from RTE_Record_Component_Available). Tells 60 -- the called subprogram to set RTE_Is_Available to False rather than 61 -- generating an error message. 62 63 RTE_Is_Available : Boolean; 64 -- Set True by RTE_Available on entry. When RTE_Available_Call is set 65 -- True, set False if RTE would otherwise generate an error message. 66 67 ---------------- 68 -- Unit table -- 69 ---------------- 70 71 -- The unit table has one entry for each unit included in the definition 72 -- of the type RTU_Id in the spec. The table entries are initialized in 73 -- Initialize to set the Entity field to Empty, indicating that the 74 -- corresponding unit has not yet been loaded. The fields are set when 75 -- a unit is loaded to contain the defining entity for the unit, the 76 -- unit name, and the unit number. 77 78 -- Note that a unit can be loaded either by a call to find an entity 79 -- within the unit (e.g. RTE), or by an explicit with of the unit. In 80 -- the latter case it is critical to make a call to Set_RTU_Loaded to 81 -- ensure that the entry in this table reflects the load. 82 83 -- A unit retrieved through rtsfind may end up in the context of several 84 -- other units, in addition to the main unit. These additional with_clauses 85 -- are needed to generate a proper traversal order for Inspector. To 86 -- minimize somewhat the redundancy created by numerous calls to rtsfind 87 -- from different units, we keep track of the list of implicit with_clauses 88 -- already created for the current loaded unit. 89 90 type RT_Unit_Table_Record is record 91 Entity : Entity_Id; 92 Uname : Unit_Name_Type; 93 First_Implicit_With : Node_Id; 94 Unum : Unit_Number_Type; 95 end record; 96 97 RT_Unit_Table : array (RTU_Id) of RT_Unit_Table_Record; 98 99 -------------------------- 100 -- Runtime Entity Table -- 101 -------------------------- 102 103 -- There is one entry in the runtime entity table for each entity that is 104 -- included in the definition of the RE_Id type in the spec. The entries 105 -- are set by Initialize_Rtsfind to contain Empty, indicating that the 106 -- entity has not yet been located. Once the entity is located for the 107 -- first time, its ID is stored in this array, so that subsequent calls 108 -- for the same entity can be satisfied immediately. 109 110 -- NOTE: In order to avoid conflicts between record components and subprgs 111 -- that have the same name (i.e. subprogram External_Tag and 112 -- component External_Tag of package Ada.Tags) this table is not used 113 -- with Record_Components. 114 115 RE_Table : array (RE_Id) of Entity_Id; 116 117 -------------------------------- 118 -- Generation of with_clauses -- 119 -------------------------------- 120 121 -- When a unit is implicitly loaded as a result of a call to RTE, it is 122 -- necessary to create one or two implicit with_clauses. We add such 123 -- with_clauses to the extended main unit if needed, and also to whatever 124 -- unit needs them, which is not necessarily the main unit. The former 125 -- ensures that the object is correctly loaded by the binder. The latter 126 -- is necessary for SofCheck Inspector. 127 128 -- The field First_Implicit_With in the unit table record are used to 129 -- avoid creating duplicate with_clauses. 130 131 ----------------------- 132 -- Local Subprograms -- 133 ----------------------- 134 135 function Check_CRT (E : RE_Id; Eid : Entity_Id) return Entity_Id; 136 -- Check entity Eid to ensure that configurable run-time restrictions are 137 -- met. May generate an error message (if RTE_Available_Call is false) and 138 -- raise RE_Not_Available if entity E does not exist (e.g. Eid is Empty). 139 -- Also check that entity is not overloaded. 140 141 procedure Entity_Not_Defined (Id : RE_Id); 142 -- Outputs error messages for an entity that is not defined in the run-time 143 -- library (the form of the error message is tailored for no run time or 144 -- configurable run time mode as required). 145 146 function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type; 147 -- Retrieves the Unit Name given a unit id represented by its enumeration 148 -- value in RTU_Id. 149 150 procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id); 151 pragma No_Return (Load_Fail); 152 -- Internal procedure called if we can't successfully locate or process a 153 -- run-time unit. The parameters give information about the error message 154 -- to be given. S is a reason for failing to compile the file and U_Id is 155 -- the unit id. RE_Id is the RE_Id originally passed to RTE. The message in 156 -- S is one of the following: 157 -- 158 -- "not found" 159 -- "had parser errors" 160 -- "had semantic errors" 161 -- 162 -- The "not found" case is treated specially in that it is considered 163 -- a normal situation in configurable run-time mode, and generates 164 -- a warning, but is otherwise ignored. 165 166 procedure Load_RTU 167 (U_Id : RTU_Id; 168 Id : RE_Id := RE_Null; 169 Use_Setting : Boolean := False); 170 -- Load the unit whose Id is given if not already loaded. The unit is 171 -- loaded and analyzed, and the entry in RT_Unit_Table is updated to 172 -- reflect the load. Use_Setting is used to indicate the initial setting 173 -- for the Is_Potentially_Use_Visible flag of the entity for the loaded 174 -- unit (if it is indeed loaded). A value of False means nothing special 175 -- need be done. A value of True indicates that this flag must be set to 176 -- True. It is needed only in the Text_IO_Kludge procedure, which may 177 -- materialize an entity of Text_IO (or [Wide_]Wide_Text_IO) that was 178 -- previously unknown. Id is the RE_Id value of the entity which was 179 -- originally requested. Id is used only for error message detail, and if 180 -- it is RE_Null, then the attempt to output the entity name is ignored. 181 182 function Make_Unit_Name 183 (U : RT_Unit_Table_Record; 184 N : Node_Id) return Node_Id; 185 -- If the unit is a child unit, build fully qualified name for use in 186 -- With_Clause. 187 188 procedure Maybe_Add_With (U : in out RT_Unit_Table_Record); 189 -- If necessary, add an implicit with_clause from the current unit to the 190 -- one represented by U. 191 192 procedure Output_Entity_Name (Id : RE_Id; Msg : String); 193 -- Output continuation error message giving qualified name of entity 194 -- corresponding to Id, appending the string given by Msg. This call 195 -- is only effective in All_Errors mode. 196 197 function RE_Chars (E : RE_Id) return Name_Id; 198 -- Given a RE_Id value returns the Chars of the corresponding entity 199 200 procedure RTE_Error_Msg (Msg : String); 201 -- Generates a message by calling Error_Msg_N specifying Current_Error_Node 202 -- as the node location using the given Msg text. Special processing in the 203 -- case where RTE_Available_Call is set. In this case, no message is output 204 -- and instead RTE_Is_Available is set to False. Note that this can only be 205 -- used if you are sure that the message comes directly or indirectly from 206 -- a call to the RTE function. 207 208 --------------- 209 -- Check_CRT -- 210 --------------- 211 212 function Check_CRT (E : RE_Id; Eid : Entity_Id) return Entity_Id is 213 U_Id : constant RTU_Id := RE_Unit_Table (E); 214 215 begin 216 if No (Eid) then 217 if RTE_Available_Call then 218 RTE_Is_Available := False; 219 else 220 Entity_Not_Defined (E); 221 end if; 222 223 raise RE_Not_Available; 224 225 -- Entity is available 226 227 else 228 -- If in No_Run_Time mode and entity is not in one of the 229 -- specially permitted units, raise the exception. 230 231 if No_Run_Time_Mode 232 and then not OK_No_Run_Time_Unit (U_Id) 233 then 234 Entity_Not_Defined (E); 235 raise RE_Not_Available; 236 end if; 237 238 -- Check entity is not overloaded, checking for special exceptions 239 240 if Has_Homonym (Eid) 241 and then E /= RE_Save_Occurrence 242 then 243 Set_Standard_Error; 244 Write_Str ("Run-time configuration error ("); 245 Write_Str ("rtsfind entity """); 246 Get_Decoded_Name_String (Chars (Eid)); 247 Set_Casing (Mixed_Case); 248 Write_Str (Name_Buffer (1 .. Name_Len)); 249 Write_Str (""" is overloaded)"); 250 Write_Eol; 251 raise Unrecoverable_Error; 252 end if; 253 254 -- Otherwise entity is accessible 255 256 return Eid; 257 end if; 258 end Check_CRT; 259 260 ------------------------ 261 -- Entity_Not_Defined -- 262 ------------------------ 263 264 procedure Entity_Not_Defined (Id : RE_Id) is 265 begin 266 if No_Run_Time_Mode then 267 268 -- If the error occurs when compiling the body of a predefined 269 -- unit for inlining purposes, the body must be illegal in this 270 -- mode, and there is no point in continuing. 271 272 if Is_Predefined_File_Name 273 (Unit_File_Name (Get_Source_Unit (Sloc (Current_Error_Node)))) 274 then 275 Error_Msg_N 276 ("construct not allowed in no run time mode!", 277 Current_Error_Node); 278 raise Unrecoverable_Error; 279 280 else 281 RTE_Error_Msg ("|construct not allowed in no run time mode"); 282 end if; 283 284 elsif Configurable_Run_Time_Mode then 285 RTE_Error_Msg ("|construct not allowed in this configuration>"); 286 else 287 RTE_Error_Msg ("run-time configuration error"); 288 end if; 289 290 Output_Entity_Name (Id, "not defined"); 291 end Entity_Not_Defined; 292 293 ------------------- 294 -- Get_Unit_Name -- 295 ------------------- 296 297 function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type is 298 Uname_Chars : constant String := RTU_Id'Image (U_Id); 299 300 begin 301 Name_Len := Uname_Chars'Length; 302 Name_Buffer (1 .. Name_Len) := Uname_Chars; 303 Set_Casing (All_Lower_Case); 304 305 if U_Id in Ada_Child then 306 Name_Buffer (4) := '.'; 307 308 if U_Id in Ada_Calendar_Child then 309 Name_Buffer (13) := '.'; 310 311 elsif U_Id in Ada_Dispatching_Child then 312 Name_Buffer (16) := '.'; 313 314 elsif U_Id in Ada_Interrupts_Child then 315 Name_Buffer (15) := '.'; 316 317 elsif U_Id in Ada_Numerics_Child then 318 Name_Buffer (13) := '.'; 319 320 elsif U_Id in Ada_Real_Time_Child then 321 Name_Buffer (14) := '.'; 322 323 elsif U_Id in Ada_Streams_Child then 324 Name_Buffer (12) := '.'; 325 326 elsif U_Id in Ada_Strings_Child then 327 Name_Buffer (12) := '.'; 328 329 elsif U_Id in Ada_Text_IO_Child then 330 Name_Buffer (12) := '.'; 331 332 elsif U_Id in Ada_Wide_Text_IO_Child then 333 Name_Buffer (17) := '.'; 334 335 elsif U_Id in Ada_Wide_Wide_Text_IO_Child then 336 Name_Buffer (22) := '.'; 337 end if; 338 339 elsif U_Id in Interfaces_Child then 340 Name_Buffer (11) := '.'; 341 342 elsif U_Id in System_Child then 343 Name_Buffer (7) := '.'; 344 345 if U_Id in System_Dim_Child then 346 Name_Buffer (11) := '.'; 347 end if; 348 349 if U_Id in System_Multiprocessors_Child then 350 Name_Buffer (23) := '.'; 351 end if; 352 353 if U_Id in System_Storage_Pools_Child then 354 Name_Buffer (21) := '.'; 355 end if; 356 357 if U_Id in System_Strings_Child then 358 Name_Buffer (15) := '.'; 359 end if; 360 361 if U_Id in System_Tasking_Child then 362 Name_Buffer (15) := '.'; 363 end if; 364 365 if U_Id in System_Tasking_Restricted_Child then 366 Name_Buffer (26) := '.'; 367 end if; 368 369 if U_Id in System_Tasking_Protected_Objects_Child then 370 Name_Buffer (33) := '.'; 371 end if; 372 373 if U_Id in System_Tasking_Async_Delays_Child then 374 Name_Buffer (28) := '.'; 375 end if; 376 end if; 377 378 -- Add %s at end for spec 379 380 Name_Buffer (Name_Len + 1) := '%'; 381 Name_Buffer (Name_Len + 2) := 's'; 382 Name_Len := Name_Len + 2; 383 384 return Name_Find; 385 end Get_Unit_Name; 386 387 ---------------- 388 -- Initialize -- 389 ---------------- 390 391 procedure Initialize is 392 begin 393 -- Initialize the unit table 394 395 for J in RTU_Id loop 396 RT_Unit_Table (J).Entity := Empty; 397 end loop; 398 399 for J in RE_Id loop 400 RE_Table (J) := Empty; 401 end loop; 402 403 RTE_Is_Available := False; 404 end Initialize; 405 406 ------------ 407 -- Is_RTE -- 408 ------------ 409 410 function Is_RTE (Ent : Entity_Id; E : RE_Id) return Boolean is 411 E_Unit_Name : Unit_Name_Type; 412 Ent_Unit_Name : Unit_Name_Type; 413 414 S : Entity_Id; 415 E1 : Entity_Id; 416 E2 : Entity_Id; 417 418 begin 419 if No (Ent) then 420 return False; 421 422 -- If E has already a corresponding entity, check it directly, 423 -- going to full views if they exist to deal with the incomplete 424 -- and private type cases properly. 425 426 elsif Present (RE_Table (E)) then 427 E1 := Ent; 428 429 if Is_Type (E1) and then Present (Full_View (E1)) then 430 E1 := Full_View (E1); 431 end if; 432 433 E2 := RE_Table (E); 434 435 if Is_Type (E2) and then Present (Full_View (E2)) then 436 E2 := Full_View (E2); 437 end if; 438 439 return E1 = E2; 440 end if; 441 442 -- If the unit containing E is not loaded, we already know that the 443 -- entity we have cannot have come from this unit. 444 445 E_Unit_Name := Get_Unit_Name (RE_Unit_Table (E)); 446 447 if not Is_Loaded (E_Unit_Name) then 448 return False; 449 end if; 450 451 -- Here the unit containing the entity is loaded. We have not made 452 -- an explicit call to RTE to get the entity in question, but we may 453 -- have obtained a reference to it indirectly from some other entity 454 -- in the same unit, or some other unit that references it. 455 456 -- Get the defining unit of the entity 457 458 S := Scope (Ent); 459 460 if Ekind (S) /= E_Package then 461 return False; 462 end if; 463 464 Ent_Unit_Name := Get_Unit_Name (Unit_Declaration_Node (S)); 465 466 -- If the defining unit of the entity we are testing is not the 467 -- unit containing E, then they cannot possibly match. 468 469 if Ent_Unit_Name /= E_Unit_Name then 470 return False; 471 end if; 472 473 -- If the units match, then compare the names (remember that no 474 -- overloading is permitted in entities fetched using Rtsfind). 475 476 if RE_Chars (E) = Chars (Ent) then 477 RE_Table (E) := Ent; 478 479 -- If front-end inlining is enabled, we may be within a body that 480 -- contains inlined functions, which has not been retrieved through 481 -- rtsfind, and therefore is not yet recorded in the RT_Unit_Table. 482 -- Add the unit information now, it must be fully available. 483 484 declare 485 U : RT_Unit_Table_Record 486 renames RT_Unit_Table (RE_Unit_Table (E)); 487 begin 488 if No (U.Entity) then 489 U.Entity := S; 490 U.Uname := E_Unit_Name; 491 U.Unum := Get_Source_Unit (S); 492 end if; 493 end; 494 495 return True; 496 else 497 return False; 498 end if; 499 end Is_RTE; 500 501 ------------ 502 -- Is_RTU -- 503 ------------ 504 505 function Is_RTU (Ent : Entity_Id; U : RTU_Id) return Boolean is 506 E : constant Entity_Id := RT_Unit_Table (U).Entity; 507 begin 508 return Present (E) and then E = Ent; 509 end Is_RTU; 510 511 ---------------------------- 512 -- Is_Text_IO_Kludge_Unit -- 513 ---------------------------- 514 515 function Is_Text_IO_Kludge_Unit (Nam : Node_Id) return Boolean is 516 Prf : Node_Id; 517 Sel : Node_Id; 518 519 begin 520 if Nkind (Nam) /= N_Expanded_Name then 521 return False; 522 end if; 523 524 Prf := Prefix (Nam); 525 Sel := Selector_Name (Nam); 526 527 if Nkind (Sel) /= N_Expanded_Name 528 or else Nkind (Prf) /= N_Identifier 529 or else Chars (Prf) /= Name_Ada 530 then 531 return False; 532 end if; 533 534 Prf := Prefix (Sel); 535 Sel := Selector_Name (Sel); 536 537 return 538 Nkind (Prf) = N_Identifier 539 and then 540 (Chars (Prf) = Name_Text_IO 541 or else 542 Chars (Prf) = Name_Wide_Text_IO 543 or else 544 Chars (Prf) = Name_Wide_Wide_Text_IO) 545 and then 546 Nkind (Sel) = N_Identifier 547 and then 548 Chars (Sel) in Text_IO_Package_Name; 549 end Is_Text_IO_Kludge_Unit; 550 551 --------------- 552 -- Load_Fail -- 553 --------------- 554 555 procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id) is 556 M : String (1 .. 100); 557 P : Natural := 0; 558 559 begin 560 -- Output header message 561 562 if Configurable_Run_Time_Mode then 563 RTE_Error_Msg ("construct not allowed in configurable run-time mode"); 564 else 565 RTE_Error_Msg ("run-time library configuration error"); 566 end if; 567 568 -- Output file name and reason string 569 570 M (1 .. 6) := "\file "; 571 P := 6; 572 573 Get_Name_String 574 (Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False)); 575 M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); 576 P := P + Name_Len; 577 578 M (P + 1) := ' '; 579 P := P + 1; 580 581 M (P + 1 .. P + S'Length) := S; 582 P := P + S'Length; 583 584 RTE_Error_Msg (M (1 .. P)); 585 586 -- Output entity name 587 588 Output_Entity_Name (Id, "not available"); 589 590 -- In configurable run time mode, we raise RE_Not_Available, and the 591 -- caller is expected to deal gracefully with this. In the case of a 592 -- call to RTE_Available, this exception will be caught in Rtsfind, 593 -- and result in a returned value of False for the call. 594 595 if Configurable_Run_Time_Mode then 596 raise RE_Not_Available; 597 598 -- Here we have a load failure in normal full run time mode. See if we 599 -- are in the context of an RTE_Available call. If so, we just raise 600 -- RE_Not_Available. This can happen if a unit is unavailable, which 601 -- happens for example in the VM case, where the run-time is not 602 -- complete, but we do not regard it as a configurable run-time. 603 -- If the caller has done an explicit call to RTE_Available, then 604 -- clearly the caller is prepared to deal with a result of False. 605 606 elsif RTE_Available_Call then 607 RTE_Is_Available := False; 608 raise RE_Not_Available; 609 610 -- If we are not in the context of an RTE_Available call, we are really 611 -- trying to load an entity that is not there, and that should never 612 -- happen, so in this case we signal a fatal error. 613 614 else 615 raise Unrecoverable_Error; 616 end if; 617 end Load_Fail; 618 619 -------------- 620 -- Load_RTU -- 621 -------------- 622 623 procedure Load_RTU 624 (U_Id : RTU_Id; 625 Id : RE_Id := RE_Null; 626 Use_Setting : Boolean := False) 627 is 628 U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); 629 Priv_Par : constant Elist_Id := New_Elmt_List; 630 Lib_Unit : Node_Id; 631 632 procedure Save_Private_Visibility; 633 -- If the current unit is the body of child unit or the spec of a 634 -- private child unit, the private declarations of the parent(s) are 635 -- visible. If the unit to be loaded is another public sibling, its 636 -- compilation will affect the visibility of the common ancestors. 637 -- Indicate those that must be restored. 638 639 procedure Restore_Private_Visibility; 640 -- Restore the visibility of ancestors after compiling RTU 641 642 -------------------------------- 643 -- Restore_Private_Visibility -- 644 -------------------------------- 645 646 procedure Restore_Private_Visibility is 647 E_Par : Elmt_Id; 648 649 begin 650 E_Par := First_Elmt (Priv_Par); 651 while Present (E_Par) loop 652 if not In_Private_Part (Node (E_Par)) then 653 Install_Private_Declarations (Node (E_Par)); 654 end if; 655 656 Next_Elmt (E_Par); 657 end loop; 658 end Restore_Private_Visibility; 659 660 ----------------------------- 661 -- Save_Private_Visibility -- 662 ----------------------------- 663 664 procedure Save_Private_Visibility is 665 Par : Entity_Id; 666 667 begin 668 Par := Scope (Current_Scope); 669 while Present (Par) 670 and then Par /= Standard_Standard 671 loop 672 if Ekind (Par) = E_Package 673 and then Is_Compilation_Unit (Par) 674 and then In_Private_Part (Par) 675 then 676 Append_Elmt (Par, Priv_Par); 677 end if; 678 679 Par := Scope (Par); 680 end loop; 681 end Save_Private_Visibility; 682 683 -- Start of processing for Load_RTU 684 685 begin 686 -- Nothing to do if unit is already loaded 687 688 if Present (U.Entity) then 689 return; 690 end if; 691 692 -- Note if secondary stack is used 693 694 if U_Id = System_Secondary_Stack then 695 Opt.Sec_Stack_Used := True; 696 end if; 697 698 -- Otherwise we need to load the unit, First build unit name 699 -- from the enumeration literal name in type RTU_Id. 700 701 U.Uname := Get_Unit_Name (U_Id); 702 U. First_Implicit_With := Empty; 703 704 -- Now do the load call, note that setting Error_Node to Empty is 705 -- a signal to Load_Unit that we will regard a failure to find the 706 -- file as a fatal error, and that it should not output any kind 707 -- of diagnostics, since we will take care of it here. 708 709 -- We save style checking switches and turn off style checking for 710 -- loading the unit, since we don't want any style checking! 711 712 declare 713 Save_Style_Check : constant Boolean := Style_Check; 714 begin 715 Style_Check := False; 716 U.Unum := 717 Load_Unit 718 (Load_Name => U.Uname, 719 Required => False, 720 Subunit => False, 721 Error_Node => Empty); 722 Style_Check := Save_Style_Check; 723 end; 724 725 -- Check for bad unit load 726 727 if U.Unum = No_Unit then 728 Load_Fail ("not found", U_Id, Id); 729 elsif Fatal_Error (U.Unum) then 730 Load_Fail ("had parser errors", U_Id, Id); 731 end if; 732 733 -- Make sure that the unit is analyzed 734 735 declare 736 Was_Analyzed : constant Boolean := 737 Analyzed (Cunit (Current_Sem_Unit)); 738 739 begin 740 -- Pretend that the current unit is analyzed, in case it is System 741 -- or some such. This allows us to put some declarations, such as 742 -- exceptions and packed arrays of Boolean, into System even though 743 -- expanding them requires System... 744 745 -- This is a bit odd but works fine. If the RTS unit does not depend 746 -- in any way on the current unit, then it never gets back into the 747 -- current unit's tree, and the change we make to the current unit 748 -- tree is never noticed by anyone (it is undone in a moment). That 749 -- is the normal situation. 750 751 -- If the RTS Unit *does* depend on the current unit, for instance, 752 -- when you are compiling System, then you had better have finished 753 -- analyzing the part of System that is depended on before you try to 754 -- load the RTS Unit. This means having the code in System ordered in 755 -- an appropriate manner. 756 757 Set_Analyzed (Cunit (Current_Sem_Unit), True); 758 759 if not Analyzed (Cunit (U.Unum)) then 760 761 -- If the unit is already loaded through a limited_with_clause, 762 -- the relevant entities must already be available. We do not 763 -- want to load and analyze the unit because this would create 764 -- a real semantic dependence when the purpose of the limited_with 765 -- is precisely to avoid such. 766 767 if From_With_Type (Cunit_Entity (U.Unum)) then 768 null; 769 770 else 771 Save_Private_Visibility; 772 Semantics (Cunit (U.Unum)); 773 Restore_Private_Visibility; 774 775 if Fatal_Error (U.Unum) then 776 Load_Fail ("had semantic errors", U_Id, Id); 777 end if; 778 end if; 779 end if; 780 781 -- Undo the pretence 782 783 Set_Analyzed (Cunit (Current_Sem_Unit), Was_Analyzed); 784 end; 785 786 Lib_Unit := Unit (Cunit (U.Unum)); 787 U.Entity := Defining_Entity (Lib_Unit); 788 789 if Use_Setting then 790 Set_Is_Potentially_Use_Visible (U.Entity, True); 791 end if; 792 end Load_RTU; 793 794 -------------------- 795 -- Make_Unit_Name -- 796 -------------------- 797 798 function Make_Unit_Name 799 (U : RT_Unit_Table_Record; 800 N : Node_Id) return Node_Id is 801 802 Nam : Node_Id; 803 Scop : Entity_Id; 804 805 begin 806 Nam := New_Reference_To (U.Entity, Standard_Location); 807 Scop := Scope (U.Entity); 808 809 if Nkind (N) = N_Defining_Program_Unit_Name then 810 while Scop /= Standard_Standard loop 811 Nam := 812 Make_Expanded_Name (Standard_Location, 813 Chars => Chars (U.Entity), 814 Prefix => New_Reference_To (Scop, Standard_Location), 815 Selector_Name => Nam); 816 Set_Entity (Nam, U.Entity); 817 818 Scop := Scope (Scop); 819 end loop; 820 end if; 821 822 return Nam; 823 end Make_Unit_Name; 824 825 -------------------- 826 -- Maybe_Add_With -- 827 -------------------- 828 829 procedure Maybe_Add_With (U : in out RT_Unit_Table_Record) is 830 begin 831 -- We do not need to generate a with_clause for a call issued from 832 -- RTE_Component_Available. However, for CodePeer, we need these 833 -- additional with's, because for a sequence like "if RTE_Available (X) 834 -- then ... RTE (X)" the RTE call fails to create some necessary 835 -- with's. 836 837 if RTE_Available_Call and then not Generate_SCIL then 838 return; 839 end if; 840 841 -- Avoid creating directly self-referential with clauses 842 843 if Current_Sem_Unit = U.Unum then 844 return; 845 end if; 846 847 -- Add the with_clause, if not already in the context of the 848 -- current compilation unit. 849 850 declare 851 LibUnit : constant Node_Id := Unit (Cunit (U.Unum)); 852 Clause : Node_Id; 853 Withn : Node_Id; 854 855 begin 856 Clause := U.First_Implicit_With; 857 while Present (Clause) loop 858 if Parent (Clause) = Cunit (Current_Sem_Unit) then 859 return; 860 end if; 861 862 Clause := Next_Implicit_With (Clause); 863 end loop; 864 865 Withn := 866 Make_With_Clause (Standard_Location, 867 Name => 868 Make_Unit_Name 869 (U, Defining_Unit_Name (Specification (LibUnit)))); 870 871 Set_Library_Unit (Withn, Cunit (U.Unum)); 872 Set_Corresponding_Spec (Withn, U.Entity); 873 Set_First_Name (Withn, True); 874 Set_Implicit_With (Withn, True); 875 Set_Next_Implicit_With (Withn, U.First_Implicit_With); 876 877 U.First_Implicit_With := Withn; 878 879 Mark_Rewrite_Insertion (Withn); 880 Append (Withn, Context_Items (Cunit (Current_Sem_Unit))); 881 Check_Restriction_No_Dependence (Name (Withn), Current_Error_Node); 882 end; 883 end Maybe_Add_With; 884 885 ------------------------ 886 -- Output_Entity_Name -- 887 ------------------------ 888 889 procedure Output_Entity_Name (Id : RE_Id; Msg : String) is 890 M : String (1 .. 2048); 891 P : Natural := 0; 892 -- M (1 .. P) is current message to be output 893 894 RE_Image : constant String := RE_Id'Image (Id); 895 896 begin 897 if Id = RE_Null then 898 return; 899 end if; 900 901 M (1 .. 9) := "\entity """; 902 P := 9; 903 904 -- Add unit name to message, excluding %s or %b at end 905 906 Get_Name_String (Get_Unit_Name (RE_Unit_Table (Id))); 907 Name_Len := Name_Len - 2; 908 Set_Casing (Mixed_Case); 909 M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); 910 P := P + Name_Len; 911 912 -- Add a qualifying period 913 914 M (P + 1) := '.'; 915 P := P + 1; 916 917 -- Add entity name and closing quote to message 918 919 Name_Len := RE_Image'Length - 3; 920 Name_Buffer (1 .. Name_Len) := RE_Image (4 .. RE_Image'Length); 921 Set_Casing (Mixed_Case); 922 M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); 923 P := P + Name_Len; 924 M (P + 1) := '"'; 925 P := P + 1; 926 927 -- Add message 928 929 M (P + 1) := ' '; 930 P := P + 1; 931 M (P + 1 .. P + Msg'Length) := Msg; 932 P := P + Msg'Length; 933 934 -- Output message at current error node location 935 936 RTE_Error_Msg (M (1 .. P)); 937 end Output_Entity_Name; 938 939 -------------- 940 -- RE_Chars -- 941 -------------- 942 943 function RE_Chars (E : RE_Id) return Name_Id is 944 RE_Name_Chars : constant String := RE_Id'Image (E); 945 946 begin 947 -- Copy name skipping initial RE_ or RO_XX characters 948 949 if RE_Name_Chars (1 .. 2) = "RE" then 950 for J in 4 .. RE_Name_Chars'Last loop 951 Name_Buffer (J - 3) := Fold_Lower (RE_Name_Chars (J)); 952 end loop; 953 954 Name_Len := RE_Name_Chars'Length - 3; 955 956 else 957 for J in 7 .. RE_Name_Chars'Last loop 958 Name_Buffer (J - 6) := Fold_Lower (RE_Name_Chars (J)); 959 end loop; 960 961 Name_Len := RE_Name_Chars'Length - 6; 962 end if; 963 964 return Name_Find; 965 end RE_Chars; 966 967 --------- 968 -- RTE -- 969 --------- 970 971 function RTE (E : RE_Id) return Entity_Id is 972 U_Id : constant RTU_Id := RE_Unit_Table (E); 973 U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); 974 975 Lib_Unit : Node_Id; 976 Pkg_Ent : Entity_Id; 977 Ename : Name_Id; 978 979 -- The following flag is used to disable front-end inlining when RTE 980 -- is invoked. This prevents the analysis of other runtime bodies when 981 -- a particular spec is loaded through Rtsfind. This is both efficient, 982 -- and it prevents spurious visibility conflicts between use-visible 983 -- user entities, and entities in run-time packages. 984 985 Save_Front_End_Inlining : Boolean; 986 987 procedure Check_RPC; 988 -- Reject programs that make use of distribution features not supported 989 -- on the current target. Also check that the PCS is compatible with 990 -- the code generator version. On such targets (VMS, Vxworks, others?) 991 -- we provide a minimal body for System.Rpc that only supplies an 992 -- implementation of Partition_Id. 993 994 function Find_Local_Entity (E : RE_Id) return Entity_Id; 995 -- This function is used when entity E is in this compilation's main 996 -- unit. It gets the value from the already compiled declaration. 997 998 --------------- 999 -- Check_RPC -- 1000 --------------- 1001 1002 procedure Check_RPC is 1003 begin 1004 -- Bypass this check if debug flag -gnatdR set 1005 1006 if Debug_Flag_RR then 1007 return; 1008 end if; 1009 1010 -- Otherwise we need the check if we are going after one of the 1011 -- critical entities in System.RPC / System.Partition_Interface. 1012 1013 if E = RE_Do_Rpc 1014 or else 1015 E = RE_Do_Apc 1016 or else 1017 E = RE_Params_Stream_Type 1018 or else 1019 E = RE_Request_Access 1020 then 1021 -- If generating RCI stubs, check that we have a real PCS 1022 1023 if (Distribution_Stub_Mode = Generate_Receiver_Stub_Body 1024 or else 1025 Distribution_Stub_Mode = Generate_Caller_Stub_Body) 1026 and then Get_PCS_Name = Name_No_DSA 1027 then 1028 Set_Standard_Error; 1029 Write_Str ("distribution feature not supported"); 1030 Write_Eol; 1031 raise Unrecoverable_Error; 1032 1033 -- In all cases, check Exp_Dist and System.Partition_Interface 1034 -- consistency. 1035 1036 elsif Get_PCS_Version /= 1037 Exp_Dist.PCS_Version_Number (Get_PCS_Name) 1038 then 1039 Set_Standard_Error; 1040 Write_Str ("PCS version mismatch: expander "); 1041 Write_Int (Exp_Dist.PCS_Version_Number (Get_PCS_Name)); 1042 Write_Str (", PCS ("); 1043 Write_Name (Get_PCS_Name); 1044 Write_Str (") "); 1045 Write_Int (Get_PCS_Version); 1046 Write_Eol; 1047 raise Unrecoverable_Error; 1048 end if; 1049 end if; 1050 end Check_RPC; 1051 1052 ----------------------- 1053 -- Find_Local_Entity -- 1054 ----------------------- 1055 1056 function Find_Local_Entity (E : RE_Id) return Entity_Id is 1057 RE_Str : constant String := RE_Id'Image (E); 1058 Nam : Name_Id; 1059 Ent : Entity_Id; 1060 1061 Save_Nam : constant String := Name_Buffer (1 .. Name_Len); 1062 -- Save name buffer and length over call 1063 1064 begin 1065 Name_Len := Natural'Max (0, RE_Str'Length - 3); 1066 Name_Buffer (1 .. Name_Len) := 1067 RE_Str (RE_Str'First + 3 .. RE_Str'Last); 1068 1069 Nam := Name_Find; 1070 Ent := Entity_Id (Get_Name_Table_Info (Nam)); 1071 1072 Name_Len := Save_Nam'Length; 1073 Name_Buffer (1 .. Name_Len) := Save_Nam; 1074 1075 return Ent; 1076 end Find_Local_Entity; 1077 1078 -- Start of processing for RTE 1079 1080 begin 1081 -- Doing a rtsfind in system.ads is special, as we cannot do this 1082 -- when compiling System itself. So if we are compiling system then 1083 -- we should already have acquired and processed the declaration 1084 -- of the entity. The test is to see if this compilation's main unit 1085 -- is System. If so, return the value from the already compiled 1086 -- declaration and otherwise do a regular find. 1087 1088 -- Not pleasant, but these kinds of annoying recursion when 1089 -- writing an Ada compiler in Ada have to be broken somewhere! 1090 1091 if Present (Main_Unit_Entity) 1092 and then Chars (Main_Unit_Entity) = Name_System 1093 and then Analyzed (Main_Unit_Entity) 1094 and then not Is_Child_Unit (Main_Unit_Entity) 1095 then 1096 return Check_CRT (E, Find_Local_Entity (E)); 1097 end if; 1098 1099 Save_Front_End_Inlining := Front_End_Inlining; 1100 Front_End_Inlining := False; 1101 1102 -- Load unit if unit not previously loaded 1103 1104 if No (RE_Table (E)) then 1105 Load_RTU (U_Id, Id => E); 1106 Lib_Unit := Unit (Cunit (U.Unum)); 1107 1108 -- In the subprogram case, we are all done, the entity we want 1109 -- is the entity for the subprogram itself. Note that we do not 1110 -- bother to check that it is the entity that was requested. 1111 -- the only way that could fail to be the case is if runtime is 1112 -- hopelessly misconfigured, and it isn't worth testing for this. 1113 1114 if Nkind (Lib_Unit) = N_Subprogram_Declaration then 1115 RE_Table (E) := U.Entity; 1116 1117 -- Otherwise we must have the package case. First check package 1118 -- entity itself (e.g. RTE_Name for System.Interrupts.Name) 1119 1120 else 1121 pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration); 1122 Ename := RE_Chars (E); 1123 1124 -- First we search the package entity chain. If the package 1125 -- only has a limited view, scan the corresponding list of 1126 -- incomplete types. 1127 1128 if From_With_Type (U.Entity) then 1129 Pkg_Ent := First_Entity (Limited_View (U.Entity)); 1130 else 1131 Pkg_Ent := First_Entity (U.Entity); 1132 end if; 1133 1134 while Present (Pkg_Ent) loop 1135 if Ename = Chars (Pkg_Ent) then 1136 RE_Table (E) := Pkg_Ent; 1137 Check_RPC; 1138 goto Found; 1139 end if; 1140 1141 Next_Entity (Pkg_Ent); 1142 end loop; 1143 1144 -- If we did not find the entity in the package entity chain, 1145 -- then check if the package entity itself matches. Note that 1146 -- we do this check after searching the entity chain, since 1147 -- the rule is that in case of ambiguity, we prefer the entity 1148 -- defined within the package, rather than the package itself. 1149 1150 if Ename = Chars (U.Entity) then 1151 RE_Table (E) := U.Entity; 1152 end if; 1153 1154 -- If we didn't find the entity we want, something is wrong. 1155 -- We just leave RE_Table (E) set to Empty and the appropriate 1156 -- action will be taken by Check_CRT when we exit. 1157 1158 end if; 1159 end if; 1160 1161 <<Found>> 1162 Maybe_Add_With (U); 1163 1164 Front_End_Inlining := Save_Front_End_Inlining; 1165 return Check_CRT (E, RE_Table (E)); 1166 end RTE; 1167 1168 ------------------- 1169 -- RTE_Available -- 1170 ------------------- 1171 1172 function RTE_Available (E : RE_Id) return Boolean is 1173 Dummy : Entity_Id; 1174 pragma Warnings (Off, Dummy); 1175 1176 Result : Boolean; 1177 1178 Save_RTE_Available_Call : constant Boolean := RTE_Available_Call; 1179 Save_RTE_Is_Available : constant Boolean := RTE_Is_Available; 1180 -- These are saved recursively because the call to load a unit 1181 -- caused by an upper level call may perform a recursive call 1182 -- to this routine during analysis of the corresponding unit. 1183 1184 begin 1185 RTE_Available_Call := True; 1186 RTE_Is_Available := True; 1187 Dummy := RTE (E); 1188 Result := RTE_Is_Available; 1189 RTE_Available_Call := Save_RTE_Available_Call; 1190 RTE_Is_Available := Save_RTE_Is_Available; 1191 return Result; 1192 1193 exception 1194 when RE_Not_Available => 1195 RTE_Available_Call := Save_RTE_Available_Call; 1196 RTE_Is_Available := Save_RTE_Is_Available; 1197 return False; 1198 end RTE_Available; 1199 1200 -------------------------- 1201 -- RTE_Record_Component -- 1202 -------------------------- 1203 1204 function RTE_Record_Component (E : RE_Id) return Entity_Id is 1205 U_Id : constant RTU_Id := RE_Unit_Table (E); 1206 U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); 1207 E1 : Entity_Id; 1208 Ename : Name_Id; 1209 Found_E : Entity_Id; 1210 Lib_Unit : Node_Id; 1211 Pkg_Ent : Entity_Id; 1212 1213 -- The following flag is used to disable front-end inlining when 1214 -- RTE_Record_Component is invoked. This prevents the analysis of other 1215 -- runtime bodies when a particular spec is loaded through Rtsfind. This 1216 -- is both efficient, and it prevents spurious visibility conflicts 1217 -- between use-visible user entities, and entities in run-time packages. 1218 1219 Save_Front_End_Inlining : Boolean; 1220 1221 begin 1222 -- Note: Contrary to subprogram RTE, there is no need to do any special 1223 -- management with package system.ads because it has no record type 1224 -- declarations. 1225 1226 Save_Front_End_Inlining := Front_End_Inlining; 1227 Front_End_Inlining := False; 1228 1229 -- Load unit if unit not previously loaded 1230 1231 if not Present (U.Entity) then 1232 Load_RTU (U_Id, Id => E); 1233 end if; 1234 1235 Lib_Unit := Unit (Cunit (U.Unum)); 1236 1237 pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration); 1238 Ename := RE_Chars (E); 1239 1240 -- Search the entity in the components of record type declarations 1241 -- found in the package entity chain. 1242 1243 Found_E := Empty; 1244 Pkg_Ent := First_Entity (U.Entity); 1245 Search : while Present (Pkg_Ent) loop 1246 if Is_Record_Type (Pkg_Ent) then 1247 E1 := First_Entity (Pkg_Ent); 1248 while Present (E1) loop 1249 if Ename = Chars (E1) then 1250 pragma Assert (not Present (Found_E)); 1251 Found_E := E1; 1252 end if; 1253 1254 Next_Entity (E1); 1255 end loop; 1256 end if; 1257 1258 Next_Entity (Pkg_Ent); 1259 end loop Search; 1260 1261 -- If we didn't find the entity we want, something is wrong. The 1262 -- appropriate action will be taken by Check_CRT when we exit. 1263 1264 Maybe_Add_With (U); 1265 1266 Front_End_Inlining := Save_Front_End_Inlining; 1267 return Check_CRT (E, Found_E); 1268 end RTE_Record_Component; 1269 1270 ------------------------------------ 1271 -- RTE_Record_Component_Available -- 1272 ------------------------------------ 1273 1274 function RTE_Record_Component_Available (E : RE_Id) return Boolean is 1275 Dummy : Entity_Id; 1276 pragma Warnings (Off, Dummy); 1277 1278 Result : Boolean; 1279 1280 Save_RTE_Available_Call : constant Boolean := RTE_Available_Call; 1281 Save_RTE_Is_Available : constant Boolean := RTE_Is_Available; 1282 -- These are saved recursively because the call to load a unit 1283 -- caused by an upper level call may perform a recursive call 1284 -- to this routine during analysis of the corresponding unit. 1285 1286 begin 1287 RTE_Available_Call := True; 1288 RTE_Is_Available := True; 1289 Dummy := RTE_Record_Component (E); 1290 Result := RTE_Is_Available; 1291 RTE_Available_Call := Save_RTE_Available_Call; 1292 RTE_Is_Available := Save_RTE_Is_Available; 1293 return Result; 1294 1295 exception 1296 when RE_Not_Available => 1297 RTE_Available_Call := Save_RTE_Available_Call; 1298 RTE_Is_Available := Save_RTE_Is_Available; 1299 return False; 1300 end RTE_Record_Component_Available; 1301 1302 ------------------- 1303 -- RTE_Error_Msg -- 1304 ------------------- 1305 1306 procedure RTE_Error_Msg (Msg : String) is 1307 begin 1308 if RTE_Available_Call then 1309 RTE_Is_Available := False; 1310 else 1311 Error_Msg_N (Msg, Current_Error_Node); 1312 1313 -- Bump count of violations if we are in configurable run-time 1314 -- mode and this is not a continuation message. 1315 1316 if Configurable_Run_Time_Mode and then Msg (Msg'First) /= '\' then 1317 Configurable_Run_Time_Violations := 1318 Configurable_Run_Time_Violations + 1; 1319 end if; 1320 end if; 1321 end RTE_Error_Msg; 1322 1323 ---------------- 1324 -- RTU_Entity -- 1325 ---------------- 1326 1327 function RTU_Entity (U : RTU_Id) return Entity_Id is 1328 begin 1329 return RT_Unit_Table (U).Entity; 1330 end RTU_Entity; 1331 1332 ---------------- 1333 -- RTU_Loaded -- 1334 ---------------- 1335 1336 function RTU_Loaded (U : RTU_Id) return Boolean is 1337 begin 1338 return Present (RT_Unit_Table (U).Entity); 1339 end RTU_Loaded; 1340 1341 -------------------- 1342 -- Set_RTU_Loaded -- 1343 -------------------- 1344 1345 procedure Set_RTU_Loaded (N : Node_Id) is 1346 Loc : constant Source_Ptr := Sloc (N); 1347 Unum : constant Unit_Number_Type := Get_Source_Unit (Loc); 1348 Uname : constant Unit_Name_Type := Unit_Name (Unum); 1349 E : constant Entity_Id := 1350 Defining_Entity (Unit (Cunit (Unum))); 1351 begin 1352 pragma Assert (Is_Predefined_File_Name (Unit_File_Name (Unum))); 1353 1354 -- Loop through entries in RTU table looking for matching entry 1355 1356 for U_Id in RTU_Id'Range loop 1357 1358 -- Here we have a match 1359 1360 if Get_Unit_Name (U_Id) = Uname then 1361 declare 1362 U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); 1363 -- The RT_Unit_Table entry that may need updating 1364 1365 begin 1366 -- If entry is not set, set it now, and indicate that it was 1367 -- loaded through an explicit context clause. 1368 1369 if No (U.Entity) then 1370 U := (Entity => E, 1371 Uname => Get_Unit_Name (U_Id), 1372 Unum => Unum, 1373 First_Implicit_With => Empty); 1374 end if; 1375 1376 return; 1377 end; 1378 end if; 1379 end loop; 1380 end Set_RTU_Loaded; 1381 1382 -------------------- 1383 -- Text_IO_Kludge -- 1384 -------------------- 1385 1386 procedure Text_IO_Kludge (Nam : Node_Id) is 1387 Chrs : Name_Id; 1388 1389 type Name_Map_Type is array (Text_IO_Package_Name) of RTU_Id; 1390 1391 Name_Map : constant Name_Map_Type := Name_Map_Type'( 1392 Name_Decimal_IO => Ada_Text_IO_Decimal_IO, 1393 Name_Enumeration_IO => Ada_Text_IO_Enumeration_IO, 1394 Name_Fixed_IO => Ada_Text_IO_Fixed_IO, 1395 Name_Float_IO => Ada_Text_IO_Float_IO, 1396 Name_Integer_IO => Ada_Text_IO_Integer_IO, 1397 Name_Modular_IO => Ada_Text_IO_Modular_IO); 1398 1399 Wide_Name_Map : constant Name_Map_Type := Name_Map_Type'( 1400 Name_Decimal_IO => Ada_Wide_Text_IO_Decimal_IO, 1401 Name_Enumeration_IO => Ada_Wide_Text_IO_Enumeration_IO, 1402 Name_Fixed_IO => Ada_Wide_Text_IO_Fixed_IO, 1403 Name_Float_IO => Ada_Wide_Text_IO_Float_IO, 1404 Name_Integer_IO => Ada_Wide_Text_IO_Integer_IO, 1405 Name_Modular_IO => Ada_Wide_Text_IO_Modular_IO); 1406 1407 Wide_Wide_Name_Map : constant Name_Map_Type := Name_Map_Type'( 1408 Name_Decimal_IO => Ada_Wide_Wide_Text_IO_Decimal_IO, 1409 Name_Enumeration_IO => Ada_Wide_Wide_Text_IO_Enumeration_IO, 1410 Name_Fixed_IO => Ada_Wide_Wide_Text_IO_Fixed_IO, 1411 Name_Float_IO => Ada_Wide_Wide_Text_IO_Float_IO, 1412 Name_Integer_IO => Ada_Wide_Wide_Text_IO_Integer_IO, 1413 Name_Modular_IO => Ada_Wide_Wide_Text_IO_Modular_IO); 1414 1415 To_Load : RTU_Id; 1416 -- Unit to be loaded, from one of the above maps 1417 1418 begin 1419 -- Nothing to do if name is not an identifier or a selected component 1420 -- whose selector_name is an identifier. 1421 1422 if Nkind (Nam) = N_Identifier then 1423 Chrs := Chars (Nam); 1424 1425 elsif Nkind (Nam) = N_Selected_Component 1426 and then Nkind (Selector_Name (Nam)) = N_Identifier 1427 then 1428 Chrs := Chars (Selector_Name (Nam)); 1429 1430 else 1431 return; 1432 end if; 1433 1434 -- Nothing to do if name is not one of the Text_IO subpackages 1435 -- Otherwise look through loaded units, and if we find Text_IO 1436 -- or [Wide_]Wide_Text_IO already loaded, then load the proper child. 1437 1438 if Chrs in Text_IO_Package_Name then 1439 for U in Main_Unit .. Last_Unit loop 1440 Get_Name_String (Unit_File_Name (U)); 1441 1442 if Name_Len = 12 then 1443 1444 -- Here is where we do the loads if we find one of the units 1445 -- Ada.Text_IO or Ada.[Wide_]Wide_Text_IO. An interesting 1446 -- detail is that these units may already be used (i.e. their 1447 -- In_Use flags may be set). Normally when the In_Use flag is 1448 -- set, the Is_Potentially_Use_Visible flag of all entities in 1449 -- the package is set, but the new entity we are mysteriously 1450 -- adding was not there to have its flag set at the time. So 1451 -- that's why we pass the extra parameter to RTU_Find, to make 1452 -- sure the flag does get set now. Given that those generic 1453 -- packages are in fact child units, we must indicate that 1454 -- they are visible. 1455 1456 if Name_Buffer (1 .. 12) = "a-textio.ads" then 1457 To_Load := Name_Map (Chrs); 1458 1459 elsif Name_Buffer (1 .. 12) = "a-witeio.ads" then 1460 To_Load := Wide_Name_Map (Chrs); 1461 1462 elsif Name_Buffer (1 .. 12) = "a-ztexio.ads" then 1463 To_Load := Wide_Wide_Name_Map (Chrs); 1464 1465 else 1466 goto Continue; 1467 end if; 1468 1469 Load_RTU (To_Load, Use_Setting => In_Use (Cunit_Entity (U))); 1470 Set_Is_Visible_Lib_Unit (RT_Unit_Table (To_Load).Entity); 1471 1472 -- Prevent creation of an implicit 'with' from (for example) 1473 -- Ada.Wide_Text_IO.Integer_IO to Ada.Text_IO.Integer_IO, 1474 -- because these could create cycles. First check whether the 1475 -- simple names match ("integer_io" = "integer_io"), and then 1476 -- check whether the parent is indeed one of the 1477 -- [[Wide_]Wide_]Text_IO packages. 1478 1479 if Chrs = Chars (Cunit_Entity (Current_Sem_Unit)) then 1480 declare 1481 Parent_Name : constant Unit_Name_Type := 1482 Get_Parent_Spec_Name 1483 (Unit_Name (Current_Sem_Unit)); 1484 1485 begin 1486 if Parent_Name /= No_Unit_Name then 1487 Get_Name_String (Parent_Name); 1488 1489 declare 1490 P : String renames Name_Buffer (1 .. Name_Len); 1491 begin 1492 if P = "ada.text_io%s" or else 1493 P = "ada.wide_text_io%s" or else 1494 P = "ada.wide_wide_text_io%s" 1495 then 1496 goto Continue; 1497 end if; 1498 end; 1499 end if; 1500 end; 1501 end if; 1502 1503 -- Add an implicit with clause from the current unit to the 1504 -- [[Wide_]Wide_]Text_IO child (if necessary). 1505 1506 Maybe_Add_With (RT_Unit_Table (To_Load)); 1507 end if; 1508 1509 <<Continue>> null; 1510 end loop; 1511 end if; 1512 1513 exception 1514 -- Generate error message if run-time unit not available 1515 1516 when RE_Not_Available => 1517 Error_Msg_N ("& not available", Nam); 1518 end Text_IO_Kludge; 1519 1520end Rtsfind; 1521