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-vms.adb] - Rev 414
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 is the version for OpenVMS with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Task_Lock; with Interfaces.C; use Interfaces.C; package body GNAT.Sockets.Thin is type VMS_Msghdr is new Msghdr; pragma Pack (VMS_Msghdr); -- On VMS (unlike other platforms), struct msghdr is packed, so a specific -- derived type is required. 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. Note that 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 to 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"); 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 C.int; pragma Import (C, Syscall_Recvmsg, "recvmsg"); function Syscall_Sendmsg (S : C.int; Msg : System.Address; Flags : C.int) return C.int; 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, Typ, Protocol : C.int) return C.int; pragma Import (C, Syscall_Socket, "socket"); 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 of 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; 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 : C.int; GNAT_Msg : Msghdr; for GNAT_Msg'Address use Msg; pragma Import (Ada, GNAT_Msg); VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg); begin loop Res := Syscall_Recvmsg (S, VMS_Msg'Address, 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; GNAT_Msg := Msghdr (VMS_Msg); return ssize_t (Res); end C_Recvmsg; --------------- -- C_Sendmsg -- --------------- function C_Sendmsg (S : C.int; Msg : System.Address; Flags : C.int) return ssize_t is Res : C.int; GNAT_Msg : Msghdr; for GNAT_Msg'Address use Msg; pragma Import (Ada, GNAT_Msg); VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg); begin loop Res := Syscall_Sendmsg (S, VMS_Msg'Address, 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; GNAT_Msg := Msghdr (VMS_Msg); return ssize_t (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; 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 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 separate; -------------------------- -- 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