diff options
author | Richard Kenner <kenner@gcc.gnu.org> | 2001-10-02 10:18:40 -0400 |
---|---|---|
committer | Richard Kenner <kenner@gcc.gnu.org> | 2001-10-02 10:18:40 -0400 |
commit | 38cbfe40a046b12a3d9bc56e6cf76d86c458ef39 (patch) | |
tree | 6570bc15069492ca4f53a85c5d09a36d099fd63f /gcc/ada/g-socthi.adb | |
parent | 70482933d8f6a73b660f4cfa97b5c7c9deaf152e (diff) | |
download | gcc-38cbfe40a046b12a3d9bc56e6cf76d86c458ef39.tar.gz |
New Language: Ada
From-SVN: r45955
Diffstat (limited to 'gcc/ada/g-socthi.adb')
-rw-r--r-- | gcc/ada/g-socthi.adb | 495 |
1 files changed, 495 insertions, 0 deletions
diff --git a/gcc/ada/g-socthi.adb b/gcc/ada/g-socthi.adb new file mode 100644 index 00000000000..7fdf17e3660 --- /dev/null +++ b/gcc/ada/g-socthi.adb @@ -0,0 +1,495 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 2001 Ada Core Technologies, Inc. -- +-- -- +-- 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with Interfaces.C; use Interfaces.C; + +package body GNAT.Sockets.Thin is + + -- 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 set a socket in non-blocking mode + -- by purpose. We track the socket in such a mode by redefining + -- C_Ioctl. In blocking IO operations, we exit normally when the + -- non-blocking flag is set by user, we poll and try later when + -- this flag is set automatically by this package. + + type Socket_Info is record + Non_Blocking : Boolean := False; + end record; + + Table : array (C.int range 0 .. 31) of Socket_Info; + -- Get info on blocking flag. This array is limited to 32 sockets + -- because the select operation allows socket set of less then 32 + -- sockets. + + Quantum : constant Duration := 0.2; + -- comment needed ??? + + Thread_Blocking_IO : Boolean := True; + + function Syscall_Accept + (S : C.int; + Addr : System.Address; + Addrlen : 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_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) + return C.int; + pragma Import (C, Syscall_Ioctl, "ioctl"); + + 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 : Sockaddr_In_Access; + Fromlen : access C.int) + return C.int; + pragma Import (C, Syscall_Recvfrom, "recvfrom"); + + function Syscall_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int; + pragma Import (C, Syscall_Send, "send"); + + function Syscall_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : Sockaddr_In_Access; + 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"); + + procedure Set_Non_Blocking (S : C.int); + + -------------- + -- C_Accept -- + -------------- + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) + return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Accept (S, Addr, Addrlen); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Table (S).Non_Blocking + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + if not Thread_Blocking_IO + and then Res /= Failure + then + -- A socket inherits the properties ot its server especially + -- the FNDELAY flag. + + Table (Res).Non_Blocking := Table (S).Non_Blocking; + Set_Non_Blocking (Res); + end if; + + return Res; + 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 Thread_Blocking_IO + or else Res /= Failure + or else Table (S).Non_Blocking + or else Errno /= Constants.EINPROGRESS + then + return Res; + end if; + + declare + Set : aliased Fd_Set; + Now : aliased Timeval; + + begin + loop + Set := 2 ** Natural (S); + Now := Immediat; + Res := C_Select + (S + 1, + null, Set'Unchecked_Access, + null, 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 = Constants.EISCONN + then + return Thin.Success; + else + return Res; + end if; + end C_Connect; + + ------------- + -- C_Ioctl -- + ------------- + + function C_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) + return C.int + is + begin + if not Thread_Blocking_IO + and then Req = Constants.FIONBIO + then + Table (S).Non_Blocking := (Arg.all /= 0); + end if; + + return Syscall_Ioctl (S, Req, Arg); + end C_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 Thread_Blocking_IO + or else Res /= Failure + or else Table (S).Non_Blocking + or else Errno /= Constants.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 : Sockaddr_In_Access; + Fromlen : access C.int) + return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Table (S).Non_Blocking + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recvfrom; + + ------------ + -- C_Send -- + ------------ + + function C_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Send (S, Msg, Len, Flags); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Table (S).Non_Blocking + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Send; + + -------------- + -- C_Sendto -- + -------------- + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : Sockaddr_In_Access; + Tolen : C.int) + return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Table (S).Non_Blocking + or else Errno /= Constants.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 + Res : C.int; + + begin + Res := Syscall_Socket (Domain, Typ, Protocol); + + if not Thread_Blocking_IO + and then Res /= Failure + then + Set_Non_Blocking (Res); + end if; + + return Res; + end C_Socket; + + ----------- + -- Clear -- + ----------- + + procedure Clear + (Item : in out Fd_Set; + Socket : in C.int) + is + Mask : constant Fd_Set := 2 ** Natural (Socket); + + begin + if (Item and Mask) /= 0 then + Item := Item xor Mask; + end if; + end Clear; + + ----------- + -- Empty -- + ----------- + + procedure Empty (Item : in out Fd_Set) is + begin + Item := 0; + end Empty; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + null; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Process_Blocking_IO : Boolean) is + begin + Thread_Blocking_IO := not Process_Blocking_IO; + end Initialize; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Item : Fd_Set) return Boolean is + begin + return Item = 0; + end Is_Empty; + + ------------ + -- Is_Set -- + ------------ + + function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean is + begin + return (Item and 2 ** Natural (Socket)) /= 0; + end Is_Set; + + --------- + -- Max -- + --------- + + function Max (Item : Fd_Set) return C.int + is + L : C.int := -1; + C : Fd_Set := Item; + + begin + while C /= 0 loop + L := L + 1; + C := C / 2; + end loop; + return L; + end Max; + + --------- + -- Set -- + --------- + + procedure Set (Item : in out Fd_Set; Socket : in C.int) is + begin + Item := Item or 2 ** Natural (Socket); + end Set; + + ---------------------- + -- Set_Non_Blocking -- + ---------------------- + + procedure Set_Non_Blocking (S : C.int) is + Res : C.int; + Val : aliased C.int := 1; + + begin + + -- Do not use C_Fcntl because this subprogram tracks the + -- sockets set by user in non-blocking mode. + + Res := Syscall_Ioctl (S, Constants.FIONBIO, Val'Unchecked_Access); + end Set_Non_Blocking; + + -------------------------- + -- Socket_Error_Message -- + -------------------------- + + function Socket_Error_Message (Errno : Integer) return String is + use type Interfaces.C.Strings.chars_ptr; + + C_Msg : C.Strings.chars_ptr; + + begin + C_Msg := C_Strerror (C.int (Errno)); + + if C_Msg = C.Strings.Null_Ptr then + return "Unknown system error"; + + else + return C.Strings.Value (C_Msg); + end if; + end Socket_Error_Message; + +end GNAT.Sockets.Thin; |