GCC v8.2
[gcc.git] / gcc / ada / libgnat / 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-2018, 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
33 package 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
320 end System.Partition_Interface;