gcc/ada/a-reatim.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA 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-2002, Florida State University             --
  10 --                                                                          --
  11 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNARL was developed by the GNARL team at Florida State University. It is --
  30 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com).     --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with System.Task_Primitives.Operations;
  35 --  used for Monotonic_Clock
  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    -- Nanoseconds --
 158    -----------------
 159
 160    function Nanoseconds (NS : Integer) return Time_Span is
 161    begin
 162       return Time_Span_Unit * NS;
 163    end Nanoseconds;
 164
 165    -----------
 166    -- Split --
 167    -----------
 168
 169    procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is
 170       T_Val : Time;
 171
 172    begin
 173       --  Special-case for Time_First, whose absolute value is anomalous,
 174       --  courtesy of two's complement.
 175
 176       if T = Time_First then
 177          T_Val := abs (Time_Last);
 178       else
 179          T_Val := abs (T);
 180       end if;
 181
 182       --  Extract the integer part of T, truncating towards zero.
 183
 184       if T_Val < 0.5 then
 185          SC := 0;
 186       else
 187          SC := Seconds_Count (Time_Span' (T_Val - 0.5));
 188       end if;
 189
 190       if T < 0.0 then
 191          SC := -SC;
 192       end if;
 193
 194       --  If original time is negative, need to truncate towards negative
 195       --  infinity, to make TS non-negative, as per ARM.
 196
 197       if Time (SC) > T then
 198          SC := SC - 1;
 199       end if;
 200
 201       TS := Time_Span (Duration (T) - Duration (SC));
 202    end Split;
 203
 204    -------------
 205    -- Time_Of --
 206    -------------
 207
 208    function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is
 209    begin
 210       return Time (SC) + TS;
 211    end Time_Of;
 212
 213    -----------------
 214    -- To_Duration --
 215    -----------------
 216
 217    function To_Duration (TS : Time_Span) return Duration is
 218    begin
 219       return Duration (TS);
 220    end To_Duration;
 221
 222    ------------------
 223    -- To_Time_Span --
 224    ------------------
 225
 226    function To_Time_Span (D : Duration) return Time_Span is
 227    begin
 228       return Time_Span (D);
 229    end To_Time_Span;
 230
 231 end Ada.Real_Time;