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-2010, AdaCore                     --
  11 --                                                                          --
  12 -- GNARL 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 2,  or (at your option) any later ver- --
  15 -- sion. GNARL 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.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  20 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  21 -- Boston, MA 02110-1301, USA.                                              --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNARL was developed by the GNARL team at Florida State University.       --
  31 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with System.Tasking;
  36
  37 package body Ada.Real_Time is
  38
  39    ---------
  40    -- "*" --
  41    ---------
  42
  43    --  Note that Constraint_Error may be propagated
  44
  45    function "*" (Left : Time_Span; Right : Integer) return Time_Span is
  46       pragma Unsuppress (Overflow_Check);
  47    begin
  48       return Time_Span (Duration (Left) * Right);
  49    end "*";
  50
  51    function "*" (Left : Integer; Right : Time_Span) return Time_Span is
  52       pragma Unsuppress (Overflow_Check);
  53    begin
  54       return Time_Span (Left * Duration (Right));
  55    end "*";
  56
  57    ---------
  58    -- "+" --
  59    ---------
  60
  61    --  Note that Constraint_Error may be propagated
  62
  63    function "+" (Left : Time; Right : Time_Span) return Time is
  64       pragma Unsuppress (Overflow_Check);
  65    begin
  66       return Time (Duration (Left) + Duration (Right));
  67    end "+";
  68
  69    function "+" (Left : Time_Span; Right : Time) return Time is
  70       pragma Unsuppress (Overflow_Check);
  71    begin
  72       return Time (Duration (Left) + Duration (Right));
  73    end "+";
  74
  75    function "+" (Left, Right : Time_Span) return Time_Span is
  76       pragma Unsuppress (Overflow_Check);
  77    begin
  78       return Time_Span (Duration (Left) + Duration (Right));
  79    end "+";
  80
  81    ---------
  82    -- "-" --
  83    ---------
  84
  85    --  Note that Constraint_Error may be propagated
  86
  87    function "-" (Left : Time; Right : Time_Span) return Time is
  88       pragma Unsuppress (Overflow_Check);
  89    begin
  90       return Time (Duration (Left) - Duration (Right));
  91    end "-";
  92
  93    function "-" (Left, Right : Time) return Time_Span is
  94       pragma Unsuppress (Overflow_Check);
  95    begin
  96       return Time_Span (Duration (Left) - Duration (Right));
  97    end "-";
  98
  99    function "-" (Left, Right : Time_Span) return Time_Span is
 100       pragma Unsuppress (Overflow_Check);
 101    begin
 102       return Time_Span (Duration (Left) - Duration (Right));
 103    end "-";
 104
 105    function "-" (Right : Time_Span) return Time_Span is
 106       pragma Unsuppress (Overflow_Check);
 107    begin
 108       return Time_Span_Zero - Right;
 109    end "-";
 110
 111    ---------
 112    -- "/" --
 113    ---------
 114
 115    --  Note that Constraint_Error may be propagated
 116
 117    function "/" (Left, Right : Time_Span) return Integer is
 118       pragma Unsuppress (Overflow_Check);
 119    begin
 120       return Integer (Duration (Left) / Duration (Right));
 121    end "/";
 122
 123    function "/" (Left : Time_Span; Right : Integer) return Time_Span is
 124       pragma Unsuppress (Overflow_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;