Licensing changes to GPLv3 resp. GPLv3 with GCC Runtime Exception.

[thirdparty/gcc.git] / gcc / ada / s-parint.adb

------------------------------------------------------------------------------
--                                                                          --
--                         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;