New Language: Ada

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45957 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 303 insertions, 0 deletions

diff --git a/gcc/ada/s-parint.adb b/gcc/ada/s-parint.adb
new file mode 100644
index 00000000000..4d8e80d2706
--- /dev/null
+++ b/gcc/ada/s-parint.adb
@@ -0,0 +1,303 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         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;