gcc/ada/s-parint.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --            S Y S T E M . P A R T I T I O N _ I N T E R F A C E           --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                   (Dummy body for non-distributed case)                  --
   9 --                                                                          --
  10 --                                                                          --
  11 --          Copyright (C) 1995-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 package body System.Partition_Interface is
  37
  38    pragma Warnings (Off); -- supress warnings for unreferenced formals
  39
  40    M : constant := 7;
  41
  42    type String_Access is access String;
  43
  44    --  To have a minimal implementation of U'Partition_ID.
  45
  46    type Pkg_Node;
  47    type Pkg_List is access Pkg_Node;
  48    type Pkg_Node is record
  49       Name : String_Access;
  50       Next : Pkg_List;
  51    end record;
  52
  53    Pkg_Head : Pkg_List;
  54    Pkg_Tail : Pkg_List;
  55
  56    function getpid return Integer;
  57    pragma Import (C, getpid);
  58
  59    PID : constant Integer := getpid;
  60
  61    function Lower (S : String) return String;
  62
  63    Passive_Prefix : constant String := "SP__";
  64    --  String prepended in top of shared passive packages
  65
  66    procedure Check
  67      (Name    : in Unit_Name;
  68       Version : in String;
  69       RCI     : in Boolean := True)
  70    is
  71    begin
  72       null;
  73    end Check;
  74
  75    -----------------------------
  76    -- Get_Active_Partition_Id --
  77    -----------------------------
  78
  79    function Get_Active_Partition_ID
  80      (Name : Unit_Name)
  81       return System.RPC.Partition_ID
  82    is
  83       P : Pkg_List := Pkg_Head;
  84       N : String   := Lower (Name);
  85
  86    begin
  87       while P /= null loop
  88          if P.Name.all = N then
  89             return Get_Local_Partition_ID;
  90          end if;
  91
  92          P := P.Next;
  93       end loop;
  94
  95       return M;
  96    end Get_Active_Partition_ID;
  97
  98    ------------------------
  99    -- Get_Active_Version --
 100    ------------------------
 101
 102    function Get_Active_Version
 103      (Name : Unit_Name)
 104       return String
 105    is
 106    begin
 107       return "";
 108    end Get_Active_Version;
 109
 110    ----------------------------
 111    -- Get_Local_Partition_Id --
 112    ----------------------------
 113
 114    function Get_Local_Partition_ID return System.RPC.Partition_ID is
 115    begin
 116       return System.RPC.Partition_ID (PID mod M);
 117    end Get_Local_Partition_ID;
 118
 119    ------------------------------
 120    -- Get_Passive_Partition_ID --
 121    ------------------------------
 122
 123    function Get_Passive_Partition_ID
 124      (Name : Unit_Name)
 125       return System.RPC.Partition_ID
 126    is
 127    begin
 128       return Get_Local_Partition_ID;
 129    end Get_Passive_Partition_ID;
 130
 131    -------------------------
 132    -- Get_Passive_Version --
 133    -------------------------
 134
 135    function Get_Passive_Version
 136      (Name : Unit_Name)
 137       return String
 138    is
 139    begin
 140       return "";
 141    end Get_Passive_Version;
 142
 143    ------------------------------
 144    -- Get_RCI_Package_Receiver --
 145    ------------------------------
 146
 147    function Get_RCI_Package_Receiver
 148      (Name : Unit_Name)
 149       return Interfaces.Unsigned_64
 150    is
 151    begin
 152       return 0;
 153    end Get_RCI_Package_Receiver;
 154
 155    -------------------------------
 156    -- Get_Unique_Remote_Pointer --
 157    -------------------------------
 158
 159    procedure Get_Unique_Remote_Pointer
 160      (Handler : in out RACW_Stub_Type_Access)
 161    is
 162    begin
 163       null;
 164    end Get_Unique_Remote_Pointer;
 165
 166    ------------
 167    -- Launch --
 168    ------------
 169
 170    procedure Launch
 171      (Rsh_Command  : in String;
 172       Name_Is_Host : in Boolean;
 173       General_Name : in String;
 174       Command_Line : in String)
 175    is
 176    begin
 177       null;
 178    end Launch;
 179
 180    -----------
 181    -- Lower --
 182    -----------
 183
 184    function Lower (S : String) return String is
 185       T : String := S;
 186
 187    begin
 188       for J in T'Range loop
 189          if T (J) in 'A' .. 'Z' then
 190             T (J) := Character'Val (Character'Pos (T (J)) -
 191                                     Character'Pos ('A') +
 192                                     Character'Pos ('a'));
 193          end if;
 194       end loop;
 195
 196       return T;
 197    end Lower;
 198
 199    ------------------------------------
 200    -- Raise_Program_Error_For_E_4_18 --
 201    ------------------------------------
 202
 203    procedure Raise_Program_Error_For_E_4_18 is
 204    begin
 205       Ada.Exceptions.Raise_Exception
 206         (Program_Error'Identity,
 207         "Illegal usage of remote access to class-wide type. See RM E.4(18)");
 208    end Raise_Program_Error_For_E_4_18;
 209
 210    -------------------------------------
 211    -- Raise_Program_Error_Unknown_Tag --
 212    -------------------------------------
 213
 214    procedure Raise_Program_Error_Unknown_Tag
 215      (E : in Ada.Exceptions.Exception_Occurrence)
 216    is
 217    begin
 218       Ada.Exceptions.Raise_Exception
 219         (Program_Error'Identity, Ada.Exceptions.Exception_Message (E));
 220    end Raise_Program_Error_Unknown_Tag;
 221
 222    --------------
 223    -- RCI_Info --
 224    --------------
 225
 226    package body RCI_Info is
 227
 228       -----------------------------
 229       -- Get_Active_Partition_ID --
 230       -----------------------------
 231
 232       function Get_Active_Partition_ID return System.RPC.Partition_ID is
 233          P : Pkg_List := Pkg_Head;
 234          N : String   := Lower (RCI_Name);
 235
 236       begin
 237          while P /= null loop
 238             if P.Name.all = N then
 239                return Get_Local_Partition_ID;
 240             end if;
 241
 242             P := P.Next;
 243          end loop;
 244
 245          return M;
 246       end Get_Active_Partition_ID;
 247
 248       ------------------------------
 249       -- Get_RCI_Package_Receiver --
 250       ------------------------------
 251
 252       function Get_RCI_Package_Receiver return Interfaces.Unsigned_64 is
 253       begin
 254          return 0;
 255       end Get_RCI_Package_Receiver;
 256
 257    end RCI_Info;
 258
 259    ------------------------------
 260    -- Register_Passive_Package --
 261    ------------------------------
 262
 263    procedure Register_Passive_Package
 264      (Name    : in Unit_Name;
 265       Version : in String := "")
 266    is
 267    begin
 268       Register_Receiving_Stub (Passive_Prefix & Name, null, Version);
 269    end Register_Passive_Package;
 270
 271    -----------------------------
 272    -- Register_Receiving_Stub --
 273    -----------------------------
 274
 275    procedure Register_Receiving_Stub
 276      (Name     : in Unit_Name;
 277       Receiver : in RPC.RPC_Receiver;
 278       Version  : in String := "")
 279    is
 280    begin
 281       if Pkg_Tail = null then
 282          Pkg_Head := new Pkg_Node'(new String'(Lower (Name)), null);
 283          Pkg_Tail := Pkg_Head;
 284
 285       else
 286          Pkg_Tail.Next := new Pkg_Node'(new String'(Lower (Name)), null);
 287          Pkg_Tail := Pkg_Tail.Next;
 288       end if;
 289    end Register_Receiving_Stub;
 290
 291    ---------
 292    -- Run --
 293    ---------
 294
 295    procedure Run
 296      (Main : in Main_Subprogram_Type := null)
 297    is
 298    begin
 299       if Main /= null then
 300          Main.all;
 301       end if;
 302    end Run;
 303
 304 end System.Partition_Interface;