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-2001 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
35package 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   -- 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
303end System.Partition_Interface;
304