# to LIBGNAT_TARGET_PAIRS.
GNATRTL_SOCKETS_OBJS = g-soccon$(objext) g-socket$(objext) g-socthi$(objext) \
- g-soliop$(objext) g-sothco$(objext)
+ g-soliop$(objext) g-sothco$(objext) g-socpol$(objext)
DUMMY_SOCKETS_TARGET_PAIRS = \
g-socket.adb<libgnat/g-socket__dummy.adb \
g-socthi.adb<libgnat/g-socthi__dummy.adb \
g-socthi.ads<libgnat/g-socthi__dummy.ads \
g-sothco.adb<libgnat/g-sothco__dummy.adb \
- g-sothco.ads<libgnat/g-sothco__dummy.ads
+ g-sothco.ads<libgnat/g-sothco__dummy.ads \
+ g-socpol.adb<libgnat/g-socpol__dummy.adb \
+ g-socpol.ads<libgnat/g-socpol__dummy.ads
# On platforms where atomic increment/decrement operations are supported,
# special version of Ada.Strings.Unbounded package can be used.
s-vxwork.ads<libgnarl/s-vxwork__ppc.ads \
g-socthi.ads<libgnat/g-socthi__vxworks.ads \
g-socthi.adb<libgnat/g-socthi__vxworks.adb \
+ g-sopowa.adb<libgnat/g-sopowa__posix.adb \
g-stsifd.adb<libgnat/g-stsifd__sockets.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
LIBGNAT_TARGET_PAIRS += \
g-socthi.ads<libgnat/g-socthi__vxworks.ads \
g-socthi.adb<libgnat/g-socthi__vxworks.adb \
+ g-sopowa.adb<libgnat/g-sopowa__posix.adb \
g-stsifd.adb<libgnat/g-stsifd__sockets.adb
endif
LIBGNAT_TARGET_PAIRS += \
g-socthi.ads<libgnat/g-socthi__vxworks.ads \
g-socthi.adb<libgnat/g-socthi__vxworks.adb \
+ g-sopowa.adb<libgnat/g-sopowa__posix.adb \
g-stsifd.adb<libgnat/g-stsifd__sockets.adb
endif
s-vxwork.ads<libgnarl/s-vxwork__x86.ads \
g-socthi.ads<libgnat/g-socthi__vxworks.ads \
g-socthi.adb<libgnat/g-socthi__vxworks.adb \
+ g-sopowa.adb<libgnat/g-sopowa__posix.adb \
g-stsifd.adb<libgnat/g-stsifd__sockets.adb \
$(ATOMICS_TARGET_PAIRS)
s-taspri.ads<libgnarl/s-taspri__vxworks.ads \
g-socthi.ads<libgnat/g-socthi__vxworks.ads \
g-socthi.adb<libgnat/g-socthi__vxworks.adb \
+ g-sopowa.adb<libgnat/g-sopowa__posix.adb \
g-stsifd.adb<libgnat/g-stsifd__sockets.adb
ifeq ($(strip $(filter-out aarch64, $(target_cpu))),)
else
LIBGNAT_TARGET_PAIRS = \
g-socthi.ads<libgnat/g-socthi__mingw.ads \
- g-socthi.adb<libgnat/g-socthi__mingw.adb
+ g-socthi.adb<libgnat/g-socthi__mingw.adb \
+ g-sopowa.adb<libgnat/g-sopowa__mingw.adb
endif
LIBGNAT_TARGET_PAIRS += \
a-dirval.adb<libgnat/a-dirval__mingw.adb \
#define FD_SETSIZE 1024
#ifdef __MINGW32__
+/* winsock2.h allows WSAPoll related definitions only when
+ * _WIN32_WINNT >= 0x0600 */
+#if !defined(_WIN32_WINNT) || _WIN32_WINNT < 0x0600
+#define _WIN32_WINNT 0x0600
+#endif
+
#include <winsock2.h>
#include <ws2tcpip.h>
#include <versionhelpers.h>
("g-sha512", F), -- GNAT.SHA512
("g-signal", F), -- GNAT.Signals
("g-socket", F), -- GNAT.Sockets
+ ("g-socpol", F), -- GNAT.Sockets.Poll
("g-souinf", F), -- GNAT.Source_Info
("g-speche", F), -- GNAT.Spell_Checker
("g-spchge", F), -- GNAT.Spell_Checker_Generic
else Value);
-- Removes dot at the end of error message
- procedure Raise_Socket_Error (Error : Integer);
- -- Raise Socket_Error with an exception message describing the error code
- -- from errno.
-
procedure Raise_Host_Error (H_Error : Integer; Name : String);
-- Raise Host_Error exception with message describing error code (note
-- hstrerror seems to be obsolete) from h_errno. Name is the name
Wait_For_A_Full_Reception : constant Request_Flag_Type := 4;
Send_End_Of_Record : constant Request_Flag_Type := 8;
+ procedure Raise_Socket_Error (Error : Integer);
+ -- Raise Socket_Error with an exception message describing the error code
+ -- from errno.
+
end GNAT.Sockets;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . P O L L --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, 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 3, 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Calendar;
+
+with GNAT.Sockets.Thin;
+
+package body GNAT.Sockets.Poll is
+
+ To_C : constant array (Wait_Event_Type) of Events_Type :=
+ (Input => SOC.POLLIN or SOC.POLLPRI, Output => SOC.POLLOUT);
+ -- To convert Wait_Event_Type to C I/O events flags
+
+ procedure Set_Mode (Item : out Pollfd; Mode : Wait_Event_Set);
+ -- Set I/O waiting mode on Item
+
+ procedure Set_Event
+ (Item : out Pollfd; Event : Wait_Event_Type; Value : Boolean);
+ -- Set or reset waiting state on I/O event
+
+ procedure Check_Range (Self : Set; Index : Positive) with Inline;
+ -- raise Constraint_Error if Index is more than number of sockets in Self
+
+ function Status (Item : Pollfd) return Event_Set is
+ (Input => (Item.REvents and To_C (Input)) /= 0,
+ Output => (Item.REvents and To_C (Output)) /= 0,
+ Error => (Item.REvents and SOC.POLLERR) /= 0,
+ Hang_Up => (Item.REvents and SOC.POLLHUP) /= 0,
+ Invalid_Request => (Item.REvents and SOC.POLLNVAL) /= 0);
+ -- Get I/O events from C word
+
+ procedure Wait
+ (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer);
+ -- Waits until one or more of the sockets descriptors become ready for some
+ -- class of I/O operation or error state occurs on one or more of them.
+ -- Timeout is in milliseconds. Result mean how many sockets ready for I/O
+ -- or have error state.
+
+ ----------
+ -- Wait --
+ ----------
+
+ procedure Wait
+ (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer)
+ is separate;
+
+ ------------
+ -- Create --
+ ------------
+
+ function Create (Size : Positive) return Set is
+ begin
+ return Result : Set (Size);
+ end Create;
+
+ ------------
+ -- To_Set --
+ ------------
+
+ function To_Set
+ (Socket : Socket_Type;
+ Events : Wait_Event_Set;
+ Size : Positive := 1) return Set is
+ begin
+ return Result : Set (Size) do
+ Append (Result, Socket, Events);
+ end return;
+ end To_Set;
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append
+ (Self : in out Set; Socket : Socket_Type; Events : Wait_Event_Set) is
+ begin
+ Insert (Self, Socket, Events, Self.Length + 1);
+ end Append;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Self : in out Set;
+ Socket : Socket_Type;
+ Events : Wait_Event_Set;
+ Index : Positive;
+ Keep_Order : Boolean := False) is
+ begin
+ if Self.Size <= Self.Length then
+ raise Constraint_Error with "Socket set is full";
+
+ elsif Index > Self.Length + 1 then
+ raise Constraint_Error with "Insert out of range";
+ end if;
+
+ if Socket < 0 then
+ raise Socket_Error with
+ "Wrong socket descriptor " & Socket_Type'Image (Socket);
+ end if;
+
+ Self.Length := Self.Length + 1;
+
+ if Index /= Self.Length then
+ if Keep_Order then
+ Self.Fds (Index + 1 .. Self.Length) :=
+ Self.Fds (Index .. Self.Length - 1);
+ else
+ Self.Fds (Self.Length) := Self.Fds (Index);
+ end if;
+
+ Self.Fds (Index).Events := 0;
+ end if;
+
+ Self.Fds (Index).Socket := FD_Type (Socket);
+ Set_Mode (Self.Fds (Index), Events);
+
+ if FD_Type (Socket) > Self.Max_FD then
+ Self.Max_FD := FD_Type (Socket);
+ Self.Max_OK := True;
+ end if;
+ end Insert;
+
+ -----------------
+ -- Check_Range --
+ -----------------
+
+ procedure Check_Range (Self : Set; Index : Positive) is
+ begin
+ if Index > Self.Length then
+ raise Constraint_Error;
+ end if;
+ end Check_Range;
+
+ ----------
+ -- Copy --
+ ----------
+
+ procedure Copy (Source : Set; Target : out Set) is
+ begin
+ if Target.Size < Source.Length then
+ raise Constraint_Error with
+ "Can't copy because size of target less than source length";
+ end if;
+
+ Target.Fds (1 .. Source.Length) := Source.Fds (1 .. Source.Length);
+
+ Target.Length := Source.Length;
+ Target.Max_FD := Source.Max_FD;
+ Target.Max_OK := Source.Max_OK;
+ end Copy;
+
+ ----------------
+ -- Get_Events --
+ ----------------
+
+ function Get_Events
+ (Self : Set; Index : Positive) return Wait_Event_Set is
+ begin
+ Check_Range (Self, Index);
+ return
+ (Input => (Self.Fds (Index).Events and To_C (Input)) /= 0,
+ Output => (Self.Fds (Index).Events and To_C (Output)) /= 0);
+ end Get_Events;
+
+ ------------
+ -- Growth --
+ ------------
+
+ function Growth (Self : Set) return Set is
+ begin
+ return Resize
+ (Self,
+ (case Self.Size is
+ when 1 .. 20 => 32,
+ when 21 .. 50 => 64,
+ when 51 .. 99 => Self.Size + Self.Size / 3,
+ when others => Self.Size + Self.Size / 4));
+ end Growth;
+
+ ------------
+ -- Remove --
+ ------------
+
+ procedure Remove
+ (Self : in out Set; Index : Positive; Keep_Order : Boolean := False) is
+ begin
+ Check_Range (Self, Index);
+
+ if Self.Max_FD = Self.Fds (Index).Socket then
+ Self.Max_OK := False;
+ end if;
+
+ if Index < Self.Length then
+ if Keep_Order then
+ Self.Fds (Index .. Self.Length - 1) :=
+ Self.Fds (Index + 1 .. Self.Length);
+ else
+ Self.Fds (Index) := Self.Fds (Self.Length);
+ end if;
+ end if;
+
+ Self.Length := Self.Length - 1;
+ end Remove;
+
+ ------------
+ -- Resize --
+ ------------
+
+ function Resize (Self : Set; Size : Positive) return Set is
+ begin
+ return Result : Set (Size) do
+ Copy (Self, Result);
+ end return;
+ end Resize;
+
+ ---------------
+ -- Set_Event --
+ ---------------
+
+ procedure Set_Event
+ (Self : in out Set;
+ Index : Positive;
+ Event : Wait_Event_Type;
+ Value : Boolean) is
+ begin
+ Check_Range (Self, Index);
+ Set_Event (Self.Fds (Index), Event, Value);
+ end Set_Event;
+
+ procedure Set_Event
+ (Item : out Pollfd; Event : Wait_Event_Type; Value : Boolean) is
+ begin
+ if Value then
+ Item.Events := Item.Events or To_C (Event);
+ else
+ Item.Events := Item.Events and not To_C (Event);
+ end if;
+ end Set_Event;
+
+ ----------------
+ -- Set_Events --
+ ----------------
+
+ procedure Set_Events
+ (Self : in out Set;
+ Index : Positive;
+ Events : Wait_Event_Set) is
+ begin
+ Check_Range (Self, Index);
+ Set_Mode (Self.Fds (Index), Events);
+ end Set_Events;
+
+ --------------
+ -- Set_Mode --
+ --------------
+
+ procedure Set_Mode (Item : out Pollfd; Mode : Wait_Event_Set) is
+ begin
+ for J in Mode'Range loop
+ Set_Event (Item, J, Mode (J));
+ end loop;
+ end Set_Mode;
+
+ ------------
+ -- Socket --
+ ------------
+
+ function Socket (Self : Set; Index : Positive) return Socket_Type is
+ begin
+ Check_Range (Self, Index);
+ return Socket_Type (Self.Fds (Index).Socket);
+ end Socket;
+
+ -----------
+ -- State --
+ -----------
+
+ procedure State
+ (Self : Set;
+ Index : Positive;
+ Socket : out Socket_Type;
+ Status : out Event_Set) is
+ begin
+ Check_Range (Self, Index);
+ Socket := Socket_Type (Self.Fds (Index).Socket);
+ Status := Poll.Status (Self.Fds (Index));
+ end State;
+
+ ----------
+ -- Wait --
+ ----------
+
+ procedure Wait (Self : in out Set; Timeout : Duration; Count : out Natural)
+ is
+ use Ada.Calendar;
+ -- Used to calculate partially consumed timeout on EINTR.
+ -- Better to use Ada.Real_Time, but we can't in current GNAT because
+ -- Ada.Real_Time is in tasking part of runtime.
+
+ Result : Integer;
+ Poll_Timeout : Duration := Timeout;
+ C_Timeout : Interfaces.C.int;
+ Errno : Integer;
+ Stamp : constant Time := Clock;
+ begin
+ if Self.Length = 0 then
+ Count := 0;
+ return;
+ end if;
+
+ loop
+ if Poll_Timeout >= Duration (Interfaces.C.int'Last - 8) / 1_000 then
+ -- Minus 8 is to workaround Linux kernel 2.6.24 bug with close to
+ -- Integer'Last poll timeout values.
+ -- syscall (SYS_poll, &ufds, 1, 2147483644); // is waiting
+ -- syscall (SYS_poll, &ufds, 1, 2147483645); // is not waiting
+ -- Timeout values close to maximum could be not safe because of
+ -- possible time conversion boundary errors in the kernel.
+ -- Use unlimited timeout instead of maximum 24 days timeout for
+ -- safety reasons.
+
+ C_Timeout := -1;
+ else
+ C_Timeout := Interfaces.C.int (Poll_Timeout * 1_000);
+ end if;
+
+ Wait (Self, C_Timeout, Result);
+
+ exit when Result >= 0;
+
+ Errno := Thin.Socket_Errno;
+
+ -- In case of EINTR error we have to continue waiting for network
+ -- events.
+
+ if Errno = SOC.EINTR then
+ if C_Timeout >= 0 then
+ Poll_Timeout := Timeout - (Clock - Stamp);
+
+ if Poll_Timeout < 0.0 then
+ Count := 0;
+ return;
+
+ elsif Poll_Timeout > Timeout then
+ -- Clock moved back in time. This should not be happen when
+ -- we use monotonic time.
+
+ Poll_Timeout := Timeout;
+ end if;
+ end if;
+
+ else
+ Raise_Socket_Error (Errno);
+ end if;
+ end loop;
+
+ Count := Result;
+ end Wait;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next (Self : Set; Index : in out Natural) is
+ begin
+ loop
+ Index := Index + 1;
+
+ if Index > Self.Length then
+ Index := 0;
+ return;
+
+ elsif Self.Fds (Index).REvents /= 0 then
+ return;
+ end if;
+ end loop;
+ end Next;
+
+ ------------
+ -- Status --
+ ------------
+
+ function Status (Self : Set; Index : Positive) return Event_Set is
+ begin
+ Check_Range (Self, Index);
+ return Status (Self.Fds (Index));
+ end Status;
+
+ --------------
+ -- C_Status --
+ --------------
+
+ function C_Status
+ (Self : Set; Index : Positive) return Interfaces.C.unsigned is
+ begin
+ Check_Range (Self, Index);
+ return Interfaces.C.unsigned (Self.Fds (Index).REvents);
+ end C_Status;
+
+end GNAT.Sockets.Poll;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . P O L L --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, 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 3, 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides an interface to wait for one of a set of sockets to
+-- become ready to perform I/O.
+
+with System.OS_Constants;
+
+package GNAT.Sockets.Poll is
+
+ type Event_Type is (Input, Output, Error, Hang_Up, Invalid_Request);
+ -- I/O events we can expect on socket.
+ -- Input - socket ready to read;
+ -- Output - socket available for write;
+ -- Error - socket is in error state;
+ -- Hang_Up - peer closed;
+ -- Invalid_Request - invalid socket;
+
+ type Event_Set is array (Event_Type) of Boolean;
+ -- The type to get results on events waiting
+
+ subtype Wait_Event_Type is Event_Type range Input .. Output;
+ type Wait_Event_Set is array (Wait_Event_Type) of Boolean;
+ -- The type to set events to wait. Note that Error event would be waited
+ -- anyway.
+
+ -------------------------------
+ -- Predefined set of events --
+ -------------------------------
+
+ Input_Event : constant Wait_Event_Set;
+ -- Wait for input availability only
+
+ Output_Event : constant Wait_Event_Set;
+ -- Wait for output availability only
+
+ Both_Events : constant Wait_Event_Set;
+ -- Wait for Input and Output availability
+
+ Error_Event : constant Wait_Event_Set;
+ -- Wait only for error state on socket
+
+ type Set (Size : Positive) is private;
+ -- Set of sockets with I/O event set to wait on
+
+ function Create (Size : Positive) return Set;
+ -- Create empty socket set with defined size
+
+ function To_Set
+ (Socket : Socket_Type;
+ Events : Wait_Event_Set;
+ Size : Positive := 1) return Set;
+ -- Create socket set and put the Socket there at the first place.
+ -- Events parameter is defining what state of the socket we are going to
+ -- wait.
+
+ procedure Append
+ (Self : in out Set;
+ Socket : Socket_Type;
+ Events : Wait_Event_Set);
+ -- Add Socket and its I/O waiting state at the end of Self
+
+ procedure Insert
+ (Self : in out Set;
+ Socket : Socket_Type;
+ Events : Wait_Event_Set;
+ Index : Positive;
+ Keep_Order : Boolean := False);
+ -- Insert Socket and its I/O waiting state at the Index position.
+ -- If Keep_Order is True then all next elements moved to the next index up.
+ -- Otherwise the old element from Index moved to the end of the Self set.
+
+ procedure Remove
+ (Self : in out Set; Index : Positive; Keep_Order : Boolean := False);
+ -- Remove socket from Index. If Keep_Order is True then move all next
+ -- elements after removed one to previous index. If Keep_Order is False
+ -- then move the last element on place of the removed one.
+
+ procedure Set_Event
+ (Self : in out Set;
+ Index : Positive;
+ Event : Wait_Event_Type;
+ Value : Boolean);
+ -- Set I/O waiting event to Value for the socket at Index position
+
+ procedure Set_Events
+ (Self : in out Set;
+ Index : Positive;
+ Events : Wait_Event_Set);
+ -- Set I/O waiting events for the socket at Index position
+
+ function Get_Events
+ (Self : Set; Index : Positive) return Wait_Event_Set;
+ -- Get I/O waiting events for the socket at Index position
+
+ function Length (Self : Set) return Natural;
+ -- Get the number of sockets currently in the Self set
+
+ function Full (Self : Set) return Boolean;
+ -- Return True if there is no more space in the Self set for new sockets
+
+ procedure Wait (Self : in out Set; Timeout : Duration; Count : out Natural);
+ -- Wait no longer than Timeout on the socket set for the I/O events.
+ -- Count output parameter is the number of elements in the Self set are
+ -- detected for I/O events. Zero Count mean timeout on wait.
+ -- The iteration over activated elements in set could be done with routine
+ -- Next. The kind of I/O events on element could be cheched with State or
+ -- Status routines.
+
+ procedure Next (Self : Set; Index : in out Natural);
+ -- Iterate over set looking for the next index with active I/O event state.
+ -- Put 0 initially into Index. Each iteration increments Index and then
+ -- checks for state. End of iterations can be detected by 0 in the Index.
+
+ procedure Copy (Source : Set; Target : out Set);
+ -- Copy sockets and its I/O waiting events from Source set into Target
+
+ function Resize (Self : Set; Size : Positive) return Set;
+ -- Returns the copy of Source with modified Size
+
+ function Growth (Self : Set) return Set;
+ -- Returns the copy of Source with increased Size
+
+ function Socket (Self : Set; Index : Positive) return Socket_Type;
+ -- Returns the Socket from Index position
+
+ function Status (Self : Set; Index : Positive) return Event_Set;
+ -- Returns I/O events detected in previous Wait call at Index position
+
+ procedure State
+ (Self : Set;
+ Index : Positive;
+ Socket : out Socket_Type;
+ Status : out Event_Set);
+ -- Returns Socket and its I/O events detected in previous Wait call at
+ -- Index position.
+
+ function C_Status
+ (Self : Set; Index : Positive) return Interfaces.C.unsigned;
+ -- Return word with I/O events detected flags in previous Wait call at
+ -- Index position. Possible flags are defined in System.OS_Constants names
+ -- starting with POLL prefix.
+
+private
+
+ Input_Event : constant Wait_Event_Set := (Input => True, Output => False);
+ Output_Event : constant Wait_Event_Set := (Input => False, Output => True);
+ Both_Events : constant Wait_Event_Set := (others => True);
+ Error_Event : constant Wait_Event_Set := (others => False);
+
+ package SOC renames System.OS_Constants;
+
+ type nfds_t is mod 2 ** SOC.SIZEOF_nfds_t;
+ for nfds_t'Size use SOC.SIZEOF_nfds_t;
+
+ FD_Type_Bound : constant := 2 ** (SOC.SIZEOF_fd_type - 1);
+
+ type FD_Type is range -FD_Type_Bound .. FD_Type_Bound - 1;
+ for FD_Type'Size use SOC.SIZEOF_fd_type;
+
+ type Events_Type is mod 2 ** SOC.SIZEOF_pollfd_events;
+ for Events_Type'Size use SOC.SIZEOF_pollfd_events;
+
+ type Pollfd is record
+ Socket : FD_Type;
+ Events : Events_Type := 0;
+ REvents : Events_Type := 0;
+ end record with Convention => C;
+
+ type Poll_Set is array (Positive range <>) of Pollfd with Convention => C;
+
+ type Set (Size : Positive) is record
+ Length : Natural := 0;
+ Max_FD : FD_Type := 0;
+ Max_OK : Boolean;
+ -- Is the Max_FD actual. It can became inactual after remove socket with
+ -- Max_FD from set and became actual again after add socket with FD more
+ -- than Max_FD.
+ Fds : Poll_Set (1 .. Size);
+ end record;
+
+ function Length (Self : Set) return Natural
+ is (Self.Length);
+
+ function Full (Self : Set) return Boolean
+ is (Self.Size = Self.Length);
+
+end GNAT.Sockets.Poll;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . P O L L --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, 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 3, 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+pragma No_Body;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . P O L L --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, 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 3, 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package is a placeholder for the sockets binding for platforms where
+-- it is not implemented.
+
+package GNAT.Sockets.Thin_Common is
+ pragma Unimplemented_Unit;
+end GNAT.Sockets.Thin_Common;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . P O L L . W A I T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, 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 3, 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Wait implementation on top of native poll call
+--
+-- This submodule can be used on systems where poll system call is natively
+-- supported. Microsoft Windows supports WSAPoll system call from Vista
+-- version and this submodule can be used on such Windows versions too, the
+-- System.OS_Constants.Poll_Linkname constant defines appropriate link name
+-- for Windows. But we do not use WSAPoll in GNAT.Sockets.Poll implementation
+-- for now because it is much slower than select system call, at least in
+-- Windows version 10.0.18363.1016.
+
+separate (GNAT.Sockets.Poll)
+
+procedure Wait
+ (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer)
+is
+
+ function Poll
+ (Fds : Poll_Set;
+ Nfds : nfds_t;
+ Timeout : Interfaces.C.int) return Integer
+ with Import, Convention => Stdcall, External_Name => SOC.Poll_Linkname;
+
+begin
+ Result := Poll (Fds.Fds, nfds_t (Fds.Length), Timeout);
+end Wait;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . P O L L . W A I T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, 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 3, 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Wait implementation on top of Windows select call
+--
+-- Microsoft Windows from Vista version has WSAPoll function in API which is
+-- similar to POSIX poll call, but experiments show that the WSAPoll is much
+-- slower than select at least in Windows version 10.0.18363.1016.
+
+with GNAT.Sockets.Poll.G_Wait;
+
+separate (GNAT.Sockets.Poll)
+
+procedure Wait
+ (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer)
+is
+ use Interfaces;
+
+ type FD_Array is array (1 .. Fds.Length) of FD_Type
+ with Convention => C;
+
+ type FD_Set_Type is record
+ Count : C.int;
+ Set : FD_Array;
+ end record with Convention => C;
+
+ procedure Reset_Socket_Set (Set : in out FD_Set_Type) with Inline;
+
+ procedure Insert_Socket_In_Set (Set : in out FD_Set_Type; FD : FD_Type)
+ with Inline;
+
+ function Is_Socket_In_Set (Set : FD_Set_Type; FD : FD_Type) return C.int
+ with Import, Convention => C,
+ External_Name => "__gnat_is_socket_in_set";
+
+ --------------------------
+ -- Insert_Socket_In_Set --
+ --------------------------
+
+ procedure Insert_Socket_In_Set (Set : in out FD_Set_Type; FD : FD_Type) is
+ begin
+ Set.Count := Set.Count + 1;
+ Set.Set (Integer (Set.Count)) := FD;
+ end Insert_Socket_In_Set;
+
+ ----------------------
+ -- Reset_Socket_Set --
+ ----------------------
+
+ procedure Reset_Socket_Set (Set : in out FD_Set_Type) is
+ begin
+ Set.Count := 0;
+ end Reset_Socket_Set;
+
+ ----------
+ -- Poll --
+ ----------
+
+ procedure Poll is new G_Wait
+ (FD_Set_Type, Reset_Socket_Set, Insert_Socket_In_Set, Is_Socket_In_Set);
+
+begin
+ Poll (Fds, Timeout, Result);
+end Wait;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . P O L L . W A I T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, 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 3, 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Wait implementation on top of posix select call
+
+with GNAT.Sockets.Poll.G_Wait;
+
+separate (GNAT.Sockets.Poll)
+
+procedure Wait
+ (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer)
+is
+ use Interfaces;
+
+ function Get_Max_FD return FD_Type;
+ -- Check is Max_FD is actual and correct it if necessary
+
+ type FD_Set_Type is array (0 .. Get_Max_FD / C.long'Size) of C.long
+ with Convention => C;
+
+ procedure Reset_Socket_Set (Set : in out FD_Set_Type);
+ -- Use own FD_ZERO routine because FD_Set_Type size depend on Fds.Max_FD
+
+ procedure Insert_Socket_In_Set (Set : in out FD_Set_Type; FD : FD_Type)
+ with Import, Convention => C,
+ External_Name => "__gnat_insert_socket_in_set";
+
+ function Is_Socket_In_Set (Set : FD_Set_Type; FD : FD_Type) return C.int
+ with Import, Convention => C,
+ External_Name => "__gnat_is_socket_in_set";
+
+ procedure Reset_Socket_Set (Set : in out FD_Set_Type) is
+ begin
+ Set := (others => 0);
+ end Reset_Socket_Set;
+
+ procedure Poll is new G_Wait
+ (FD_Set_Type, Reset_Socket_Set, Insert_Socket_In_Set, Is_Socket_In_Set);
+
+ ----------------
+ -- Get_Max_FD --
+ ----------------
+
+ function Get_Max_FD return FD_Type is
+ begin
+ if not Fds.Max_OK then
+ Fds.Max_FD := Fds.Fds (Fds.Fds'First).Socket;
+
+ for J in Fds.Fds'First + 1 .. Fds.Length loop
+ if Fds.Max_FD < Fds.Fds (J).Socket then
+ Fds.Max_FD := Fds.Fds (J).Socket;
+ end if;
+ end loop;
+
+ Fds.Max_OK := True;
+ end if;
+
+ return Fds.Max_FD;
+ end Get_Max_FD;
+
+begin
+ Poll (Fds, Timeout, Result);
+end Wait;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . P O L L . G _ W A I T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2020, 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 3, 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with GNAT.Sockets.Thin_Common;
+
+procedure GNAT.Sockets.Poll.G_Wait
+ (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer)
+is
+ use Interfaces;
+
+ use type C.int;
+
+ function C_Select
+ (Nfds : C.int;
+ readfds : access FD_Set_Type;
+ writefds : access FD_Set_Type;
+ exceptfds : access FD_Set_Type;
+ timeout : access Thin_Common.Timeval) return Integer
+ with Import => True, Convention => Stdcall, External_Name => "select";
+
+ Timeout_V : aliased Thin_Common.Timeval;
+ Timeout_A : access Thin_Common.Timeval;
+
+ Rfds : aliased FD_Set_Type;
+ Rcount : Natural := 0;
+ Wfds : aliased FD_Set_Type;
+ Wcount : Natural := 0;
+ Efds : aliased FD_Set_Type;
+
+ Rfdsa : access FD_Set_Type;
+ Wfdsa : access FD_Set_Type;
+
+ FD_Events : Events_Type;
+
+begin
+ -- Setup (convert data from poll to select layout)
+
+ if Timeout >= 0 then
+ Timeout_A := Timeout_V'Access;
+ Timeout_V.tv_sec := Thin_Common.time_t (Timeout / 1000);
+ Timeout_V.tv_usec := Thin_Common.suseconds_t (Timeout rem 1000 * 1000);
+ end if;
+
+ Reset_Socket_Set (Rfds);
+ Reset_Socket_Set (Wfds);
+ Reset_Socket_Set (Efds);
+
+ for J in Fds.Fds'First .. Fds.Length loop
+ Fds.Fds (J).REvents := 0;
+
+ FD_Events := Fds.Fds (J).Events;
+
+ if (FD_Events and (SOC.POLLIN or SOC.POLLPRI)) /= 0 then
+ Insert_Socket_In_Set (Rfds, Fds.Fds (J).Socket);
+ Rcount := Rcount + 1;
+ end if;
+
+ if (FD_Events and SOC.POLLOUT) /= 0 then
+ Insert_Socket_In_Set (Wfds, Fds.Fds (J).Socket);
+ Wcount := Wcount + 1;
+ end if;
+
+ Insert_Socket_In_Set (Efds, Fds.Fds (J).Socket);
+
+ if Fds.Fds (J).Socket > Fds.Max_FD then
+ raise Program_Error with "Wrong Max_FD";
+ end if;
+ end loop;
+
+ -- Any non-null descriptor set must contain at least one handle
+ -- to a socket on Windows (MSDN).
+
+ if Rcount /= 0 then
+ Rfdsa := Rfds'Access;
+ end if;
+
+ if Wcount /= 0 then
+ Wfdsa := Wfds'Access;
+ end if;
+
+ -- Call OS select
+
+ Result :=
+ C_Select (C.int (Fds.Max_FD + 1), Rfdsa, Wfdsa, Efds'Access, Timeout_A);
+
+ -- Build result (convert back from select to poll layout)
+
+ if Result > 0 then
+ Result := 0;
+
+ for J in Fds.Fds'First .. Fds.Length loop
+ if Is_Socket_In_Set (Rfds, Fds.Fds (J).Socket) /= 0 then
+ -- Do not need "or" with Poll_Ptr (J).REvents because it's zero
+
+ Fds.Fds (J).REvents := SOC.POLLIN;
+ end if;
+
+ if Is_Socket_In_Set (Wfds, Fds.Fds (J).Socket) /= 0 then
+ Fds.Fds (J).REvents := Fds.Fds (J).REvents or SOC.POLLOUT;
+ end if;
+
+ if Is_Socket_In_Set (Efds, Fds.Fds (J).Socket) /= 0 then
+ Fds.Fds (J).REvents := Fds.Fds (J).REvents or SOC.POLLERR;
+ end if;
+
+ if Fds.Fds (J).REvents /= 0 then
+ Result := Result + 1;
+ end if;
+ end loop;
+ end if;
+end GNAT.Sockets.Poll.G_Wait;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . P O L L . G _ W A I T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2020, 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 3, 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces.C;
+
+private generic
+ type FD_Set_Type is private;
+ with procedure Reset_Socket_Set (Set : in out FD_Set_Type);
+ with procedure Insert_Socket_In_Set
+ (Set : in out FD_Set_Type; FD : FD_Type);
+ with function Is_Socket_In_Set
+ (Set : FD_Set_Type; FD : FD_Type) return Interfaces.C.int;
+procedure GNAT.Sockets.Poll.G_Wait
+ (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer);
+-- Common code to implement GNAT.Sockets.Poll.Wait routine on top of posix or
+-- win32 select API.
+-- Posix and Win32 select has the same API but different socket set structure.
+-- C API for select has socket set size defined at compilation stage. This Ada
+-- implementation allow to define size of socket set at the execution time.
+-- Unlike C select API we do not need allocate socket set for maximum number
+-- of sockets when we need to check only few of them. And we are not limited
+-- with FD_SETSIZE when we need more sockets to check.
/* Define _BSD_SOURCE to get CRTSCTS */
# define _BSD_SOURCE
-#endif /* defined (__linux__) */
+#endif /* defined (__linux__) || defined (__ANDROID__) */
/* Include gsocket.h before any system header so it can redefine FD_SETSIZE */
**/
# include <vxWorks.h>
+#elif !defined(__MINGW32__)
+#include <poll.h>
#endif
#include "adaint.h"
#endif
#if defined(_WIN32) || defined(__vxworks)
+#define SIZEOF_nfds_t sizeof (int) * 8
#define SIZEOF_socklen_t sizeof (size_t)
#else
+#define SIZEOF_nfds_t sizeof (nfds_t) * 8
#define SIZEOF_socklen_t sizeof (socklen_t)
#endif
+CND(SIZEOF_nfds_t, "Size of nfds_t");
CND(SIZEOF_socklen_t, "Size of socklen_t");
+{
+#if defined(__vxworks)
+#define SIZEOF_fd_type sizeof (int) * 8
+#define SIZEOF_pollfd_events sizeof (short) * 8
+#else
+const struct pollfd v_pollfd;
+#define SIZEOF_fd_type sizeof (v_pollfd.fd) * 8
+#define SIZEOF_pollfd_events sizeof (v_pollfd.events) * 8
+#endif
+CND(SIZEOF_fd_type, "Size of socket fd");
+CND(SIZEOF_pollfd_events, "Size of pollfd.events");
+}
+
#ifndef IF_NAMESIZE
#ifdef IF_MAX_STRING_SIZE
#define IF_NAMESIZE IF_MAX_STRING_SIZE
#endif
CND(IF_NAMESIZE, "Max size of interface name with 0 terminator");
+/*
+
+ -- Poll values
+
+*/
+
+#if defined(__vxworks)
+#ifndef POLLIN
+#define POLLIN 1
+#endif
+
+#ifndef POLLPRI
+#define POLLPRI 2
+#endif
+
+#ifndef POLLOUT
+#define POLLOUT 4
+#endif
+
+#ifndef POLLERR
+#define POLLERR 8
+#endif
+
+#ifndef POLLHUP
+#define POLLHUP 16
+#endif
+
+#ifndef POLLNVAL
+#define POLLNVAL 32
+#endif
+
+#elif defined(_WIN32)
+#define POLLPRI 0
+/* If the POLLPRI flag is set on a socket for the Microsoft Winsock provider,
+ * the WSAPoll function will fail. */
+#endif
+
+CND(POLLIN, "There is data to read");
+CND(POLLPRI, "Urgent data to read");
+CND(POLLOUT, "Writing will not block");
+CND(POLLERR, "Error (output only)");
+CND(POLLHUP, "Hang up (output only)");
+CND(POLLNVAL, "Invalid request");
+
/*
-- Fields of struct msghdr
#endif
CST(Inet_Ntop_Linkname, "")
+#if defined(_WIN32)
+# define Poll_Linkname "WSAPoll"
+#else
+# define Poll_Linkname "poll"
+#endif
+CST(Poll_Linkname, "")
+
#endif /* HAVE_SOCKETS */
/*
projects / gcc.git / commitdiff