path: root/gcc/ada/lib-load.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             L I B . L O A D                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.86 $
--                                                                          --
--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
--                                                                          --
-- 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,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
--                                                                          --
------------------------------------------------------------------------------

with Atree;    use Atree;
with Debug;    use Debug;
with Errout;   use Errout;
with Fname;    use Fname;
with Fname.UF; use Fname.UF;
with Namet;    use Namet;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Opt;      use Opt;
with Osint;    use Osint;
with Output;   use Output;
with Par;
with Scn;      use Scn;
with Sinfo;    use Sinfo;
with Sinput;   use Sinput;
with Sinput.L; use Sinput.L;
with Tbuild;   use Tbuild;
with Uname;    use Uname;

package body Lib.Load is

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

   function Spec_Is_Irrelevant
     (Spec_Unit : Unit_Number_Type;
      Body_Unit : Unit_Number_Type)
      return      Boolean;
   --  The Spec_Unit and Body_Unit parameters are the unit numbers of the
   --  spec file that corresponds to the main unit which is a body. This
   --  function determines if the spec file is irrelevant and will be
   --  overridden by the body as described in RM 10.1.4(4). See description
   --  in "Special Handling of Subprogram Bodies" for further details.

   procedure Write_Dependency_Chain;
   --  This procedure is used to generate error message info lines that
   --  trace the current dependency chain when a load error occurs.

   -------------------------------
   -- Create_Dummy_Package_Unit --
   -------------------------------

   function Create_Dummy_Package_Unit
     (With_Node : Node_Id;
      Spec_Name : Unit_Name_Type)
      return      Unit_Number_Type
   is
      Unum         : Unit_Number_Type;
      Cunit_Entity : Entity_Id;
      Cunit        : Node_Id;
      Du_Name      : Node_Or_Entity_Id;
      End_Lab      : Node_Id;
      Save_CS      : constant Boolean := Get_Comes_From_Source_Default;

   begin
      --  The created dummy package unit does not come from source

      Set_Comes_From_Source_Default (False);

      --  Normal package

      if Nkind (Name (With_Node)) = N_Identifier then
         Cunit_Entity :=
           Make_Defining_Identifier (No_Location,
             Chars => Chars (Name (With_Node)));
         Du_Name := Cunit_Entity;
         End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location);

      --  Child package

      else -- Nkind (Name (With_Node)) = N_Expanded_Name
         Cunit_Entity :=
           Make_Defining_Identifier (No_Location,
             Chars => Chars (Selector_Name (Name (With_Node))));
         Du_Name :=
           Make_Defining_Program_Unit_Name (No_Location,
             Name => New_Copy_Tree (Prefix (Name (With_Node))),
             Defining_Identifier => Cunit_Entity);
         End_Lab :=
           Make_Designator (No_Location,
             Name => New_Copy_Tree (Prefix (Name (With_Node))),
             Identifier => New_Occurrence_Of (Cunit_Entity, No_Location));
      end if;

      Cunit :=
        Make_Compilation_Unit (No_Location,
          Context_Items => Empty_List,
          Unit =>
            Make_Package_Declaration (No_Location,
              Specification =>
                Make_Package_Specification (No_Location,
                  Defining_Unit_Name   => Du_Name,
                  Visible_Declarations => Empty_List,
                  End_Label            => End_Lab)),
          Aux_Decls_Node =>
            Make_Compilation_Unit_Aux (No_Location));

      Units.Increment_Last;
      Unum := Units.Last;

      Units.Table (Unum) := (
        Cunit           => Cunit,
        Cunit_Entity    => Cunit_Entity,
        Dependency_Num  => 0,
        Dependent_Unit  => False,
        Dynamic_Elab    => False,
        Error_Location  => Sloc (With_Node),
        Expected_Unit   => Spec_Name,
        Fatal_Error     => True,
        Generate_Code   => False,
        Has_RACW        => False,
        Ident_String    => Empty,
        Loading         => False,
        Main_Priority   => Default_Main_Priority,
        Serial_Number   => 0,
        Source_Index    => No_Source_File,
        Unit_File_Name  => Get_File_Name (Spec_Name, Subunit => False),
        Unit_Name       => Spec_Name,
        Version         => 0);

      Set_Comes_From_Source_Default (Save_CS);
      Set_Error_Posted (Cunit_Entity);
      Set_Error_Posted (Cunit);
      return Unum;
   end Create_Dummy_Package_Unit;

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

   procedure Initialize is
      Fname : File_Name_Type;

   begin
      Units.Init;
      Load_Stack.Init;
      Load_Stack.Increment_Last;
      Load_Stack.Table (Load_Stack.Last) := Main_Unit;

      --  Initialize unit table entry for Main_Unit. Note that we don't know
      --  the unit name yet, that gets filled in when the parser parses the
      --  main unit, at which time a check is made that it matches the main
      --  file name, and then the Unit_Name field is set. The Cunit and
      --  Cunit_Entity fields also get filled in later by the parser.

      Units.Increment_Last;
      Fname := Next_Main_Source;

      Units.Table (Main_Unit).Unit_File_Name := Fname;

      if Fname /= No_File then

         Main_Source_File := Load_Source_File (Fname);
         Current_Error_Source_File := Main_Source_File;

         Units.Table (Main_Unit) := (
           Cunit           => Empty,
           Cunit_Entity    => Empty,
           Dependency_Num  => 0,
           Dependent_Unit  => True,
           Dynamic_Elab    => False,
           Error_Location  => No_Location,
           Expected_Unit   => No_Name,
           Fatal_Error     => False,
           Generate_Code   => False,
           Has_RACW        => False,
           Loading         => True,
           Ident_String    => Empty,
           Main_Priority   => Default_Main_Priority,
           Serial_Number   => 0,
           Source_Index    => Main_Source_File,
           Unit_File_Name  => Fname,
           Unit_Name       => No_Name,
           Version         => Source_Checksum (Main_Source_File));
      end if;
   end Initialize;

   ------------------------
   -- Initialize_Version --
   ------------------------

   procedure Initialize_Version (U : Unit_Number_Type) is
   begin
      Units.Table (U).Version := Source_Checksum (Source_Index (U));
   end Initialize_Version;

   ---------------
   -- Load_Unit --
   ---------------

   function Load_Unit
     (Load_Name  : Unit_Name_Type;
      Required   : Boolean;
      Error_Node : Node_Id;
      Subunit    : Boolean;
      Corr_Body  : Unit_Number_Type := No_Unit;
      Renamings  : Boolean          := False)
      return       Unit_Number_Type
   is
      Calling_Unit : Unit_Number_Type;
      Uname_Actual : Unit_Name_Type;
      Unum         : Unit_Number_Type;
      Unump        : Unit_Number_Type;
      Fname        : File_Name_Type;
      Src_Ind      : Source_File_Index;
      Discard      : List_Id;

      procedure Set_Load_Unit_Dependency (U : Unit_Number_Type);
      --  Sets the Dependent_Unit flag unless we have a predefined unit
      --  being loaded in No_Run_Time mode. In this case we do not want
      --  to create a dependency, since we have loaded the unit only
      --  to inline stuff from it. If this is not the case, an error
      --  message will be issued in Rtsfind in any case.

      procedure Set_Load_Unit_Dependency (U : Unit_Number_Type) is
      begin
         if No_Run_Time
           and then Is_Internal_File_Name (Unit_File_Name (U))
         then
            null;
         else
            Units.Table (U).Dependent_Unit := True;
         end if;
      end Set_Load_Unit_Dependency;

   --  Start of processing for Load_Unit

   begin
      --  If renamings are allowed and we have a child unit name, then we
      --  must first load the parent to deal with finding the real name.

      if Renamings and then Is_Child_Name (Load_Name) then
         Unump :=
           Load_Unit
             (Load_Name  => Get_Parent_Spec_Name (Load_Name),
              Required   => Required,
              Subunit    => False,
              Renamings  => True,
              Error_Node => Error_Node);

         if Unump = No_Unit then
            return No_Unit;
         end if;

         --  If parent is a renaming, then we use the renamed package as
         --  the actual parent for the subsequent load operation.

         if Nkind (Parent (Cunit_Entity (Unump))) =
           N_Package_Renaming_Declaration
         then
            Uname_Actual :=
              New_Child
                (Load_Name,
                 Get_Unit_Name (Name (Parent (Cunit_Entity (Unump)))));

            --  Save the renaming entity, to establish its visibility when
            --  installing the context. The implicit with is on this entity,
            --  not on the package it renames.

            if Nkind (Error_Node) = N_With_Clause
              and then Nkind (Name (Error_Node)) = N_Selected_Component
            then
               declare
                  Par : Node_Id := Name (Error_Node);

               begin
                  while Nkind (Par) = N_Selected_Component
                    and then Chars (Selector_Name (Par)) /=
                      Chars (Cunit_Entity (Unump))
                  loop
                     Par := Prefix (Par);
                  end loop;

                  if Nkind (Par) = N_Selected_Component then
                     --  some intermediate parent is a renaming.

                     Set_Entity (Selector_Name (Par), Cunit_Entity (Unump));

                  else
                     --  the ultimate parent is a renaming.

                     Set_Entity (Par, Cunit_Entity (Unump));
                  end if;
               end;
            end if;

         --  If the parent is not a renaming, then get its name (this may
         --  be different from the parent spec name obtained above because
         --  of renamings higher up in the hierarchy).

         else
            Uname_Actual := New_Child (Load_Name, Unit_Name (Unump));
         end if;

      --  Here if unit to be loaded is not a child unit

      else
         Uname_Actual := Load_Name;
      end if;

      Fname := Get_File_Name (Uname_Actual, Subunit);

      if Debug_Flag_L then
         Write_Eol;
         Write_Str ("*** Load request for unit: ");
         Write_Unit_Name (Load_Name);

         if Required then
            Write_Str (" (Required = True)");
         else
            Write_Str (" (Required = False)");
         end if;

         Write_Eol;

         if Uname_Actual /= Load_Name then
            Write_Str ("*** Actual unit loaded: ");
            Write_Unit_Name (Uname_Actual);
         end if;
      end if;

      --  Capture error location if it is for the main unit. The idea is to
      --  post errors on the main unit location, not the most recent unit.

      if Present (Error_Node) then

         --  It seems like In_Extended_Main_Source_Unit (Error_Node) would
         --  do the trick here, but that's wrong, it is much too early to
         --  call this routine. We are still in the parser, and the required
         --  semantic information is not established yet. So we base the
         --  judgment on unit names.

         Get_External_Unit_Name_String (Unit_Name (Main_Unit));

         declare
            Main_Unit_Name : constant String := Name_Buffer (1 .. Name_Len);

         begin
            Get_External_Unit_Name_String
              (Unit_Name (Get_Source_Unit (Error_Node)));

            --  If the two names are identical, then for sure we are part
            --  of the extended main unit

            if Main_Unit_Name = Name_Buffer (1 .. Name_Len) then
               Load_Msg_Sloc := Sloc (Error_Node);

            --  If the load is called from a with_type clause, the error
            --  node is correct.

            elsif Nkind (Parent (Error_Node)) = N_With_Type_Clause then
               Load_Msg_Sloc := Sloc (Error_Node);

            --  Otherwise, check for the subunit case, and if so, consider
            --  we have a match if one name is a prefix of the other name.

            else
               if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
                    or else
                  Nkind (Unit (Cunit (Get_Source_Unit (Error_Node)))) =
                                                                N_Subunit
               then
                  Name_Len := Integer'Min (Name_Len, Main_Unit_Name'Length);

                  if Name_Buffer (1 .. Name_Len)
                        =
                     Main_Unit_Name (1 .. Name_Len)
                  then
                     Load_Msg_Sloc := Sloc (Error_Node);
                  end if;
               end if;
            end if;
         end;
      end if;

      --  If we are generating error messages, then capture calling unit

      if Present (Error_Node) then
         Calling_Unit := Get_Source_Unit (Error_Node);
      else
         Calling_Unit := No_Unit;
      end if;

      --  See if we already have an entry for this unit

      Unum := Main_Unit;

      while Unum <= Units.Last loop
         exit when Uname_Actual = Units.Table (Unum).Unit_Name;
         Unum := Unum + 1;
      end loop;

      --  Whether or not the entry was found, Unum is now the right value,
      --  since it is one more than Units.Last (i.e. the index of the new
      --  entry we will create) in the not found case.

      --  A special check is necessary in the unit not found case. If the unit
      --  is not found, but the file in which it lives has already been loaded,
      --  then we have the problem that the file does not contain the unit that
      --  is needed. We simply treat this as a file not found condition.

      if Unum > Units.Last then
         for J in Units.First .. Units.Last loop
            if Fname = Units.Table (J).Unit_File_Name then
               if Debug_Flag_L then
                  Write_Str ("  file does not contain unit, Unit_Number = ");
                  Write_Int (Int (Unum));
                  Write_Eol;
                  Write_Eol;
               end if;

               if Present (Error_Node) then

                  if Is_Predefined_File_Name (Fname) then
                     Error_Msg_Name_1 := Uname_Actual;
                     Error_Msg
                       ("% is not a language defined unit", Load_Msg_Sloc);
                  else
                     Error_Msg_Name_1 := Fname;
                     Error_Msg_Unit_1 := Uname_Actual;
                     Error_Msg
                       ("File{ does not contain unit$", Load_Msg_Sloc);
                  end if;

                  Write_Dependency_Chain;
                  return No_Unit;

               else
                  return No_Unit;
               end if;
            end if;
         end loop;
      end if;

      --  If we are proceeding with load, then make load stack entry

      Load_Stack.Increment_Last;
      Load_Stack.Table (Load_Stack.Last) := Unum;

      --  Case of entry already in table

      if Unum <= Units.Last then

         --  Here is where we check for a circular dependency, which is
         --  an attempt to load a unit which is currently in the process
         --  of being loaded. We do *not* care about a circular chain that
         --  leads back to a body, because this kind of circular dependence
         --  legitimately occurs (e.g. two package bodies that contain
         --  inlined subprogram referenced by the other).

         if Loading (Unum)
           and then (Is_Spec_Name (Units.Table (Unum).Unit_Name)
                       or else Acts_As_Spec (Units.Table (Unum).Cunit))
         then
            if Debug_Flag_L then
               Write_Str ("  circular dependency encountered");
               Write_Eol;
            end if;

            if Present (Error_Node) then
               Error_Msg ("circular unit dependency", Load_Msg_Sloc);
               Write_Dependency_Chain;
            else
               Load_Stack.Decrement_Last;
            end if;

            return No_Unit;
         end if;

         if Debug_Flag_L then
            Write_Str ("  unit already in file table, Unit_Number = ");
            Write_Int (Int (Unum));
            Write_Eol;
         end if;

         Load_Stack.Decrement_Last;
         Set_Load_Unit_Dependency (Unum);
         return Unum;

      --  File is not already in table, so try to open it

      else
         if Debug_Flag_L then
            Write_Str ("  attempt unit load, Unit_Number = ");
            Write_Int (Int (Unum));
            Write_Eol;
         end if;

         Src_Ind := Load_Source_File (Fname);

         --  Make a partial entry in the file table, used even in the file not
         --  found case to print the dependency chain including the last entry

         Units.Increment_Last;
         Units.Table (Unum).Unit_Name := Uname_Actual;

         --  File was found

         if Src_Ind /= No_Source_File then
            Units.Table (Unum) := (
              Cunit           => Empty,
              Cunit_Entity    => Empty,
              Dependency_Num  => 0,
              Dependent_Unit  => False,
              Dynamic_Elab    => False,
              Error_Location  => Sloc (Error_Node),
              Expected_Unit   => Uname_Actual,
              Fatal_Error     => False,
              Generate_Code   => False,
              Has_RACW        => False,
              Ident_String    => Empty,
              Loading         => True,
              Main_Priority   => Default_Main_Priority,
              Serial_Number   => 0,
              Source_Index    => Src_Ind,
              Unit_File_Name  => Fname,
              Unit_Name       => Uname_Actual,
              Version         => Source_Checksum (Src_Ind));

            --  Parse the new unit

            Initialize_Scanner (Unum, Source_Index (Unum));
            Discard := Par (Configuration_Pragmas => False);
            Set_Loading (Unum, False);

            --  If spec is irrelevant, then post errors and quit

            if Corr_Body /= No_Unit
              and then Spec_Is_Irrelevant (Unum, Corr_Body)
            then
               Error_Msg_Name_1 := Unit_File_Name (Corr_Body);
               Error_Msg
                 ("cannot compile subprogram in file {!",
                  Load_Msg_Sloc);
               Error_Msg_Name_1 := Unit_File_Name (Unum);
               Error_Msg
                 ("incorrect spec in file { must be removed first!",
                  Load_Msg_Sloc);
               return No_Unit;
            end if;

            --  If loaded unit had a fatal error, then caller inherits it!

            if Units.Table (Unum).Fatal_Error
              and then Present (Error_Node)
            then
               Units.Table (Calling_Unit).Fatal_Error := True;
            end if;

            --  Remove load stack entry and return the entry in the file table

            Load_Stack.Decrement_Last;
            Set_Load_Unit_Dependency (Unum);
            return Unum;

         --  Case of file not found

         else
            if Debug_Flag_L then
               Write_Str ("  file was not found, load failed");
               Write_Eol;
            end if;

            --  Generate message if unit required

            if Required and then Present (Error_Node) then

               if Is_Predefined_File_Name (Fname) then
                  Error_Msg_Name_1 := Uname_Actual;
                  Error_Msg
                    ("% is not a predefined library unit", Load_Msg_Sloc);

               else
                  Error_Msg_Name_1 := Fname;
                  Error_Msg ("file{ not found", Load_Msg_Sloc);
               end if;

               Write_Dependency_Chain;

               --  Remove unit from stack, to avoid cascaded errors on
               --  subsequent missing files.

               Load_Stack.Decrement_Last;
               Units.Decrement_Last;

            --  If unit not required, remove load stack entry and the junk
            --  file table entry, and return No_Unit to indicate not found,

            else
               Load_Stack.Decrement_Last;
               Units.Decrement_Last;
            end if;

            return No_Unit;
         end if;
      end if;
   end Load_Unit;

   ------------------------
   -- Make_Instance_Unit --
   ------------------------

   --  If the unit is an instance, it appears as a package declaration, but
   --  contains both declaration and body of the instance. The body becomes
   --  the main unit of the compilation, and the declaration is inserted
   --  at the end of the unit table. The main unit now has the name of a
   --  body, which is constructed from the name of the original spec,
   --  and is attached to the compilation node of the original unit. The
   --  declaration has been attached to a new compilation unit node, and
   --  code will have to be generated for it.

   procedure Make_Instance_Unit (N : Node_Id) is
      Sind : constant Source_File_Index := Source_Index (Main_Unit);

   begin
      Units.Increment_Last;

      Units.Table (Units.Last)               := Units.Table (Main_Unit);
      Units.Table (Units.Last).Cunit         := Library_Unit (N);
      Units.Table (Units.Last).Generate_Code := True;

      Units.Table (Main_Unit).Cunit          := N;
      Units.Table (Main_Unit).Unit_Name      :=
        Get_Body_Name (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N))));
      Units.Table (Main_Unit).Version        := Source_Checksum (Sind);
   end Make_Instance_Unit;

   ------------------------
   -- Spec_Is_Irrelevant --
   ------------------------

   function Spec_Is_Irrelevant
     (Spec_Unit : Unit_Number_Type;
      Body_Unit : Unit_Number_Type)
      return      Boolean
   is
      Sunit : constant Node_Id := Cunit (Spec_Unit);
      Bunit : constant Node_Id := Cunit (Body_Unit);

   begin
      --  The spec is irrelevant if the body is a subprogram body, and the
      --  spec is other than a subprogram spec or generic subprogram spec.
      --  Note that the names must be the same, we don't need to check that,
      --  because we already know that from the fact that the file names are
      --  the same.

      return
         Nkind (Unit (Bunit)) = N_Subprogram_Body
           and then Nkind (Unit (Sunit)) /= N_Subprogram_Declaration
           and then Nkind (Unit (Sunit)) /= N_Generic_Subprogram_Declaration;

   end Spec_Is_Irrelevant;

   --------------------
   -- Version_Update --
   --------------------

   procedure Version_Update (U : Node_Id; From : Node_Id) is
      Unum  : constant Unit_Number_Type := Get_Cunit_Unit_Number (U);
      Fnum  : constant Unit_Number_Type := Get_Cunit_Unit_Number (From);

   begin
      Units.Table (Unum).Version :=
        Units.Table (Unum).Version
          xor
        Source_Checksum (Source_Index (Fnum));
   end Version_Update;

   ----------------------------
   -- Write_Dependency_Chain --
   ----------------------------

   procedure Write_Dependency_Chain is
   begin
      --  The dependency chain is only written if it is at least two entries
      --  deep, otherwise it is trivial (the main unit depending on a unit
      --  that it obviously directly depends on).

      if Load_Stack.Last - 1 > Load_Stack.First then
         for U in Load_Stack.First .. Load_Stack.Last - 1 loop
            Error_Msg_Unit_1 := Unit_Name (Load_Stack.Table (U));
            Error_Msg_Unit_2 := Unit_Name (Load_Stack.Table (U + 1));
            Error_Msg ("$ depends on $!", Load_Msg_Sloc);
         end loop;
      end if;
   end Write_Dependency_Chain;

end Lib.Load;