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$
  11 --                                                                          --
  12 --          Copyright (C) 1995-2001 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    pragma Warnings (Off); -- supress warnings for unreferenced formals
  40
  41    M : constant := 7;
  42
  43    type String_Access is access String;
  44
  45    --  To have a minimal implementation of U'Partition_ID.
  46
  47    type Pkg_Node;
  48    type Pkg_List is access Pkg_Node;
  49    type Pkg_Node is record
  50       Name : String_Access;
  51       Next : Pkg_List;
  52    end record;
  53
  54    Pkg_Head : Pkg_List;
  55    Pkg_Tail : Pkg_List;
  56
  57    function getpid return Integer;
  58    pragma Import (C, getpid);
  59
  60    PID : constant Integer := getpid;
  61
  62    function Lower (S : String) return String;
  63
  64    Passive_Prefix : constant String := "SP__";
  65    --  String prepended in top of shared passive packages
  66
  67    procedure Check
  68      (Name    : in Unit_Name;
  69       Version : in String;
  70       RCI     : in Boolean := True)
  71    is
  72    begin
  73       null;
  74    end Check;
  75
  76    -----------------------------
  77    -- Get_Active_Partition_Id --
  78    -----------------------------
  79
  80    function Get_Active_Partition_ID
  81      (Name : Unit_Name)
  82       return System.RPC.Partition_ID
  83    is
  84       P : Pkg_List := Pkg_Head;
  85       N : String   := Lower (Name);
  86
  87    begin
  88       while P /= null loop
  89          if P.Name.all = N then
  90             return Get_Local_Partition_ID;
  91          end if;
  92
  93          P := P.Next;
  94       end loop;
  95
  96       return M;
  97    end Get_Active_Partition_ID;
  98
  99    ------------------------
 100    -- Get_Active_Version --
 101    ------------------------
 102
 103    function Get_Active_Version
 104      (Name : Unit_Name)
 105       return String
 106    is
 107    begin
 108       return "";
 109    end Get_Active_Version;
 110
 111    ----------------------------
 112    -- Get_Local_Partition_Id --
 113    ----------------------------
 114
 115    function Get_Local_Partition_ID return System.RPC.Partition_ID is
 116    begin
 117       return System.RPC.Partition_ID (PID mod M);
 118    end Get_Local_Partition_ID;
 119
 120    ------------------------------
 121    -- Get_Passive_Partition_ID --
 122    ------------------------------
 123
 124    function Get_Passive_Partition_ID
 125      (Name : Unit_Name)
 126       return System.RPC.Partition_ID
 127    is
 128    begin
 129       return Get_Local_Partition_ID;
 130    end Get_Passive_Partition_ID;
 131
 132    -------------------------
 133    -- Get_Passive_Version --
 134    -------------------------
 135
 136    function Get_Passive_Version
 137      (Name : Unit_Name)
 138       return String
 139    is
 140    begin
 141       return "";
 142    end Get_Passive_Version;
 143
 144    ------------------------------
 145    -- Get_RCI_Package_Receiver --
 146    ------------------------------
 147
 148    function Get_RCI_Package_Receiver
 149      (Name : Unit_Name)
 150       return Interfaces.Unsigned_64
 151    is
 152    begin
 153       return 0;
 154    end Get_RCI_Package_Receiver;
 155
 156    -------------------------------
 157    -- Get_Unique_Remote_Pointer --
 158    -------------------------------
 159
 160    procedure Get_Unique_Remote_Pointer
 161      (Handler : in out RACW_Stub_Type_Access)
 162    is
 163    begin
 164       null;
 165    end Get_Unique_Remote_Pointer;
 166
 167    ------------
 168    -- Launch --
 169    ------------
 170
 171    procedure Launch
 172      (Rsh_Command  : in String;
 173       Name_Is_Host : in Boolean;
 174       General_Name : in String;
 175       Command_Line : in String)
 176    is
 177    begin
 178       null;
 179    end Launch;
 180
 181    -----------
 182    -- Lower --
 183    -----------
 184
 185    function Lower (S : String) return String is
 186       T : String := S;
 187
 188    begin
 189       for J in T'Range loop
 190          if T (J) in 'A' .. 'Z' then
 191             T (J) := Character'Val (Character'Pos (T (J)) -
 192                                     Character'Pos ('A') +
 193                                     Character'Pos ('a'));
 194          end if;
 195       end loop;
 196
 197       return T;
 198    end Lower;
 199
 200    ------------------------------------
 201    -- Raise_Program_Error_For_E_4_18 --
 202    ------------------------------------
 203
 204    procedure Raise_Program_Error_For_E_4_18 is
 205    begin
 206       Ada.Exceptions.Raise_Exception
 207         (Program_Error'Identity,
 208         "Illegal usage of remote access to class-wide type. See RM E.4(18)");
 209    end Raise_Program_Error_For_E_4_18;
 210
 211    -------------------------------------
 212    -- Raise_Program_Error_Unknown_Tag --
 213    -------------------------------------
 214
 215    procedure Raise_Program_Error_Unknown_Tag
 216      (E : in Ada.Exceptions.Exception_Occurrence)
 217    is
 218    begin
 219       Ada.Exceptions.Raise_Exception
 220         (Program_Error'Identity, Ada.Exceptions.Exception_Message (E));
 221    end Raise_Program_Error_Unknown_Tag;
 222
 223    --------------
 224    -- RCI_Info --
 225    --------------
 226
 227    package body RCI_Info is
 228
 229       -----------------------------
 230       -- Get_Active_Partition_ID --
 231       -----------------------------
 232
 233       function Get_Active_Partition_ID return System.RPC.Partition_ID is
 234          P : Pkg_List := Pkg_Head;
 235          N : String   := Lower (RCI_Name);
 236
 237       begin
 238          while P /= null loop
 239             if P.Name.all = N then
 240                return Get_Local_Partition_ID;
 241             end if;
 242
 243             P := P.Next;
 244          end loop;
 245
 246          return M;
 247       end Get_Active_Partition_ID;
 248
 249       ------------------------------
 250       -- Get_RCI_Package_Receiver --
 251       ------------------------------
 252
 253       function Get_RCI_Package_Receiver return Interfaces.Unsigned_64 is
 254       begin
 255          return 0;
 256       end Get_RCI_Package_Receiver;
 257
 258    end RCI_Info;
 259
 260    ------------------------------
 261    -- Register_Passive_Package --
 262    ------------------------------
 263
 264    procedure Register_Passive_Package
 265      (Name    : in Unit_Name;
 266       Version : in String := "")
 267    is
 268    begin
 269       Register_Receiving_Stub (Passive_Prefix & Name, null, Version);
 270    end Register_Passive_Package;
 271
 272    -----------------------------
 273    -- Register_Receiving_Stub --
 274    -----------------------------
 275
 276    procedure Register_Receiving_Stub
 277      (Name     : in Unit_Name;
 278       Receiver : in RPC.RPC_Receiver;
 279       Version  : in String := "")
 280    is
 281    begin
 282       if Pkg_Tail = null then
 283          Pkg_Head := new Pkg_Node'(new String'(Lower (Name)), null);
 284          Pkg_Tail := Pkg_Head;
 285
 286       else
 287          Pkg_Tail.Next := new Pkg_Node'(new String'(Lower (Name)), null);
 288          Pkg_Tail := Pkg_Tail.Next;
 289       end if;
 290    end Register_Receiving_Stub;
 291
 292    ---------
 293    -- Run --
 294    ---------
 295
 296    procedure Run
 297      (Main : in Main_Subprogram_Type := null)
 298    is
 299    begin
 300       if Main /= null then
 301          Main.all;
 302       end if;
 303    end Run;
 304
 305 end System.Partition_Interface;