URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc1/] [gcc/] [ada/] [g-socthi.adb] - Rev 281
Go to most recent revision | 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 is the default version with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Task_Lock; with Interfaces.C; use Interfaces.C; package body GNAT.Sockets.Thin is Non_Blocking_Sockets : aliased Fd_Set; -- When this package is initialized with Process_Blocking_IO set -- to True, sockets are set in non-blocking mode to avoid blocking -- the whole process when a thread wants to perform a blocking IO -- operation. But the user can also set a socket in non-blocking -- mode by purpose. In order to make a difference between these -- two situations, we track the origin of non-blocking mode in -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has -- been set in non-blocking mode by the user. Quantum : constant Duration := 0.2; -- When SOSC.Thread_Blocking_IO is False, we set sockets in -- non-blocking mode and we spend a period of time Quantum between -- two attempts on a blocking operation. Unknown_System_Error : constant C.Strings.chars_ptr := C.Strings.New_String ("Unknown system error"); -- Comments required for following functions ??? function Syscall_Accept (S : C.int; Addr : System.Address; Addrlen : not null access C.int) return C.int; pragma Import (C, Syscall_Accept, "accept"); function Syscall_Connect (S : C.int; Name : System.Address; Namelen : C.int) return C.int; pragma Import (C, Syscall_Connect, "connect"); function Syscall_Recv (S : C.int; Msg : System.Address; Len : C.int; Flags : C.int) return C.int; pragma Import (C, Syscall_Recv, "recv"); function Syscall_Recvfrom (S : C.int; Msg : System.Address; Len : C.int; Flags : C.int; From : System.Address; Fromlen : not null access C.int) return C.int; pragma Import (C, Syscall_Recvfrom, "recvfrom"); function Syscall_Recvmsg (S : C.int; Msg : System.Address; Flags : C.int) return ssize_t; pragma Import (C, Syscall_Recvmsg, "recvmsg"); function Syscall_Sendmsg (S : C.int; Msg : System.Address; Flags : C.int) return ssize_t; pragma Import (C, Syscall_Sendmsg, "sendmsg"); function Syscall_Sendto (S : C.int; Msg : System.Address; Len : C.int; Flags : C.int; To : System.Address; Tolen : C.int) return C.int; pragma Import (C, Syscall_Sendto, "sendto"); function Syscall_Socket (Domain : C.int; Typ : C.int; Protocol : C.int) return C.int; pragma Import (C, Syscall_Socket, "socket"); procedure Disable_SIGPIPE (S : C.int); pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe"); procedure Disable_All_SIGPIPEs; pragma Import (C, Disable_All_SIGPIPEs, "__gnat_disable_all_sigpipes"); -- Sets the process to ignore all SIGPIPE signals on platforms that -- don't support Disable_SIGPIPE for particular streams. function Non_Blocking_Socket (S : C.int) return Boolean; procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); -------------- -- C_Accept -- -------------- function C_Accept (S : C.int; Addr : System.Address; Addrlen : not null access C.int) return C.int is R : C.int; Val : aliased C.int := 1; Discard : C.int; pragma Warnings (Off, Discard); begin loop R := Syscall_Accept (S, Addr, Addrlen); exit when SOSC.Thread_Blocking_IO or else R /= Failure or else Non_Blocking_Socket (S) or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; if not SOSC.Thread_Blocking_IO and then R /= Failure then -- A socket inherits the properties ot its server especially -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram -- tracks sockets set in non-blocking mode by user. Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); end if; Disable_SIGPIPE (R); return R; end C_Accept; --------------- -- C_Connect -- --------------- function C_Connect (S : C.int; Name : System.Address; Namelen : C.int) return C.int is Res : C.int; begin Res := Syscall_Connect (S, Name, Namelen); if SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) or else Errno /= SOSC.EINPROGRESS then return Res; end if; declare WSet : aliased Fd_Set; Now : aliased Timeval; begin Reset_Socket_Set (WSet'Access); loop Insert_Socket_In_Set (WSet'Access, S); Now := Immediat; Res := C_Select (S + 1, No_Fd_Set_Access, WSet'Access, No_Fd_Set_Access, Now'Unchecked_Access); exit when Res > 0; if Res = Failure then return Res; end if; delay Quantum; end loop; end; Res := Syscall_Connect (S, Name, Namelen); if Res = Failure and then Errno = SOSC.EISCONN then return Thin_Common.Success; else return Res; end if; end C_Connect; ------------------ -- Socket_Ioctl -- ------------------ function Socket_Ioctl (S : C.int; Req : C.int; Arg : access C.int) return C.int is begin if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then if Arg.all /= 0 then Set_Non_Blocking_Socket (S, True); end if; end if; return C_Ioctl (S, Req, Arg); end Socket_Ioctl; ------------ -- C_Recv -- ------------ function C_Recv (S : C.int; Msg : System.Address; Len : C.int; Flags : C.int) return C.int is Res : C.int; begin loop Res := Syscall_Recv (S, Msg, Len, Flags); exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; return Res; end C_Recv; ---------------- -- C_Recvfrom -- ---------------- function C_Recvfrom (S : C.int; Msg : System.Address; Len : C.int; Flags : C.int; From : System.Address; Fromlen : not null access C.int) return C.int is Res : C.int; begin loop Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; return Res; end C_Recvfrom; --------------- -- C_Recvmsg -- --------------- function C_Recvmsg (S : C.int; Msg : System.Address; Flags : C.int) return ssize_t is Res : ssize_t; begin loop Res := Syscall_Recvmsg (S, Msg, Flags); exit when SOSC.Thread_Blocking_IO or else Res /= ssize_t (Failure) or else Non_Blocking_Socket (S) or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; return Res; end C_Recvmsg; --------------- -- C_Sendmsg -- --------------- function C_Sendmsg (S : C.int; Msg : System.Address; Flags : C.int) return ssize_t is Res : ssize_t; begin loop Res := Syscall_Sendmsg (S, Msg, Flags); exit when SOSC.Thread_Blocking_IO or else Res /= ssize_t (Failure) or else Non_Blocking_Socket (S) or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; return Res; end C_Sendmsg; -------------- -- C_Sendto -- -------------- function C_Sendto (S : C.int; Msg : System.Address; Len : C.int; Flags : C.int; To : System.Address; Tolen : C.int) return C.int is Res : C.int; begin loop Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); exit when SOSC.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; end loop; return Res; end C_Sendto; -------------- -- C_Socket -- -------------- function C_Socket (Domain : C.int; Typ : C.int; Protocol : C.int) return C.int is R : C.int; Val : aliased C.int := 1; Discard : C.int; pragma Unreferenced (Discard); begin R := Syscall_Socket (Domain, Typ, Protocol); if not SOSC.Thread_Blocking_IO and then R /= Failure then -- Do not use Socket_Ioctl as this subprogram tracks sockets set -- in non-blocking mode by user. Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); Set_Non_Blocking_Socket (R, False); end if; Disable_SIGPIPE (R); return R; end C_Socket; -------------- -- Finalize -- -------------- procedure Finalize is begin null; end Finalize; ------------------------- -- Host_Error_Messages -- ------------------------- package body Host_Error_Messages is separate; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Disable_All_SIGPIPEs; Reset_Socket_Set (Non_Blocking_Sockets'Access); end Initialize; ------------------------- -- Non_Blocking_Socket -- ------------------------- function Non_Blocking_Socket (S : C.int) return Boolean is R : Boolean; begin Task_Lock.Lock; R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0); Task_Lock.Unlock; return R; end Non_Blocking_Socket; ----------------------------- -- Set_Non_Blocking_Socket -- ----------------------------- procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is begin Task_Lock.Lock; if V then Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S); else Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S); end if; Task_Lock.Unlock; end Set_Non_Blocking_Socket; -------------------- -- Signalling_Fds -- -------------------- package body Signalling_Fds is -- In this default implementation, we use a C version of these -- subprograms provided by socket.c. function C_Create (Fds : not null access Fd_Pair) return C.int; function C_Read (Rsig : C.int) return C.int; function C_Write (Wsig : C.int) return C.int; procedure C_Close (Sig : C.int); pragma Import (C, C_Create, "__gnat_create_signalling_fds"); pragma Import (C, C_Read, "__gnat_read_signalling_fd"); pragma Import (C, C_Write, "__gnat_write_signalling_fd"); pragma Import (C, C_Close, "__gnat_close_signalling_fd"); function Create (Fds : not null access Fd_Pair) return C.int renames C_Create; function Read (Rsig : C.int) return C.int renames C_Read; function Write (Wsig : C.int) return C.int renames C_Write; procedure Close (Sig : C.int) renames C_Close; end Signalling_Fds; -------------------------- -- Socket_Error_Message -- -------------------------- function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr is separate; end GNAT.Sockets.Thin;
Go to most recent revision | Compare with Previous | Blame | View Log