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-2005, 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.Task_Primitives.Operations;
  36 --  used for Monotonic_Clock
  37
  38 package body Ada.Real_Time 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    begin
 121       return Integer (Duration (Left) / Duration (Right));
 122    end "/";
 123
 124    function "/" (Left : Time_Span; Right : Integer) return Time_Span is
 125       pragma Unsuppress (Overflow_Check);
 126    begin
 127       return Time_Span (Duration (Left) / Right);
 128    end "/";
 129
 130    -----------
 131    -- Clock --
 132    -----------
 133
 134    function Clock return Time is
 135    begin
 136       return Time (System.Task_Primitives.Operations.Monotonic_Clock);
 137    end Clock;
 138
 139    ------------------
 140    -- Microseconds --
 141    ------------------
 142
 143    function Microseconds (US : Integer) return Time_Span is
 144    begin
 145       return Time_Span_Unit * US * 1_000;
 146    end Microseconds;
 147
 148    ------------------
 149    -- Milliseconds --
 150    ------------------
 151
 152    function Milliseconds (MS : Integer) return Time_Span is
 153    begin
 154       return Time_Span_Unit * MS * 1_000_000;
 155    end Milliseconds;
 156
 157    -------------
 158    -- Minutes --
 159    -------------
 160
 161    function Minutes (M : Integer) return Time_Span is
 162    begin
 163       return Milliseconds (M) * Integer'(60_000);
 164    end Minutes;
 165
 166    -----------------
 167    -- Nanoseconds --
 168    -----------------
 169
 170    function Nanoseconds (NS : Integer) return Time_Span is
 171    begin
 172       return Time_Span_Unit * NS;
 173    end Nanoseconds;
 174
 175    -------------
 176    -- Seconds --
 177    -------------
 178
 179    function Seconds (S : Integer) return Time_Span is
 180    begin
 181       return Milliseconds (S) * Integer'(1000);
 182    end Seconds;
 183
 184    -----------
 185    -- Split --
 186    -----------
 187
 188    procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is
 189       T_Val : Time;
 190
 191    begin
 192       --  Special-case for Time_First, whose absolute value is anomalous,
 193       --  courtesy of two's complement.
 194
 195       if T = Time_First then
 196          T_Val := abs (Time_Last);
 197       else
 198          T_Val := abs (T);
 199       end if;
 200
 201       --  Extract the integer part of T, truncating towards zero
 202
 203       if T_Val < 0.5 then
 204          SC := 0;
 205       else
 206          SC := Seconds_Count (Time_Span'(T_Val - 0.5));
 207       end if;
 208
 209       if T < 0.0 then
 210          SC := -SC;
 211       end if;
 212
 213       --  If original time is negative, need to truncate towards negative
 214       --  infinity, to make TS non-negative, as per ARM.
 215
 216       if Time (SC) > T then
 217          SC := SC - 1;
 218       end if;
 219
 220       TS := Time_Span (Duration (T) - Duration (SC));
 221    end Split;
 222
 223    -------------
 224    -- Time_Of --
 225    -------------
 226
 227    function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is
 228    begin
 229       return Time (SC) + TS;
 230    end Time_Of;
 231
 232    -----------------
 233    -- To_Duration --
 234    -----------------
 235
 236    function To_Duration (TS : Time_Span) return Duration is
 237    begin
 238       return Duration (TS);
 239    end To_Duration;
 240
 241    ------------------
 242    -- To_Time_Span --
 243    ------------------
 244
 245    function To_Time_Span (D : Duration) return Time_Span is
 246    begin
 247       return Time_Span (D);
 248    end To_Time_Span;
 249
 250 end Ada.Real_Time;