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