blob: fbb50af08003eccc08d1ae30aeeefb8b6afd94a6 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- L I B . L O A D --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
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 Osint.C; use Osint.C;
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 Stand; use Stand;
with Targparm; use Targparm;
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);
Set_Is_Child_Unit (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;
Set_Scope (Cunit_Entity, Standard_Standard);
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));
-- Mark the dummy package as analyzed to prevent analysis of this
-- (non-existent) unit in -gnatQ mode because at the moment the
-- structure and attributes of this dummy package does not allow
-- a normal analysis of this unit
Set_Analyzed (Cunit);
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
begin
Units.Init;
Load_Stack.Init;
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_Main_Source --
----------------------
procedure Load_Main_Source is
Fname : File_Name_Type;
begin
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 Load_Main_Source;
---------------
-- 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;
procedure Set_Load_Unit_Dependency (U : Unit_Number_Type);
-- Sets the Dependent_Unit flag unless we have a predefined unit
-- being loaded in High_Integrity_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.
------------------------------
-- Set_Load_Unit_Dependency --
------------------------------
procedure Set_Load_Unit_Dependency (U : Unit_Number_Type) is
begin
-- Differentiate between pragma No_Run_Time mode (that can be
-- used with a standard installation), and HI-E mode which comes
-- with a special installation.
-- For Configurable_Run_Time_Mode set by a pragma, we do not want to
-- create a dependency since the binder would generate references to
-- these units. In the case of configurable run-time, we do want to
-- establish this dependency.
if Configurable_Run_Time_Mode
and then not Configurable_Run_Time_On_Target
and then not Debug_Flag_YY
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.
-- Note: Unit_Name (Main_Unit) is not set if we are parsing gnat.adc.
if Present (Error_Node)
and then Unit_Name (Main_Unit) /= No_Name
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).
-- Ada0Y (AI-50217): We also ignore limited_with clauses, because
-- their purpose is precisely to create legal circular structures.
if Loading (Unum)
and then (Is_Spec_Name (Units.Table (Unum).Unit_Name)
or else Acts_As_Spec (Units.Table (Unum).Cunit))
and then (Nkind (Error_Node) /= N_With_Clause
or else not Limited_Present (Error_Node))
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_List (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
if Source_Index (Fnum) /= No_Source_File then
Units.Table (Unum).Version :=
Units.Table (Unum).Version
xor
Source_Checksum (Source_Index (Fnum));
end if;
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;