?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* gcc.dg/guality/guality.exp: Skip on AIX.
[official-gcc.git] / gcc / ada / g-socthi-mingw.adb
blobad82c167d67bd999b638901e55ed8c1f7837fac3
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 ------------------------------------------------------------------------------
31
32 -- This package provides a target dependent thin interface to the sockets
33 -- layer for use by the GNAT.Sockets package (g-socket.ads). This package
34 -- should not be directly with'ed by an applications program.
35
36 -- This version is for NT
37
38 with Ada.Streams; use Ada.Streams;
39 with Ada.Unchecked_Conversion;
40 with Interfaces.C.Strings; use Interfaces.C.Strings;
41 with System; use System;
42 with System.Storage_Elements; use System.Storage_Elements;
43
44 package body GNAT.Sockets.Thin is
45
46 use type C.unsigned;
47 use type C.int;
48
49 WSAData_Dummy : array (1 .. 512) of C.int;
50
51 WS_Version : constant := 16#0202#;
52 -- Winsock 2.2
53
54 Initialized : Boolean := False;
55
56 function Standard_Connect
57 (S : C.int;
58 Name : System.Address;
59 Namelen : C.int) return C.int;
60 pragma Import (Stdcall, Standard_Connect, "connect");
61
62 function Standard_Select
63 (Nfds : C.int;
64 Readfds : access Fd_Set;
65 Writefds : access Fd_Set;
66 Exceptfds : access Fd_Set;
67 Timeout : Timeval_Access) return C.int;
68 pragma Import (Stdcall, Standard_Select, "select");
69
70 type Error_Type is
71 (N_EINTR,
72 N_EBADF,
73 N_EACCES,
74 N_EFAULT,
75 N_EINVAL,
76 N_EMFILE,
77 N_EWOULDBLOCK,
78 N_EINPROGRESS,
79 N_EALREADY,
80 N_ENOTSOCK,
81 N_EDESTADDRREQ,
82 N_EMSGSIZE,
83 N_EPROTOTYPE,
84 N_ENOPROTOOPT,
85 N_EPROTONOSUPPORT,
86 N_ESOCKTNOSUPPORT,
87 N_EOPNOTSUPP,
88 N_EPFNOSUPPORT,
89 N_EAFNOSUPPORT,
90 N_EADDRINUSE,
91 N_EADDRNOTAVAIL,
92 N_ENETDOWN,
93 N_ENETUNREACH,
94 N_ENETRESET,
95 N_ECONNABORTED,
96 N_ECONNRESET,
97 N_ENOBUFS,
98 N_EISCONN,
99 N_ENOTCONN,
100 N_ESHUTDOWN,
101 N_ETOOMANYREFS,
102 N_ETIMEDOUT,
103 N_ECONNREFUSED,
104 N_ELOOP,
105 N_ENAMETOOLONG,
106 N_EHOSTDOWN,
107 N_EHOSTUNREACH,
108 N_WSASYSNOTREADY,
109 N_WSAVERNOTSUPPORTED,
110 N_WSANOTINITIALISED,
111 N_WSAEDISCON,
112 N_HOST_NOT_FOUND,
113 N_TRY_AGAIN,
114 N_NO_RECOVERY,
115 N_NO_DATA,
116 N_OTHERS);
117
118 Error_Messages : constant array (Error_Type) of chars_ptr :=
119 (N_EINTR =>
120 New_String ("Interrupted system call"),
121 N_EBADF =>
122 New_String ("Bad file number"),
123 N_EACCES =>
124 New_String ("Permission denied"),
125 N_EFAULT =>
126 New_String ("Bad address"),
127 N_EINVAL =>
128 New_String ("Invalid argument"),
129 N_EMFILE =>
130 New_String ("Too many open files"),
131 N_EWOULDBLOCK =>
132 New_String ("Operation would block"),
133 N_EINPROGRESS =>
134 New_String ("Operation now in progress. This error is "
135 & "returned if any Windows Sockets API "
136 & "function is called while a blocking "
137 & "function is in progress"),
138 N_EALREADY =>
139 New_String ("Operation already in progress"),
140 N_ENOTSOCK =>
141 New_String ("Socket operation on nonsocket"),
142 N_EDESTADDRREQ =>
143 New_String ("Destination address required"),
144 N_EMSGSIZE =>
145 New_String ("Message too long"),
146 N_EPROTOTYPE =>
147 New_String ("Protocol wrong type for socket"),
148 N_ENOPROTOOPT =>
149 New_String ("Protocol not available"),
150 N_EPROTONOSUPPORT =>
151 New_String ("Protocol not supported"),
152 N_ESOCKTNOSUPPORT =>
153 New_String ("Socket type not supported"),
154 N_EOPNOTSUPP =>
155 New_String ("Operation not supported on socket"),
156 N_EPFNOSUPPORT =>
157 New_String ("Protocol family not supported"),
158 N_EAFNOSUPPORT =>
159 New_String ("Address family not supported by protocol family"),
160 N_EADDRINUSE =>
161 New_String ("Address already in use"),
162 N_EADDRNOTAVAIL =>
163 New_String ("Cannot assign requested address"),
164 N_ENETDOWN =>
165 New_String ("Network is down. This error may be "
166 & "reported at any time if the Windows "
167 & "Sockets implementation detects an "
168 & "underlying failure"),
169 N_ENETUNREACH =>
170 New_String ("Network is unreachable"),
171 N_ENETRESET =>
172 New_String ("Network dropped connection on reset"),
173 N_ECONNABORTED =>
174 New_String ("Software caused connection abort"),
175 N_ECONNRESET =>
176 New_String ("Connection reset by peer"),
177 N_ENOBUFS =>
178 New_String ("No buffer space available"),
179 N_EISCONN =>
180 New_String ("Socket is already connected"),
181 N_ENOTCONN =>
182 New_String ("Socket is not connected"),
183 N_ESHUTDOWN =>
184 New_String ("Cannot send after socket shutdown"),
185 N_ETOOMANYREFS =>
186 New_String ("Too many references: cannot splice"),
187 N_ETIMEDOUT =>
188 New_String ("Connection timed out"),
189 N_ECONNREFUSED =>
190 New_String ("Connection refused"),
191 N_ELOOP =>
192 New_String ("Too many levels of symbolic links"),
193 N_ENAMETOOLONG =>
194 New_String ("File name too long"),
195 N_EHOSTDOWN =>
196 New_String ("Host is down"),
197 N_EHOSTUNREACH =>
198 New_String ("No route to host"),
199 N_WSASYSNOTREADY =>
200 New_String ("Returned by WSAStartup(), indicating that "
201 & "the network subsystem is unusable"),
202 N_WSAVERNOTSUPPORTED =>
203 New_String ("Returned by WSAStartup(), indicating that "
204 & "the Windows Sockets DLL cannot support "
205 & "this application"),
206 N_WSANOTINITIALISED =>
207 New_String ("Winsock not initialized. This message is "
208 & "returned by any function except WSAStartup(), "
209 & "indicating that a successful WSAStartup() has "
210 & "not yet been performed"),
211 N_WSAEDISCON =>
212 New_String ("Disconnected"),
213 N_HOST_NOT_FOUND =>
214 New_String ("Host not found. This message indicates "
215 & "that the key (name, address, and so on) was not found"),
216 N_TRY_AGAIN =>
217 New_String ("Nonauthoritative host not found. This error may "
218 & "suggest that the name service itself is not "
219 & "functioning"),
220 N_NO_RECOVERY =>
221 New_String ("Nonrecoverable error. This error may suggest that the "
222 & "name service itself is not functioning"),
223 N_NO_DATA =>
224 New_String ("Valid name, no data record of requested type. "
225 & "This error indicates that the key (name, address, "
226 & "and so on) was not found."),
227 N_OTHERS =>
228 New_String ("Unknown system error"));
229
230 ---------------
231 -- C_Connect --
232 ---------------
233
234 function C_Connect
235 (S : C.int;
236 Name : System.Address;
237 Namelen : C.int) return C.int
238 is
239 Res : C.int;
240
241 begin
242 Res := Standard_Connect (S, Name, Namelen);
243
244 if Res = -1 then
245 if Socket_Errno = SOSC.EWOULDBLOCK then
246 Set_Socket_Errno (SOSC.EINPROGRESS);
247 end if;
248 end if;
249
250 return Res;
251 end C_Connect;
252
253 ------------------
254 -- Socket_Ioctl --
255 ------------------
256
257 function Socket_Ioctl
258 (S : C.int;
259 Req : SOSC.IOCTL_Req_T;
260 Arg : access C.int) return C.int
261 is
262 begin
263 return C_Ioctl (S, Req, Arg);
264 end Socket_Ioctl;
265
266 ---------------
267 -- C_Recvmsg --
268 ---------------
269
270 function C_Recvmsg
271 (S : C.int;
272 Msg : System.Address;
273 Flags : C.int) return System.CRTL.ssize_t
274 is
275 use type C.size_t;
276
277 Fill : constant Boolean :=
278 SOSC.MSG_WAITALL /= -1
279 and then (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0;
280 -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors
281
282 Res : C.int;
283 Count : C.int := 0;
284
285 MH : Msghdr;
286 for MH'Address use Msg;
287
288 Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
289 for Iovec'Address use MH.Msg_Iov;
290 pragma Import (Ada, Iovec);
291
292 Iov_Index : Integer;
293 Current_Iovec : Vector_Element;
294
295 function To_Access is new Ada.Unchecked_Conversion
296 (System.Address, Stream_Element_Reference);
297 pragma Warnings (Off, Stream_Element_Reference);
298
299 Req : Request_Type (Name => N_Bytes_To_Read);
300
301 begin
302 -- Windows does not provide an implementation of recvmsg(). The spec for
303 -- WSARecvMsg() is incompatible with the data types we define, and is
304 -- available starting with Windows Vista and Server 2008 only. So,
305 -- we use C_Recv instead.
306
307 -- Check how much data are available
308
309 Control_Socket (Socket_Type (S), Req);
310
311 -- Fill the vectors
312
313 Iov_Index := -1;
314 Current_Iovec := (Base => null, Length => 0);
315
316 loop
317 if Current_Iovec.Length = 0 then
318 Iov_Index := Iov_Index + 1;
319 exit when Iov_Index > Integer (Iovec'Last);
320 Current_Iovec := Iovec (SOSC.Msg_Iovlen_T (Iov_Index));
321 end if;
322
323 Res :=
324 C_Recv
325 (S,
326 Current_Iovec.Base.all'Address,
327 C.int (Current_Iovec.Length),
328 Flags);
329
330 if Res < 0 then
331 return System.CRTL.ssize_t (Res);
332
333 elsif Res = 0 and then not Fill then
334 exit;
335
336 else
337 pragma Assert (Stream_Element_Count (Res) <= Current_Iovec.Length);
338
339 Count := Count + Res;
340 Current_Iovec.Length :=
341 Current_Iovec.Length - Stream_Element_Count (Res);
342 Current_Iovec.Base :=
343 To_Access (Current_Iovec.Base.all'Address
344 + Storage_Offset (Res));
345
346 -- If all the data that was initially available read, do not
347 -- attempt to receive more, since this might block, or merge data
348 -- from successive datagrams for a datagram-oriented socket. We
349 -- still try to receive more if we need to fill all vectors
350 -- (MSG_WAITALL flag is set).
351
352 exit when Natural (Count) >= Req.Size
353 and then
354
355 -- Either we are not in fill mode
356
357 (not Fill
358
359 -- Or else last vector filled
360
361 or else (Interfaces.C.size_t (Iov_Index) = Iovec'Last
362 and then Current_Iovec.Length = 0));
363 end if;
364 end loop;
365
366 return System.CRTL.ssize_t (Count);
367 end C_Recvmsg;
368
369 --------------
370 -- C_Select --
371 --------------
372
373 function C_Select
374 (Nfds : C.int;
375 Readfds : access Fd_Set;
376 Writefds : access Fd_Set;
377 Exceptfds : access Fd_Set;
378 Timeout : Timeval_Access) return C.int
379 is
380 pragma Warnings (Off, Exceptfds);
381
382 Original_WFS : aliased constant Fd_Set := Writefds.all;
383
384 Res : C.int;
385 S : aliased C.int;
386 Last : aliased C.int;
387
388 begin
389 -- Asynchronous connection failures are notified in the exception fd
390 -- set instead of the write fd set. To ensure POSIX compatibility, copy
391 -- write fd set into exception fd set. Once select() returns, check any
392 -- socket present in the exception fd set and peek at incoming
393 -- out-of-band data. If the test is not successful, and the socket is
394 -- present in the initial write fd set, then move the socket from the
395 -- exception fd set to the write fd set.
396
397 if Writefds /= No_Fd_Set_Access then
398
399 -- Add any socket present in write fd set into exception fd set
400
401 declare
402 WFS : aliased Fd_Set := Writefds.all;
403 begin
404 Last := Nfds - 1;
405 loop
406 Get_Socket_From_Set
407 (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access);
408 exit when S = -1;
409 Insert_Socket_In_Set (Exceptfds, S);
410 end loop;
411 end;
412 end if;
413
414 Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout);
415
416 if Exceptfds /= No_Fd_Set_Access then
417 declare
418 EFSC : aliased Fd_Set := Exceptfds.all;
419 Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB;
420 Buffer : Character;
421 Length : C.int;
422 Fromlen : aliased C.int;
423
424 begin
425 Last := Nfds - 1;
426 loop
427 Get_Socket_From_Set
428 (EFSC'Access, S'Unchecked_Access, Last'Unchecked_Access);
429
430 -- No more sockets in EFSC
431
432 exit when S = -1;
433
434 -- Check out-of-band data
435
436 Length :=
437 C_Recvfrom
438 (S, Buffer'Address, 1, Flag,
439 From => System.Null_Address,
440 Fromlen => Fromlen'Unchecked_Access);
441 -- Is Fromlen necessary if From is Null_Address???
442
443 -- If the signal is not an out-of-band data, then it
444 -- is a connection failure notification.
445
446 if Length = -1 then
447 Remove_Socket_From_Set (Exceptfds, S);
448
449 -- If S is present in the initial write fd set, move it from
450 -- exception fd set back to write fd set. Otherwise, ignore
451 -- this event since the user is not watching for it.
452
453 if Writefds /= No_Fd_Set_Access
454 and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0)
455 then
456 Insert_Socket_In_Set (Writefds, S);
457 end if;
458 end if;
459 end loop;
460 end;
461 end if;
462 return Res;
463 end C_Select;
464
465 ---------------
466 -- C_Sendmsg --
467 ---------------
468
469 function C_Sendmsg
470 (S : C.int;
471 Msg : System.Address;
472 Flags : C.int) return System.CRTL.ssize_t
473 is
474 use type C.size_t;
475
476 Res : C.int;
477 Count : C.int := 0;
478
479 MH : Msghdr;
480 for MH'Address use Msg;
481
482 Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
483 for Iovec'Address use MH.Msg_Iov;
484 pragma Import (Ada, Iovec);
485
486 begin
487 -- Windows does not provide an implementation of sendmsg(). The spec for
488 -- WSASendMsg() is incompatible with the data types we define, and is
489 -- available starting with Windows Vista and Server 2008 only. So
490 -- use C_Sendto instead.
491
492 for J in Iovec'Range loop
493 Res :=
494 C_Sendto
495 (S,
496 Iovec (J).Base.all'Address,
497 C.int (Iovec (J).Length),
498 Flags => Flags,
499 To => MH.Msg_Name,
500 Tolen => C.int (MH.Msg_Namelen));
501
502 if Res < 0 then
503 return System.CRTL.ssize_t (Res);
504 else
505 Count := Count + Res;
506 end if;
507
508 -- Exit now if the buffer is not fully transmitted
509
510 exit when Stream_Element_Count (Res) < Iovec (J).Length;
511 end loop;
512
513 return System.CRTL.ssize_t (Count);
514 end C_Sendmsg;
515
516 --------------
517 -- Finalize --
518 --------------
519
520 procedure Finalize is
521 begin
522 if Initialized then
523 WSACleanup;
524 Initialized := False;
525 end if;
526 end Finalize;
527
528 -------------------------
529 -- Host_Error_Messages --
530 -------------------------
531
532 package body Host_Error_Messages is
533
534 -- On Windows, socket and host errors share the same code space, and
535 -- error messages are provided by Socket_Error_Message, so the default
536 -- separate body for Host_Error_Messages is not used in this case.
537
538 function Host_Error_Message
539 (H_Errno : Integer) return C.Strings.chars_ptr
540 renames Socket_Error_Message;
541
542 end Host_Error_Messages;
543
544 ----------------
545 -- Initialize --
546 ----------------
547
548 procedure Initialize is
549 Return_Value : Interfaces.C.int;
550 begin
551 if not Initialized then
552 Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
553 pragma Assert (Return_Value = 0);
554 Initialized := True;
555 end if;
556 end Initialize;
557
558 --------------------
559 -- Signalling_Fds --
560 --------------------
561
562 package body Signalling_Fds is separate;
563
564 --------------------------
565 -- Socket_Error_Message --
566 --------------------------
567
568 function Socket_Error_Message
569 (Errno : Integer) return C.Strings.chars_ptr
570 is
571 use GNAT.Sockets.SOSC;
572
573 begin
574 case Errno is
575 when EINTR => return Error_Messages (N_EINTR);
576 when EBADF => return Error_Messages (N_EBADF);
577 when EACCES => return Error_Messages (N_EACCES);
578 when EFAULT => return Error_Messages (N_EFAULT);
579 when EINVAL => return Error_Messages (N_EINVAL);
580 when EMFILE => return Error_Messages (N_EMFILE);
581 when EWOULDBLOCK => return Error_Messages (N_EWOULDBLOCK);
582 when EINPROGRESS => return Error_Messages (N_EINPROGRESS);
583 when EALREADY => return Error_Messages (N_EALREADY);
584 when ENOTSOCK => return Error_Messages (N_ENOTSOCK);
585 when EDESTADDRREQ => return Error_Messages (N_EDESTADDRREQ);
586 when EMSGSIZE => return Error_Messages (N_EMSGSIZE);
587 when EPROTOTYPE => return Error_Messages (N_EPROTOTYPE);
588 when ENOPROTOOPT => return Error_Messages (N_ENOPROTOOPT);
589 when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT);
590 when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT);
591 when EOPNOTSUPP => return Error_Messages (N_EOPNOTSUPP);
592 when EPFNOSUPPORT => return Error_Messages (N_EPFNOSUPPORT);
593 when EAFNOSUPPORT => return Error_Messages (N_EAFNOSUPPORT);
594 when EADDRINUSE => return Error_Messages (N_EADDRINUSE);
595 when EADDRNOTAVAIL => return Error_Messages (N_EADDRNOTAVAIL);
596 when ENETDOWN => return Error_Messages (N_ENETDOWN);
597 when ENETUNREACH => return Error_Messages (N_ENETUNREACH);
598 when ENETRESET => return Error_Messages (N_ENETRESET);
599 when ECONNABORTED => return Error_Messages (N_ECONNABORTED);
600 when ECONNRESET => return Error_Messages (N_ECONNRESET);
601 when ENOBUFS => return Error_Messages (N_ENOBUFS);
602 when EISCONN => return Error_Messages (N_EISCONN);
603 when ENOTCONN => return Error_Messages (N_ENOTCONN);
604 when ESHUTDOWN => return Error_Messages (N_ESHUTDOWN);
605 when ETOOMANYREFS => return Error_Messages (N_ETOOMANYREFS);
606 when ETIMEDOUT => return Error_Messages (N_ETIMEDOUT);
607 when ECONNREFUSED => return Error_Messages (N_ECONNREFUSED);
608 when ELOOP => return Error_Messages (N_ELOOP);
609 when ENAMETOOLONG => return Error_Messages (N_ENAMETOOLONG);
610 when EHOSTDOWN => return Error_Messages (N_EHOSTDOWN);
611 when EHOSTUNREACH => return Error_Messages (N_EHOSTUNREACH);
612
613 -- Windows-specific error codes
614
615 when WSASYSNOTREADY => return Error_Messages (N_WSASYSNOTREADY);
616 when WSAVERNOTSUPPORTED =>
617 return Error_Messages (N_WSAVERNOTSUPPORTED);
618 when WSANOTINITIALISED =>
619 return Error_Messages (N_WSANOTINITIALISED);
620 when WSAEDISCON => return Error_Messages (N_WSAEDISCON);
621
622 -- h_errno values
623
624 when HOST_NOT_FOUND => return Error_Messages (N_HOST_NOT_FOUND);
625 when TRY_AGAIN => return Error_Messages (N_TRY_AGAIN);
626 when NO_RECOVERY => return Error_Messages (N_NO_RECOVERY);
627 when NO_DATA => return Error_Messages (N_NO_DATA);
628
629 when others => return Error_Messages (N_OTHERS);
630 end case;
631 end Socket_Error_Message;
632
633 end GNAT.Sockets.Thin;
Mirror of the offical gcc git repository hosted at gcc.gnu.org