gcc/ada/libgnat/g-spogwa.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --             G N A T . S O C K E T S . P O L L . G _ W A I T              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                       Copyright (C) 2020-2024, AdaCore                   --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with GNAT.Sockets.Thin_Common;
  33
  34 procedure GNAT.Sockets.Poll.G_Wait
  35   (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer)
  36 is
  37    use Interfaces;
  38
  39    function C_Select
  40      (Nfds      : C.int;
  41       readfds   : access FD_Set_Type;
  42       writefds  : access FD_Set_Type;
  43       exceptfds : access FD_Set_Type;
  44       timeout   : access Thin_Common.Timeval) return Integer
  45      with Import => True, Convention => Stdcall, External_Name => "select";
  46
  47    Timeout_V : aliased Thin_Common.Timeval;
  48    Timeout_A : access Thin_Common.Timeval;
  49
  50    Rfds      : aliased FD_Set_Type;
  51    Rcount    : Natural := 0;
  52    Wfds      : aliased FD_Set_Type;
  53    Wcount    : Natural := 0;
  54    Efds      : aliased FD_Set_Type;
  55
  56    Rfdsa     : access FD_Set_Type;
  57    Wfdsa     : access FD_Set_Type;
  58
  59    FD_Events : Events_Type;
  60
  61 begin
  62    --  Setup (convert data from poll to select layout)
  63
  64    if Timeout >= 0 then
  65       Timeout_A := Timeout_V'Access;
  66       Timeout_V.Tv_Sec  := Thin_Common.time_t  (Timeout / 1000);
  67       Timeout_V.Tv_Usec := Thin_Common.suseconds_t (Timeout rem 1000 * 1000);
  68    end if;
  69
  70    Reset_Socket_Set (Rfds);
  71    Reset_Socket_Set (Wfds);
  72    Reset_Socket_Set (Efds);
  73
  74    for J in Fds.Fds'First .. Fds.Length loop
  75       Fds.Fds (J).REvents := 0;
  76
  77       FD_Events := Fds.Fds (J).Events;
  78
  79       if (FD_Events and (SOC.POLLIN or SOC.POLLPRI)) /= 0 then
  80          Insert_Socket_In_Set (Rfds, Fds.Fds (J).Socket);
  81          Rcount := Rcount + 1;
  82       end if;
  83
  84       if (FD_Events and SOC.POLLOUT) /= 0 then
  85          Insert_Socket_In_Set (Wfds, Fds.Fds (J).Socket);
  86          Wcount := Wcount + 1;
  87       end if;
  88
  89       Insert_Socket_In_Set (Efds, Fds.Fds (J).Socket);
  90
  91       if Fds.Fds (J).Socket > Fds.Max_FD then
  92          raise Program_Error with "Wrong Max_FD";
  93       end if;
  94    end loop;
  95
  96    --  Any non-null descriptor set must contain at least one handle
  97    --  to a socket on Windows (MSDN).
  98
  99    if Rcount /= 0 then
 100       Rfdsa := Rfds'Access;
 101    end if;
 102
 103    if Wcount /= 0 then
 104       Wfdsa := Wfds'Access;
 105    end if;
 106
 107    --  Call OS select
 108
 109    Result :=
 110      C_Select (C.int (Fds.Max_FD + 1), Rfdsa, Wfdsa, Efds'Access, Timeout_A);
 111
 112    --  Build result (convert back from select to poll layout)
 113
 114    if Result > 0 then
 115       Result := 0;
 116
 117       for J in Fds.Fds'First .. Fds.Length loop
 118          if Is_Socket_In_Set (Rfds, Fds.Fds (J).Socket) /= 0 then
 119             --  Do not need "or" with Poll_Ptr (J).REvents because it's zero
 120
 121             Fds.Fds (J).REvents := SOC.POLLIN;
 122          end if;
 123
 124          if Is_Socket_In_Set (Wfds, Fds.Fds (J).Socket) /= 0 then
 125             Fds.Fds (J).REvents := Fds.Fds (J).REvents or SOC.POLLOUT;
 126          end if;
 127
 128          if Is_Socket_In_Set (Efds, Fds.Fds (J).Socket) /= 0 then
 129             Fds.Fds (J).REvents := Fds.Fds (J).REvents or SOC.POLLERR;
 130          end if;
 131
 132          if Fds.Fds (J).REvents /= 0 then
 133             Result := Result + 1;
 134          end if;
 135       end loop;
 136    end if;
 137 end GNAT.Sockets.Poll.G_Wait;