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-1994, Florida State University            --
  10 --             Copyright (C) 1995-2003, Ada Core Technologies               --
  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,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, 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    -- Nanoseconds --
 159    -----------------
 160
 161    function Nanoseconds (NS : Integer) return Time_Span is
 162    begin
 163       return Time_Span_Unit * NS;
 164    end Nanoseconds;
 165
 166    -----------
 167    -- Split --
 168    -----------
 169
 170    procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is
 171       T_Val : Time;
 172
 173    begin
 174       --  Special-case for Time_First, whose absolute value is anomalous,
 175       --  courtesy of two's complement.
 176
 177       if T = Time_First then
 178          T_Val := abs (Time_Last);
 179       else
 180          T_Val := abs (T);
 181       end if;
 182
 183       --  Extract the integer part of T, truncating towards zero.
 184
 185       if T_Val < 0.5 then
 186          SC := 0;
 187       else
 188          SC := Seconds_Count (Time_Span'(T_Val - 0.5));
 189       end if;
 190
 191       if T < 0.0 then
 192          SC := -SC;
 193       end if;
 194
 195       --  If original time is negative, need to truncate towards negative
 196       --  infinity, to make TS non-negative, as per ARM.
 197
 198       if Time (SC) > T then
 199          SC := SC - 1;
 200       end if;
 201
 202       TS := Time_Span (Duration (T) - Duration (SC));
 203    end Split;
 204
 205    -------------
 206    -- Time_Of --
 207    -------------
 208
 209    function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is
 210    begin
 211       return Time (SC) + TS;
 212    end Time_Of;
 213
 214    -----------------
 215    -- To_Duration --
 216    -----------------
 217
 218    function To_Duration (TS : Time_Span) return Duration is
 219    begin
 220       return Duration (TS);
 221    end To_Duration;
 222
 223    ------------------
 224    -- To_Time_Span --
 225    ------------------
 226
 227    function To_Time_Span (D : Duration) return Time_Span is
 228    begin
 229       return Time_Span (D);
 230    end To_Time_Span;
 231
 232 end Ada.Real_Time;