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       pragma Suppress (Overflow_Check);
 231       pragma Suppress (Range_Check);
 232       --  We do all our own checks for this function
 233
 234       --  This is not such a simple case, since TS is already 64 bits, and
 235       --  so we can't just promote everything to a wider type to ensure proper
 236       --  testing for overflow. The situation is that Seconds_Count is a MUCH
 237       --  wider type than Time_Span and Time (both of which have the underlying
 238       --  type Duration).
 239
 240       --         <------------------- Seconds_Count -------------------->
 241       --                            <-- Duration -->
 242
 243       --  Now it is possible for an SC value outside the Duration range to
 244       --  be "brought back into range" by an appropriate TS value, but there
 245       --  are also clearly SC values that are completely out of range. Note
 246       --  that the above diagram is wildly out of scale, the difference in
 247       --  ranges is much greater than shown.
 248
 249       --  We can't just go generating out of range Duration values to test for
 250       --  overflow, since Duration is a full range type, so we follow the steps
 251       --  shown below.
 252
 253       SC_Lo : constant Seconds_Count :=
 254                 Seconds_Count (Duration (Time_Span_First) + Duration'(0.5));
 255       SC_Hi : constant Seconds_Count :=
 256                 Seconds_Count (Duration (Time_Span_Last)  - Duration'(0.5));
 257       --  These are the maximum values of the seconds (integer) part of the
 258       --  Duration range. Used to compute and check the seconds in the result.
 259
 260       TS_SC : Seconds_Count;
 261       --  Seconds part of input value
 262
 263       TS_Fraction : Duration;
 264       --  Fractional part of input value, may be negative
 265
 266       Result_SC : Seconds_Count;
 267       --  Seconds value for result
 268
 269       Fudge : constant Seconds_Count := 10;
 270       --  Fudge value used to do end point checks far from end point
 271
 272       FudgeD : constant Duration := Duration (Fudge);
 273       --  Fudge value as Duration
 274
 275       Fudged_Result : Duration;
 276       --  Result fudged up or down by FudgeD
 277
 278       procedure Out_Of_Range;
 279       pragma No_Return (Out_Of_Range);
 280       --  Raise exception for result out of range
 281
 282       ------------------
 283       -- Out_Of_Range --
 284       ------------------
 285
 286       procedure Out_Of_Range is
 287       begin
 288          raise Constraint_Error with
 289            "result for Ada.Real_Time.Time_Of is out of range";
 290       end Out_Of_Range;
 291
 292    --  Start of processing for Time_Of
 293
 294    begin
 295       --  If SC is so far out of range that there is no possibility of the
 296       --  addition of TS getting it back in range, raise an exception right
 297       --  away. That way we don't have to worry about SC values overflowing.
 298
 299       if SC < 3 * SC_Lo or else SC > 3 * SC_Hi then
 300          Out_Of_Range;
 301       end if;
 302
 303       --  Decompose input TS value
 304
 305       TS_SC := Seconds_Count (Duration (TS));
 306       TS_Fraction := Duration (TS) - Duration (TS_SC);
 307
 308       --  Compute result seconds. If clearly out of range, raise error now
 309
 310       Result_SC := SC + TS_SC;
 311
 312       if Result_SC < (SC_Lo - 1) or else Result_SC > (SC_Hi + 1) then
 313          Out_Of_Range;
 314       end if;
 315
 316       --  Now the result is simply Result_SC + TS_Fraction, but we can't just
 317       --  go computing that since it might be out of range. So what we do is
 318       --  to compute a value fudged down or up by 10.0 (arbitrary value, but
 319       --  that will do fine), and check that fudged value, and if in range
 320       --  unfudge it and return the result.
 321
 322       --  Fudge positive result down, and check high bound
 323
 324       if Result_SC > 0 then
 325          Fudged_Result := Duration (Result_SC - Fudge) + TS_Fraction;
 326
 327          if Fudged_Result <= Duration'Last - FudgeD then
 328             return Time (Fudged_Result + FudgeD);
 329          else
 330             Out_Of_Range;
 331          end if;
 332
 333       --  Same for negative values of seconds, fudge up and check low bound
 334
 335       else
 336          Fudged_Result := Duration (Result_SC + Fudge) + TS_Fraction;
 337
 338          if Fudged_Result >= Duration'First + FudgeD then
 339             return Time (Fudged_Result - FudgeD);
 340          else
 341             Out_Of_Range;
 342          end if;
 343       end if;
 344    end Time_Of;
 345
 346    -----------------
 347    -- To_Duration --
 348    -----------------
 349
 350    function To_Duration (TS : Time_Span) return Duration is
 351    begin
 352       return Duration (TS);
 353    end To_Duration;
 354
 355    ------------------
 356    -- To_Time_Span --
 357    ------------------
 358
 359    function To_Time_Span (D : Duration) return Time_Span is
 360    begin
 361       --  Note regarding AI-00432 requiring range checking on this conversion.
 362       --  In almost all versions of GNAT (and all to which this version of the
 363       --  Ada.Real_Time package apply), the range of Time_Span and Duration are
 364       --  the same, so there is no issue of overflow.
 365
 366       return Time_Span (D);
 367    end To_Time_Span;
 368
 369 begin
 370    --  Ensure that the tasking run time is initialized when using clock and/or
 371    --  delay operations. The initialization routine has the required machinery
 372    --  to prevent multiple calls to Initialize.
 373
 374    System.Tasking.Initialize;
 375 end Ada.Real_Time;