OS/2 Shareware BBS: 10 Tools

home *** CD-ROM | disk | FTP | other *** search

/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adav313.zip / gnat-3_13p-os2-bin-20010916.zip / emx / gnatlib / s-parint.adb < prev next >

Wrap

Text File | 2000-07-19 | 9KB | 304 lines

------------------------------------------------------------------------------ -- -- -- 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) -- -- -- -- $Revision: 1.21 $ -- -- -- Copyright (C) 1995-2000 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. -- -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ package body System.Partition_Interface is 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; 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 : in Unit_Name; Version : in String; RCI : in 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_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; ------------ -- Launch -- ------------ procedure Launch (Rsh_Command : in String; Name_Is_Host : in Boolean; General_Name : in String; Command_Line : in String) is begin null; end Launch; ----------- -- 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_For_E_4_18 -- ------------------------------------ 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; ------------------------------------- -- Raise_Program_Error_Unknown_Tag -- ------------------------------------- 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; -------------- -- RCI_Info -- -------------- package body RCI_Info 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_Info; ------------------------------ -- Register_Passive_Package -- ------------------------------ 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; ----------------------------- -- Register_Receiving_Stub -- ----------------------------- 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; --------- -- Run -- --------- procedure Run (Main : in Main_Subprogram_Type := null) is begin if Main /= null then Main.all; end if; end Run; end System.Partition_Interface;