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-2009, 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 3,  or (at your option) any later ver- --
15-- sion.  GNAT 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.                                     --
18--                                                                          --
19-- As a special exception under Section 7 of GPL version 3, you are granted --
20-- additional permissions described in the GCC Runtime Library Exception,   --
21-- version 3.1, as published by the Free Software Foundation.               --
22--                                                                          --
23-- You should have received a copy of the GNU General Public License and    --
24-- a copy of the GCC Runtime Library Exception along with this program;     --
25-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
26-- <http://www.gnu.org/licenses/>.                                          --
27--                                                                          --
28-- GNAT was originally developed  by the GNAT team at  New York University. --
29-- Extensive contributions were provided by Ada Core Technologies Inc.      --
30--                                                                          --
31------------------------------------------------------------------------------
32
33package body System.Partition_Interface is
34
35   pragma Warnings (Off); -- suppress warnings for unreferenced formals
36
37   M : constant := 7;
38
39   type String_Access is access String;
40
41   --  To have a minimal implementation of U'Partition_ID
42
43   type Pkg_Node;
44   type Pkg_List is access Pkg_Node;
45   type Pkg_Node is record
46      Name          : String_Access;
47      Subp_Info     : System.Address;
48      Subp_Info_Len : Integer;
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    : Unit_Name;
67      Version : String;
68      RCI     : 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) return System.RPC.Partition_ID
80   is
81      P : Pkg_List := Pkg_Head;
82      N : String   := Lower (Name);
83
84   begin
85      while P /= null loop
86         if P.Name.all = N then
87            return Get_Local_Partition_ID;
88         end if;
89
90         P := P.Next;
91      end loop;
92
93      return M;
94   end Get_Active_Partition_ID;
95
96   ------------------------
97   -- Get_Active_Version --
98   ------------------------
99
100   function Get_Active_Version (Name : Unit_Name) return String is
101   begin
102      return "";
103   end Get_Active_Version;
104
105   ----------------------------
106   -- Get_Local_Partition_Id --
107   ----------------------------
108
109   function Get_Local_Partition_ID return System.RPC.Partition_ID is
110   begin
111      return System.RPC.Partition_ID (PID mod M);
112   end Get_Local_Partition_ID;
113
114   ------------------------------
115   -- Get_Passive_Partition_ID --
116   ------------------------------
117
118   function Get_Passive_Partition_ID
119     (Name : Unit_Name) return System.RPC.Partition_ID
120   is
121   begin
122      return Get_Local_Partition_ID;
123   end Get_Passive_Partition_ID;
124
125   -------------------------
126   -- Get_Passive_Version --
127   -------------------------
128
129   function Get_Passive_Version (Name : Unit_Name) return String is
130   begin
131      return "";
132   end Get_Passive_Version;
133
134   ------------------
135   -- Get_RAS_Info --
136   ------------------
137
138   procedure Get_RAS_Info
139     (Name          :  Unit_Name;
140      Subp_Id       :  Subprogram_Id;
141      Proxy_Address : out Interfaces.Unsigned_64)
142   is
143      LName : constant String := Lower (Name);
144      N : Pkg_List;
145   begin
146      N := Pkg_Head;
147      while N /= null loop
148         if N.Name.all = LName then
149            declare
150               subtype Subprogram_Array is RCI_Subp_Info_Array
151                 (First_RCI_Subprogram_Id ..
152                  First_RCI_Subprogram_Id + N.Subp_Info_Len - 1);
153               Subprograms : Subprogram_Array;
154               for Subprograms'Address use N.Subp_Info;
155               pragma Import (Ada, Subprograms);
156            begin
157               Proxy_Address :=
158                 Interfaces.Unsigned_64 (Subprograms (Integer (Subp_Id)).Addr);
159               return;
160            end;
161         end if;
162         N := N.Next;
163      end loop;
164      Proxy_Address := 0;
165   end Get_RAS_Info;
166
167   ------------------------------
168   -- Get_RCI_Package_Receiver --
169   ------------------------------
170
171   function Get_RCI_Package_Receiver
172     (Name : Unit_Name) return Interfaces.Unsigned_64
173   is
174   begin
175      return 0;
176   end Get_RCI_Package_Receiver;
177
178   -------------------------------
179   -- Get_Unique_Remote_Pointer --
180   -------------------------------
181
182   procedure Get_Unique_Remote_Pointer
183     (Handler : in out RACW_Stub_Type_Access)
184   is
185   begin
186      null;
187   end Get_Unique_Remote_Pointer;
188
189   -----------
190   -- Lower --
191   -----------
192
193   function Lower (S : String) return String is
194      T : String := S;
195
196   begin
197      for J in T'Range loop
198         if T (J) in 'A' .. 'Z' then
199            T (J) := Character'Val (Character'Pos (T (J)) -
200                                    Character'Pos ('A') +
201                                    Character'Pos ('a'));
202         end if;
203      end loop;
204
205      return T;
206   end Lower;
207
208   -------------------------------------
209   -- Raise_Program_Error_Unknown_Tag --
210   -------------------------------------
211
212   procedure Raise_Program_Error_Unknown_Tag
213     (E : Ada.Exceptions.Exception_Occurrence)
214   is
215   begin
216      raise Program_Error with Ada.Exceptions.Exception_Message (E);
217   end Raise_Program_Error_Unknown_Tag;
218
219   -----------------
220   -- RCI_Locator --
221   -----------------
222
223   package body RCI_Locator is
224
225      -----------------------------
226      -- Get_Active_Partition_ID --
227      -----------------------------
228
229      function Get_Active_Partition_ID return System.RPC.Partition_ID is
230         P : Pkg_List := Pkg_Head;
231         N : String   := Lower (RCI_Name);
232
233      begin
234         while P /= null loop
235            if P.Name.all = N then
236               return Get_Local_Partition_ID;
237            end if;
238
239            P := P.Next;
240         end loop;
241
242         return M;
243      end Get_Active_Partition_ID;
244
245      ------------------------------
246      -- Get_RCI_Package_Receiver --
247      ------------------------------
248
249      function Get_RCI_Package_Receiver return Interfaces.Unsigned_64 is
250      begin
251         return 0;
252      end Get_RCI_Package_Receiver;
253
254   end RCI_Locator;
255
256   ------------------------------
257   -- Register_Passive_Package --
258   ------------------------------
259
260   procedure Register_Passive_Package
261     (Name    : Unit_Name;
262      Version : String := "")
263   is
264   begin
265      Register_Receiving_Stub
266        (Passive_Prefix & Name, null, Version, System.Null_Address, 0);
267   end Register_Passive_Package;
268
269   -----------------------------
270   -- Register_Receiving_Stub --
271   -----------------------------
272
273   procedure Register_Receiving_Stub
274     (Name          : Unit_Name;
275      Receiver      : RPC_Receiver;
276      Version       : String := "";
277      Subp_Info     : System.Address;
278      Subp_Info_Len : Integer)
279   is
280      N : constant Pkg_List :=
281            new Pkg_Node'(new String'(Lower (Name)),
282                          Subp_Info, Subp_Info_Len,
283                          Next => null);
284   begin
285      if Pkg_Tail = null then
286         Pkg_Head := N;
287      else
288         Pkg_Tail.Next := N;
289      end if;
290      Pkg_Tail := N;
291   end Register_Receiving_Stub;
292
293   ---------
294   -- Run --
295   ---------
296
297   procedure Run
298     (Main : Main_Subprogram_Type := null)
299   is
300   begin
301      if Main /= null then
302         Main.all;
303      end if;
304   end Run;
305
306   --------------------
307   -- Same_Partition --
308   --------------------
309
310   function Same_Partition
311      (Left  : not null access RACW_Stub_Type;
312       Right : not null access RACW_Stub_Type) return Boolean
313   is
314      pragma Unreferenced (Left);
315      pragma Unreferenced (Right);
316   begin
317      return True;
318   end Same_Partition;
319
320end System.Partition_Interface;
321