------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . P A R T I T I O N _ I N T E R F A C E --
-- --
-- B o d y --
-- (Dummy body for non-distributed case) --
-- --
-- Copyright (C) 1995-2023, Free Software Foundation, Inc. --
-- --
-- GNARL 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. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body System.Partition_Interface is
pragma Warnings (Off); -- suppress warnings for unreferenced formals
M : constant := 7;
type String_Access is access String;
-- To have a minimal implementation of U'Partition_ID
type Pkg_Node;
type Pkg_List is access Pkg_Node;
type Pkg_Node is record
Name : String_Access;
Subp_Info : System.Address;
Subp_Info_Len : Integer;
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__";
-- String prepended in top of shared passive packages
procedure Check
(Name : Unit_Name;
Version : String;
RCI : Boolean := True)
is
begin
null;
end Check;
-----------------------------
-- Get_Active_Partition_ID --
-----------------------------
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;
------------------------
-- Get_Active_Version --
------------------------
function Get_Active_Version (Name : Unit_Name) return String is
begin
return "";
end Get_Active_Version;
----------------------------
-- Get_Local_Partition_ID --
----------------------------
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;
------------------------------
-- Get_Passive_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;
-------------------------
-- Get_Passive_Version --
-------------------------
function Get_Passive_Version (Name : Unit_Name) return String is
begin
return "";
end Get_Passive_Version;
------------------
-- Get_RAS_Info --
------------------
procedure Get_RAS_Info
(Name : Unit_Name;
Subp_Id : Subprogram_Id;
Proxy_Address : out Interfaces.Unsigned_64)
is
LName : constant String := Lower (Name);
N : Pkg_List;
begin
N := Pkg_Head;
while N /= null loop
if N.Name.all = LName then
declare
subtype Subprogram_Array is RCI_Subp_Info_Array
(First_RCI_Subprogram_Id ..
First_RCI_Subprogram_Id + N.Subp_Info_Len - 1);
Subprograms : Subprogram_Array;
for Subprograms'Address use N.Subp_Info;
pragma Import (Ada, Subprograms);
begin
Proxy_Address :=
Interfaces.Unsigned_64 (Subprograms (Integer (Subp_Id)).Addr);
return;
end;
end if;
N := N.Next;
end loop;
Proxy_Address := 0;
end Get_RAS_Info;
------------------------------
-- Get_RCI_Package_Receiver --
------------------------------
function Get_RCI_Package_Receiver
(Name : Unit_Name) return Interfaces.Unsigned_64
is
begin
return 0;
end Get_RCI_Package_Receiver;
-------------------------------
-- Get_Unique_Remote_Pointer --
-------------------------------
procedure Get_Unique_Remote_Pointer
(Handler : in out RACW_Stub_Type_Access)
is
begin
null;
end Get_Unique_Remote_Pointer;
-----------
-- Lower --
-----------
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;
-------------------------------------
-- Raise_Program_Error_Unknown_Tag --
-------------------------------------
procedure Raise_Program_Error_Unknown_Tag
(E : Ada.Exceptions.Exception_Occurrence)
is
begin
raise Program_Error with Ada.Exceptions.Exception_Message (E);
end Raise_Program_Error_Unknown_Tag;
-----------------
-- RCI_Locator --
-----------------
package body RCI_Locator is
-----------------------------
-- Get_Active_Partition_ID --
-----------------------------
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;
------------------------------
-- Get_RCI_Package_Receiver --
------------------------------
function Get_RCI_Package_Receiver return Interfaces.Unsigned_64 is
begin
return 0;
end Get_RCI_Package_Receiver;
end RCI_Locator;
------------------------------
-- Register_Passive_Package --
------------------------------
procedure Register_Passive_Package
(Name : Unit_Name;
Version : String := "")
is
begin
Register_Receiving_Stub
(Passive_Prefix & Name, null, Version, System.Null_Address, 0);
end Register_Passive_Package;
-----------------------------
-- Register_Receiving_Stub --
-----------------------------
procedure Register_Receiving_Stub
(Name : Unit_Name;
Receiver : RPC_Receiver;
Version : String := "";
Subp_Info : System.Address;
Subp_Info_Len : Integer)
is
N : constant Pkg_List :=
new Pkg_Node'(new String'(Lower (Name)),
Subp_Info, Subp_Info_Len,
Next => null);
begin
if Pkg_Tail = null then
Pkg_Head := N;
else
Pkg_Tail.Next := N;
end if;
Pkg_Tail := N;
end Register_Receiving_Stub;
---------
-- Run --
---------
procedure Run
(Main : Main_Subprogram_Type := null)
is
begin
if Main /= null then
Main.all;
end if;
end Run;
--------------------
-- Same_Partition --
--------------------
function Same_Partition
(Left : not null access RACW_Stub_Type;
Right : not null access RACW_Stub_Type) return Boolean
is
pragma Unreferenced (Left);
pragma Unreferenced (Right);
begin
return True;
end Same_Partition;
end System.Partition_Interface;