with Atree; use Atree;
with Casing; use Casing;
with Csets; use Csets;
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
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 Opt; use Opt;
with Sem; use Sem;
with Sem_Ch7; use Sem_Ch7;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Snames; use Snames;
with Tbuild; use Tbuild;
with Uname; use Uname;
package body Rtsfind is
RTE_Available_Call : Boolean := False;
RTE_Is_Available : Boolean;
type RT_Unit_Table_Record is record
Entity : Entity_Id;
Uname : Unit_Name_Type;
Unum : Unit_Number_Type;
Withed : Boolean;
end record;
RT_Unit_Table : array (RTU_Id) of RT_Unit_Table_Record;
RE_Table : array (RE_Id) of Entity_Id;
procedure Entity_Not_Defined (Id : RE_Id);
procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id);
function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type;
procedure Load_RTU
(U_Id : RTU_Id;
Id : RE_Id := RE_Null;
Use_Setting : Boolean := False);
procedure Output_Entity_Name (Id : RE_Id; Msg : String);
function RE_Chars (E : RE_Id) return Name_Id;
procedure RTE_Error_Msg (Msg : String);
procedure Entity_Not_Defined (Id : RE_Id) is
begin
if No_Run_Time_Mode then
if Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Sloc (Current_Error_Node))))
then
Error_Msg_N
("construct not allowed in no run time mode!",
Current_Error_Node);
raise Unrecoverable_Error;
else
RTE_Error_Msg ("|construct not allowed in no run time mode");
end if;
elsif Configurable_Run_Time_Mode then
RTE_Error_Msg ("|construct not allowed in this configuration>");
else
RTE_Error_Msg ("run-time configuration error");
end if;
Output_Entity_Name (Id, "not defined");
end Entity_Not_Defined;
function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type is
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_Finalization_Child then
Name_Buffer (17) := '.';
elsif U_Id in Ada_Interrupts_Child then
Name_Buffer (15) := '.';
elsif U_Id in Ada_Real_Time_Child then
Name_Buffer (14) := '.';
elsif U_Id in Ada_Streams_Child then
Name_Buffer (12) := '.';
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;
if U_Id in System_Tasking_Restricted_Child then
Name_Buffer (26) := '.';
end if;
if U_Id in System_Tasking_Protected_Objects_Child then
Name_Buffer (33) := '.';
end if;
if U_Id in System_Tasking_Async_Delays_Child then
Name_Buffer (28) := '.';
end if;
end if;
Name_Buffer (Name_Len + 1) := '%';
Name_Buffer (Name_Len + 2) := 's';
Name_Len := Name_Len + 2;
return Name_Find;
end Get_Unit_Name;
procedure Initialize is
begin
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;
RTE_Is_Available := False;
end Initialize;
function Is_RTE (Ent : Entity_Id; E : RE_Id) return Boolean is
E_Unit_Name : Unit_Name_Type;
Ent_Unit_Name : Unit_Name_Type;
S : Entity_Id;
E1 : Entity_Id;
E2 : Entity_Id;
begin
if No (Ent) then
return False;
elsif Present (RE_Table (E)) then
E1 := Ent;
if Is_Type (E1) and then Present (Full_View (E1)) then
E1 := Full_View (E1);
end if;
E2 := RE_Table (E);
if Is_Type (E2) and then Present (Full_View (E2)) then
E2 := Full_View (E2);
end if;
return E1 = E2;
end if;
E_Unit_Name := Get_Unit_Name (RE_Unit_Table (E));
if not Is_Loaded (E_Unit_Name) then
return False;
end if;
S := Scope (Ent);
if Ekind (S) /= E_Package then
return False;
end if;
Ent_Unit_Name := Get_Unit_Name (Unit_Declaration_Node (S));
if Ent_Unit_Name /= E_Unit_Name then
return False;
end if;
if RE_Chars (E) = Chars (Ent) then
RE_Table (E) := Ent;
declare
U : RT_Unit_Table_Record
renames RT_Unit_Table (RE_Unit_Table (E));
begin
if No (U.Entity) then
U.Entity := S;
U.Uname := E_Unit_Name;
U.Unum := Get_Source_Unit (S);
end if;
end;
return True;
else
return False;
end if;
end Is_RTE;
function Is_RTU (Ent : Entity_Id; U : RTU_Id) return Boolean is
E : constant Entity_Id := RT_Unit_Table (U).Entity;
begin
return Present (E) and then E = Ent;
end Is_RTU;
function Is_Text_IO_Kludge_Unit (Nam : Node_Id) return Boolean is
Prf : Node_Id;
Sel : Node_Id;
begin
if Nkind (Nam) /= N_Expanded_Name then
return False;
end if;
Prf := Prefix (Nam);
Sel := Selector_Name (Nam);
if Nkind (Sel) /= N_Expanded_Name
or else Nkind (Prf) /= N_Identifier
or else Chars (Prf) /= Name_Ada
then
return False;
end if;
Prf := Prefix (Sel);
Sel := Selector_Name (Sel);
return
Nkind (Prf) = N_Identifier
and then
(Chars (Prf) = Name_Text_IO or else Chars (Prf) = Name_Wide_Text_IO)
and then
Nkind (Sel) = N_Identifier
and then
Chars (Sel) in Text_IO_Package_Name;
end Is_Text_IO_Kludge_Unit;
procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id) is
M : String (1 .. 100);
P : Natural := 0;
begin
if Configurable_Run_Time_Mode then
RTE_Error_Msg ("construct not allowed in configurable run-time mode");
else
RTE_Error_Msg ("run-time library configuration error");
end if;
if S /= "not found"
or else not Configurable_Run_Time_Mode
or else All_Errors_Mode
then
M (1 .. 6) := "\file ";
P := 6;
Get_Name_String
(Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False));
M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len);
P := P + Name_Len;
M (P + 1) := ' ';
P := P + 1;
M (P + 1 .. P + S'Length) := S;
P := P + S'Length;
RTE_Error_Msg (M (1 .. P));
Output_Entity_Name (Id, "not available");
end if;
raise RE_Not_Available;
end Load_Fail;
procedure Load_RTU
(U_Id : RTU_Id;
Id : RE_Id := RE_Null;
Use_Setting : Boolean := False)
is
U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
Priv_Par : constant Elist_Id := New_Elmt_List;
Lib_Unit : Node_Id;
procedure Save_Private_Visibility;
procedure Restore_Private_Visibility;
procedure Restore_Private_Visibility is
E_Par : Elmt_Id;
begin
E_Par := First_Elmt (Priv_Par);
while Present (E_Par) loop
if not In_Private_Part (Node (E_Par)) then
Install_Private_Declarations (Node (E_Par));
end if;
Next_Elmt (E_Par);
end loop;
end Restore_Private_Visibility;
procedure Save_Private_Visibility is
Par : Entity_Id;
begin
Par := Scope (Current_Scope);
while Present (Par)
and then Par /= Standard_Standard
loop
if Ekind (Par) = E_Package
and then Is_Compilation_Unit (Par)
and then In_Private_Part (Par)
then
Append_Elmt (Par, Priv_Par);
end if;
Par := Scope (Par);
end loop;
end Save_Private_Visibility;
begin
if Present (U.Entity) then
return;
end if;
if U_Id = System_Secondary_Stack then
Opt.Sec_Stack_Used := True;
end if;
U.Uname := Get_Unit_Name (U_Id);
U.Withed := False;
declare
Loaded : Boolean;
pragma Warnings (Off, Loaded);
begin
Loaded := Is_Loaded (U.Uname);
end;
U.Unum :=
Load_Unit
(Load_Name => U.Uname,
Required => False,
Subunit => False,
Error_Node => Empty);
if U.Unum = No_Unit then
Load_Fail ("not found", U_Id, Id);
elsif Fatal_Error (U.Unum) then
Load_Fail ("had parser errors", U_Id, Id);
end if;
declare
Was_Analyzed : constant Boolean :=
Analyzed (Cunit (Current_Sem_Unit));
begin
Set_Analyzed (Cunit (Current_Sem_Unit), True);
if not Analyzed (Cunit (U.Unum)) then
Save_Private_Visibility;
Semantics (Cunit (U.Unum));
Restore_Private_Visibility;
if Fatal_Error (U.Unum) then
Load_Fail ("had semantic errors", U_Id, Id);
end if;
end if;
Set_Analyzed (Cunit (Current_Sem_Unit), Was_Analyzed);
end;
Lib_Unit := Unit (Cunit (U.Unum));
U.Entity := Defining_Entity (Lib_Unit);
if Use_Setting then
Set_Is_Potentially_Use_Visible (U.Entity, True);
end if;
end Load_RTU;
procedure Output_Entity_Name (Id : RE_Id; Msg : String) is
M : String (1 .. 2048);
P : Natural := 0;
RE_Image : constant String := RE_Id'Image (Id);
begin
if Id = RE_Null or else not All_Errors_Mode then
return;
end if;
M (1 .. 9) := "\entity """;
P := 9;
Get_Name_String (Get_Unit_Name (RE_Unit_Table (Id)));
Name_Len := Name_Len - 2;
Set_Casing (Mixed_Case);
M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len);
P := P + Name_Len;
M (P + 1) := '.';
P := P + 1;
Name_Len := RE_Image'Length - 3;
Name_Buffer (1 .. Name_Len) := RE_Image (4 .. RE_Image'Length);
Set_Casing (Mixed_Case);
M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len);
P := P + Name_Len;
M (P + 1) := '"';
P := P + 1;
M (P + 1) := ' ';
P := P + 1;
M (P + 1 .. P + Msg'Length) := Msg;
P := P + Msg'Length;
RTE_Error_Msg (M (1 .. P));
end Output_Entity_Name;
function RE_Chars (E : RE_Id) return Name_Id is
RE_Name_Chars : constant String := RE_Id'Image (E);
begin
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;
return Name_Find;
end RE_Chars;
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;
Save_Front_End_Inlining : Boolean;
function Check_CRT (Eid : Entity_Id) return Entity_Id;
procedure Check_RPC;
function Find_Local_Entity (E : RE_Id) return Entity_Id;
function Make_Unit_Name (N : Node_Id) return Node_Id;
function Check_CRT (Eid : Entity_Id) return Entity_Id is
begin
if No (Eid) then
Entity_Not_Defined (E);
raise RE_Not_Available;
else
if No_Run_Time_Mode
and then not OK_No_Run_Time_Unit (U_Id)
then
Entity_Not_Defined (E);
raise RE_Not_Available;
end if;
return Eid;
end if;
end Check_CRT;
procedure Check_RPC is
begin
if Debug_Flag_RR then
return;
end if;
if (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
or else
Distribution_Stub_Mode = Generate_Caller_Stub_Body)
and then (E = RE_Do_Rpc
or else
E = RE_Do_Apc
or else
E = RE_Params_Stream_Type
or else
E = RE_RPC_Receiver)
then
declare
DSA_Implementation : constant Entity_Id :=
RTE (RE_DSA_Implementation);
begin
if Chars (Entity (Expression
(Parent (DSA_Implementation)))) = Name_No_DSA
then
Set_Standard_Error;
Write_Str ("distribution feature not supported");
Write_Eol;
raise Unrecoverable_Error;
end if;
end;
end if;
end Check_RPC;
function Find_Local_Entity (E : RE_Id) return Entity_Id is
RE_Str : String renames RE_Id'Image (E);
Ent : Entity_Id;
Save_Nam : constant String := Name_Buffer (1 .. Name_Len);
begin
Name_Len := Natural'Max (0, RE_Str'Length - 3);
Name_Buffer (1 .. Name_Len) :=
RE_Str (RE_Str'First + 3 .. RE_Str'Last);
Ent := Entity_Id (Get_Name_Table_Info (Name_Find));
Name_Len := Save_Nam'Length;
Name_Buffer (1 .. Name_Len) := Save_Nam;
return Ent;
end Find_Local_Entity;
function Make_Unit_Name (N : Node_Id) return Node_Id is
Nam : Node_Id;
Scop : Entity_Id;
begin
Nam := New_Reference_To (U.Entity, Standard_Location);
Scop := Scope (U.Entity);
if Nkind (N) = N_Defining_Program_Unit_Name then
while Scop /= Standard_Standard loop
Nam :=
Make_Expanded_Name (Standard_Location,
Chars => Chars (U.Entity),
Prefix => New_Reference_To (Scop, Standard_Location),
Selector_Name => Nam);
Set_Entity (Nam, U.Entity);
Scop := Scope (Scop);
end loop;
end if;
return Nam;
end Make_Unit_Name;
begin
if Present (Main_Unit_Entity)
and then Chars (Main_Unit_Entity) = Name_System
and then Analyzed (Main_Unit_Entity)
and then not Is_Child_Unit (Main_Unit_Entity)
then
return Check_CRT (Find_Local_Entity (E));
end if;
Save_Front_End_Inlining := Front_End_Inlining;
Front_End_Inlining := Configurable_Run_Time_Mode;
if No (RE_Table (E)) then
Load_RTU (U_Id, Id => E);
Lib_Unit := Unit (Cunit (U.Unum));
if Nkind (Lib_Unit) = N_Subprogram_Declaration then
RE_Table (E) := U.Entity;
else
pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration);
Ename := RE_Chars (E);
Pkg_Ent := First_Entity (U.Entity);
while Present (Pkg_Ent) loop
if Ename = Chars (Pkg_Ent) then
RE_Table (E) := Pkg_Ent;
Check_RPC;
goto Found;
end if;
Next_Entity (Pkg_Ent);
end loop;
if Ename = Chars (U.Entity) then
RE_Table (E) := U.Entity;
end if;
end if;
end if;
<<Found>>
if (not U.Withed)
and then
In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit))
and then not RTE_Available_Call
then
U.Withed := True;
declare
Withn : Node_Id;
Lib_Unit : Node_Id;
begin
Lib_Unit := Unit (Cunit (U.Unum));
Withn :=
Make_With_Clause (Standard_Location,
Name =>
Make_Unit_Name
(Defining_Unit_Name (Specification (Lib_Unit))));
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;
end if;
Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (RE_Table (E));
end RTE;
function RTE_Available (E : RE_Id) return Boolean is
Dummy : Entity_Id;
pragma Warnings (Off, Dummy);
Result : Boolean;
Save_RTE_Available_Call : constant Boolean := RTE_Available_Call;
Save_RTE_Is_Available : constant Boolean := RTE_Is_Available;
begin
RTE_Available_Call := True;
RTE_Is_Available := True;
Dummy := RTE (E);
Result := RTE_Is_Available;
RTE_Available_Call := Save_RTE_Available_Call;
RTE_Is_Available := Save_RTE_Is_Available;
return Result;
exception
when RE_Not_Available =>
RTE_Available_Call := Save_RTE_Available_Call;
RTE_Is_Available := Save_RTE_Is_Available;
return False;
end RTE_Available;
procedure RTE_Error_Msg (Msg : String) is
begin
if RTE_Available_Call then
RTE_Is_Available := False;
else
Error_Msg_N (Msg, Current_Error_Node);
if Configurable_Run_Time_Mode and then Msg (1) /= '\' then
Configurable_Run_Time_Violations :=
Configurable_Run_Time_Violations + 1;
end if;
end if;
end RTE_Error_Msg;
function RTU_Loaded (U : RTU_Id) return Boolean is
begin
return Present (RT_Unit_Table (U).Entity);
end RTU_Loaded;
procedure Set_RTU_Loaded (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
Uname : constant Unit_Name_Type := Unit_Name (Unum);
E : constant Entity_Id :=
Defining_Entity (Unit (Cunit (Unum)));
begin
pragma Assert (Is_Predefined_File_Name (Unit_File_Name (Unum)));
for U_Id in RTU_Id'Range loop
if Get_Unit_Name (U_Id) = Uname then
declare
U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
begin
if not Present (U.Entity) then
U.Entity := E;
U.Uname := Get_Unit_Name (U_Id);
U.Unum := Unum;
U.Withed := False;
end if;
return;
end;
end if;
end loop;
end Set_RTU_Loaded;
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 : constant 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 : constant 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
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;
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
if Name_Buffer (1 .. 12) = "a-textio.ads" then
Load_RTU
(Name_Map (Chrs),
Use_Setting => In_Use (Cunit_Entity (U)));
Set_Is_Visible_Child_Unit
(RT_Unit_Table (Name_Map (Chrs)).Entity);
elsif Name_Buffer (1 .. 12) = "a-witeio.ads" then
Load_RTU
(Wide_Name_Map (Chrs),
Use_Setting => In_Use (Cunit_Entity (U)));
Set_Is_Visible_Child_Unit
(RT_Unit_Table (Wide_Name_Map (Chrs)).Entity);
end if;
end if;
end loop;
end if;
end Text_IO_Kludge;
end Rtsfind;