diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/s-parint.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/s-parint.adb | 323 |
1 files changed, 0 insertions, 323 deletions
diff --git a/gcc-4.2.1/gcc/ada/s-parint.adb b/gcc-4.2.1/gcc/ada/s-parint.adb deleted file mode 100644 index 6091f3d1d..000000000 --- a/gcc-4.2.1/gcc/ada/s-parint.adb +++ /dev/null @@ -1,323 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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-2005, 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, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, 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; |