diff options
Diffstat (limited to 'gcc/ada/g-socthi-mingw.adb')
| -rw-r--r-- | gcc/ada/g-socthi-mingw.adb | 631 |
1 files changed, 0 insertions, 631 deletions
diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb deleted file mode 100644 index 6ce2fb6cc42..00000000000 --- a/gcc/ada/g-socthi-mingw.adb +++ /dev/null @@ -1,631 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a target dependent thin interface to the sockets --- layer for use by the GNAT.Sockets package (g-socket.ads). This package --- should not be directly with'ed by an applications program. - --- This version is for NT - -with Ada.Unchecked_Conversion; -with Interfaces.C.Strings; use Interfaces.C.Strings; -with System; use System; -with System.Storage_Elements; use System.Storage_Elements; - -package body GNAT.Sockets.Thin is - - use type C.unsigned; - - WSAData_Dummy : array (1 .. 512) of C.int; - - WS_Version : constant := 16#0202#; - -- Winsock 2.2 - - Initialized : Boolean := False; - - function Standard_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - pragma Import (Stdcall, Standard_Connect, "connect"); - - function Standard_Select - (Nfds : C.int; - Readfds : access Fd_Set; - Writefds : access Fd_Set; - Exceptfds : access Fd_Set; - Timeout : Timeval_Access) return C.int; - pragma Import (Stdcall, Standard_Select, "select"); - - type Error_Type is - (N_EINTR, - N_EBADF, - N_EACCES, - N_EFAULT, - N_EINVAL, - N_EMFILE, - N_EWOULDBLOCK, - N_EINPROGRESS, - N_EALREADY, - N_ENOTSOCK, - N_EDESTADDRREQ, - N_EMSGSIZE, - N_EPROTOTYPE, - N_ENOPROTOOPT, - N_EPROTONOSUPPORT, - N_ESOCKTNOSUPPORT, - N_EOPNOTSUPP, - N_EPFNOSUPPORT, - N_EAFNOSUPPORT, - N_EADDRINUSE, - N_EADDRNOTAVAIL, - N_ENETDOWN, - N_ENETUNREACH, - N_ENETRESET, - N_ECONNABORTED, - N_ECONNRESET, - N_ENOBUFS, - N_EISCONN, - N_ENOTCONN, - N_ESHUTDOWN, - N_ETOOMANYREFS, - N_ETIMEDOUT, - N_ECONNREFUSED, - N_ELOOP, - N_ENAMETOOLONG, - N_EHOSTDOWN, - N_EHOSTUNREACH, - N_WSASYSNOTREADY, - N_WSAVERNOTSUPPORTED, - N_WSANOTINITIALISED, - N_WSAEDISCON, - N_HOST_NOT_FOUND, - N_TRY_AGAIN, - N_NO_RECOVERY, - N_NO_DATA, - N_OTHERS); - - Error_Messages : constant array (Error_Type) of chars_ptr := - (N_EINTR => - New_String ("Interrupted system call"), - N_EBADF => - New_String ("Bad file number"), - N_EACCES => - New_String ("Permission denied"), - N_EFAULT => - New_String ("Bad address"), - N_EINVAL => - New_String ("Invalid argument"), - N_EMFILE => - New_String ("Too many open files"), - N_EWOULDBLOCK => - New_String ("Operation would block"), - N_EINPROGRESS => - New_String ("Operation now in progress. This error is " - & "returned if any Windows Sockets API " - & "function is called while a blocking " - & "function is in progress"), - N_EALREADY => - New_String ("Operation already in progress"), - N_ENOTSOCK => - New_String ("Socket operation on nonsocket"), - N_EDESTADDRREQ => - New_String ("Destination address required"), - N_EMSGSIZE => - New_String ("Message too long"), - N_EPROTOTYPE => - New_String ("Protocol wrong type for socket"), - N_ENOPROTOOPT => - New_String ("Protocol not available"), - N_EPROTONOSUPPORT => - New_String ("Protocol not supported"), - N_ESOCKTNOSUPPORT => - New_String ("Socket type not supported"), - N_EOPNOTSUPP => - New_String ("Operation not supported on socket"), - N_EPFNOSUPPORT => - New_String ("Protocol family not supported"), - N_EAFNOSUPPORT => - New_String ("Address family not supported by protocol family"), - N_EADDRINUSE => - New_String ("Address already in use"), - N_EADDRNOTAVAIL => - New_String ("Cannot assign requested address"), - N_ENETDOWN => - New_String ("Network is down. This error may be " - & "reported at any time if the Windows " - & "Sockets implementation detects an " - & "underlying failure"), - N_ENETUNREACH => - New_String ("Network is unreachable"), - N_ENETRESET => - New_String ("Network dropped connection on reset"), - N_ECONNABORTED => - New_String ("Software caused connection abort"), - N_ECONNRESET => - New_String ("Connection reset by peer"), - N_ENOBUFS => - New_String ("No buffer space available"), - N_EISCONN => - New_String ("Socket is already connected"), - N_ENOTCONN => - New_String ("Socket is not connected"), - N_ESHUTDOWN => - New_String ("Cannot send after socket shutdown"), - N_ETOOMANYREFS => - New_String ("Too many references: cannot splice"), - N_ETIMEDOUT => - New_String ("Connection timed out"), - N_ECONNREFUSED => - New_String ("Connection refused"), - N_ELOOP => - New_String ("Too many levels of symbolic links"), - N_ENAMETOOLONG => - New_String ("File name too long"), - N_EHOSTDOWN => - New_String ("Host is down"), - N_EHOSTUNREACH => - New_String ("No route to host"), - N_WSASYSNOTREADY => - New_String ("Returned by WSAStartup(), indicating that " - & "the network subsystem is unusable"), - N_WSAVERNOTSUPPORTED => - New_String ("Returned by WSAStartup(), indicating that " - & "the Windows Sockets DLL cannot support " - & "this application"), - N_WSANOTINITIALISED => - New_String ("Winsock not initialized. This message is " - & "returned by any function except WSAStartup(), " - & "indicating that a successful WSAStartup() has " - & "not yet been performed"), - N_WSAEDISCON => - New_String ("Disconnected"), - N_HOST_NOT_FOUND => - New_String ("Host not found. This message indicates " - & "that the key (name, address, and so on) was not found"), - N_TRY_AGAIN => - New_String ("Nonauthoritative host not found. This error may " - & "suggest that the name service itself is not " - & "functioning"), - N_NO_RECOVERY => - New_String ("Nonrecoverable error. This error may suggest that the " - & "name service itself is not functioning"), - N_NO_DATA => - New_String ("Valid name, no data record of requested type. " - & "This error indicates that the key (name, address, " - & "and so on) was not found."), - N_OTHERS => - New_String ("Unknown system error")); - - --------------- - -- C_Connect -- - --------------- - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int - is - Res : C.int; - - begin - Res := Standard_Connect (S, Name, Namelen); - - if Res = -1 then - if Socket_Errno = SOSC.EWOULDBLOCK then - Set_Socket_Errno (SOSC.EINPROGRESS); - end if; - end if; - - return Res; - end C_Connect; - - ------------------ - -- Socket_Ioctl -- - ------------------ - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int - is - begin - return C_Ioctl (S, Req, Arg); - end Socket_Ioctl; - - --------------- - -- C_Recvmsg -- - --------------- - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - use type C.size_t; - - Fill : constant Boolean := - SOSC.MSG_WAITALL /= -1 - and then (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0; - -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors - - Res : C.int; - Count : C.int := 0; - - MH : Msghdr; - for MH'Address use Msg; - - Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element; - for Iovec'Address use MH.Msg_Iov; - pragma Import (Ada, Iovec); - - Iov_Index : Integer; - Current_Iovec : Vector_Element; - - function To_Access is new Ada.Unchecked_Conversion - (System.Address, Stream_Element_Reference); - pragma Warnings (Off, Stream_Element_Reference); - - Req : Request_Type (Name => N_Bytes_To_Read); - - begin - -- Windows does not provide an implementation of recvmsg(). The spec for - -- WSARecvMsg() is incompatible with the data types we define, and is - -- available starting with Windows Vista and Server 2008 only. So, - -- we use C_Recv instead. - - -- Check how much data are available - - Control_Socket (Socket_Type (S), Req); - - -- Fill the vectors - - Iov_Index := -1; - Current_Iovec := (Base => null, Length => 0); - - loop - if Current_Iovec.Length = 0 then - Iov_Index := Iov_Index + 1; - exit when Iov_Index > Integer (Iovec'Last); - Current_Iovec := Iovec (SOSC.Msg_Iovlen_T (Iov_Index)); - end if; - - Res := - C_Recv - (S, - Current_Iovec.Base.all'Address, - C.int (Current_Iovec.Length), - Flags); - - if Res < 0 then - return System.CRTL.ssize_t (Res); - - elsif Res = 0 and then not Fill then - exit; - - else - pragma Assert (Interfaces.C.size_t (Res) <= Current_Iovec.Length); - - Count := Count + Res; - Current_Iovec.Length := - Current_Iovec.Length - Interfaces.C.size_t (Res); - Current_Iovec.Base := - To_Access (Current_Iovec.Base.all'Address - + Storage_Offset (Res)); - - -- If all the data that was initially available read, do not - -- attempt to receive more, since this might block, or merge data - -- from successive datagrams for a datagram-oriented socket. We - -- still try to receive more if we need to fill all vectors - -- (MSG_WAITALL flag is set). - - exit when Natural (Count) >= Req.Size - and then - - -- Either we are not in fill mode - - (not Fill - - -- Or else last vector filled - - or else (Interfaces.C.size_t (Iov_Index) = Iovec'Last - and then Current_Iovec.Length = 0)); - end if; - end loop; - - return System.CRTL.ssize_t (Count); - end C_Recvmsg; - - -------------- - -- C_Select -- - -------------- - - function C_Select - (Nfds : C.int; - Readfds : access Fd_Set; - Writefds : access Fd_Set; - Exceptfds : access Fd_Set; - Timeout : Timeval_Access) return C.int - is - pragma Warnings (Off, Exceptfds); - - Original_WFS : aliased constant Fd_Set := Writefds.all; - - Res : C.int; - S : aliased C.int; - Last : aliased C.int; - - begin - -- Asynchronous connection failures are notified in the exception fd - -- set instead of the write fd set. To ensure POSIX compatibility, copy - -- write fd set into exception fd set. Once select() returns, check any - -- socket present in the exception fd set and peek at incoming - -- out-of-band data. If the test is not successful, and the socket is - -- present in the initial write fd set, then move the socket from the - -- exception fd set to the write fd set. - - if Writefds /= No_Fd_Set_Access then - - -- Add any socket present in write fd set into exception fd set - - declare - WFS : aliased Fd_Set := Writefds.all; - begin - Last := Nfds - 1; - loop - Get_Socket_From_Set - (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access); - exit when S = -1; - Insert_Socket_In_Set (Exceptfds, S); - end loop; - end; - end if; - - Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout); - - if Exceptfds /= No_Fd_Set_Access then - declare - EFSC : aliased Fd_Set := Exceptfds.all; - Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB; - Buffer : Character; - Length : C.int; - Fromlen : aliased C.int; - - begin - Last := Nfds - 1; - loop - Get_Socket_From_Set - (EFSC'Access, S'Unchecked_Access, Last'Unchecked_Access); - - -- No more sockets in EFSC - - exit when S = -1; - - -- Check out-of-band data - - Length := - C_Recvfrom - (S, Buffer'Address, 1, Flag, - From => System.Null_Address, - Fromlen => Fromlen'Unchecked_Access); - -- Is Fromlen necessary if From is Null_Address??? - - -- If the signal is not an out-of-band data, then it - -- is a connection failure notification. - - if Length = -1 then - Remove_Socket_From_Set (Exceptfds, S); - - -- If S is present in the initial write fd set, move it from - -- exception fd set back to write fd set. Otherwise, ignore - -- this event since the user is not watching for it. - - if Writefds /= No_Fd_Set_Access - and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0) - then - Insert_Socket_In_Set (Writefds, S); - end if; - end if; - end loop; - end; - end if; - return Res; - end C_Select; - - --------------- - -- C_Sendmsg -- - --------------- - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - use type C.size_t; - - Res : C.int; - Count : C.int := 0; - - MH : Msghdr; - for MH'Address use Msg; - - Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element; - for Iovec'Address use MH.Msg_Iov; - pragma Import (Ada, Iovec); - - begin - -- Windows does not provide an implementation of sendmsg(). The spec for - -- WSASendMsg() is incompatible with the data types we define, and is - -- available starting with Windows Vista and Server 2008 only. So - -- use C_Sendto instead. - - for J in Iovec'Range loop - Res := - C_Sendto - (S, - Iovec (J).Base.all'Address, - C.int (Iovec (J).Length), - Flags => Flags, - To => MH.Msg_Name, - Tolen => C.int (MH.Msg_Namelen)); - - if Res < 0 then - return System.CRTL.ssize_t (Res); - else - Count := Count + Res; - end if; - - -- Exit now if the buffer is not fully transmitted - - exit when Interfaces.C.size_t (Res) < Iovec (J).Length; - end loop; - - return System.CRTL.ssize_t (Count); - end C_Sendmsg; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - begin - if Initialized then - WSACleanup; - Initialized := False; - end if; - end Finalize; - - ------------------------- - -- Host_Error_Messages -- - ------------------------- - - package body Host_Error_Messages is - - -- On Windows, socket and host errors share the same code space, and - -- error messages are provided by Socket_Error_Message, so the default - -- separate body for Host_Error_Messages is not used in this case. - - function Host_Error_Message (H_Errno : Integer) return String - renames Socket_Error_Message; - - end Host_Error_Messages; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - Return_Value : Interfaces.C.int; - begin - if not Initialized then - Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address); - pragma Assert (Return_Value = 0); - Initialized := True; - end if; - end Initialize; - - -------------------- - -- Signalling_Fds -- - -------------------- - - package body Signalling_Fds is separate; - - -------------------------- - -- Socket_Error_Message -- - -------------------------- - - function Socket_Error_Message (Errno : Integer) return String is - use GNAT.Sockets.SOSC; - - Errm : C.Strings.chars_ptr; - - begin - case Errno is - when EINTR => Errm := Error_Messages (N_EINTR); - when EBADF => Errm := Error_Messages (N_EBADF); - when EACCES => Errm := Error_Messages (N_EACCES); - when EFAULT => Errm := Error_Messages (N_EFAULT); - when EINVAL => Errm := Error_Messages (N_EINVAL); - when EMFILE => Errm := Error_Messages (N_EMFILE); - when EWOULDBLOCK => Errm := Error_Messages (N_EWOULDBLOCK); - when EINPROGRESS => Errm := Error_Messages (N_EINPROGRESS); - when EALREADY => Errm := Error_Messages (N_EALREADY); - when ENOTSOCK => Errm := Error_Messages (N_ENOTSOCK); - when EDESTADDRREQ => Errm := Error_Messages (N_EDESTADDRREQ); - when EMSGSIZE => Errm := Error_Messages (N_EMSGSIZE); - when EPROTOTYPE => Errm := Error_Messages (N_EPROTOTYPE); - when ENOPROTOOPT => Errm := Error_Messages (N_ENOPROTOOPT); - when EPROTONOSUPPORT => Errm := Error_Messages (N_EPROTONOSUPPORT); - when ESOCKTNOSUPPORT => Errm := Error_Messages (N_ESOCKTNOSUPPORT); - when EOPNOTSUPP => Errm := Error_Messages (N_EOPNOTSUPP); - when EPFNOSUPPORT => Errm := Error_Messages (N_EPFNOSUPPORT); - when EAFNOSUPPORT => Errm := Error_Messages (N_EAFNOSUPPORT); - when EADDRINUSE => Errm := Error_Messages (N_EADDRINUSE); - when EADDRNOTAVAIL => Errm := Error_Messages (N_EADDRNOTAVAIL); - when ENETDOWN => Errm := Error_Messages (N_ENETDOWN); - when ENETUNREACH => Errm := Error_Messages (N_ENETUNREACH); - when ENETRESET => Errm := Error_Messages (N_ENETRESET); - when ECONNABORTED => Errm := Error_Messages (N_ECONNABORTED); - when ECONNRESET => Errm := Error_Messages (N_ECONNRESET); - when ENOBUFS => Errm := Error_Messages (N_ENOBUFS); - when EISCONN => Errm := Error_Messages (N_EISCONN); - when ENOTCONN => Errm := Error_Messages (N_ENOTCONN); - when ESHUTDOWN => Errm := Error_Messages (N_ESHUTDOWN); - when ETOOMANYREFS => Errm := Error_Messages (N_ETOOMANYREFS); - when ETIMEDOUT => Errm := Error_Messages (N_ETIMEDOUT); - when ECONNREFUSED => Errm := Error_Messages (N_ECONNREFUSED); - when ELOOP => Errm := Error_Messages (N_ELOOP); - when ENAMETOOLONG => Errm := Error_Messages (N_ENAMETOOLONG); - when EHOSTDOWN => Errm := Error_Messages (N_EHOSTDOWN); - when EHOSTUNREACH => Errm := Error_Messages (N_EHOSTUNREACH); - - -- Windows-specific error codes - - when WSASYSNOTREADY => Errm := Error_Messages (N_WSASYSNOTREADY); - when WSAVERNOTSUPPORTED => - Errm := Error_Messages (N_WSAVERNOTSUPPORTED); - when WSANOTINITIALISED => - Errm := Error_Messages (N_WSANOTINITIALISED); - when WSAEDISCON => Errm := Error_Messages (N_WSAEDISCON); - - -- h_errno values - - when HOST_NOT_FOUND => Errm := Error_Messages (N_HOST_NOT_FOUND); - when TRY_AGAIN => Errm := Error_Messages (N_TRY_AGAIN); - when NO_RECOVERY => Errm := Error_Messages (N_NO_RECOVERY); - when NO_DATA => Errm := Error_Messages (N_NO_DATA); - when others => Errm := Error_Messages (N_OTHERS); - end case; - - return Value (Errm); - end Socket_Error_Message; - -end GNAT.Sockets.Thin; |