URL
https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk
Subversion Repositories openrisc_me
[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [g-socthi-mingw.adb] - Rev 281
Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- 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-2009, 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 2, 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. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- -- Boston, MA 02110-1301, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- 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 Interfaces.C.Strings; use Interfaces.C.Strings; with System; use System; package body GNAT.Sockets.Thin is use type C.unsigned; use type C.int; 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 : C.int; 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 ssize_t is 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 recvmsg(). The spec for -- WSARecvMsg() is incompatible with the data types we define, and is -- not available in all versions of Windows. So, we use C_Recv instead. for J in Iovec'Range loop Res := C_Recv (S, Iovec (J).Base.all'Address, C.int (Iovec (J).Length), Flags); if Res < 0 then return ssize_t (Res); else Count := Count + Res; end if; end loop; return 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 ssize_t is 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 -- not available in all versions of Windows. So, we'll 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 ssize_t (Res); else Count := Count + Res; end if; end loop; return 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. The default -- separate body for Host_Error_Messages is therefore not used in -- this case. function Host_Error_Message (H_Errno : Integer) return C.Strings.chars_ptr 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 C.Strings.chars_ptr is use GNAT.Sockets.SOSC; begin case Errno is when EINTR => return Error_Messages (N_EINTR); when EBADF => return Error_Messages (N_EBADF); when EACCES => return Error_Messages (N_EACCES); when EFAULT => return Error_Messages (N_EFAULT); when EINVAL => return Error_Messages (N_EINVAL); when EMFILE => return Error_Messages (N_EMFILE); when EWOULDBLOCK => return Error_Messages (N_EWOULDBLOCK); when EINPROGRESS => return Error_Messages (N_EINPROGRESS); when EALREADY => return Error_Messages (N_EALREADY); when ENOTSOCK => return Error_Messages (N_ENOTSOCK); when EDESTADDRREQ => return Error_Messages (N_EDESTADDRREQ); when EMSGSIZE => return Error_Messages (N_EMSGSIZE); when EPROTOTYPE => return Error_Messages (N_EPROTOTYPE); when ENOPROTOOPT => return Error_Messages (N_ENOPROTOOPT); when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT); when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT); when EOPNOTSUPP => return Error_Messages (N_EOPNOTSUPP); when EPFNOSUPPORT => return Error_Messages (N_EPFNOSUPPORT); when EAFNOSUPPORT => return Error_Messages (N_EAFNOSUPPORT); when EADDRINUSE => return Error_Messages (N_EADDRINUSE); when EADDRNOTAVAIL => return Error_Messages (N_EADDRNOTAVAIL); when ENETDOWN => return Error_Messages (N_ENETDOWN); when ENETUNREACH => return Error_Messages (N_ENETUNREACH); when ENETRESET => return Error_Messages (N_ENETRESET); when ECONNABORTED => return Error_Messages (N_ECONNABORTED); when ECONNRESET => return Error_Messages (N_ECONNRESET); when ENOBUFS => return Error_Messages (N_ENOBUFS); when EISCONN => return Error_Messages (N_EISCONN); when ENOTCONN => return Error_Messages (N_ENOTCONN); when ESHUTDOWN => return Error_Messages (N_ESHUTDOWN); when ETOOMANYREFS => return Error_Messages (N_ETOOMANYREFS); when ETIMEDOUT => return Error_Messages (N_ETIMEDOUT); when ECONNREFUSED => return Error_Messages (N_ECONNREFUSED); when ELOOP => return Error_Messages (N_ELOOP); when ENAMETOOLONG => return Error_Messages (N_ENAMETOOLONG); when EHOSTDOWN => return Error_Messages (N_EHOSTDOWN); when EHOSTUNREACH => return Error_Messages (N_EHOSTUNREACH); -- Windows-specific error codes when WSASYSNOTREADY => return Error_Messages (N_WSASYSNOTREADY); when WSAVERNOTSUPPORTED => return Error_Messages (N_WSAVERNOTSUPPORTED); when WSANOTINITIALISED => return Error_Messages (N_WSANOTINITIALISED); when WSAEDISCON => return Error_Messages (N_WSAEDISCON); -- h_errno values when HOST_NOT_FOUND => return Error_Messages (N_HOST_NOT_FOUND); when TRY_AGAIN => return Error_Messages (N_TRY_AGAIN); when NO_RECOVERY => return Error_Messages (N_NO_RECOVERY); when NO_DATA => return Error_Messages (N_NO_DATA); when others => return Error_Messages (N_OTHERS); end case; end Socket_Error_Message; end GNAT.Sockets.Thin;