gcc/ada/rtsfind.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              R T S F I N D                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision$
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Atree;     use Atree;
  30 with Casing;    use Casing;
  31 with Csets;     use Csets;
  32 with Debug;     use Debug;
  33 with Einfo;     use Einfo;
  34 with Elists;    use Elists;
  35 with Fname;     use Fname;
  36 with Fname.UF;  use Fname.UF;
  37 with Lib;       use Lib;
  38 with Lib.Load;  use Lib.Load;
  39 with Namet;     use Namet;
  40 with Nlists;    use Nlists;
  41 with Nmake;     use Nmake;
  42 with Output;    use Output;
  43 with Opt;       use Opt;
  44 with Restrict;  use Restrict;
  45 with Sem;       use Sem;
  46 with Sem_Ch7;   use Sem_Ch7;
  47 with Sem_Util;  use Sem_Util;
  48 with Sinfo;     use Sinfo;
  49 with Stand;     use Stand;
  50 with Snames;    use Snames;
  51 with Tbuild;    use Tbuild;
  52 with Uname;     use Uname;
  53
  54 package body Rtsfind is
  55
  56    ----------------
  57    -- Unit table --
  58    ----------------
  59
  60    --  The unit table has one entry for each unit included in the definition
  61    --  of the type RTU_Id in the spec. The table entries are initialized in
  62    --  Initialize to set the Entity field to Empty, indicating that the
  63    --  corresponding unit has not yet been loaded. The fields are set when
  64    --  a unit is loaded to contain the defining entity for the unit, the
  65    --  unit name, and the unit number.
  66
  67    type RT_Unit_Table_Record is record
  68       Entity : Entity_Id;
  69       Uname  : Unit_Name_Type;
  70       Unum   : Unit_Number_Type;
  71       Withed : Boolean;
  72    end record;
  73
  74    RT_Unit_Table : array (RTU_Id) of RT_Unit_Table_Record;
  75
  76    --------------------------
  77    -- Runtime Entity Table --
  78    --------------------------
  79
  80    --  There is one entry in the runtime entity table for each entity that is
  81    --  included in the definition of the RE_Id type in the spec. The entries
  82    --  are set by Initialize_Rtsfind to contain Empty, indicating that the
  83    --  entity has not yet been located. Once the entity is located for the
  84    --  first time, its ID is stored in this array, so that subsequent calls
  85    --  for the same entity can be satisfied immediately.
  86
  87    RE_Table : array (RE_Id) of Entity_Id;
  88
  89    --------------------------
  90    -- Generation of WITH's --
  91    --------------------------
  92
  93    --  When a unit is implicitly loaded as a result of a call to RTE, it
  94    --  is necessary to create an implicit with to ensure that the object
  95    --  is correctly loaded by the binder. Such with statements are only
  96    --  required when the request is from the extended main unit (if a
  97    --  client needs a with, that will be taken care of when the client
  98    --  is compiled.
  99
 100    --  We always attach the with to the main unit. This is not perfectly
 101    --  accurate in terms of elaboration requirements, but it is close
 102    --  enough, since the units that are accessed using rtsfind do not
 103    --  have delicate elaboration requirements.
 104
 105    --  The flag Withed in the unit table record is initially set to False.
 106    --  It is set True if a with has been generated for the main unit for
 107    --  the corresponding unit.
 108
 109    -----------------------
 110    -- Local Subprograms --
 111    -----------------------
 112
 113    procedure Load_Fail (S : String; U_Id : RTU_Id; Ent_Name : String := "");
 114    --  Internal procedure called if we can't find the entity or unit.
 115    --  The parameter is a detailed error message that is to be given.
 116    --  S is a reason for failing to compile the file. U_Id is the unit
 117    --  id, and Ent_Name, if non-null, is the associated entity name.
 118
 119    function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type;
 120    --  Retrieves the Unit Name given a unit id represented by its
 121    --  enumaration value in RTU_Id.
 122
 123    procedure Load_RTU (U_Id : RTU_Id; Use_Setting : Boolean := False);
 124    --  Load the unit whose Id is given if not already loaded. The unit is
 125    --  loaded, analyzed, and added to the with list, and the entry in
 126    --  RT_Unit_Table is updated to reflect the load. The second parameter
 127    --  indicates the initial setting for the Is_Potentially_Use_Visible
 128    --  flag of the entity for the loaded unit (if it is indeed loaded).
 129    --  A value of False means nothing special need be done. A value of
 130    --  True indicates that this flag must be set to True. It is needed
 131    --  only in the Text_IO_Kludge procedure, which may materialize an
 132    --  entity of Text_IO (or Wide_Text_IO) that was previously unknown.
 133
 134    function RE_Chars (E : RE_Id) return Name_Id;
 135    --  Given a RE_Id value returns the Chars of the corresponding entity.
 136
 137    -------------------
 138    -- Get_Unit_Name --
 139    -------------------
 140
 141    function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type is
 142       Uname_Chars : constant String := RTU_Id'Image (U_Id);
 143
 144    begin
 145       Name_Len := Uname_Chars'Length;
 146       Name_Buffer (1 .. Name_Len) := Uname_Chars;
 147       Set_Casing (All_Lower_Case);
 148
 149       if U_Id in Ada_Child then
 150          Name_Buffer (4) := '.';
 151
 152          if U_Id in Ada_Calendar_Child then
 153             Name_Buffer (13) := '.';
 154
 155          elsif U_Id in Ada_Finalization_Child then
 156             Name_Buffer (17) := '.';
 157
 158          elsif U_Id in Ada_Real_Time_Child then
 159             Name_Buffer (14) := '.';
 160
 161          elsif U_Id in Ada_Streams_Child then
 162             Name_Buffer (12) := '.';
 163
 164          elsif U_Id in Ada_Text_IO_Child then
 165             Name_Buffer (12) := '.';
 166
 167          elsif U_Id in Ada_Wide_Text_IO_Child then
 168             Name_Buffer (17) := '.';
 169          end if;
 170
 171       elsif U_Id in Interfaces_Child then
 172          Name_Buffer (11) := '.';
 173
 174       elsif U_Id in System_Child then
 175          Name_Buffer (7) := '.';
 176
 177          if U_Id in System_Tasking_Child then
 178             Name_Buffer (15) := '.';
 179          end if;
 180
 181          if U_Id in System_Tasking_Restricted_Child then
 182             Name_Buffer (26) := '.';
 183          end if;
 184
 185          if U_Id in System_Tasking_Protected_Objects_Child then
 186             Name_Buffer (33) := '.';
 187          end if;
 188
 189          if U_Id in System_Tasking_Async_Delays_Child then
 190             Name_Buffer (28) := '.';
 191          end if;
 192       end if;
 193
 194       --  Add %s at end for spec
 195
 196       Name_Buffer (Name_Len + 1) := '%';
 197       Name_Buffer (Name_Len + 2) := 's';
 198       Name_Len := Name_Len + 2;
 199
 200       return Name_Find;
 201    end Get_Unit_Name;
 202
 203    ----------------
 204    -- Initialize --
 205    ----------------
 206
 207    procedure Initialize is
 208    begin
 209       --  Initialize the unit table
 210
 211       for J in RTU_Id loop
 212          RT_Unit_Table (J).Entity := Empty;
 213       end loop;
 214
 215       for J in RE_Id loop
 216          RE_Table (J) := Empty;
 217       end loop;
 218    end Initialize;
 219
 220    ------------
 221    -- Is_RTE --
 222    ------------
 223
 224    function Is_RTE (Ent : Entity_Id; E : RE_Id) return Boolean is
 225       E_Unit_Name   : Unit_Name_Type;
 226       Ent_Unit_Name : Unit_Name_Type;
 227
 228       S  : Entity_Id;
 229       E1 : Entity_Id;
 230       E2 : Entity_Id;
 231
 232    begin
 233       if No (Ent) then
 234          return False;
 235
 236       --  If E has already a corresponding entity, check it directly,
 237       --  going to full views if they exist to deal with the incomplete
 238       --  and private type cases properly.
 239
 240       elsif Present (RE_Table (E)) then
 241          E1 := Ent;
 242
 243          if Is_Type (E1) and then Present (Full_View (E1)) then
 244             E1 := Full_View (E1);
 245          end if;
 246
 247          E2 := RE_Table (E);
 248
 249          if Is_Type (E2) and then Present (Full_View (E2)) then
 250             E2 := Full_View (E2);
 251          end if;
 252
 253          return E1 = E2;
 254       end if;
 255
 256       --  If the unit containing E is not loaded, we already know that
 257       --  the entity we have cannot have come from this unit.
 258
 259       E_Unit_Name := Get_Unit_Name (RE_Unit_Table (E));
 260
 261       if not Is_Loaded (E_Unit_Name) then
 262          return False;
 263       end if;
 264
 265       --  Here the unit containing the entity is loaded. We have not made
 266       --  an explicit call to RTE to get the entity in question, but we may
 267       --  have obtained a reference to it indirectly from some other entity
 268       --  in the same unit, or some other unit that references it.
 269
 270       --  Get the defining unit of the entity
 271
 272       S := Scope (Ent);
 273
 274       if Ekind (S) /= E_Package then
 275          return False;
 276       end if;
 277
 278       Ent_Unit_Name := Get_Unit_Name (Unit_Declaration_Node (S));
 279
 280       --  If the defining unit of the entity we are testing is not the
 281       --  unit containing E, then they cannot possibly match.
 282
 283       if Ent_Unit_Name /= E_Unit_Name then
 284          return False;
 285       end if;
 286
 287       --  If the units match, then compare the names (remember that no
 288       --  overloading is permitted in entities fetched using Rtsfind).
 289
 290       if RE_Chars (E) = Chars (Ent) then
 291          RE_Table (E) := Ent;
 292
 293          --  If front-end inlining is enabled, we may be within a body that
 294          --  contains inlined functions, which has not been retrieved through
 295          --  rtsfind, and therefore is not yet recorded in the RT_Unit_Table.
 296          --  Add the unit information now, it must be fully available.
 297
 298          declare
 299             U : RT_Unit_Table_Record
 300                   renames  RT_Unit_Table (RE_Unit_Table (E));
 301          begin
 302             if No (U.Entity) then
 303                U.Entity := S;
 304                U.Uname  := E_Unit_Name;
 305                U.Unum   := Get_Source_Unit (S);
 306             end if;
 307          end;
 308
 309          return True;
 310       else
 311          return False;
 312       end if;
 313    end Is_RTE;
 314
 315    ----------------------------
 316    -- Is_Text_IO_Kludge_Unit --
 317    ----------------------------
 318
 319    function Is_Text_IO_Kludge_Unit (Nam : Node_Id) return Boolean is
 320       Prf : Node_Id;
 321       Sel : Node_Id;
 322
 323    begin
 324       if Nkind (Nam) /= N_Expanded_Name then
 325          return False;
 326       end if;
 327
 328       Prf := Prefix (Nam);
 329       Sel := Selector_Name (Nam);
 330
 331       if Nkind (Sel) /= N_Expanded_Name
 332         or else Nkind (Prf) /= N_Identifier
 333         or else Chars (Prf) /= Name_Ada
 334       then
 335          return False;
 336       end if;
 337
 338       Prf := Prefix (Sel);
 339       Sel := Selector_Name (Sel);
 340
 341       return
 342         Nkind (Prf) = N_Identifier
 343           and then
 344         (Chars (Prf) = Name_Text_IO or else Chars (Prf) = Name_Wide_Text_IO)
 345           and then
 346         Nkind (Sel) = N_Identifier
 347           and then
 348         Chars (Sel) in Text_IO_Package_Name;
 349
 350    end Is_Text_IO_Kludge_Unit;
 351
 352    ---------------
 353    -- Load_Fail --
 354    ---------------
 355
 356    procedure Load_Fail (S : String; U_Id : RTU_Id; Ent_Name : String := "") is
 357    begin
 358       Set_Standard_Error;
 359
 360       Write_Str ("fatal error: run-time library configuration error");
 361       Write_Eol;
 362
 363       if Ent_Name /= "" then
 364          Write_Str ("cannot locate """);
 365
 366          --  Copy name skipping initial RE_ or RO_XX characters
 367
 368          if Ent_Name (1 .. 2) = "RE" then
 369             for J in 4 .. Ent_Name'Length loop
 370                Name_Buffer (J - 3) := Ent_Name (J);
 371             end loop;
 372          else
 373             for J in 7 .. Ent_Name'Length loop
 374                Name_Buffer (J - 6) := Ent_Name (J);
 375             end loop;
 376          end if;
 377
 378          Name_Len := Ent_Name'Length - 3;
 379          Set_Casing (Mixed_Case);
 380          Write_Str (Name_Buffer (1 .. Name_Len));
 381          Write_Str (""" in file """);
 382
 383       else
 384          Write_Str ("cannot load file """);
 385       end if;
 386
 387       Write_Name
 388         (Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False));
 389       Write_Str (""" (");
 390       Write_Str (S);
 391       Write_Char (')');
 392       Write_Eol;
 393       Set_Standard_Output;
 394       raise Unrecoverable_Error;
 395    end Load_Fail;
 396
 397    --------------
 398    -- Load_RTU --
 399    --------------
 400
 401    procedure Load_RTU (U_Id : RTU_Id; Use_Setting : Boolean := False) is
 402       Loaded   : Boolean;
 403       U        : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
 404       Priv_Par : Elist_Id := New_Elmt_List;
 405       Lib_Unit : Node_Id;
 406
 407       procedure Save_Private_Visibility;
 408       --  If the current unit is the body of child unit or the spec of a
 409       --  private child unit, the private declarations of the parent (s)
 410       --  are visible. If the unit to be loaded is another public sibling,
 411       --  its compilation will affect the visibility of the common ancestors.
 412       --  Indicate those that must be restored.
 413
 414       procedure Restore_Private_Visibility;
 415       --  Restore the visibility of ancestors after compiling RTU.
 416
 417       --------------------------------
 418       -- Restore_Private_Visibility --
 419       --------------------------------
 420
 421       procedure Restore_Private_Visibility is
 422          E_Par : Elmt_Id;
 423
 424       begin
 425          E_Par := First_Elmt (Priv_Par);
 426
 427          while Present (E_Par) loop
 428             if not In_Private_Part (Node (E_Par)) then
 429                Install_Private_Declarations (Node (E_Par));
 430             end if;
 431
 432             Next_Elmt (E_Par);
 433          end loop;
 434       end Restore_Private_Visibility;
 435
 436       -----------------------------
 437       -- Save_Private_Visibility --
 438       -----------------------------
 439
 440       procedure Save_Private_Visibility is
 441          Par : Entity_Id;
 442
 443       begin
 444          Par := Scope (Current_Scope);
 445
 446          while Present (Par)
 447            and then Par /= Standard_Standard
 448          loop
 449             if Ekind (Par) = E_Package
 450               and then Is_Compilation_Unit (Par)
 451               and then In_Private_Part (Par)
 452             then
 453                Append_Elmt (Par, Priv_Par);
 454             end if;
 455
 456             Par := Scope (Par);
 457          end loop;
 458       end Save_Private_Visibility;
 459
 460    --  Start of processing for Load_RTU
 461
 462    begin
 463       --  Nothing to do if unit is already loaded
 464
 465       if Present (U.Entity) then
 466          return;
 467       end if;
 468
 469       --  Otherwise we need to load the unit, First build unit name
 470       --  from the enumeration literal name in type RTU_Id.
 471
 472       U.Uname  := Get_Unit_Name (U_Id);
 473       U.Withed := False;
 474       Loaded   := Is_Loaded (U.Uname);
 475
 476       --  Now do the load call, note that setting Error_Node to Empty is
 477       --  a signal to Load_Unit that we will regard a failure to find the
 478       --  file as a fatal error, and that it should not output any kind
 479       --  of diagnostics, since we will take care of it here.
 480
 481       U.Unum :=
 482         Load_Unit
 483           (Load_Name  => U.Uname,
 484            Required   => False,
 485            Subunit    => False,
 486            Error_Node => Empty);
 487
 488       if U.Unum = No_Unit then
 489          Load_Fail ("unit not found", U_Id);
 490
 491       elsif Fatal_Error (U.Unum) then
 492          Load_Fail ("parser errors", U_Id);
 493       end if;
 494
 495       --  Make sure that the unit is analyzed
 496
 497       declare
 498          Was_Analyzed : Boolean := Analyzed (Cunit (Current_Sem_Unit));
 499
 500       begin
 501          --  Pretend that the current unit is analysed, in case it is
 502          --  System or some such. This allows us to put some declarations,
 503          --  such as exceptions and packed arrays of Boolean, into System
 504          --  even though expanding them requires System...
 505
 506          --  This is a bit odd but works fine. If the RTS unit does not depend
 507          --  in any way on the current unit, then it never gets back into the
 508          --  current unit's tree, and the change we make to the current unit
 509          --  tree is never noticed by anyone (it is undone in a moment). That
 510          --  is the normal situation.
 511
 512          --  If the RTS Unit *does* depend on the current unit, for instance,
 513          --  when you are compiling System, then you had better have finished
 514          --  Analyzing the part of System that is depended on before you try
 515          --  to load the RTS Unit. This means having the System ordered in an
 516          --  appropriate manner.
 517
 518          Set_Analyzed (Cunit (Current_Sem_Unit), True);
 519
 520          if not Analyzed (Cunit (U.Unum)) then
 521
 522             Save_Private_Visibility;
 523             Semantics (Cunit (U.Unum));
 524             Restore_Private_Visibility;
 525
 526             if Fatal_Error (U.Unum) then
 527                Load_Fail ("semantic errors", U_Id);
 528             end if;
 529          end if;
 530
 531          --  Undo the pretence
 532
 533          Set_Analyzed (Cunit (Current_Sem_Unit), Was_Analyzed);
 534       end;
 535
 536       Lib_Unit := Unit (Cunit (U.Unum));
 537       U.Entity := Defining_Entity (Lib_Unit);
 538
 539       if Use_Setting then
 540          Set_Is_Potentially_Use_Visible (U.Entity, True);
 541       end if;
 542    end Load_RTU;
 543
 544    --------------
 545    -- RE_Chars --
 546    --------------
 547
 548    function RE_Chars (E : RE_Id) return Name_Id is
 549       RE_Name_Chars : constant String := RE_Id'Image (E);
 550
 551    begin
 552       --  Copy name skipping initial RE_ or RO_XX characters
 553
 554       if RE_Name_Chars (1 .. 2) = "RE" then
 555          for J in 4 .. RE_Name_Chars'Last loop
 556             Name_Buffer (J - 3) := Fold_Lower (RE_Name_Chars (J));
 557          end loop;
 558
 559          Name_Len := RE_Name_Chars'Length - 3;
 560
 561       else
 562          for J in 7 .. RE_Name_Chars'Last loop
 563             Name_Buffer (J - 6) := Fold_Lower (RE_Name_Chars (J));
 564          end loop;
 565
 566          Name_Len := RE_Name_Chars'Length - 6;
 567       end if;
 568
 569       return Name_Find;
 570    end RE_Chars;
 571
 572    ---------
 573    -- RTE --
 574    ---------
 575
 576    function RTE (E : RE_Id) return Entity_Id is
 577       U_Id : constant RTU_Id := RE_Unit_Table (E);
 578       U    : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
 579
 580       Ent      : Entity_Id;
 581       Lib_Unit : Node_Id;
 582       Pkg_Ent  : Entity_Id;
 583       Ename    : Name_Id;
 584
 585       procedure Check_RPC;
 586       --  Reject programs that make use of distribution features not supported
 587       --  on the current target. On such targets (VMS, Vxworks, others?) we
 588       --  only provide a minimal body for System.Rpc that only supplies an
 589       --  implementation of partition_id.
 590
 591       function Find_Local_Entity (E : RE_Id) return Entity_Id;
 592       --  This function is used when entity E is in this compilation's main
 593       --  unit. It gets the value from the already compiled declaration.
 594
 595       function Make_Unit_Name (N : Node_Id) return Node_Id;
 596       --  If the unit is a child unit, build fully qualified name for use
 597       --  in with_clause.
 598
 599       ---------------
 600       -- Check_RPC --
 601       ---------------
 602
 603       procedure Check_RPC is
 604          Body_Name    : Unit_Name_Type;
 605          Unum         : Unit_Number_Type;
 606
 607       begin
 608          --  Bypass this check if debug flag -gnatdR set
 609
 610          if Debug_Flag_RR then
 611             return;
 612          end if;
 613
 614          --  Otherwise we need the check if we are going after one of
 615          --  the critical entities in System.RPC in stubs mode.
 616
 617          if (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
 618                       or else
 619                         Distribution_Stub_Mode = Generate_Caller_Stub_Body)
 620            and then (E = RE_Do_Rpc
 621                        or else E = RE_Do_Apc
 622                        or else E = RE_Params_Stream_Type
 623                        or else E = RE_RPC_Receiver)
 624          then
 625             --  Load body of System.Rpc, and abort if this is the body that is
 626             --  provided by GNAT, for which these features are not supported
 627             --  on current target. We identify the gnat body by the presence
 628             --  of a local entity called Gnat in the first declaration.
 629
 630             Lib_Unit := Unit (Cunit (U.Unum));
 631             Body_Name := Get_Body_Name (Get_Unit_Name (Lib_Unit));
 632             Unum :=
 633               Load_Unit
 634                 (Load_Name  => Body_Name,
 635                  Required   => False,
 636                  Subunit    => False,
 637                  Error_Node => Empty,
 638                  Renamings  => True);
 639
 640             if Unum /= No_Unit then
 641                declare
 642                   Decls : List_Id := Declarations (Unit (Cunit (Unum)));
 643
 644                begin
 645                   if Present (Decls)
 646                     and then Nkind (First (Decls)) = N_Object_Declaration
 647                     and then
 648                       Chars (Defining_Identifier (First (Decls))) = Name_Gnat
 649                   then
 650                      Set_Standard_Error;
 651                      Write_Str ("distribution feature not supported");
 652                      Write_Eol;
 653                      raise Unrecoverable_Error;
 654                   end if;
 655                end;
 656             end if;
 657          end if;
 658       end Check_RPC;
 659
 660       ------------------------
 661       -- Find_System_Entity --
 662       ------------------------
 663
 664       function Find_Local_Entity (E : RE_Id) return Entity_Id is
 665          RE_Str : String renames RE_Id'Image (E);
 666          Ent    : Entity_Id;
 667
 668          Save_Nam : constant String := Name_Buffer (1 .. Name_Len);
 669          --  Save name buffer and length over call
 670
 671       begin
 672          Name_Len := Natural'Max (0, RE_Str'Length - 3);
 673          Name_Buffer (1 .. Name_Len) :=
 674            RE_Str (RE_Str'First + 3 .. RE_Str'Last);
 675
 676          Ent := Entity_Id (Get_Name_Table_Info (Name_Find));
 677
 678          Name_Len := Save_Nam'Length;
 679          Name_Buffer (1 .. Name_Len) := Save_Nam;
 680
 681          return Ent;
 682       end Find_Local_Entity;
 683
 684       --------------------
 685       -- Make_Unit_Name --
 686       --------------------
 687
 688       function Make_Unit_Name (N : Node_Id) return Node_Id is
 689          Nam  : Node_Id;
 690          Scop : Entity_Id;
 691
 692       begin
 693          Nam  := New_Reference_To (U.Entity, Standard_Location);
 694          Scop := Scope (U.Entity);
 695
 696          if Nkind (N) = N_Defining_Program_Unit_Name then
 697             while Scop /= Standard_Standard loop
 698                Nam :=
 699                  Make_Expanded_Name (Standard_Location,
 700                    Chars  => Chars (U.Entity),
 701                    Prefix => New_Reference_To (Scop, Standard_Location),
 702                    Selector_Name => Nam);
 703                Set_Entity (Nam, U.Entity);
 704
 705                Scop := Scope (Scop);
 706             end loop;
 707          end if;
 708
 709          return Nam;
 710       end Make_Unit_Name;
 711
 712    --  Start of processing for RTE
 713
 714    begin
 715       --  Check violation of no run time mode
 716
 717       if No_Run_Time
 718         and then not OK_To_Use_In_No_Run_Time_Mode (U_Id)
 719       then
 720          Disallow_In_No_Run_Time_Mode (Current_Error_Node);
 721          return Empty;
 722       end if;
 723
 724       --  Doing a rtsfind in system.ads is special, as we cannot do this
 725       --  when compiling System itself. So if we are compiling system then
 726       --  we should already have acquired and processed the declaration
 727       --  of the entity. The test is to see if this compilation's main unit
 728       --  is System. If so, return the value from the already compiled
 729       --  declaration and otherwise do a regular find.
 730
 731       --  Not pleasant, but these kinds of annoying recursion when
 732       --  writing an Ada compiler in Ada have to be broken somewhere!
 733
 734       if Present (Main_Unit_Entity)
 735         and then Chars (Main_Unit_Entity) = Name_System
 736         and then Analyzed (Main_Unit_Entity)
 737         and then not Is_Child_Unit (Main_Unit_Entity)
 738       then
 739          return Find_Local_Entity (E);
 740       end if;
 741
 742       --  Load unit if unit not previously loaded
 743
 744       if No (RE_Table (E)) then
 745          Load_RTU (U_Id);
 746          Lib_Unit := Unit (Cunit (U.Unum));
 747
 748          --  In the subprogram case, we are all done, the entity we want
 749          --  is the entity for the subprogram itself. Note that we do not
 750          --  bother to check that it is the entity that was requested.
 751          --  the only way that could fail to be the case is if runtime is
 752          --  hopelessly misconfigured, and it isn't worth testing for this.
 753
 754          if Nkind (Lib_Unit) = N_Subprogram_Declaration then
 755             RE_Table (E) := U.Entity;
 756
 757          --  Otherwise we must have the package case, and here we have to
 758          --  search the package entity chain for the entity we want. The
 759          --  entity we want must be present in this chain, or we have a
 760          --  misconfigured runtime.
 761
 762          else
 763             pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration);
 764             Ename := RE_Chars (E);
 765
 766             Pkg_Ent := First_Entity (U.Entity);
 767
 768             while Present (Pkg_Ent) loop
 769                if Ename = Chars (Pkg_Ent) then
 770                   RE_Table (E) := Pkg_Ent;
 771                   Check_RPC;
 772                   goto Found;
 773                end if;
 774
 775                Next_Entity (Pkg_Ent);
 776             end loop;
 777
 778             --  If we didn't find the unit we want, something is wrong
 779             --  although in no run time mode, we already gave a suitable
 780             --  message, and so we simply return Empty, and the caller must
 781             --  be prepared to handle this if the RTE call is otherwise
 782             --  possible in high integrity mode.
 783
 784             if No_Run_Time
 785               and then not OK_To_Use_In_No_Run_Time_Mode (U_Id)
 786             then
 787                return Empty;
 788
 789             else
 790                Load_Fail ("entity not in package", U_Id,  RE_Id'Image (E));
 791                raise Program_Error;
 792             end if;
 793          end if;
 794       end if;
 795
 796       --  See if we have to generate a with for this entity. We generate
 797       --  a with if the current unit is part of the extended main code
 798       --  unit, and if we have not already added the with. The with is
 799       --  added to the appropriate unit (the current one).
 800
 801    <<Found>>
 802       if (not U.Withed)
 803         and then
 804           In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit))
 805       then
 806          U.Withed := True;
 807
 808          declare
 809             Withn    : Node_Id;
 810             Lib_Unit : Node_Id;
 811
 812          begin
 813             Lib_Unit := Unit (Cunit (U.Unum));
 814             Withn :=
 815               Make_With_Clause (Standard_Location,
 816                 Name =>
 817                   Make_Unit_Name
 818                     (Defining_Unit_Name (Specification (Lib_Unit))));
 819             Set_Library_Unit          (Withn, Cunit (U.Unum));
 820             Set_Corresponding_Spec    (Withn, U.Entity);
 821             Set_First_Name            (Withn, True);
 822             Set_Implicit_With         (Withn, True);
 823
 824             Mark_Rewrite_Insertion (Withn);
 825             Append (Withn, Context_Items (Cunit (Current_Sem_Unit)));
 826          end;
 827       end if;
 828
 829       --  We can now obtain the entity. Check that the no run time condition
 830       --  is not violated. Note that we do not signal the error if we detect
 831       --  it in a runtime unit. This can only arise if the user explicitly
 832       --  with'ed the runtime unit (or another runtime unit that uses it
 833       --  transitively), or if some acceptable (e.g. inlined) entity is
 834       --  fetched from a unit, some of whose other routines or entities
 835       --  violate the conditions. In the latter case, it does not matter,
 836       --  since we won't be using those entities.
 837
 838       Ent := RE_Table (E);
 839
 840       if Is_Subprogram (Ent)
 841         and then not Is_Inlined (Ent)
 842         and then Sloc (Current_Error_Node) /= Standard_Location
 843         and then not
 844           Is_Predefined_File_Name
 845             (Unit_File_Name (Get_Source_Unit (Current_Error_Node)))
 846       then
 847          Disallow_In_No_Run_Time_Mode (Current_Error_Node);
 848       end if;
 849
 850       return Ent;
 851    end RTE;
 852
 853    --------------------
 854    -- Text_IO_Kludge --
 855    --------------------
 856
 857    procedure Text_IO_Kludge (Nam : Node_Id) is
 858       Chrs : Name_Id;
 859
 860       type Name_Map_Type is array (Text_IO_Package_Name) of RTU_Id;
 861
 862       Name_Map : Name_Map_Type := Name_Map_Type'(
 863         Name_Decimal_IO     => Ada_Text_IO_Decimal_IO,
 864         Name_Enumeration_IO => Ada_Text_IO_Enumeration_IO,
 865         Name_Fixed_IO       => Ada_Text_IO_Fixed_IO,
 866         Name_Float_IO       => Ada_Text_IO_Float_IO,
 867         Name_Integer_IO     => Ada_Text_IO_Integer_IO,
 868         Name_Modular_IO     => Ada_Text_IO_Modular_IO);
 869
 870       Wide_Name_Map : Name_Map_Type := Name_Map_Type'(
 871         Name_Decimal_IO     => Ada_Wide_Text_IO_Decimal_IO,
 872         Name_Enumeration_IO => Ada_Wide_Text_IO_Enumeration_IO,
 873         Name_Fixed_IO       => Ada_Wide_Text_IO_Fixed_IO,
 874         Name_Float_IO       => Ada_Wide_Text_IO_Float_IO,
 875         Name_Integer_IO     => Ada_Wide_Text_IO_Integer_IO,
 876         Name_Modular_IO     => Ada_Wide_Text_IO_Modular_IO);
 877
 878    begin
 879       --  Nothing to do if name is not identifier or a selected component
 880       --  whose selector_name is not an identifier.
 881
 882       if Nkind (Nam) = N_Identifier then
 883          Chrs := Chars (Nam);
 884
 885       elsif Nkind (Nam) = N_Selected_Component
 886         and then Nkind (Selector_Name (Nam)) = N_Identifier
 887       then
 888          Chrs := Chars (Selector_Name (Nam));
 889
 890       else
 891          return;
 892       end if;
 893
 894       --  Nothing to do if name is not one of the Text_IO subpackages
 895       --  Otherwise look through loaded units, and if we find Text_IO
 896       --  or Wide_Text_IO already loaded, then load the proper child.
 897
 898       if Chrs in Text_IO_Package_Name then
 899          for U in Main_Unit .. Last_Unit loop
 900             Get_Name_String (Unit_File_Name (U));
 901
 902             if Name_Len = 12 then
 903
 904                --  Here is where we do the loads if we find one of the
 905                --  units Ada.Text_IO or Ada.Wide_Text_IO. An interesting
 906                --  detail is that these units may already be used (i.e.
 907                --  their In_Use flags may be set). Normally when the In_Use
 908                --  flag is set, the Is_Potentially_Use_Visible flag of all
 909                --  entities in the package is set, but the new entity we
 910                --  are mysteriously adding was not there to have its flag
 911                --  set at the time. So that's why we pass the extra parameter
 912                --  to RTU_Find, to make sure the flag does get set now.
 913                --  Given that those generic packages are in fact child units,
 914                --  we must indicate that they are visible.
 915
 916                if Name_Buffer (1 .. 12) = "a-textio.ads" then
 917                   Load_RTU (Name_Map (Chrs), In_Use (Cunit_Entity (U)));
 918                   Set_Is_Visible_Child_Unit
 919                     (RT_Unit_Table (Name_Map (Chrs)).Entity);
 920
 921                elsif Name_Buffer (1 .. 12) = "a-witeio.ads" then
 922                   Load_RTU (Wide_Name_Map (Chrs), In_Use (Cunit_Entity (U)));
 923                   Set_Is_Visible_Child_Unit
 924                     (RT_Unit_Table (Wide_Name_Map (Chrs)).Entity);
 925                end if;
 926             end if;
 927          end loop;
 928       end if;
 929    end Text_IO_Kludge;
 930
 931 end Rtsfind;