package body System.Partition_Interface is
pragma Warnings (Off);
M : constant := 7;
type String_Access is access String;
type Pkg_Node;
type Pkg_List is access Pkg_Node;
type Pkg_Node is record
Name : String_Access;
Next : Pkg_List;
end record;
Pkg_Head : Pkg_List;
Pkg_Tail : Pkg_List;
function getpid return Integer;
pragma Import (C, getpid);
PID : constant Integer := getpid;
function Lower (S : String) return String;
Passive_Prefix : constant String := "SP__";
procedure Check
(Name : in Unit_Name;
Version : in String;
RCI : in Boolean := True)
is
begin
null;
end Check;
function Get_Active_Partition_ID
(Name : Unit_Name)
return System.RPC.Partition_ID
is
P : Pkg_List := Pkg_Head;
N : String := Lower (Name);
begin
while P /= null loop
if P.Name.all = N then
return Get_Local_Partition_ID;
end if;
P := P.Next;
end loop;
return M;
end Get_Active_Partition_ID;
function Get_Active_Version
(Name : Unit_Name)
return String
is
begin
return "";
end Get_Active_Version;
function Get_Local_Partition_ID return System.RPC.Partition_ID is
begin
return System.RPC.Partition_ID (PID mod M);
end Get_Local_Partition_ID;
function Get_Passive_Partition_ID
(Name : Unit_Name)
return System.RPC.Partition_ID
is
begin
return Get_Local_Partition_ID;
end Get_Passive_Partition_ID;
function Get_Passive_Version
(Name : Unit_Name)
return String
is
begin
return "";
end Get_Passive_Version;
function Get_RCI_Package_Receiver
(Name : Unit_Name)
return Interfaces.Unsigned_64
is
begin
return 0;
end Get_RCI_Package_Receiver;
procedure Get_Unique_Remote_Pointer
(Handler : in out RACW_Stub_Type_Access)
is
begin
null;
end Get_Unique_Remote_Pointer;
procedure Launch
(Rsh_Command : in String;
Name_Is_Host : in Boolean;
General_Name : in String;
Command_Line : in String)
is
begin
null;
end Launch;
function Lower (S : String) return String is
T : String := S;
begin
for J in T'Range loop
if T (J) in 'A' .. 'Z' then
T (J) := Character'Val (Character'Pos (T (J)) -
Character'Pos ('A') +
Character'Pos ('a'));
end if;
end loop;
return T;
end Lower;
procedure Raise_Program_Error_For_E_4_18 is
begin
Ada.Exceptions.Raise_Exception
(Program_Error'Identity,
"Illegal usage of remote access to class-wide type. See RM E.4(18)");
end Raise_Program_Error_For_E_4_18;
procedure Raise_Program_Error_Unknown_Tag
(E : in Ada.Exceptions.Exception_Occurrence)
is
begin
Ada.Exceptions.Raise_Exception
(Program_Error'Identity, Ada.Exceptions.Exception_Message (E));
end Raise_Program_Error_Unknown_Tag;
package body RCI_Info is
function Get_Active_Partition_ID return System.RPC.Partition_ID is
P : Pkg_List := Pkg_Head;
N : String := Lower (RCI_Name);
begin
while P /= null loop
if P.Name.all = N then
return Get_Local_Partition_ID;
end if;
P := P.Next;
end loop;
return M;
end Get_Active_Partition_ID;
function Get_RCI_Package_Receiver return Interfaces.Unsigned_64 is
begin
return 0;
end Get_RCI_Package_Receiver;
end RCI_Info;
procedure Register_Passive_Package
(Name : in Unit_Name;
Version : in String := "")
is
begin
Register_Receiving_Stub (Passive_Prefix & Name, null, Version);
end Register_Passive_Package;
procedure Register_Receiving_Stub
(Name : in Unit_Name;
Receiver : in RPC.RPC_Receiver;
Version : in String := "")
is
begin
if Pkg_Tail = null then
Pkg_Head := new Pkg_Node'(new String'(Lower (Name)), null);
Pkg_Tail := Pkg_Head;
else
Pkg_Tail.Next := new Pkg_Node'(new String'(Lower (Name)), null);
Pkg_Tail := Pkg_Tail.Next;
end if;
end Register_Receiving_Stub;
procedure Run
(Main : in Main_Subprogram_Type := null)
is
begin
if Main /= null then
Main.all;
end if;
end Run;
end System.Partition_Interface;