------------------------------------------------------------------------------ -- -- -- 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-2018, 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 -- -- . -- -- -- -- 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;