blob: cab72c0ef557c15edd80ab39de297103e7264af0 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- L I B . L O A D --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- 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 Einfo.Entities; use Einfo.Entities;
with Errout; use Errout;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
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 Restrict; use Restrict;
with Scn; use Scn;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Sinput.L; use Sinput.L;
with Stand; use Stand;
with Tbuild; use Tbuild;
with Uname; use Uname;
package body Lib.Load is
-----------------------
-- Local Subprograms --
-----------------------
function From_Limited_With_Chain return Boolean;
-- Check whether a possible circular dependence includes units that
-- have been loaded through limited_with clauses, in which case there
-- is no real circularity.
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.
------------------------------
-- Change_Main_Unit_To_Spec --
------------------------------
procedure Change_Main_Unit_To_Spec is
U : Unit_Record renames Units.Table (Main_Unit);
N : File_Name_Type;
X : Source_File_Index;
begin
-- Get name of unit body
Get_Name_String (U.Unit_File_Name);
-- Note: for the following we should really generalize and consult the
-- file name pattern data, but for now we just deal with the common
-- naming cases, which is good enough in practice.
-- Change .adb to .ads
if Name_Len >= 5
and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb"
then
Name_Buffer (Name_Len) := 's';
-- Change .2.ada to .1.ada (Rational convention)
elsif Name_Len >= 7
and then Name_Buffer (Name_Len - 5 .. Name_Len) = ".2.ada"
then
Name_Buffer (Name_Len - 4) := '1';
-- Change .ada to _.ada (DEC convention)
elsif Name_Len >= 5
and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".ada"
then
Name_Buffer (Name_Len - 3 .. Name_Len + 1) := "_.ada";
Name_Len := Name_Len + 1;
-- No match, don't make the change
else
return;
end if;
-- Try loading the spec
N := Name_Find;
X := Load_Source_File (N);
-- No change if we did not find the spec
if X <= No_Source_File then
return;
end if;
-- Otherwise modify Main_Unit entry to point to spec
U.Unit_File_Name := N;
U.Source_Index := X;
end Change_Main_Unit_To_Spec;
-------------------------------
-- 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;
Fname : constant File_Name_Type :=
Get_File_Name (Spec_Name, Subunit => False);
Pre_Name : constant Boolean :=
Is_Predefined_File_Name (Fname, Renamings_Included => False);
Ren_Name : constant Boolean :=
Is_Predefined_Renaming_File_Name (Fname);
GNAT_Name : constant Boolean :=
Is_GNAT_File_Name (Fname);
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
Cunit_Entity :=
Make_Defining_Identifier (No_Location,
Chars => Chars (Selector_Name (Name (With_Node))));
Du_Name :=
Make_Defining_Program_Unit_Name (No_Location,
Name => Copy_Separate_Tree (Prefix (Name (With_Node))),
Defining_Identifier => Cunit_Entity);
Set_Is_Child_Unit (Cunit_Entity);
End_Lab :=
Make_Designator (No_Location,
Name => Copy_Separate_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,
Dynamic_Elab => False,
Error_Location => Sloc (With_Node),
Expected_Unit => Spec_Name,
Fatal_Error => Error_Detected,
Generate_Code => False,
Has_RACW => False,
Filler => False,
Ident_String => Empty,
Is_Predefined_Renaming => Ren_Name,
Is_Predefined_Unit => Pre_Name or Ren_Name,
Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name,
Filler2 => False,
Loading => False,
Main_Priority => Default_Main_Priority,
Main_CPU => Default_Main_CPU,
Primary_Stack_Count => 0,
Sec_Stack_Count => 0,
Munit_Index => 0,
No_Elab_Code_All => False,
Serial_Number => 0,
Source_Index => No_Source_File,
Unit_File_Name => Fname,
Unit_Name => Spec_Name,
Version => 0,
OA_Setting => 'O');
Init_Unit_Name (Unum, Spec_Name);
Set_Comes_From_Source_Default (Save_CS);
Set_Error_Posted (Cunit_Entity);
Set_Error_Posted (Cunit);
return Unum;
end Create_Dummy_Package_Unit;
-----------------------------
-- From_Limited_With_Chain --
-----------------------------
function From_Limited_With_Chain return Boolean is
Curr_Num : constant Unit_Number_Type :=
Load_Stack.Table (Load_Stack.Last).Unit_Number;
begin
-- True if the current load operation is through a limited_with clause
-- and we are not within a loop of regular with_clauses.
for U in reverse Load_Stack.First .. Load_Stack.Last - 1 loop
if Load_Stack.Table (U).Unit_Number = Curr_Num then
return False;
elsif Present (Load_Stack.Table (U).With_Node)
and then Limited_Present (Load_Stack.Table (U).With_Node)
then
return True;
end if;
end loop;
return False;
end From_Limited_With_Chain;
----------------
-- 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 : constant File_Name_Type := Next_Main_Source;
Pre_Name : constant Boolean :=
Is_Predefined_File_Name (Fname, Renamings_Included => False);
Ren_Name : constant Boolean :=
Is_Predefined_Renaming_File_Name (Fname);
GNAT_Name : constant Boolean :=
Is_GNAT_File_Name (Fname);
Version : Word := 0;
begin
Load_Stack.Increment_Last;
Load_Stack.Table (Load_Stack.Last) := (Main_Unit, Empty);
-- 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;
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;
if Main_Source_File > No_Source_File then
Version := Source_Checksum (Main_Source_File);
else
-- To avoid emitting a source location (since there is no file),
-- we write a custom error message instead of using the machinery
-- in errout.adb.
Set_Standard_Error;
if Main_Source_File = No_Access_To_Source_File then
Write_Str
("no read access for file """ & Get_Name_String (Fname)
& """");
else
Write_Str
("file """ & Get_Name_String (Fname) & """ not found");
end if;
Write_Eol;
Set_Standard_Output;
end if;
Units.Table (Main_Unit) :=
(Cunit => Empty,
Cunit_Entity => Empty,
Dependency_Num => 0,
Dynamic_Elab => False,
Error_Location => No_Location,
Expected_Unit => No_Unit_Name,
Fatal_Error => None,
Generate_Code => True,
Has_RACW => False,
Filler => False,
Ident_String => Empty,
Is_Predefined_Renaming => Ren_Name,
Is_Predefined_Unit => Pre_Name or Ren_Name,
Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name,
Filler2 => False,
Loading => True,
Main_Priority => Default_Main_Priority,
Main_CPU => Default_Main_CPU,
Primary_Stack_Count => 0,
Sec_Stack_Count => 0,
Munit_Index => 0,
No_Elab_Code_All => False,
Serial_Number => 0,
Source_Index => Main_Source_File,
Unit_File_Name => Fname,
Unit_Name => No_Unit_Name,
Version => Version,
OA_Setting => 'O');
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;
With_Node : Node_Id := Empty;
PMES : 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;
Pre_Name : Boolean;
Ren_Name : Boolean;
GNAT_Name : Boolean;
Src_Ind : Source_File_Index;
Save_PMES : constant Boolean := Parsing_Main_Extended_Source;
Save_Cunit_Restrictions : constant Save_Cunit_Boolean_Restrictions :=
Cunit_Boolean_Restrictions_Save;
-- Save current restrictions for restore at end
begin
Parsing_Main_Extended_Source := PMES;
-- Initialize restrictions to config restrictions for unit to load if
-- it is part of the main extended source, otherwise reset them.
-- Note: it's a bit odd but PMES is False for subunits, which is why
-- we have the OR here.
if PMES or Subunit then
Restore_Config_Cunit_Boolean_Restrictions;
else
Reset_Cunit_Boolean_Restrictions;
end if;
-- 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.
-- Retain the with_clause that names the child, so that if it is
-- limited, the parent is loaded under the same condition.
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,
With_Node => With_Node);
if Unump = No_Unit then
Unum := No_Unit;
goto Done;
end if;
-- If parent is a renaming, then we use the renamed package as
-- the actual parent for the subsequent load operation.
if Nkind (Unit (Cunit (Unump))) = N_Package_Renaming_Declaration then
Uname_Actual :=
New_Child
(Load_Name, Get_Unit_Name (Name (Unit (Cunit (Unump)))));
-- If the load is for a with_clause, for visibility purposes both
-- the renamed entity and renaming one must be available in the
-- current unit: the renamed one in order to retrieve the child
-- unit, and the original one because it may be used as a prefix
-- in the body of the current unit. We add an explicit with_clause
-- for the original parent so that the renaming declaration is
-- properly loaded and analyzed.
if Present (With_Node) then
Insert_After (With_Node,
Make_With_Clause (Sloc (With_Node),
Name => Copy_Separate_Tree (Prefix (Name (With_Node)))));
end if;
-- 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. This is somewhat redundant given
-- the with_clause just created, but it simplifies subsequent
-- expansion of the current with_clause.
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;
-- Case of some intermediate parent is a renaming
if Nkind (Par) = N_Selected_Component then
Set_Entity (Selector_Name (Par), Cunit_Entity (Unump));
-- Case where the ultimate parent is a renaming
else
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);
Pre_Name :=
Is_Predefined_File_Name (Fname, Renamings_Included => False);
Ren_Name := Is_Predefined_Renaming_File_Name (Fname);
GNAT_Name := Is_GNAT_File_Name (Fname);
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 Present (Unit_Name (Main_Unit))
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.
-- 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 := Unit_Names.Get (Uname_Actual);
if Unum = No_Unit then
Unum := Units.Last + 1;
end if;
-- 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.
-- We skip this test in multiple unit per file mode since in this
-- case we can have multiple units from the same source file.
if Unum > Units.Last and then Get_Unit_Index (Uname_Actual) = 0 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
Get_Name_String (Fname);
if Is_Predefined_File_Name (Fname) then
Error_Msg_Unit_1 := Uname_Actual;
Error_Msg
("$$ is not a language defined unit", Load_Msg_Sloc);
else
Error_Msg_File_1 := Fname;
Error_Msg_Unit_1 := Uname_Actual;
Error_Msg ("file{ does not contain unit$", Load_Msg_Sloc);
end if;
Write_Dependency_Chain;
Unum := No_Unit;
goto Done;
else
Unum := No_Unit;
goto Done;
end if;
end if;
end loop;
end if;
-- If we are proceeding with load, then make load stack entry,
-- and indicate the kind of with_clause responsible for the load.
Load_Stack.Increment_Last;
Load_Stack.Table (Load_Stack.Last) := (Unum, With_Node);
-- 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).
-- Ada 2005 (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))
and then not From_Limited_With_Chain
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;
Unum := No_Unit;
goto Done;
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;
goto Done;
-- Unit is not already in table, so try to open the file
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;
Init_Unit_Name (Unum, Uname_Actual);
-- File was found
if Src_Ind > No_Source_File then
Units.Table (Unum) :=
(Cunit => Empty,
Cunit_Entity => Empty,
Dependency_Num => 0,
Dynamic_Elab => False,
Error_Location => Sloc (Error_Node),
Expected_Unit => Uname_Actual,
Fatal_Error => None,
Generate_Code => False,
Has_RACW => False,
Filler => False,
Ident_String => Empty,
Is_Predefined_Renaming => Ren_Name,
Is_Predefined_Unit => Pre_Name or Ren_Name,
Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name,
Filler2 => False,
Loading => True,
Main_Priority => Default_Main_Priority,
Main_CPU => Default_Main_CPU,
Primary_Stack_Count => 0,
Sec_Stack_Count => 0,
Munit_Index => 0,
No_Elab_Code_All => False,
Serial_Number => 0,
Source_Index => Src_Ind,
Unit_File_Name => Fname,
Unit_Name => Uname_Actual,
Version => Source_Checksum (Src_Ind),
OA_Setting => 'O');
-- Parse the new unit
declare
Save_Index : constant Nat := Multiple_Unit_Index;
Save_PMES : constant Boolean := Parsing_Main_Extended_Source;
begin
Multiple_Unit_Index := Get_Unit_Index (Uname_Actual);
Units.Table (Unum).Munit_Index := Multiple_Unit_Index;
Initialize_Scanner (Unum, Source_Index (Unum));
if Calling_Unit = Main_Unit and then Subunit then
Parsing_Main_Extended_Source := True;
end if;
Discard_List (Par (Configuration_Pragmas => False));
Parsing_Main_Extended_Source := Save_PMES;
Multiple_Unit_Index := Save_Index;
Set_Loading (Unum, False);
end;
-- 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_File_1 := Unit_File_Name (Corr_Body);
Error_Msg
("cannot compile subprogram in file {!", Load_Msg_Sloc);
Error_Msg_File_1 := Unit_File_Name (Unum);
Error_Msg
("\incorrect spec in file { must be removed first!",
Load_Msg_Sloc);
Unum := No_Unit;
goto Done;
end if;
-- If loaded unit had an error, then caller inherits setting
if Present (Error_Node) then
case Units.Table (Unum).Fatal_Error is
-- Nothing to do if with'ed unit had no error
when None =>
null;
-- If with'ed unit had a detected fatal error, propagate it
when Error_Detected =>
Units.Table (Calling_Unit).Fatal_Error := Error_Detected;
-- If with'ed unit had an ignored error, then propagate it
-- but do not overide an existing setting.
when Error_Ignored =>
if Units.Table (Calling_Unit).Fatal_Error = None then
Units.Table (Calling_Unit).Fatal_Error :=
Error_Ignored;
end if;
end case;
end if;
-- Remove load stack entry and return the entry in the file table
Load_Stack.Decrement_Last;
-- All done, return unit number
goto Done;
-- Case of file not found
else
if Debug_Flag_L then
if Src_Ind = No_Access_To_Source_File then
Write_Str (" no read access to file, load failed");
else
Write_Str (" file was not found, load failed");
end if;
Write_Eol;
end if;
-- Generate message if unit required
if Required then
Get_Name_String (Fname);
if Is_Predefined_File_Name (Fname) then
-- This is a predefined library unit which is not present
-- in the run time. If a predefined unit is not available
-- it may very likely be the case that there is also pragma
-- Restriction forbidding its usage. This is typically the
-- case when building a configurable run time, where the
-- usage of certain run-time units is restricted by means
-- of both the corresponding pragma Restriction (such as
-- No_Calendar), and by not including the unit. Hence, we
-- check whether this predefined unit is forbidden, so that
-- the message about the restriction violation is generated,
-- if needed.
if Present (Error_Node) then
Check_Restricted_Unit (Load_Name, Error_Node);
end if;
Error_Msg_Unit_1 := Uname_Actual;
Error_Msg -- CODEFIX
("$$ is not a predefined library unit", Load_Msg_Sloc);
else
Error_Msg_File_1 := Fname;
if Src_Ind = No_Access_To_Source_File then
Error_Msg ("no read access to file{", Load_Msg_Sloc);
else
Error_Msg ("file{ not found", Load_Msg_Sloc);
end if;
end if;
Write_Dependency_Chain;
-- Remove unit from stack, to avoid cascaded errors on
-- subsequent missing files.
Load_Stack.Decrement_Last;
Remove_Unit (Unum);
-- 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;
Remove_Unit (Unum);
end if;
Unum := No_Unit;
goto Done;
end if;
end if;
-- Here to exit, with result in Unum
<<Done>>
Parsing_Main_Extended_Source := Save_PMES;
Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions);
return Unum;
end Load_Unit;
--------------------------
-- Make_Child_Decl_Unit --
--------------------------
procedure Make_Child_Decl_Unit (N : Node_Id) is
Unit_Decl : constant Node_Id := Library_Unit (N);
Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (N);
begin
Units.Increment_Last;
Units.Table (Units.Last) := Units.Table (Unit_Num);
Units.Table (Units.Last).Cunit := Unit_Decl;
Units.Table (Units.Last).Cunit_Entity :=
Defining_Identifier
(Defining_Unit_Name (Specification (Unit (Unit_Decl))));
Init_Unit_Name (Units.Last, Get_Spec_Name (Unit_Name (Unit_Num)));
-- The library unit created for of a child subprogram unit plays no
-- role in code generation and binding, so label it accordingly.
Units.Table (Units.Last).Generate_Code := False;
Set_Has_No_Elaboration_Code (Unit_Decl);
end Make_Child_Decl_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; In_Main : Boolean) is
Sind : constant Source_File_Index := Source_Index (Main_Unit);
begin
Units.Increment_Last;
if In_Main then
Units.Table (Units.Last) := Units.Table (Main_Unit);
Units.Table (Units.Last).Cunit := Library_Unit (N);
Init_Unit_Name (Units.Last, Unit_Name (Main_Unit));
Units.Table (Main_Unit).Cunit := N;
Units.Table (Main_Unit).Version := Source_Checksum (Sind);
Init_Unit_Name (Main_Unit,
Get_Body_Name
(Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N)))));
else
-- Duplicate information from instance unit, for the body. The unit
-- node N has been rewritten as a body, but it was placed in the
-- units table when first loaded as a declaration.
Units.Table (Units.Last) := Units.Table (Get_Cunit_Unit_Number (N));
Units.Table (Units.Last).Cunit := Library_Unit (N);
end if;
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).Unit_Number);
Error_Msg_Unit_2 :=
Unit_Name (Load_Stack.Table (U + 1).Unit_Number);
Error_Msg ("$ depends on $!", Load_Msg_Sloc);
end loop;
end if;
end Write_Dependency_Chain;
end Lib.Load;