X-Git-Url: https://oss.titaniummirror.com/gitweb?a=blobdiff_plain;f=gcc%2Fada%2Fg-socthi.adb;fp=gcc%2Fada%2Fg-socthi.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=0f764871d44ecbc221faff0165aca6121195cff5;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/g-socthi.adb b/gcc/ada/g-socthi.adb deleted file mode 100644 index 0f764871..00000000 --- a/gcc/ada/g-socthi.adb +++ /dev/null @@ -1,495 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- B o d y -- --- -- --- $Revision: 1.1 $ --- -- --- 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;