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 Restrict; use Restrict;
with Scn; use Scn;
with Sinfo; use Sinfo;
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
function From_Limited_With_Chain (Lim : Boolean) return Boolean;
function Spec_Is_Irrelevant
(Spec_Unit : Unit_Number_Type;
Body_Unit : Unit_Number_Type) return Boolean;
procedure Write_Dependency_Chain;
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
Set_Comes_From_Source_Default (False);
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);
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 => 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));
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 => True,
Generate_Code => False,
Has_RACW => False,
Ident_String => Empty,
Loading => False,
Main_Priority => Default_Main_Priority,
Munit_Index => 0,
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;
function From_Limited_With_Chain (Lim : Boolean) return Boolean is
begin
if Lim then
return True;
elsif Load_Stack.Last - 1 > Load_Stack.First then
for U in Load_Stack.First .. Load_Stack.Last - 1 loop
if Load_Stack.Table (U).From_Limited_With then
return True;
end if;
end loop;
end if;
return False;
end From_Limited_With_Chain;
procedure Initialize is
begin
Units.Init;
Load_Stack.Init;
end Initialize;
procedure Initialize_Version (U : Unit_Number_Type) is
begin
Units.Table (U).Version := Source_Checksum (Source_Index (U));
end Initialize_Version;
procedure Load_Main_Source is
Fname : File_Name_Type;
begin
Load_Stack.Increment_Last;
Load_Stack.Table (Load_Stack.Last) := (Main_Unit, False);
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,
Dynamic_Elab => False,
Error_Location => No_Location,
Expected_Unit => No_Name,
Fatal_Error => False,
Generate_Code => False,
Has_RACW => False,
Ident_String => Empty,
Loading => True,
Main_Priority => Default_Main_Priority,
Munit_Index => 0,
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;
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;
From_Limited_With : 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;
begin
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 Nkind (Parent (Cunit_Entity (Unump))) =
N_Package_Renaming_Declaration
then
Uname_Actual :=
New_Child
(Load_Name,
Get_Unit_Name (Name (Parent (Cunit_Entity (Unump)))));
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
Set_Entity (Selector_Name (Par), Cunit_Entity (Unump));
else
Set_Entity (Par, Cunit_Entity (Unump));
end if;
end;
end if;
else
Uname_Actual := New_Child (Load_Name, Unit_Name (Unump));
end if;
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;
if Present (Error_Node)
and then Unit_Name (Main_Unit) /= No_Name
then
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 Main_Unit_Name = Name_Buffer (1 .. Name_Len) then
Load_Msg_Sloc := Sloc (Error_Node);
elsif Nkind (Parent (Error_Node)) = N_With_Type_Clause then
Load_Msg_Sloc := Sloc (Error_Node);
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 Present (Error_Node) then
Calling_Unit := Get_Source_Unit (Error_Node);
else
Calling_Unit := No_Unit;
end if;
Unum := Main_Unit;
while Unum <= Units.Last loop
exit when Uname_Actual = Units.Table (Unum).Unit_Name;
Unum := Unum + 1;
end loop;
if Unum > Units.Last and then Multiple_Unit_Index = 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
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;
Load_Stack.Increment_Last;
Load_Stack.Table (Load_Stack.Last) := (Unum, From_Limited_With);
if Unum <= Units.Last then
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 (From_Limited_With)
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;
return Unum;
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);
Units.Increment_Last;
Units.Table (Unum).Unit_Name := Uname_Actual;
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 => False,
Generate_Code => False,
Has_RACW => False,
Ident_String => Empty,
Loading => True,
Main_Priority => Default_Main_Priority,
Munit_Index => 0,
Serial_Number => 0,
Source_Index => Src_Ind,
Unit_File_Name => Fname,
Unit_Name => Uname_Actual,
Version => Source_Checksum (Src_Ind));
declare
Save_Index : constant Nat := Multiple_Unit_Index;
begin
Multiple_Unit_Index := Get_Unit_Index (Uname_Actual);
Units.Table (Unum).Munit_Index := Multiple_Unit_Index;
Initialize_Scanner (Unum, Source_Index (Unum));
Discard_List (Par (Configuration_Pragmas => False,
From_Limited_With => From_Limited_With));
Multiple_Unit_Index := Save_Index;
Set_Loading (Unum, False);
end;
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 Units.Table (Unum).Fatal_Error
and then Present (Error_Node)
then
Units.Table (Calling_Unit).Fatal_Error := True;
end if;
Load_Stack.Decrement_Last;
return Unum;
else
if Debug_Flag_L then
Write_Str (" file was not found, load failed");
Write_Eol;
end if;
if Required and then Present (Error_Node) then
if Is_Predefined_File_Name (Fname) then
Check_Restricted_Unit (Load_Name, Error_Node);
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;
Load_Stack.Decrement_Last;
Units.Decrement_Last;
else
Load_Stack.Decrement_Last;
Units.Decrement_Last;
end if;
return No_Unit;
end if;
end if;
end Load_Unit;
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;
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
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;
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;
procedure Write_Dependency_Chain is
begin
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;