gcc/ada/libgnarl/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-2017, Florida State University            --
  10 --                     Copyright (C) 1995-2024, 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 Ada.Unchecked_Conversion;
  34 with System.Tasking;
  35
  36 package body Ada.Real_Time with
  37   SPARK_Mode => Off
  38 is
  39
  40    ---------
  41    -- "*" --
  42    ---------
  43
  44    --  Note that Constraint_Error may be propagated
  45
  46    function "*" (Left : Time_Span; Right : Integer) return Time_Span is
  47       pragma Unsuppress (Overflow_Check);
  48    begin
  49       return Time_Span (Duration (Left) * Right);
  50    end "*";
  51
  52    function "*" (Left : Integer; Right : Time_Span) return Time_Span is
  53       pragma Unsuppress (Overflow_Check);
  54    begin
  55       return Time_Span (Left * Duration (Right));
  56    end "*";
  57
  58    ---------
  59    -- "+" --
  60    ---------
  61
  62    --  Note that Constraint_Error may be propagated
  63
  64    function "+" (Left : Time; Right : Time_Span) return Time is
  65       pragma Unsuppress (Overflow_Check);
  66    begin
  67       return Time (Duration (Left) + Duration (Right));
  68    end "+";
  69
  70    function "+" (Left : Time_Span; Right : Time) return Time is
  71       pragma Unsuppress (Overflow_Check);
  72    begin
  73       return Time (Duration (Left) + Duration (Right));
  74    end "+";
  75
  76    function "+" (Left, Right : Time_Span) return Time_Span is
  77       pragma Unsuppress (Overflow_Check);
  78    begin
  79       return Time_Span (Duration (Left) + Duration (Right));
  80    end "+";
  81
  82    ---------
  83    -- "-" --
  84    ---------
  85
  86    --  Note that Constraint_Error may be propagated
  87
  88    function "-" (Left : Time; Right : Time_Span) return Time is
  89       pragma Unsuppress (Overflow_Check);
  90    begin
  91       return Time (Duration (Left) - Duration (Right));
  92    end "-";
  93
  94    function "-" (Left, Right : Time) return Time_Span is
  95       pragma Unsuppress (Overflow_Check);
  96    begin
  97       return Time_Span (Duration (Left) - Duration (Right));
  98    end "-";
  99
 100    function "-" (Left, Right : Time_Span) return Time_Span is
 101       pragma Unsuppress (Overflow_Check);
 102    begin
 103       return Time_Span (Duration (Left) - Duration (Right));
 104    end "-";
 105
 106    function "-" (Right : Time_Span) return Time_Span is
 107       pragma Unsuppress (Overflow_Check);
 108    begin
 109       return Time_Span_Zero - Right;
 110    end "-";
 111
 112    ---------
 113    -- "/" --
 114    ---------
 115
 116    --  Note that Constraint_Error may be propagated
 117
 118    function "/" (Left, Right : Time_Span) return Integer is
 119       pragma Unsuppress (Overflow_Check);
 120       pragma Unsuppress (Division_Check);
 121
 122       --  RM D.8 (27) specifies the effects of operators on Time_Span, and
 123       --  rounding of the division operator in particular, to be the same as
 124       --  effects on integer types. To get the correct rounding we first
 125       --  convert Time_Span to its root type Duration, which is represented as
 126       --  a 64-bit signed integer, and then use integer division.
 127
 128       type Duration_Rep is range -(2 ** 63) .. +((2 ** 63 - 1));
 129
 130       function To_Integer is
 131         new Ada.Unchecked_Conversion (Duration, Duration_Rep);
 132    begin
 133       return Integer
 134                (To_Integer (Duration (Left)) / To_Integer (Duration (Right)));
 135    end "/";
 136
 137    function "/" (Left : Time_Span; Right : Integer) return Time_Span is
 138       pragma Unsuppress (Overflow_Check);
 139       pragma Unsuppress (Division_Check);
 140    begin
 141       --  Even though checks are unsuppressed, we need an explicit check for
 142       --  the case of largest negative integer divided by minus one, since
 143       --  some library routines we use fail to catch this case. This will be
 144       --  fixed at the compiler level in the future, at which point this test
 145       --  can be removed.
 146
 147       if Left = Time_Span_First and then Right = -1 then
 148          raise Constraint_Error with "overflow";
 149       end if;
 150
 151       return Time_Span (Duration (Left) / Right);
 152    end "/";
 153
 154    -----------
 155    -- Clock --
 156    -----------
 157
 158    function Clock return Time is
 159    begin
 160       return Time (System.Task_Primitives.Operations.Monotonic_Clock);
 161    end Clock;
 162
 163    ------------------
 164    -- Microseconds --
 165    ------------------
 166
 167    function Microseconds (US : Integer) return Time_Span is
 168    begin
 169       return Time_Span_Unit * US * 1_000;
 170    end Microseconds;
 171
 172    ------------------
 173    -- Milliseconds --
 174    ------------------
 175
 176    function Milliseconds (MS : Integer) return Time_Span is
 177    begin
 178       return Time_Span_Unit * MS * 1_000_000;
 179    end Milliseconds;
 180
 181    -------------
 182    -- Minutes --
 183    -------------
 184
 185    function Minutes (M : Integer) return Time_Span is
 186    begin
 187       return Milliseconds (M) * Integer'(60_000);
 188    end Minutes;
 189
 190    -----------------
 191    -- Nanoseconds --
 192    -----------------
 193
 194    function Nanoseconds (NS : Integer) return Time_Span is
 195    begin
 196       return Time_Span_Unit * NS;
 197    end Nanoseconds;
 198
 199    -------------
 200    -- Seconds --
 201    -------------
 202
 203    function Seconds (S : Integer) return Time_Span is
 204    begin
 205       return Milliseconds (S) * Integer'(1000);
 206    end Seconds;
 207
 208    -----------
 209    -- Split --
 210    -----------
 211
 212    procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is
 213       T_Val : Time;
 214
 215    begin
 216       --  Special-case for Time_First, whose absolute value is anomalous,
 217       --  courtesy of two's complement.
 218
 219       T_Val := (if T = Time_First then abs (Time_Last) else abs (T));
 220
 221       --  Extract the integer part of T, truncating towards zero
 222
 223       SC :=
 224         (if T_Val < 0.5 then 0 else Seconds_Count (Time_Span'(T_Val - 0.5)));
 225
 226       if T < 0.0 then
 227          SC := -SC;
 228       end if;
 229
 230       --  If original time is negative, need to truncate towards negative
 231       --  infinity, to make TS non-negative, as per ARM.
 232
 233       if Time (SC) > T then
 234          SC := SC - 1;
 235       end if;
 236
 237       TS := Time_Span (Duration (T) - Duration (SC));
 238    end Split;
 239
 240    -------------
 241    -- Time_Of --
 242    -------------
 243
 244    function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is
 245       pragma Suppress (Overflow_Check);
 246       pragma Suppress (Range_Check);
 247       --  We do all our own checks for this function
 248
 249       --  This is not such a simple case, since TS is already 64 bits, and
 250       --  so we can't just promote everything to a wider type to ensure proper
 251       --  testing for overflow. The situation is that Seconds_Count is a MUCH
 252       --  wider type than Time_Span and Time (both of which have the underlying
 253       --  type Duration).
 254
 255       --         <------------------- Seconds_Count -------------------->
 256       --                            <-- Duration -->
 257
 258       --  Now it is possible for an SC value outside the Duration range to
 259       --  be "brought back into range" by an appropriate TS value, but there
 260       --  are also clearly SC values that are completely out of range. Note
 261       --  that the above diagram is wildly out of scale, the difference in
 262       --  ranges is much greater than shown.
 263
 264       --  We can't just go generating out of range Duration values to test for
 265       --  overflow, since Duration is a full range type, so we follow the steps
 266       --  shown below.
 267
 268       SC_Lo : constant Seconds_Count :=
 269                 Seconds_Count (Duration (Time_Span_First) + Duration'(0.5));
 270       SC_Hi : constant Seconds_Count :=
 271                 Seconds_Count (Duration (Time_Span_Last)  - Duration'(0.5));
 272       --  These are the maximum values of the seconds (integer) part of the
 273       --  Duration range. Used to compute and check the seconds in the result.
 274
 275       TS_SC : Seconds_Count;
 276       --  Seconds part of input value
 277
 278       TS_Fraction : Duration;
 279       --  Fractional part of input value, may be negative
 280
 281       Result_SC : Seconds_Count;
 282       --  Seconds value for result
 283
 284       Fudge : constant Seconds_Count := 10;
 285       --  Fudge value used to do end point checks far from end point
 286
 287       FudgeD : constant Duration := Duration (Fudge);
 288       --  Fudge value as Duration
 289
 290       Fudged_Result : Duration;
 291       --  Result fudged up or down by FudgeD
 292
 293       procedure Out_Of_Range;
 294       pragma No_Return (Out_Of_Range);
 295       --  Raise exception for result out of range
 296
 297       ------------------
 298       -- Out_Of_Range --
 299       ------------------
 300
 301       procedure Out_Of_Range is
 302       begin
 303          raise Constraint_Error with
 304            "result for Ada.Real_Time.Time_Of is out of range";
 305       end Out_Of_Range;
 306
 307    --  Start of processing for Time_Of
 308
 309    begin
 310       pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns",
 311                        "early returns for performance");
 312
 313       --  If SC is so far out of range that there is no possibility of the
 314       --  addition of TS getting it back in range, raise an exception right
 315       --  away. That way we don't have to worry about SC values overflowing.
 316
 317       if SC < 3 * SC_Lo or else SC > 3 * SC_Hi then
 318          Out_Of_Range;
 319       end if;
 320
 321       --  Decompose input TS value
 322
 323       TS_SC := Seconds_Count (Duration (TS));
 324       TS_Fraction := Duration (TS) - Duration (TS_SC);
 325
 326       --  Compute result seconds. If clearly out of range, raise error now
 327
 328       Result_SC := SC + TS_SC;
 329
 330       if Result_SC < (SC_Lo - 1) or else Result_SC > (SC_Hi + 1) then
 331          Out_Of_Range;
 332       end if;
 333
 334       --  Now the result is simply Result_SC + TS_Fraction, but we can't just
 335       --  go computing that since it might be out of range. So what we do is
 336       --  to compute a value fudged down or up by 10.0 (arbitrary value, but
 337       --  that will do fine), and check that fudged value, and if in range
 338       --  unfudge it and return the result.
 339
 340       --  Fudge positive result down, and check high bound
 341
 342       if Result_SC > 0 then
 343          Fudged_Result := Duration (Result_SC - Fudge) + TS_Fraction;
 344
 345          if Fudged_Result <= Duration'Last - FudgeD then
 346             return Time (Fudged_Result + FudgeD);
 347          else
 348             Out_Of_Range;
 349          end if;
 350
 351       --  Same for negative values of seconds, fudge up and check low bound
 352
 353       else
 354          Fudged_Result := Duration (Result_SC + Fudge) + TS_Fraction;
 355
 356          if Fudged_Result >= Duration'First + FudgeD then
 357             return Time (Fudged_Result - FudgeD);
 358          else
 359             Out_Of_Range;
 360          end if;
 361       end if;
 362
 363       pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns");
 364    end Time_Of;
 365
 366    -----------------
 367    -- To_Duration --
 368    -----------------
 369
 370    function To_Duration (TS : Time_Span) return Duration is
 371    begin
 372       return Duration (TS);
 373    end To_Duration;
 374
 375    ------------------
 376    -- To_Time_Span --
 377    ------------------
 378
 379    function To_Time_Span (D : Duration) return Time_Span is
 380    begin
 381       --  Note regarding AI-00432 requiring range checking on this conversion.
 382       --  In almost all versions of GNAT (and all to which this version of the
 383       --  Ada.Real_Time package apply), the range of Time_Span and Duration are
 384       --  the same, so there is no issue of overflow.
 385
 386       return Time_Span (D);
 387    end To_Time_Span;
 388
 389 begin
 390    --  Ensure that the tasking run time is initialized when using clock and/or
 391    --  delay operations. The initialization routine has the required machinery
 392    --  to prevent multiple calls to Initialize.
 393
 394    System.Tasking.Initialize;
 395 end Ada.Real_Time;