diff options
Diffstat (limited to 'gcc/ada/s-parint.adb')
| -rw-r--r-- | gcc/ada/s-parint.adb | 320 |
1 files changed, 320 insertions, 0 deletions
diff --git a/gcc/ada/s-parint.adb b/gcc/ada/s-parint.adb new file mode 100644 index 000000000..53cc49cdb --- /dev/null +++ b/gcc/ada/s-parint.adb @@ -0,0 +1,320 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009, 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; |