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-2014, 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       return Time_Span (Duration (Left) / Right);
 127    end "/";
 128
 129    -----------
 130    -- Clock --
 131    -----------
 132
 133    function Clock return Time is
 134    begin
 135       return Time (System.Task_Primitives.Operations.Monotonic_Clock);
 136    end Clock;
 137
 138    ------------------
 139    -- Microseconds --
 140    ------------------
 141
 142    function Microseconds (US : Integer) return Time_Span is
 143    begin
 144       return Time_Span_Unit * US * 1_000;
 145    end Microseconds;
 146
 147    ------------------
 148    -- Milliseconds --
 149    ------------------
 150
 151    function Milliseconds (MS : Integer) return Time_Span is
 152    begin
 153       return Time_Span_Unit * MS * 1_000_000;
 154    end Milliseconds;
 155
 156    -------------
 157    -- Minutes --
 158    -------------
 159
 160    function Minutes (M : Integer) return Time_Span is
 161    begin
 162       return Milliseconds (M) * Integer'(60_000);
 163    end Minutes;
 164
 165    -----------------
 166    -- Nanoseconds --
 167    -----------------
 168
 169    function Nanoseconds (NS : Integer) return Time_Span is
 170    begin
 171       return Time_Span_Unit * NS;
 172    end Nanoseconds;
 173
 174    -------------
 175    -- Seconds --
 176    -------------
 177
 178    function Seconds (S : Integer) return Time_Span is
 179    begin
 180       return Milliseconds (S) * Integer'(1000);
 181    end Seconds;
 182
 183    -----------
 184    -- Split --
 185    -----------
 186
 187    procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is
 188       T_Val : Time;
 189
 190    begin
 191       --  Special-case for Time_First, whose absolute value is anomalous,
 192       --  courtesy of two's complement.
 193
 194       T_Val := (if T = Time_First then abs (Time_Last) else abs (T));
 195
 196       --  Extract the integer part of T, truncating towards zero
 197
 198       SC :=
 199         (if T_Val < 0.5 then 0 else Seconds_Count (Time_Span'(T_Val - 0.5)));
 200
 201       if T < 0.0 then
 202          SC := -SC;
 203       end if;
 204
 205       --  If original time is negative, need to truncate towards negative
 206       --  infinity, to make TS non-negative, as per ARM.
 207
 208       if Time (SC) > T then
 209          SC := SC - 1;
 210       end if;
 211
 212       TS := Time_Span (Duration (T) - Duration (SC));
 213    end Split;
 214
 215    -------------
 216    -- Time_Of --
 217    -------------
 218
 219    function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is
 220    begin
 221       --  We want to return Time (SC) + TS. To avoid spurious overflows in
 222       --  the intermediate result Time (SC) we take advantage of the different
 223       --  signs in SC and TS (when that is the case).
 224
 225       --  If the signs of SC and TS are different then we avoid converting SC
 226       --  to Time (as we do in the else part). The reason for that is that SC
 227       --  converted to Time may overflow the range of Time, while the addition
 228       --  of SC plus TS does not overflow (because of their different signs).
 229       --  The approach is to add and remove the greatest value of time
 230       --  (greatest absolute value) to both SC and TS. SC and TS have different
 231       --  signs, so we add the positive constant to the negative value, and the
 232       --  negative constant to the positive value, to prevent overflows.
 233
 234       if (SC > 0 and then TS < 0.0) or else (SC < 0 and then TS > 0.0) then
 235          declare
 236             Closest_Boundary : constant Seconds_Count :=
 237               (if TS >= 0.0 then
 238                   Seconds_Count (Time_Span_Last  - Time_Span (0.5))
 239                else
 240                   Seconds_Count (Time_Span_First + Time_Span (0.5)));
 241             --  Value representing the integer part of the Time_Span boundary
 242             --  closest to TS (its number of seconds). Truncate towards zero
 243             --  to be sure that transforming this value back into Time cannot
 244             --  overflow (when SC is equal to 0). The sign of Closest_Boundary
 245             --  is always different from the sign of SC, hence avoiding
 246             --  overflow in the expression Time (SC + Closest_Boundary)
 247             --  which is part of the return statement.
 248
 249             Dist_To_Boundary : constant Time_Span :=
 250               TS - Time_Span (Closest_Boundary);
 251             --  Distance between TS and Closest_Boundary expressed in Time_Span
 252             --  Both operands in the substraction have the same sign, hence
 253             --  avoiding overflow.
 254
 255          begin
 256             --  Both operands in the inner addition have different signs,
 257             --  hence avoiding overflow. The Time () conversion and the outer
 258             --  addition can overflow only if SC + TC is not within Time'Range.
 259
 260             return Time (SC + Closest_Boundary) + Dist_To_Boundary;
 261          end;
 262
 263       --  Both operands have the same sign, so we can convert SC into Time
 264       --  right away; if this conversion overflows then the result of adding SC
 265       --  and TS would overflow anyway (so we would just be detecting the
 266       --  overflow a bit earlier).
 267
 268       else
 269          return Time (SC) + TS;
 270       end if;
 271    end Time_Of;
 272
 273    -----------------
 274    -- To_Duration --
 275    -----------------
 276
 277    function To_Duration (TS : Time_Span) return Duration is
 278    begin
 279       return Duration (TS);
 280    end To_Duration;
 281
 282    ------------------
 283    -- To_Time_Span --
 284    ------------------
 285
 286    function To_Time_Span (D : Duration) return Time_Span is
 287    begin
 288       --  Note regarding AI-00432 requiring range checking on this conversion.
 289       --  In almost all versions of GNAT (and all to which this version of the
 290       --  Ada.Real_Time package apply), the range of Time_Span and Duration are
 291       --  the same, so there is no issue of overflow.
 292
 293       return Time_Span (D);
 294    end To_Time_Span;
 295
 296 begin
 297    --  Ensure that the tasking run time is initialized when using clock and/or
 298    --  delay operations. The initialization routine has the required machinery
 299    --  to prevent multiple calls to Initialize.
 300
 301    System.Tasking.Initialize;
 302 end Ada.Real_Time;