gcc/ada/a-reatim.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
   4 --                                                                          --
   5 --                         A D A . R E A L _ T I M E                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 1991-1994, Florida State University            --
  10 --                     Copyright (C) 1995-2015, AdaCore                     --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  18 --                                                                          --
  19 -- As a special exception under Section 7 of GPL version 3, you are granted --
  20 -- additional permissions described in the GCC Runtime Library Exception,   --
  21 -- version 3.1, as published by the Free Software Foundation.               --
  22 --                                                                          --
  23 -- You should have received a copy of the GNU General Public License and    --
  24 -- a copy of the GCC Runtime Library Exception along with this program;     --
  25 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  26 -- <http://www.gnu.org/licenses/>.                                          --
  27 --                                                                          --
  28 -- GNARL was developed by the GNARL team at Florida State University.       --
  29 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  30 --                                                                          --
  31 ------------------------------------------------------------------------------
  32
  33 with System.Tasking;
  34
  35 package body Ada.Real_Time is
  36
  37    ---------
  38    -- "*" --
  39    ---------
  40
  41    --  Note that Constraint_Error may be propagated
  42
  43    function "*" (Left : Time_Span; Right : Integer) return Time_Span is
  44       pragma Unsuppress (Overflow_Check);
  45    begin
  46       return Time_Span (Duration (Left) * Right);
  47    end "*";
  48
  49    function "*" (Left : Integer; Right : Time_Span) return Time_Span is
  50       pragma Unsuppress (Overflow_Check);
  51    begin
  52       return Time_Span (Left * Duration (Right));
  53    end "*";
  54
  55    ---------
  56    -- "+" --
  57    ---------
  58
  59    --  Note that Constraint_Error may be propagated
  60
  61    function "+" (Left : Time; Right : Time_Span) return Time is
  62       pragma Unsuppress (Overflow_Check);
  63    begin
  64       return Time (Duration (Left) + Duration (Right));
  65    end "+";
  66
  67    function "+" (Left : Time_Span; Right : Time) return Time is
  68       pragma Unsuppress (Overflow_Check);
  69    begin
  70       return Time (Duration (Left) + Duration (Right));
  71    end "+";
  72
  73    function "+" (Left, Right : Time_Span) return Time_Span is
  74       pragma Unsuppress (Overflow_Check);
  75    begin
  76       return Time_Span (Duration (Left) + Duration (Right));
  77    end "+";
  78
  79    ---------
  80    -- "-" --
  81    ---------
  82
  83    --  Note that Constraint_Error may be propagated
  84
  85    function "-" (Left : Time; Right : Time_Span) return Time is
  86       pragma Unsuppress (Overflow_Check);
  87    begin
  88       return Time (Duration (Left) - Duration (Right));
  89    end "-";
  90
  91    function "-" (Left, Right : Time) return Time_Span is
  92       pragma Unsuppress (Overflow_Check);
  93    begin
  94       return Time_Span (Duration (Left) - Duration (Right));
  95    end "-";
  96
  97    function "-" (Left, Right : Time_Span) return Time_Span is
  98       pragma Unsuppress (Overflow_Check);
  99    begin
 100       return Time_Span (Duration (Left) - Duration (Right));
 101    end "-";
 102
 103    function "-" (Right : Time_Span) return Time_Span is
 104       pragma Unsuppress (Overflow_Check);
 105    begin
 106       return Time_Span_Zero - Right;
 107    end "-";
 108
 109    ---------
 110    -- "/" --
 111    ---------
 112
 113    --  Note that Constraint_Error may be propagated
 114
 115    function "/" (Left, Right : Time_Span) return Integer is
 116       pragma Unsuppress (Overflow_Check);
 117       pragma Unsuppress (Division_Check);
 118    begin
 119       return Integer (Duration (Left) / Duration (Right));
 120    end "/";
 121
 122    function "/" (Left : Time_Span; Right : Integer) return Time_Span is
 123       pragma Unsuppress (Overflow_Check);
 124       pragma Unsuppress (Division_Check);
 125    begin
 126       --  Even though checks are unsuppressed, we need an explicit check for
 127       --  the case of largest negative integer divided by minus one, since
 128       --  some library routines we use fail to catch this case. This will be
 129       --  fixed at the compiler level in the future, at which point this test
 130       --  can be removed.
 131
 132       if Left = Time_Span_First and then Right = -1 then
 133          raise Constraint_Error with "overflow";
 134       end if;
 135
 136       return Time_Span (Duration (Left) / Right);
 137    end "/";
 138
 139    -----------
 140    -- Clock --
 141    -----------
 142
 143    function Clock return Time is
 144    begin
 145       return Time (System.Task_Primitives.Operations.Monotonic_Clock);
 146    end Clock;
 147
 148    ------------------
 149    -- Microseconds --
 150    ------------------
 151
 152    function Microseconds (US : Integer) return Time_Span is
 153    begin
 154       return Time_Span_Unit * US * 1_000;
 155    end Microseconds;
 156
 157    ------------------
 158    -- Milliseconds --
 159    ------------------
 160
 161    function Milliseconds (MS : Integer) return Time_Span is
 162    begin
 163       return Time_Span_Unit * MS * 1_000_000;
 164    end Milliseconds;
 165
 166    -------------
 167    -- Minutes --
 168    -------------
 169
 170    function Minutes (M : Integer) return Time_Span is
 171    begin
 172       return Milliseconds (M) * Integer'(60_000);
 173    end Minutes;
 174
 175    -----------------
 176    -- Nanoseconds --
 177    -----------------
 178
 179    function Nanoseconds (NS : Integer) return Time_Span is
 180    begin
 181       return Time_Span_Unit * NS;
 182    end Nanoseconds;
 183
 184    -------------
 185    -- Seconds --
 186    -------------
 187
 188    function Seconds (S : Integer) return Time_Span is
 189    begin
 190       return Milliseconds (S) * Integer'(1000);
 191    end Seconds;
 192
 193    -----------
 194    -- Split --
 195    -----------
 196
 197    procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is
 198       T_Val : Time;
 199
 200    begin
 201       --  Special-case for Time_First, whose absolute value is anomalous,
 202       --  courtesy of two's complement.
 203
 204       T_Val := (if T = Time_First then abs (Time_Last) else abs (T));
 205
 206       --  Extract the integer part of T, truncating towards zero
 207
 208       SC :=
 209         (if T_Val < 0.5 then 0 else Seconds_Count (Time_Span'(T_Val - 0.5)));
 210
 211       if T < 0.0 then
 212          SC := -SC;
 213       end if;
 214
 215       --  If original time is negative, need to truncate towards negative
 216       --  infinity, to make TS non-negative, as per ARM.
 217
 218       if Time (SC) > T then
 219          SC := SC - 1;
 220       end if;
 221
 222       TS := Time_Span (Duration (T) - Duration (SC));
 223    end Split;
 224
 225    -------------
 226    -- Time_Of --
 227    -------------
 228
 229    function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is
 230    begin
 231       --  Simple case first, TS = 0.0, we need to make sure SC is in range
 232
 233       if TS = 0.0 then
 234          if SC >= Seconds_Count (Duration (Time_Span_First) + Duration'(0.5))
 235                and then
 236             SC <= Seconds_Count (Duration (Time_Span_Last)  - Duration'(0.5))
 237          then
 238             --  Don't need any further checks after that manual check
 239
 240             declare
 241                pragma Suppress (All_Checks);
 242             begin
 243                return Time (SC);
 244             end;
 245
 246          --  Here we have a Seconds_Count value that is out of range
 247
 248          else
 249             raise Constraint_Error;
 250          end if;
 251       end if;
 252
 253       --  We want to return Time (SC) + TS. To avoid spurious overflows in
 254       --  the intermediate result Time (SC) we take advantage of the different
 255       --  signs in SC and TS (when that is the case).
 256
 257       --  If the signs of SC and TS are different then we avoid converting SC
 258       --  to Time (as we do in the else part). The reason for that is that SC
 259       --  converted to Time may overflow the range of Time, while the addition
 260       --  of SC plus TS does not overflow (because of their different signs).
 261       --  The approach is to add and remove the greatest value of time
 262       --  (greatest absolute value) to both SC and TS. SC and TS have different
 263       --  signs, so we add the positive constant to the negative value, and the
 264       --  negative constant to the positive value, to prevent overflows.
 265
 266       if (SC > 0 and then TS < 0.0) or else (SC < 0 and then TS > 0.0) then
 267          declare
 268             Closest_Boundary : constant Seconds_Count :=
 269               (if TS >= 0.0 then
 270                   Seconds_Count (Time_Span_Last  - Time_Span (0.5))
 271                else
 272                   Seconds_Count (Time_Span_First + Time_Span (0.5)));
 273             --  Value representing the integer part of the Time_Span boundary
 274             --  closest to TS (its number of seconds). Truncate towards zero
 275             --  to be sure that transforming this value back into Time cannot
 276             --  overflow (when SC is equal to 0). The sign of Closest_Boundary
 277             --  is always different from the sign of SC, hence avoiding
 278             --  overflow in the expression Time (SC + Closest_Boundary)
 279             --  which is part of the return statement.
 280
 281             Dist_To_Boundary : constant Time_Span :=
 282               TS - Time_Span (Closest_Boundary);
 283             --  Distance between TS and Closest_Boundary expressed in Time_Span
 284             --  Both operands in the subtraction have the same sign, hence
 285             --  avoiding overflow.
 286
 287          begin
 288             --  Both operands in the inner addition have different signs,
 289             --  hence avoiding overflow. The Time () conversion and the outer
 290             --  addition can overflow only if SC + TC is not within Time'Range.
 291
 292             return Time (SC + Closest_Boundary) + Dist_To_Boundary;
 293          end;
 294
 295       --  Both operands have the same sign, so we can convert SC into Time
 296       --  right away; if this conversion overflows then the result of adding SC
 297       --  and TS would overflow anyway (so we would just be detecting the
 298       --  overflow a bit earlier).
 299
 300       else
 301          return Time (SC) + TS;
 302       end if;
 303    end Time_Of;
 304
 305    -----------------
 306    -- To_Duration --
 307    -----------------
 308
 309    function To_Duration (TS : Time_Span) return Duration is
 310    begin
 311       return Duration (TS);
 312    end To_Duration;
 313
 314    ------------------
 315    -- To_Time_Span --
 316    ------------------
 317
 318    function To_Time_Span (D : Duration) return Time_Span is
 319    begin
 320       --  Note regarding AI-00432 requiring range checking on this conversion.
 321       --  In almost all versions of GNAT (and all to which this version of the
 322       --  Ada.Real_Time package apply), the range of Time_Span and Duration are
 323       --  the same, so there is no issue of overflow.
 324
 325       return Time_Span (D);
 326    end To_Time_Span;
 327
 328 begin
 329    --  Ensure that the tasking run time is initialized when using clock and/or
 330    --  delay operations. The initialization routine has the required machinery
 331    --  to prevent multiple calls to Initialize.
 332
 333    System.Tasking.Initialize;
 334 end Ada.Real_Time;