OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-reatim.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
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
-- 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
   begin
118
      return Integer (Duration (Left) / Duration (Right));
119
   end "/";
120
 
121
   function "/" (Left : Time_Span; Right : Integer) return Time_Span is
122
      pragma Unsuppress (Overflow_Check);
123
   begin
124
      return Time_Span (Duration (Left) / Right);
125
   end "/";
126
 
127
   -----------
128
   -- Clock --
129
   -----------
130
 
131
   function Clock return Time is
132
   begin
133
      return Time (System.Task_Primitives.Operations.Monotonic_Clock);
134
   end Clock;
135
 
136
   ------------------
137
   -- Microseconds --
138
   ------------------
139
 
140
   function Microseconds (US : Integer) return Time_Span is
141
   begin
142
      return Time_Span_Unit * US * 1_000;
143
   end Microseconds;
144
 
145
   ------------------
146
   -- Milliseconds --
147
   ------------------
148
 
149
   function Milliseconds (MS : Integer) return Time_Span is
150
   begin
151
      return Time_Span_Unit * MS * 1_000_000;
152
   end Milliseconds;
153
 
154
   -------------
155
   -- Minutes --
156
   -------------
157
 
158
   function Minutes (M : Integer) return Time_Span is
159
   begin
160
      return Milliseconds (M) * Integer'(60_000);
161
   end Minutes;
162
 
163
   -----------------
164
   -- Nanoseconds --
165
   -----------------
166
 
167
   function Nanoseconds (NS : Integer) return Time_Span is
168
   begin
169
      return Time_Span_Unit * NS;
170
   end Nanoseconds;
171
 
172
   -------------
173
   -- Seconds --
174
   -------------
175
 
176
   function Seconds (S : Integer) return Time_Span is
177
   begin
178
      return Milliseconds (S) * Integer'(1000);
179
   end Seconds;
180
 
181
   -----------
182
   -- Split --
183
   -----------
184
 
185
   procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is
186
      T_Val : Time;
187
 
188
   begin
189
      --  Special-case for Time_First, whose absolute value is anomalous,
190
      --  courtesy of two's complement.
191
 
192
      T_Val := (if T = Time_First then abs (Time_Last) else abs (T));
193
 
194
      --  Extract the integer part of T, truncating towards zero
195
 
196
      SC :=
197
        (if T_Val < 0.5 then 0 else Seconds_Count (Time_Span'(T_Val - 0.5)));
198
 
199
      if T < 0.0 then
200
         SC := -SC;
201
      end if;
202
 
203
      --  If original time is negative, need to truncate towards negative
204
      --  infinity, to make TS non-negative, as per ARM.
205
 
206
      if Time (SC) > T then
207
         SC := SC - 1;
208
      end if;
209
 
210
      TS := Time_Span (Duration (T) - Duration (SC));
211
   end Split;
212
 
213
   -------------
214
   -- Time_Of --
215
   -------------
216
 
217
   function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is
218
   begin
219
      return Time (SC) + TS;
220
   end Time_Of;
221
 
222
   -----------------
223
   -- To_Duration --
224
   -----------------
225
 
226
   function To_Duration (TS : Time_Span) return Duration is
227
   begin
228
      return Duration (TS);
229
   end To_Duration;
230
 
231
   ------------------
232
   -- To_Time_Span --
233
   ------------------
234
 
235
   function To_Time_Span (D : Duration) return Time_Span is
236
   begin
237
      --  Note regarding AI-00432 requiring range checking on this conversion.
238
      --  In almost all versions of GNAT (and all to which this version of the
239
      --  Ada.Real_Time package apply), the range of Time_Span and Duration are
240
      --  the same, so there is no issue of overflow.
241
 
242
      return Time_Span (D);
243
   end To_Time_Span;
244
 
245
begin
246
   --  Ensure that the tasking run time is initialized when using clock and/or
247
   --  delay operations. The initialization routine has the required machinery
248
   --  to prevent multiple calls to Initialize.
249
 
250
   System.Tasking.Initialize;
251
end Ada.Real_Time;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.