1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
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 --
8 -- (Dummy body for non-distributed case) --
10 -- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
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, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, USA. --
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. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
35 package body System
.Partition_Interface
is
37 pragma Warnings
(Off
); -- suppress warnings for unreferenced formals
41 type String_Access
is access String;
43 -- To have a minimal implementation of U'Partition_ID
46 type Pkg_List
is access Pkg_Node
;
47 type Pkg_Node
is record
49 Subp_Info
: System
.Address
;
50 Subp_Info_Len
: Integer;
57 function getpid
return Integer;
58 pragma Import
(C
, getpid
);
60 PID
: constant Integer := getpid
;
62 function Lower
(S
: String) return String;
64 Passive_Prefix
: constant String := "SP__";
65 -- String prepended in top of shared passive packages
70 RCI
: Boolean := True)
76 -----------------------------
77 -- Get_Active_Partition_Id --
78 -----------------------------
80 function Get_Active_Partition_ID
81 (Name
: Unit_Name
) return System
.RPC
.Partition_ID
83 P
: Pkg_List
:= Pkg_Head
;
84 N
: String := Lower
(Name
);
88 if P
.Name
.all = N
then
89 return Get_Local_Partition_ID
;
96 end Get_Active_Partition_ID
;
98 ------------------------
99 -- Get_Active_Version --
100 ------------------------
102 function Get_Active_Version
(Name
: Unit_Name
) return String is
105 end Get_Active_Version
;
107 ----------------------------
108 -- Get_Local_Partition_Id --
109 ----------------------------
111 function Get_Local_Partition_ID
return System
.RPC
.Partition_ID
is
113 return System
.RPC
.Partition_ID
(PID
mod M
);
114 end Get_Local_Partition_ID
;
116 ------------------------------
117 -- Get_Passive_Partition_ID --
118 ------------------------------
120 function Get_Passive_Partition_ID
121 (Name
: Unit_Name
) return System
.RPC
.Partition_ID
124 return Get_Local_Partition_ID
;
125 end Get_Passive_Partition_ID
;
127 -------------------------
128 -- Get_Passive_Version --
129 -------------------------
131 function Get_Passive_Version
(Name
: Unit_Name
) return String is
134 end Get_Passive_Version
;
140 procedure Get_RAS_Info
142 Subp_Id
: Subprogram_Id
;
143 Proxy_Address
: out Interfaces
.Unsigned_64
)
145 LName
: constant String := Lower
(Name
);
150 if N
.Name
.all = LName
then
152 subtype Subprogram_Array
is RCI_Subp_Info_Array
153 (First_RCI_Subprogram_Id
..
154 First_RCI_Subprogram_Id
+ N
.Subp_Info_Len
- 1);
155 Subprograms
: Subprogram_Array
;
156 for Subprograms
'Address use N
.Subp_Info
;
157 pragma Import
(Ada
, Subprograms
);
160 Interfaces
.Unsigned_64
(Subprograms
(Integer (Subp_Id
)).Addr
);
169 ------------------------------
170 -- Get_RCI_Package_Receiver --
171 ------------------------------
173 function Get_RCI_Package_Receiver
174 (Name
: Unit_Name
) return Interfaces
.Unsigned_64
178 end Get_RCI_Package_Receiver
;
180 -------------------------------
181 -- Get_Unique_Remote_Pointer --
182 -------------------------------
184 procedure Get_Unique_Remote_Pointer
185 (Handler
: in out RACW_Stub_Type_Access
)
189 end Get_Unique_Remote_Pointer
;
195 function Lower
(S
: String) return String is
199 for J
in T
'Range loop
200 if T
(J
) in 'A' .. 'Z' then
201 T
(J
) := Character'Val (Character'Pos (T
(J
)) -
202 Character'Pos ('A') +
203 Character'Pos ('a'));
210 -------------------------------------
211 -- Raise_Program_Error_Unknown_Tag --
212 -------------------------------------
214 procedure Raise_Program_Error_Unknown_Tag
215 (E
: Ada
.Exceptions
.Exception_Occurrence
)
218 raise Program_Error
with Ada
.Exceptions
.Exception_Message
(E
);
219 end Raise_Program_Error_Unknown_Tag
;
225 package body RCI_Locator
is
227 -----------------------------
228 -- Get_Active_Partition_ID --
229 -----------------------------
231 function Get_Active_Partition_ID
return System
.RPC
.Partition_ID
is
232 P
: Pkg_List
:= Pkg_Head
;
233 N
: String := Lower
(RCI_Name
);
237 if P
.Name
.all = N
then
238 return Get_Local_Partition_ID
;
245 end Get_Active_Partition_ID
;
247 ------------------------------
248 -- Get_RCI_Package_Receiver --
249 ------------------------------
251 function Get_RCI_Package_Receiver
return Interfaces
.Unsigned_64
is
254 end Get_RCI_Package_Receiver
;
258 ------------------------------
259 -- Register_Passive_Package --
260 ------------------------------
262 procedure Register_Passive_Package
264 Version
: String := "")
267 Register_Receiving_Stub
268 (Passive_Prefix
& Name
, null, Version
, System
.Null_Address
, 0);
269 end Register_Passive_Package
;
271 -----------------------------
272 -- Register_Receiving_Stub --
273 -----------------------------
275 procedure Register_Receiving_Stub
277 Receiver
: RPC_Receiver
;
278 Version
: String := "";
279 Subp_Info
: System
.Address
;
280 Subp_Info_Len
: Integer)
282 N
: constant Pkg_List
:=
283 new Pkg_Node
'(new String'(Lower
(Name
)),
284 Subp_Info
, Subp_Info_Len
,
287 if Pkg_Tail
= null then
293 end Register_Receiving_Stub
;
300 (Main
: Main_Subprogram_Type
:= null)
312 function Same_Partition
313 (Left
: not null access RACW_Stub_Type
;
314 Right
: not null access RACW_Stub_Type
) return Boolean
316 pragma Unreferenced
(Left
);
317 pragma Unreferenced
(Right
);
322 end System
.Partition_Interface
;