Geek Gadgets 1/ADE-1.bin/ade-dist/gnat-2.06-src.tgz/tar.out/fsf/gnat/ada/rtsfind.adb

Text File | 1996-09-28 | 15KB | 418 lines

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              R T S F I N D                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.47 $                             --
--                                                                          --
--        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
--                                                                          --
------------------------------------------------------------------------------

with Atree;    use Atree;
with Casing;   use Casing;
with Csets;    use Csets;
with Einfo;    use Einfo;
with Fname;    use Fname;
with Lib;      use Lib;
with Lib.Load; use Lib.Load;
with Namet;    use Namet;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Output;   use Output;
with Sem;      use Sem;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Snames;   use Snames;
with Tbuild;   use Tbuild;

package body Rtsfind is

   ----------------
   -- Unit table --
   ----------------

   --  The unit table has one entry for each unit included in the definition
   --  of the type RTU_Id in the spec. The table entries are initialized in
   --  Initialize to set the Entity field to Empty, indicating that the
   --  corresponding unit has not yet been loaded. The fields are set when
   --  a unit is loaded to contain the defining entity for the unit, the
   --  unit name, and the unit number.

   type RT_Unit_Table_Record is record
      Entity : Entity_Id;
      Uname  : Unit_Name_Type;
      Unum   : Unit_Number_Type;
   end record;

   RT_Unit_Table : array (RTU_Id) of RT_Unit_Table_Record;

   --------------------------
   -- Runtime Entity Table --
   --------------------------

   --  There is one entry in the runtime entity table for each entity that is
   --  included in the definition of the RE_Id type in the spec. The entries
   --  are set by Initialize_Rtsfind to contain Empty, indicating that the
   --  entity has not yet been located. Once the entity is located for the
   --  first time, its ID is stored in this array, so that subsequent calls
   --  for the same entity can be satisfied immediately.

   RE_Table : array (RE_Id) of Entity_Id;

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Load_Fail (S : String; U_Id : RTU_Id; Ent_Name : String := "");
   --  Internal procedure called if we can't find the entity or unit.
   --  The parameter is a detailed error message that is to be given.
   --  S is a reason for failing to compile the file. U_Id is the unit
   --  id, and Ent_Name, if non-null, is the associated entity name.

   procedure Load_RTU (U_Id : RTU_Id; Use_Setting : Boolean := False);
   --  Load the unit whose Id is given if not already loaded. The unit is
   --  loaded, analyzed, and added to the with list, and the entry in
   --  RT_Unit_Table is updated to reflect the load. The second parameter
   --  indicates the initial setting for the Is_Potentially_Use_Visible
   --  flag of the entity for the loaded unit (if it is indeed loaded).
   --  A value of False means nothing special need be done. A value of
   --  True indicates that this flag must be set to True. It is needed
   --  only in the Text_IO_Kludge procedure, which may materialize an
   --  entity of Text_IO (or Wide_Text_IO) that was previously unknown.

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      --  Initialize the unit table

      for J in RTU_Id loop
         RT_Unit_Table (J).Entity := Empty;
      end loop;

      for J in RE_Id loop
         RE_Table (J) := Empty;
      end loop;
   end Initialize;

   ---------------
   -- Load_Fail --
   ---------------

   procedure Load_Fail (S : String; U_Id : RTU_Id; Ent_Name : String := "") is
   begin
      Set_Standard_Error;

      Write_Str ("fatal error: runtime library configuration error");
      Write_Eol;

      if Ent_Name /= "" then
         Write_Str ("cannot locate """);

         --  Copy name skipping initial RE_ or RO_XX characters

         if Ent_Name (1 .. 2) = "RE" then
            for J in 4 .. Ent_Name'Length loop
               Name_Buffer (J - 3) := Ent_Name (J);
            end loop;
         else
            for J in 7 .. Ent_Name'Length loop
               Name_Buffer (J - 6) := Ent_Name (J);
            end loop;
         end if;

         Name_Len := Ent_Name'Length - 3;
         Set_Casing (Mixed_Case);
         Write_Str (Name_Buffer (1 .. Name_Len));
         Write_Str (""" in file """);

      else
         Write_Str ("cannot load file """);
      end if;

      Write_Name (Get_File_Name (RT_Unit_Table (U_Id).Uname));
      Write_Str (""" (");
      Write_Str (S);
      Write_Char (')');
      Write_Eol;
      Set_Standard_Output;
      raise Unrecoverable_Error;
   end Load_Fail;

   --------------
   -- Load_RTU --
   --------------

   procedure Load_RTU (U_Id : RTU_Id; Use_Setting : Boolean := False) is
      Lib_Unit : Node_Id;
      Loaded   : Boolean;
      U        : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
      Withn    : Node_Id;

   begin
      --  Nothing to do if unit is already loaded

      if Present (U.Entity) then
         return;
      end if;

      --  Otherwise we need to load the unit, First build unit name
      --  from the enumeration literal name in type RTU_Id.

      declare
         Uname_Chars : constant String := RTU_Id'Image (U_Id);

      begin
         Name_Len := Uname_Chars'Length;
         Name_Buffer (1 .. Name_Len) := Uname_Chars;
         Set_Casing (All_Lower_Case);

         if U_Id in Ada_Child then
            Name_Buffer (4) := '.';

            if U_Id in Ada_Calendar_Child then
               Name_Buffer (13) := '.';

            elsif U_Id in Ada_Real_Time_Child then
               Name_Buffer (14) := '.';

            elsif U_Id in Ada_Text_IO_Child then
               Name_Buffer (12) := '.';

            elsif U_Id in Ada_Wide_Text_IO_Child then
               Name_Buffer (17) := '.';
            end if;

         elsif U_Id in Interfaces_Child then
            Name_Buffer (11) := '.';

         elsif U_Id in System_Child then
            Name_Buffer (7) := '.';

            if U_Id in System_Tasking_Child then
               Name_Buffer (15) := '.';
            end if;
         end if;
      end;

      --  Add %s at end for spec

      Name_Buffer (Name_Len + 1) := '%';
      Name_Buffer (Name_Len + 2) := 's';
      Name_Len := Name_Len + 2;

      U.Uname := Name_Find;
      Loaded := Is_Loaded (U.Uname);
      U.Unum := Load_Unit (U.Uname, False, Empty);

      if U.Unum = No_Unit then
         Load_Fail ("unit not found", U_Id);
      elsif Fatal_Error (U.Unum) then
         Load_Fail ("parser errors", U_Id);
      end if;

      --  Make sure that the unit is analyzed

      if not Analyzed (Cunit (U.Unum)) then
         Semantics (Cunit (U.Unum));

         if Fatal_Error (U.Unum) then
            Load_Fail ("semantic errors", U_Id);
         end if;
      end if;

      Lib_Unit := Unit (Cunit (U.Unum));
      U.Entity := Defining_Unit_Simple_Name (Specification (Lib_Unit));

      if Use_Setting then
         Set_Is_Potentially_Use_Visible (U.Entity, True);
      end if;

      --  Add to with list if we loaded the unit

      if not Loaded then
         Withn :=
           Make_With_Clause (Standard_Location,
             Name => New_Reference_To (U.Entity, Standard_Location));
         Set_Library_Unit          (Withn, Cunit (U.Unum));
         Set_Corresponding_Spec    (Withn, U.Entity);
         Set_First_Name            (Withn, True);
         Set_Implicit_With         (Withn, True);

         Mark_Rewrite_Insertion (Withn);
         Append (Withn, Context_Items (Cunit (Current_Sem_Unit)));
      end if;
   end Load_RTU;

   ---------
   -- RTE --
   ---------

   function RTE (E : RE_Id) return Entity_Id is
      U_Id : constant RTU_Id := RE_Unit_Table (E);
      U    : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);

      Lib_Unit : Node_Id;
      Pkg_Ent  : Entity_Id;
      Ename    : Name_Id;

   begin
      --  Immediate return if entity previously located

      if Present (RE_Table (E)) then
         return RE_Table (E);
      end if;

      --  Otherwise load the unit

      Load_RTU (U_Id);
      Lib_Unit := Unit (Cunit (U.Unum));

      --  In the subprogram case, we are all done, the entity we want is
      --  the entity for the subprogram itself. Note that we do not bother
      --  to check that it is in fact the entity that was requested, the
      --  only way that could fail to be the case is if runtime is hopelessly
      --  misconfigured, and it isn't worth testing for this.

      if Nkind (Lib_Unit) = N_Subprogram_Declaration then
         RE_Table (E) := U.Entity;
         return RE_Table (E);

      --  Otherwise we must have the package case, and here we have to search
      --  the package entity chain for the entity we want. The entity we want
      --  must be present in this chain, or we have a misconfigured runtime.

      else
         pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration);

         declare
            RE_Name_Chars : constant String := RE_Id'Image (E);

         begin
            --  Copy name skipping initial RE_ or RO_XX characters

            if RE_Name_Chars (1 .. 2) = "RE" then
               for J in 4 .. RE_Name_Chars'Last loop
                  Name_Buffer (J - 3) := Fold_Lower (RE_Name_Chars (J));
               end loop;

               Name_Len := RE_Name_Chars'Length - 3;

            else
               for J in 7 .. RE_Name_Chars'Last loop
                  Name_Buffer (J - 6) := Fold_Lower (RE_Name_Chars (J));
               end loop;

               Name_Len := RE_Name_Chars'Length - 6;
            end if;

            Ename := Name_Find;

            Pkg_Ent := First_Entity (U.Entity);

            while Present (Pkg_Ent) loop
               if Ename = Chars (Pkg_Ent) then
                  RE_Table (E) := Pkg_Ent;
                  return Pkg_Ent;
               end if;

               Pkg_Ent := Next_Entity (Pkg_Ent);
            end loop;

            --  If we didn't find the unit we want, something is wrong!

            Load_Fail ("entity not in package", U_Id, RE_Name_Chars);
         end;
      end if;

   end RTE;

   --------------------
   -- Text_IO_Kludge --
   --------------------

   procedure Text_IO_Kludge (Nam : Node_Id) is
      Chrs : Name_Id;

      type Name_Map_Type is array (Text_IO_Package_Name) of RTU_Id;

      Name_Map : Name_Map_Type := Name_Map_Type'(
        Name_Decimal_IO     => Ada_Text_IO_Decimal_IO,
        Name_Enumeration_IO => Ada_Text_IO_Enumeration_IO,
        Name_Fixed_IO       => Ada_Text_IO_Fixed_IO,
        Name_Float_IO       => Ada_Text_IO_Float_IO,
        Name_Integer_IO     => Ada_Text_IO_Integer_IO,
        Name_Modular_IO     => Ada_Text_IO_Modular_IO);

      Wide_Name_Map : Name_Map_Type := Name_Map_Type'(
        Name_Decimal_IO     => Ada_Wide_Text_IO_Decimal_IO,
        Name_Enumeration_IO => Ada_Wide_Text_IO_Enumeration_IO,
        Name_Fixed_IO       => Ada_Wide_Text_IO_Fixed_IO,
        Name_Float_IO       => Ada_Wide_Text_IO_Float_IO,
        Name_Integer_IO     => Ada_Wide_Text_IO_Integer_IO,
        Name_Modular_IO     => Ada_Wide_Text_IO_Modular_IO);

   begin
      --  Nothing to do if name is not identifier or a selected component
      --  whose selector_name is not an identifier.

      if Nkind (Nam) = N_Identifier then
         Chrs := Chars (Nam);

      elsif Nkind (Nam) = N_Selected_Component
        and then Nkind (Selector_Name (Nam)) = N_Identifier
      then
         Chrs := Chars (Selector_Name (Nam));

      else
         return;
      end if;

      --  Nothing to do if name is not one of the Text_IO subpackages
      --  Otherwise look through loaded units, and if we find Text_IO
      --  or Wide_Text_IO already loaded, then load the proper child.

      if Chrs in Text_IO_Package_Name then
         for U in Main_Unit .. Last_Unit loop
            Get_Name_String (Unit_File_Name (U));

            if Name_Len = 12 then

               --  Here is where we do the loads if we find one of the
               --  units Ada.Text_IO or Ada.Wide_Text_IO. An interesting
               --  detail is that these units may already be used (i.e.
               --  their In_Use flags may be set). Normally when the In_Use
               --  flag is set, the Is_Potentially_Use_Visible flag of all
               --  entities in the package is set, but the new entity we
               --  are mysteriously adding was not there to have its flag
               --  set at the time. So that's why we pass the extra parameter
               --  to RTU_Find, to make sure the flag does get set now.

               if Name_Buffer (1 .. 12) = "a-textio.ads" then
                  Load_RTU (Name_Map (Chrs), In_Use (Cunit_Entity (U)));
               elsif Name_Buffer (1 .. 12) = "a-witeio.ads" then
                  Load_RTU (Wide_Name_Map (Chrs), In_Use (Cunit_Entity (U)));
               end if;
            end if;
         end loop;
      end if;
   end Text_IO_Kludge;

end Rtsfind;