fixing pr42337
[official-gcc.git] / gcc / ada / g-socthi-vxworks.adb
blobe6a8ee6064446a39dd2be5403f6ee8840c400714
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) 2002-2009, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 -- This package provides a target dependent thin interface to the sockets
35 -- layer for use by the GNAT.Sockets package (g-socket.ads). This package
36 -- should not be directly with'ed by an applications program.
38 -- This version is for VxWorks
40 with GNAT.OS_Lib; use GNAT.OS_Lib;
41 with GNAT.Task_Lock;
43 with Interfaces.C; use Interfaces.C;
45 package body GNAT.Sockets.Thin is
47 Non_Blocking_Sockets : aliased Fd_Set;
48 -- When this package is initialized with Process_Blocking_IO set
49 -- to True, sockets are set in non-blocking mode to avoid blocking
50 -- the whole process when a thread wants to perform a blocking IO
51 -- operation. But the user can also set a socket in non-blocking
52 -- mode by purpose. In order to make a difference between these
53 -- two situations, we track the origin of non-blocking mode in
54 -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
55 -- been set in non-blocking mode by the user.
57 Quantum : constant Duration := 0.2;
58 -- When SOSC.Thread_Blocking_IO is False, we set sockets in
59 -- non-blocking mode and we spend a period of time Quantum between
60 -- two attempts on a blocking operation.
62 Unknown_System_Error : constant C.Strings.chars_ptr :=
63 C.Strings.New_String ("Unknown system error");
65 -----------------------
66 -- Local Subprograms --
67 -----------------------
69 -- All these require comments ???
71 function Syscall_Accept
72 (S : C.int;
73 Addr : System.Address;
74 Addrlen : not null access C.int) return C.int;
75 pragma Import (C, Syscall_Accept, "accept");
77 function Syscall_Connect
78 (S : C.int;
79 Name : System.Address;
80 Namelen : C.int) return C.int;
81 pragma Import (C, Syscall_Connect, "connect");
83 function Syscall_Recv
84 (S : C.int;
85 Msg : System.Address;
86 Len : C.int;
87 Flags : C.int) return C.int;
88 pragma Import (C, Syscall_Recv, "recv");
90 function Syscall_Recvfrom
91 (S : C.int;
92 Msg : System.Address;
93 Len : C.int;
94 Flags : C.int;
95 From : System.Address;
96 Fromlen : not null access C.int) return C.int;
97 pragma Import (C, Syscall_Recvfrom, "recvfrom");
99 function Syscall_Recvmsg
100 (S : C.int;
101 Msg : System.Address;
102 Flags : C.int) return C.int;
103 pragma Import (C, Syscall_Recvmsg, "recvmsg");
105 function Syscall_Sendmsg
106 (S : C.int;
107 Msg : System.Address;
108 Flags : C.int) return C.int;
109 pragma Import (C, Syscall_Sendmsg, "sendmsg");
111 function Syscall_Send
112 (S : C.int;
113 Msg : System.Address;
114 Len : C.int;
115 Flags : C.int) return C.int;
116 pragma Import (C, Syscall_Send, "send");
118 function Syscall_Sendto
119 (S : C.int;
120 Msg : System.Address;
121 Len : C.int;
122 Flags : C.int;
123 To : System.Address;
124 Tolen : C.int) return C.int;
125 pragma Import (C, Syscall_Sendto, "sendto");
127 function Syscall_Socket
128 (Domain : C.int;
129 Typ : C.int;
130 Protocol : C.int) return C.int;
131 pragma Import (C, Syscall_Socket, "socket");
133 function Non_Blocking_Socket (S : C.int) return Boolean;
134 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
136 --------------
137 -- C_Accept --
138 --------------
140 function C_Accept
141 (S : C.int;
142 Addr : System.Address;
143 Addrlen : not null access C.int) return C.int
145 R : C.int;
146 Val : aliased C.int := 1;
148 Res : C.int;
149 pragma Unreferenced (Res);
151 begin
152 loop
153 R := Syscall_Accept (S, Addr, Addrlen);
154 exit when SOSC.Thread_Blocking_IO
155 or else R /= Failure
156 or else Non_Blocking_Socket (S)
157 or else Errno /= SOSC.EWOULDBLOCK;
158 delay Quantum;
159 end loop;
161 if not SOSC.Thread_Blocking_IO
162 and then R /= Failure
163 then
164 -- A socket inherits the properties of its server especially
165 -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
166 -- tracks sockets set in non-blocking mode by user.
168 Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
169 Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
170 -- Is it OK to ignore result ???
171 end if;
173 return R;
174 end C_Accept;
176 ---------------
177 -- C_Connect --
178 ---------------
180 function C_Connect
181 (S : C.int;
182 Name : System.Address;
183 Namelen : C.int) return C.int
185 Res : C.int;
187 begin
188 Res := Syscall_Connect (S, Name, Namelen);
190 if SOSC.Thread_Blocking_IO
191 or else Res /= Failure
192 or else Non_Blocking_Socket (S)
193 or else Errno /= SOSC.EINPROGRESS
194 then
195 return Res;
196 end if;
198 declare
199 WSet : aliased Fd_Set;
200 Now : aliased Timeval;
201 begin
202 Reset_Socket_Set (WSet'Access);
203 loop
204 Insert_Socket_In_Set (WSet'Access, S);
205 Now := Immediat;
206 Res := C_Select
207 (S + 1,
208 No_Fd_Set_Access,
209 WSet'Access,
210 No_Fd_Set_Access,
211 Now'Unchecked_Access);
213 exit when Res > 0;
215 if Res = Failure then
216 return Res;
217 end if;
219 delay Quantum;
220 end loop;
221 end;
223 Res := Syscall_Connect (S, Name, Namelen);
225 if Res = Failure
226 and then Errno = SOSC.EISCONN
227 then
228 return Thin_Common.Success;
229 else
230 return Res;
231 end if;
232 end C_Connect;
234 ------------------
235 -- Socket_Ioctl --
236 ------------------
238 function Socket_Ioctl
239 (S : C.int;
240 Req : C.int;
241 Arg : access C.int) return C.int
243 begin
244 if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
245 if Arg.all /= 0 then
246 Set_Non_Blocking_Socket (S, True);
247 end if;
248 end if;
250 return C_Ioctl (S, Req, Arg);
251 end Socket_Ioctl;
253 ------------
254 -- C_Recv --
255 ------------
257 function C_Recv
258 (S : C.int;
259 Msg : System.Address;
260 Len : C.int;
261 Flags : C.int) return C.int
263 Res : C.int;
265 begin
266 loop
267 Res := Syscall_Recv (S, Msg, Len, Flags);
268 exit when SOSC.Thread_Blocking_IO
269 or else Res /= Failure
270 or else Non_Blocking_Socket (S)
271 or else Errno /= SOSC.EWOULDBLOCK;
272 delay Quantum;
273 end loop;
275 return Res;
276 end C_Recv;
278 ----------------
279 -- C_Recvfrom --
280 ----------------
282 function C_Recvfrom
283 (S : C.int;
284 Msg : System.Address;
285 Len : C.int;
286 Flags : C.int;
287 From : System.Address;
288 Fromlen : not null access C.int) return C.int
290 Res : C.int;
292 begin
293 loop
294 Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
295 exit when SOSC.Thread_Blocking_IO
296 or else Res /= Failure
297 or else Non_Blocking_Socket (S)
298 or else Errno /= SOSC.EWOULDBLOCK;
299 delay Quantum;
300 end loop;
302 return Res;
303 end C_Recvfrom;
305 ---------------
306 -- C_Recvmsg --
307 ---------------
309 function C_Recvmsg
310 (S : C.int;
311 Msg : System.Address;
312 Flags : C.int) return ssize_t
314 Res : C.int;
316 begin
317 loop
318 Res := Syscall_Recvmsg (S, Msg, Flags);
319 exit when SOSC.Thread_Blocking_IO
320 or else Res /= Failure
321 or else Non_Blocking_Socket (S)
322 or else Errno /= SOSC.EWOULDBLOCK;
323 delay Quantum;
324 end loop;
326 return ssize_t (Res);
327 end C_Recvmsg;
329 ---------------
330 -- C_Sendmsg --
331 ---------------
333 function C_Sendmsg
334 (S : C.int;
335 Msg : System.Address;
336 Flags : C.int) return ssize_t
338 Res : C.int;
340 begin
341 loop
342 Res := Syscall_Sendmsg (S, Msg, Flags);
343 exit when SOSC.Thread_Blocking_IO
344 or else Res /= Failure
345 or else Non_Blocking_Socket (S)
346 or else Errno /= SOSC.EWOULDBLOCK;
347 delay Quantum;
348 end loop;
350 return ssize_t (Res);
351 end C_Sendmsg;
353 --------------
354 -- C_Sendto --
355 --------------
357 function C_Sendto
358 (S : C.int;
359 Msg : System.Address;
360 Len : C.int;
361 Flags : C.int;
362 To : System.Address;
363 Tolen : C.int) return C.int
365 use System;
367 Res : C.int;
369 begin
370 loop
371 if To = Null_Address then
373 -- In violation of the standard sockets API, VxWorks does not
374 -- support sendto(2) calls on connected sockets with a null
375 -- destination address, so use send(2) instead in that case.
377 Res := Syscall_Send (S, Msg, Len, Flags);
379 -- Normal case where destination address is non-null
381 else
382 Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
383 end if;
385 exit when SOSC.Thread_Blocking_IO
386 or else Res /= Failure
387 or else Non_Blocking_Socket (S)
388 or else Errno /= SOSC.EWOULDBLOCK;
389 delay Quantum;
390 end loop;
392 return Res;
393 end C_Sendto;
395 --------------
396 -- C_Socket --
397 --------------
399 function C_Socket
400 (Domain : C.int;
401 Typ : C.int;
402 Protocol : C.int) return C.int
404 R : C.int;
405 Val : aliased C.int := 1;
407 Res : C.int;
408 pragma Unreferenced (Res);
410 begin
411 R := Syscall_Socket (Domain, Typ, Protocol);
413 if not SOSC.Thread_Blocking_IO
414 and then R /= Failure
415 then
416 -- Do not use Socket_Ioctl as this subprogram tracks sockets set
417 -- in non-blocking mode by user.
419 Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
420 -- Is it OK to ignore result ???
421 Set_Non_Blocking_Socket (R, False);
422 end if;
424 return R;
425 end C_Socket;
427 --------------
428 -- Finalize --
429 --------------
431 procedure Finalize is
432 begin
433 null;
434 end Finalize;
436 -------------------------
437 -- Host_Error_Messages --
438 -------------------------
440 package body Host_Error_Messages is separate;
442 ----------------
443 -- Initialize --
444 ----------------
446 procedure Initialize is
447 begin
448 Reset_Socket_Set (Non_Blocking_Sockets'Access);
449 end Initialize;
451 -------------------------
452 -- Non_Blocking_Socket --
453 -------------------------
455 function Non_Blocking_Socket (S : C.int) return Boolean is
456 R : Boolean;
457 begin
458 Task_Lock.Lock;
459 R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
460 Task_Lock.Unlock;
461 return R;
462 end Non_Blocking_Socket;
464 -----------------------------
465 -- Set_Non_Blocking_Socket --
466 -----------------------------
468 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
469 begin
470 Task_Lock.Lock;
471 if V then
472 Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
473 else
474 Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
475 end if;
477 Task_Lock.Unlock;
478 end Set_Non_Blocking_Socket;
480 --------------------
481 -- Signalling_Fds --
482 --------------------
484 package body Signalling_Fds is separate;
486 --------------------------
487 -- Socket_Error_Message --
488 --------------------------
490 function Socket_Error_Message
491 (Errno : Integer) return C.Strings.chars_ptr
492 is separate;
494 end GNAT.Sockets.Thin;