gcc/ada/libgnat/s-optide.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --     S Y S T E M . O S _ P R I M I T I V E S. T I M E D _ D E L A Y       --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 2012-2018, 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 --  This is the Posix, Posix2008, and LynxOS version of this procedure.
  33
  34 separate (System.OS_Primitives)
  35 procedure Timed_Delay
  36   (Time : Duration;
  37    Mode : Integer)
  38 is
  39    Request    : aliased timespec;
  40    Remaind    : aliased timespec;
  41    Rel_Time   : Duration;
  42    Abs_Time   : Duration;
  43    Base_Time  : constant Duration := Clock;
  44    Check_Time : Duration := Base_Time;
  45    Time_Chunk : Duration;
  46
  47    Result : Integer;
  48    pragma Unreferenced (Result);
  49
  50 begin
  51    if Mode = Relative then
  52       Rel_Time := Time;
  53       Abs_Time := Time + Check_Time;
  54    else
  55       Rel_Time := Time - Check_Time;
  56       Abs_Time := Time;
  57    end if;
  58
  59    --  To keep a sensible Max_Sensible_Delay on a target whose system
  60    --  maximum is less than sensible, we split the delay into manageable
  61    --  chunks of time less than or equal to the Max_System_Delay.
  62
  63    if Rel_Time > 0.0 then
  64       Time_Chunk := Rel_Time;
  65       loop
  66          pragma Warnings (Off, "condition is always *");
  67          if Max_System_Delay < Max_Sensible_Delay and then
  68             Time_Chunk > Max_System_Delay
  69          then
  70             Time_Chunk := Max_System_Delay;
  71          end if;
  72          pragma Warnings (On);
  73
  74          Request := To_Timespec (Time_Chunk);
  75          Result := nanosleep (Request'Access, Remaind'Access);
  76
  77          Check_Time := Clock;
  78
  79          exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
  80
  81          Time_Chunk := Abs_Time - Check_Time;
  82       end loop;
  83    end if;
  84 end Timed_Delay;