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 --          Copyright (C) 1995-2004 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 package body System.Partition_Interface is
  36
  37    pragma Warnings (Off); -- supress warnings for unreferenced formals
  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    -- Lower --
 167    -----------
 168
 169    function Lower (S : String) return String is
 170       T : String := S;
 171
 172    begin
 173       for J in T'Range loop
 174          if T (J) in 'A' .. 'Z' then
 175             T (J) := Character'Val (Character'Pos (T (J)) -
 176                                     Character'Pos ('A') +
 177                                     Character'Pos ('a'));
 178          end if;
 179       end loop;
 180
 181       return T;
 182    end Lower;
 183
 184    -------------------------------------
 185    -- Raise_Program_Error_Unknown_Tag --
 186    -------------------------------------
 187
 188    procedure Raise_Program_Error_Unknown_Tag
 189      (E : in Ada.Exceptions.Exception_Occurrence)
 190    is
 191    begin
 192       Ada.Exceptions.Raise_Exception
 193         (Program_Error'Identity, Ada.Exceptions.Exception_Message (E));
 194    end Raise_Program_Error_Unknown_Tag;
 195
 196    --------------
 197    -- RCI_Info --
 198    --------------
 199
 200    package body RCI_Info is
 201
 202       -----------------------------
 203       -- Get_Active_Partition_ID --
 204       -----------------------------
 205
 206       function Get_Active_Partition_ID return System.RPC.Partition_ID is
 207          P : Pkg_List := Pkg_Head;
 208          N : String   := Lower (RCI_Name);
 209
 210       begin
 211          while P /= null loop
 212             if P.Name.all = N then
 213                return Get_Local_Partition_ID;
 214             end if;
 215
 216             P := P.Next;
 217          end loop;
 218
 219          return M;
 220       end Get_Active_Partition_ID;
 221
 222       ------------------------------
 223       -- Get_RCI_Package_Receiver --
 224       ------------------------------
 225
 226       function Get_RCI_Package_Receiver return Interfaces.Unsigned_64 is
 227       begin
 228          return 0;
 229       end Get_RCI_Package_Receiver;
 230
 231    end RCI_Info;
 232
 233    ------------------------------
 234    -- Register_Passive_Package --
 235    ------------------------------
 236
 237    procedure Register_Passive_Package
 238      (Name    : in Unit_Name;
 239       Version : in String := "")
 240    is
 241    begin
 242       Register_Receiving_Stub (Passive_Prefix & Name, null, Version);
 243    end Register_Passive_Package;
 244
 245    -----------------------------
 246    -- Register_Receiving_Stub --
 247    -----------------------------
 248
 249    procedure Register_Receiving_Stub
 250      (Name     : in Unit_Name;
 251       Receiver : in RPC.RPC_Receiver;
 252       Version  : in String := "")
 253    is
 254    begin
 255       if Pkg_Tail = null then
 256          Pkg_Head := new Pkg_Node'(new String'(Lower (Name)), null);
 257          Pkg_Tail := Pkg_Head;
 258
 259       else
 260          Pkg_Tail.Next := new Pkg_Node'(new String'(Lower (Name)), null);
 261          Pkg_Tail := Pkg_Tail.Next;
 262       end if;
 263    end Register_Receiving_Stub;
 264
 265    ---------
 266    -- Run --
 267    ---------
 268
 269    procedure Run
 270      (Main : in Main_Subprogram_Type := null)
 271    is
 272    begin
 273       if Main /= null then
 274          Main.all;
 275       end if;
 276    end Run;
 277
 278 end System.Partition_Interface;