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       return Time (SC) + TS;
 222    end Time_Of;
 223
 224    -----------------
 225    -- To_Duration --
 226    -----------------
 227
 228    function To_Duration (TS : Time_Span) return Duration is
 229    begin
 230       return Duration (TS);
 231    end To_Duration;
 232
 233    ------------------
 234    -- To_Time_Span --
 235    ------------------
 236
 237    function To_Time_Span (D : Duration) return Time_Span is
 238    begin
 239       --  Note regarding AI-00432 requiring range checking on this conversion.
 240       --  In almost all versions of GNAT (and all to which this version of the
 241       --  Ada.Real_Time package apply), the range of Time_Span and Duration are
 242       --  the same, so there is no issue of overflow.
 243
 244       return Time_Span (D);
 245    end To_Time_Span;
 246
 247 begin
 248    --  Ensure that the tasking run time is initialized when using clock and/or
 249    --  delay operations. The initialization routine has the required machinery
 250    --  to prevent multiple calls to Initialize.
 251
 252    System.Tasking.Initialize;
 253 end Ada.Real_Time;