------------------------------------------------------------------------------ -- -- -- 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-2004 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 2, or (at your option) any later ver- -- -- sion. GNARL 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. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNARL; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- 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); -- supress 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 Ada.Exceptions.Raise_Exception (Program_Error'Identity, 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 : access RACW_Stub_Type; Right : access RACW_Stub_Type) return Boolean is pragma Unreferenced (Left); pragma Unreferenced (Right); begin return True; end Same_Partition; end System.Partition_Interface;