PR target/58115
[official-gcc.git] / gcc / ada / g-socthi-vms.adb
blob8a49dc5b0d541e0e98b53a66a3f2c8b6e605442a
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T . S O C K E T S . T H I N --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2012, AdaCore --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
32 -- This is the version for OpenVMS
34 with GNAT.OS_Lib; use GNAT.OS_Lib;
35 with GNAT.Task_Lock;
37 with Interfaces.C; use Interfaces.C;
39 package body GNAT.Sockets.Thin is
41 type VMS_Msghdr is new Msghdr;
42 pragma Pack (VMS_Msghdr);
43 -- On VMS 8.x (unlike other platforms), struct msghdr is packed, so a
44 -- specific derived type is required. This structure was not packed on
45 -- VMS 7.3.
47 function Is_VMS_V7 return Integer;
48 pragma Import (C, Is_VMS_V7, "__gnat_is_vms_v7");
49 -- Helper (defined in init.c) that returns a non-zero value if the VMS
50 -- version is 7.x.
52 VMS_V7 : constant Boolean := Is_VMS_V7 /= 0;
53 -- True if VMS version is 7.x.
55 Non_Blocking_Sockets : aliased Fd_Set;
56 -- When this package is initialized with Process_Blocking_IO set to True,
57 -- sockets are set in non-blocking mode to avoid blocking the whole process
58 -- when a thread wants to perform a blocking IO operation. But the user can
59 -- also set a socket in non-blocking mode by purpose. In order to make a
60 -- difference between these two situations, we track the origin of
61 -- non-blocking mode in Non_Blocking_Sockets. Note that if S is in
62 -- Non_Blocking_Sockets, it has been set in non-blocking mode by the user.
64 Quantum : constant Duration := 0.2;
65 -- When SOSC.Thread_Blocking_IO is False, we set sockets to non-blocking
66 -- mode and we spend a period of time Quantum between two attempts on a
67 -- blocking operation.
69 Unknown_System_Error : constant C.Strings.chars_ptr :=
70 C.Strings.New_String ("Unknown system error");
72 function Syscall_Accept
73 (S : C.int;
74 Addr : System.Address;
75 Addrlen : not null access C.int) return C.int;
76 pragma Import (C, Syscall_Accept, "accept");
78 function Syscall_Connect
79 (S : C.int;
80 Name : System.Address;
81 Namelen : C.int) return C.int;
82 pragma Import (C, Syscall_Connect, "connect");
84 function Syscall_Recv
85 (S : C.int;
86 Msg : System.Address;
87 Len : C.int;
88 Flags : C.int) return C.int;
89 pragma Import (C, Syscall_Recv, "recv");
91 function Syscall_Recvfrom
92 (S : C.int;
93 Msg : System.Address;
94 Len : C.int;
95 Flags : C.int;
96 From : System.Address;
97 Fromlen : not null access C.int) return C.int;
98 pragma Import (C, Syscall_Recvfrom, "recvfrom");
100 function Syscall_Recvmsg
101 (S : C.int;
102 Msg : System.Address;
103 Flags : C.int) return C.int;
104 pragma Import (C, Syscall_Recvmsg, "recvmsg");
106 function Syscall_Sendmsg
107 (S : C.int;
108 Msg : System.Address;
109 Flags : C.int) return C.int;
110 pragma Import (C, Syscall_Sendmsg, "sendmsg");
112 function Syscall_Sendto
113 (S : C.int;
114 Msg : System.Address;
115 Len : C.int;
116 Flags : C.int;
117 To : System.Address;
118 Tolen : C.int) return C.int;
119 pragma Import (C, Syscall_Sendto, "sendto");
121 function Syscall_Socket
122 (Domain, Typ, Protocol : C.int) return C.int;
123 pragma Import (C, Syscall_Socket, "socket");
125 function Non_Blocking_Socket (S : C.int) return Boolean;
126 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
128 --------------
129 -- C_Accept --
130 --------------
132 function C_Accept
133 (S : C.int;
134 Addr : System.Address;
135 Addrlen : not null access C.int) return C.int
137 R : C.int;
138 Val : aliased C.int := 1;
140 Discard : C.int;
141 pragma Warnings (Off, Discard);
143 begin
144 loop
145 R := Syscall_Accept (S, Addr, Addrlen);
146 exit when SOSC.Thread_Blocking_IO
147 or else R /= Failure
148 or else Non_Blocking_Socket (S)
149 or else Errno /= SOSC.EWOULDBLOCK;
150 delay Quantum;
151 end loop;
153 if not SOSC.Thread_Blocking_IO
154 and then R /= Failure
155 then
156 -- A socket inherits the properties of its server, especially
157 -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
158 -- tracks sockets set in non-blocking mode by user.
160 Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
161 Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
162 end if;
164 return R;
165 end C_Accept;
167 ---------------
168 -- C_Connect --
169 ---------------
171 function C_Connect
172 (S : C.int;
173 Name : System.Address;
174 Namelen : C.int) return C.int
176 Res : C.int;
178 begin
179 Res := Syscall_Connect (S, Name, Namelen);
181 if SOSC.Thread_Blocking_IO
182 or else Res /= Failure
183 or else Non_Blocking_Socket (S)
184 or else Errno /= SOSC.EINPROGRESS
185 then
186 return Res;
187 end if;
189 declare
190 WSet : aliased Fd_Set;
191 Now : aliased Timeval;
193 begin
194 Reset_Socket_Set (WSet'Access);
195 loop
196 Insert_Socket_In_Set (WSet'Access, S);
197 Now := Immediat;
198 Res := C_Select
199 (S + 1,
200 No_Fd_Set_Access,
201 WSet'Access,
202 No_Fd_Set_Access,
203 Now'Unchecked_Access);
205 exit when Res > 0;
207 if Res = Failure then
208 return Res;
209 end if;
211 delay Quantum;
212 end loop;
213 end;
215 Res := Syscall_Connect (S, Name, Namelen);
217 if Res = Failure and then Errno = SOSC.EISCONN then
218 return Thin_Common.Success;
219 else
220 return Res;
221 end if;
222 end C_Connect;
224 ------------------
225 -- Socket_Ioctl --
226 ------------------
228 function Socket_Ioctl
229 (S : C.int;
230 Req : SOSC.IOCTL_Req_T;
231 Arg : access C.int) return C.int
233 begin
234 if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
235 if Arg.all /= 0 then
236 Set_Non_Blocking_Socket (S, True);
237 end if;
238 end if;
240 return C_Ioctl (S, Req, Arg);
241 end Socket_Ioctl;
243 ------------
244 -- C_Recv --
245 ------------
247 function C_Recv
248 (S : C.int;
249 Msg : System.Address;
250 Len : C.int;
251 Flags : C.int) return C.int
253 Res : C.int;
255 begin
256 loop
257 Res := Syscall_Recv (S, Msg, Len, Flags);
258 exit when SOSC.Thread_Blocking_IO
259 or else Res /= Failure
260 or else Non_Blocking_Socket (S)
261 or else Errno /= SOSC.EWOULDBLOCK;
262 delay Quantum;
263 end loop;
265 return Res;
266 end C_Recv;
268 ----------------
269 -- C_Recvfrom --
270 ----------------
272 function C_Recvfrom
273 (S : C.int;
274 Msg : System.Address;
275 Len : C.int;
276 Flags : C.int;
277 From : System.Address;
278 Fromlen : not null access C.int) return C.int
280 Res : C.int;
282 begin
283 loop
284 Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
285 exit when SOSC.Thread_Blocking_IO
286 or else Res /= Failure
287 or else Non_Blocking_Socket (S)
288 or else Errno /= SOSC.EWOULDBLOCK;
289 delay Quantum;
290 end loop;
292 return Res;
293 end C_Recvfrom;
295 ---------------
296 -- C_Recvmsg --
297 ---------------
299 function C_Recvmsg
300 (S : C.int;
301 Msg : System.Address;
302 Flags : C.int) return System.CRTL.ssize_t
304 Res : C.int;
306 Msg_Addr : System.Address;
308 GNAT_Msg : Msghdr;
309 for GNAT_Msg'Address use Msg;
310 pragma Import (Ada, GNAT_Msg);
312 VMS_Msg : aliased VMS_Msghdr;
314 begin
315 if VMS_V7 then
316 Msg_Addr := Msg;
317 else
318 VMS_Msg := VMS_Msghdr (GNAT_Msg);
319 Msg_Addr := VMS_Msg'Address;
320 end if;
322 loop
323 Res := Syscall_Recvmsg (S, Msg_Addr, Flags);
324 exit when SOSC.Thread_Blocking_IO
325 or else Res /= Failure
326 or else Non_Blocking_Socket (S)
327 or else Errno /= SOSC.EWOULDBLOCK;
328 delay Quantum;
329 end loop;
331 if not VMS_V7 then
332 GNAT_Msg := Msghdr (VMS_Msg);
333 end if;
335 return System.CRTL.ssize_t (Res);
336 end C_Recvmsg;
338 ---------------
339 -- C_Sendmsg --
340 ---------------
342 function C_Sendmsg
343 (S : C.int;
344 Msg : System.Address;
345 Flags : C.int) return System.CRTL.ssize_t
347 Res : C.int;
349 Msg_Addr : System.Address;
351 GNAT_Msg : Msghdr;
352 for GNAT_Msg'Address use Msg;
353 pragma Import (Ada, GNAT_Msg);
355 VMS_Msg : aliased VMS_Msghdr;
357 begin
358 if VMS_V7 then
359 Msg_Addr := Msg;
360 else
361 VMS_Msg := VMS_Msghdr (GNAT_Msg);
362 Msg_Addr := VMS_Msg'Address;
363 end if;
365 loop
366 Res := Syscall_Sendmsg (S, Msg_Addr, Flags);
367 exit when SOSC.Thread_Blocking_IO
368 or else Res /= Failure
369 or else Non_Blocking_Socket (S)
370 or else Errno /= SOSC.EWOULDBLOCK;
371 delay Quantum;
372 end loop;
374 if not VMS_V7 then
375 GNAT_Msg := Msghdr (VMS_Msg);
376 end if;
378 return System.CRTL.ssize_t (Res);
379 end C_Sendmsg;
381 --------------
382 -- C_Sendto --
383 --------------
385 function C_Sendto
386 (S : C.int;
387 Msg : System.Address;
388 Len : C.int;
389 Flags : C.int;
390 To : System.Address;
391 Tolen : C.int) return C.int
393 Res : C.int;
395 begin
396 loop
397 Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
398 exit when SOSC.Thread_Blocking_IO
399 or else Res /= Failure
400 or else Non_Blocking_Socket (S)
401 or else Errno /= SOSC.EWOULDBLOCK;
402 delay Quantum;
403 end loop;
405 return Res;
406 end C_Sendto;
408 --------------
409 -- C_Socket --
410 --------------
412 function C_Socket
413 (Domain : C.int;
414 Typ : C.int;
415 Protocol : C.int) return C.int
417 R : C.int;
418 Val : aliased C.int := 1;
420 Discard : C.int;
421 pragma Unreferenced (Discard);
423 begin
424 R := Syscall_Socket (Domain, Typ, Protocol);
426 if not SOSC.Thread_Blocking_IO
427 and then R /= Failure
428 then
429 -- Do not use Socket_Ioctl as this subprogram tracks sockets set
430 -- in non-blocking mode by user.
432 Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
433 Set_Non_Blocking_Socket (R, False);
434 end if;
436 return R;
437 end C_Socket;
439 --------------
440 -- Finalize --
441 --------------
443 procedure Finalize is
444 begin
445 null;
446 end Finalize;
448 -------------------------
449 -- Host_Error_Messages --
450 -------------------------
452 package body Host_Error_Messages is separate;
454 ----------------
455 -- Initialize --
456 ----------------
458 procedure Initialize is
459 begin
460 Reset_Socket_Set (Non_Blocking_Sockets'Access);
461 end Initialize;
463 -------------------------
464 -- Non_Blocking_Socket --
465 -------------------------
467 function Non_Blocking_Socket (S : C.int) return Boolean is
468 R : Boolean;
469 begin
470 Task_Lock.Lock;
471 R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
472 Task_Lock.Unlock;
473 return R;
474 end Non_Blocking_Socket;
476 -----------------------------
477 -- Set_Non_Blocking_Socket --
478 -----------------------------
480 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
481 begin
482 Task_Lock.Lock;
484 if V then
485 Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
486 else
487 Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
488 end if;
490 Task_Lock.Unlock;
491 end Set_Non_Blocking_Socket;
493 --------------------
494 -- Signalling_Fds --
495 --------------------
497 package body Signalling_Fds is separate;
499 --------------------------
500 -- Socket_Error_Message --
501 --------------------------
503 function Socket_Error_Message
504 (Errno : Integer) return C.Strings.chars_ptr
505 is separate;
507 end GNAT.Sockets.Thin;