summaryrefslogtreecommitdiff
path: root/gcc/ada/urealp.ads
blob: 57bc0fa8c139536d48bb91fc0f2802906ef8e242 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                               U R E A L P                                --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--          Copyright (C) 1992-2004 Free Software Foundation, Inc.          --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  Support for universal real arithmetic

with Types; use Types;
with Uintp; use Uintp;

package Urealp is

   ---------------------------------------
   -- Representation of Universal Reals --
   ---------------------------------------

   --  A universal real value is represented by a single value (which is
   --  an index into an internal table). These values are not hashed, so
   --  the equality operator should not be used on Ureal values (instead
   --  use the UR_Eq function).

   --  A Ureal value represents an arbitrary precision universal real value,
   --  stored internally using four components

   --    the numerator (Uint, always non-negative)
   --    the denominator (Uint, always non-zero, always positive if base = 0)
   --    a real base (Nat, either zero, or in the range 2 .. 16)
   --    a sign flag (Boolean), set if negative

   --  If the base is zero, then the absolute value of the Ureal is simply
   --  numerator/denominator. If the base is non-zero, then the absolute
   --  value is num / (rbase ** den).

   --  Negative numbers are represented by the sign of the numerator being
   --  negative. The denominator is always positive.

   --  A normalized Ureal value has base = 0, and numerator/denominator
   --  reduced to lowest terms, with zero itself being represented as 0/1.
   --  This is a canonical format, so that for normalized Ureal values it
   --  is the case that two equal values always have the same denominator
   --  and numerator values.

   --  Note: a value of minus zero is legitimate, and the operations in
   --  Urealp preserve the handling of signed zeroes in accordance with
   --  the rules of IEEE P754 ("IEEE floating point").

   ------------------------------
   -- Types for Urealp Package --
   ------------------------------

   type Ureal is private;
   --  Type used for representation of universal reals

   No_Ureal : constant Ureal;
   --  Constant used to indicate missing or unset Ureal value

   ---------------------
   -- Ureal Constants --
   ---------------------

   function Ureal_0 return Ureal;
   --  Returns value 0.0

   function Ureal_M_0 return Ureal;
   --  Returns value -0.0

   function Ureal_Tenth return Ureal;
   --  Returns value 0.1

   function Ureal_Half return Ureal;
   --  Returns value 0.5

   function Ureal_1 return Ureal;
   --  Returns value 1.0

   function Ureal_2 return Ureal;
   --  Returns value 2.0

   function Ureal_10 return Ureal;
   --  Returns value 10.0

   function Ureal_100 return Ureal;
   --  Returns value 100.0

   function Ureal_2_80 return Ureal;
   --  Returns value 2.0 ** 80

   function Ureal_2_M_80 return Ureal;
   --  Returns value 2.0 ** (-80)

   function Ureal_2_128 return Ureal;
   --  Returns value 2.0 ** 128

   function Ureal_2_M_128 return Ureal;
   --  Returns value 2.0 ** (-128)

   function Ureal_10_36 return Ureal;
   --  Returns value 10.0 ** 36

   function Ureal_M_10_36 return Ureal;
   --  Returns value -(10.0

   -----------------
   -- Subprograms --
   -----------------

   procedure Initialize;
   --  Initialize Ureal tables. Note that Initialize must not be called if
   --  Tree_Read is used. Note also that there is no Lock routine in this
   --  unit. These tables are among the few tables that can be expanded
   --  during Gigi processing.

   procedure Tree_Read;
   --  Initializes internal tables from current tree file using the relevant
   --  Table.Tree_Read routines. Note that Initialize should not be called if
   --  Tree_Read is used. Tree_Read includes all necessary initialization.

   procedure Tree_Write;
   --  Writes out internal tables to current tree file using the relevant
   --  Table.Tree_Write routines.

   function Rbase (Real : Ureal) return Nat;
   --  Return the base of the universal real.

   function Denominator (Real : Ureal) return Uint;
   --  Return the denominator of the universal real.

   function Numerator (Real : Ureal) return Uint;
   --  Return the numerator of the universal real.

   function Norm_Den (Real : Ureal) return Uint;
   --  Return the denominator of the universal real after a normalization.

   function Norm_Num (Real : Ureal) return Uint;
   --  Return the numerator of the universal real after a normalization.

   function UR_From_Uint (UI : Uint) return Ureal;
   --  Returns real corresponding to universal integer value

   function UR_To_Uint (Real : Ureal) return Uint;
   --  Return integer value obtained by accurate rounding of real value.
   --  The rounding of values half way between two integers is away from
   --  zero, as required by normal Ada 95 rounding semantics.

   function UR_Trunc (Real : Ureal) return Uint;
   --  Return integer value obtained by a truncation of real towards zero

   function UR_Ceiling (Real : Ureal) return Uint;
   --  Return value of smallest integer not less than the given value

   function UR_Floor (Real : Ureal) return Uint;
   --  Return value of smallest integer not greater than the given value

   --  Conversion table for above four functions

   --    Input    To_Uint    Trunc    Ceiling    Floor
   --     1.0        1         1         1         1
   --     1.2        1         1         2         1
   --     1.5        2         1         2         1
   --     1.7        2         1         2         1
   --     2.0        2         2         2         2
   --    -1.0       -1        -1        -1        -1
   --    -1.2       -1        -1        -1        -2
   --    -1.5       -2        -1        -1        -2
   --    -1.7       -2        -1        -1        -2
   --    -2.0       -2        -2        -2        -2

   function UR_From_Components
     (Num      : Uint;
      Den      : Uint;
      Rbase    : Nat := 0;
      Negative : Boolean := False)
      return     Ureal;
   --  Builds real value from given numerator, denominator and base. The
   --  value is negative if Negative is set to true, and otherwise is
   --  non-negative.

   function UR_Add (Left : Ureal; Right : Ureal) return Ureal;
   function UR_Add (Left : Ureal; Right : Uint)  return Ureal;
   function UR_Add (Left : Uint;  Right : Ureal) return Ureal;
   --  Returns real sum of operands

   function UR_Div (Left : Ureal; Right : Ureal) return Ureal;
   function UR_Div (Left : Uint;  Right : Ureal) return Ureal;
   function UR_Div (Left : Ureal; Right : Uint)  return Ureal;
   --  Returns real quotient of operands. Fatal error if Right is zero

   function UR_Mul (Left : Ureal; Right : Ureal) return Ureal;
   function UR_Mul (Left : Uint;  Right : Ureal) return Ureal;
   function UR_Mul (Left : Ureal; Right : Uint)  return Ureal;
   --  Returns real product of operands

   function UR_Sub (Left : Ureal; Right : Ureal) return Ureal;
   function UR_Sub (Left : Uint;  Right : Ureal) return Ureal;
   function UR_Sub (Left : Ureal; Right : Uint)  return Ureal;
   --  Returns real difference of operands

   function UR_Exponentiate (Real  : Ureal; N : Uint) return  Ureal;
   --  Returns result of raising Ureal to Uint power.
   --  Fatal error if Left is 0 and Right is negative.

   function UR_Abs (Real : Ureal) return Ureal;
   --  Returns abs function of real

   function UR_Negate (Real : Ureal) return Ureal;
   --  Returns negative of real

   function UR_Eq (Left, Right : Ureal) return Boolean;
   --  Compares reals for equality.

   function UR_Max (Left, Right : Ureal) return Ureal;
   --  Returns the maximum of two reals

   function UR_Min (Left, Right : Ureal) return Ureal;
   --  Returns the minimum of two reals

   function UR_Ne (Left, Right : Ureal) return Boolean;
   --  Compares reals for inequality.

   function UR_Lt (Left, Right : Ureal) return Boolean;
   --  Compares reals for less than.

   function UR_Le (Left, Right : Ureal) return Boolean;
   --  Compares reals for less than or equal.

   function UR_Gt (Left, Right : Ureal) return Boolean;
   --  Compares reals for greater than.

   function UR_Ge (Left, Right : Ureal) return Boolean;
   --  Compares reals for greater than or equal.

   function UR_Is_Zero (Real : Ureal) return Boolean;
   --  Tests if real value is zero

   function UR_Is_Negative (Real : Ureal) return Boolean;
   --  Tests if real value is negative, note that negative zero gives true

   function UR_Is_Positive (Real : Ureal) return Boolean;
   --  Test if real value is greater than zero

   procedure UR_Write (Real : Ureal);
   --  Writes value of Real to standard output. Used only for debugging and
   --  tree/source output. If the result is easily representable as a standard
   --  Ada literal, it will be given that way, but as a result of evaluation
   --  of static expressions, it is possible to generate constants (e.g. 1/13)
   --  which have no such representation. In such cases (and in cases where it
   --  is too much work to figure out the Ada literal), the string that is
   --  output is of the form [numerator/denominator].

   procedure pr (Real : Ureal);
   pragma Export (Ada, pr);
   --  Writes value of Real to standard output with a terminating line return,
   --  using UR_Write as described above. This is for use from the debugger.

   ------------------------
   -- Operator Renamings --
   ------------------------

   function "+" (Left : Ureal; Right : Ureal) return Ureal renames UR_Add;
   function "+" (Left : Uint;  Right : Ureal) return Ureal renames UR_Add;
   function "+" (Left : Ureal; Right : Uint)  return Ureal renames UR_Add;

   function "/" (Left : Ureal; Right : Ureal) return Ureal renames UR_Div;
   function "/" (Left : Uint;  Right : Ureal) return Ureal renames UR_Div;
   function "/" (Left : Ureal; Right : Uint)  return Ureal renames UR_Div;

   function "*" (Left : Ureal; Right : Ureal) return Ureal renames UR_Mul;
   function "*" (Left : Uint;  Right : Ureal) return Ureal renames UR_Mul;
   function "*" (Left : Ureal; Right : Uint)  return Ureal renames UR_Mul;

   function "-" (Left : Ureal; Right : Ureal) return Ureal renames UR_Sub;
   function "-" (Left : Uint;  Right : Ureal) return Ureal renames UR_Sub;
   function "-" (Left : Ureal; Right : Uint)  return Ureal renames UR_Sub;

   function "**"  (Real  : Ureal; N : Uint) return Ureal
                                                     renames UR_Exponentiate;

   function "abs" (Real : Ureal) return Ureal renames UR_Abs;

   function "-"   (Real : Ureal) return Ureal renames UR_Negate;

   function "="   (Left, Right : Ureal) return Boolean renames UR_Eq;

   function "<"   (Left, Right : Ureal) return Boolean renames UR_Lt;

   function "<="  (Left, Right : Ureal) return Boolean renames UR_Le;

   function ">="  (Left, Right : Ureal) return Boolean renames UR_Ge;

   function ">"   (Left, Right : Ureal) return Boolean renames UR_Gt;

   -----------------------------
   -- Mark/Release Processing --
   -----------------------------

   --  The space used by Ureal data is not automatically reclaimed. However,
   --  a mark-release regime is implemented which allows storage to be
   --  released back to a previously noted mark. This is used for example
   --  when doing comparisons, where only intermediate results get stored
   --  that do not need to be saved for future use.

   type Save_Mark is private;

   function Mark return Save_Mark;
   --  Note mark point for future release

   procedure Release (M : Save_Mark);
   --  Release storage allocated since mark was noted

   ------------------------------------
   -- Representation of Ureal Values --
   ------------------------------------

private

   type Ureal is new Int range Ureal_Low_Bound .. Ureal_High_Bound;
   for Ureal'Size use 32;

   No_Ureal : constant Ureal := Ureal'First;

   type Save_Mark is new Int;

   pragma Inline (Denominator);
   pragma Inline (Mark);
   pragma Inline (Norm_Num);
   pragma Inline (Norm_Den);
   pragma Inline (Numerator);
   pragma Inline (Rbase);
   pragma Inline (Release);
   pragma Inline (Ureal_0);
   pragma Inline (Ureal_M_0);
   pragma Inline (Ureal_Tenth);
   pragma Inline (Ureal_Half);
   pragma Inline (Ureal_1);
   pragma Inline (Ureal_2);
   pragma Inline (Ureal_10);
   pragma Inline (UR_From_Components);

end Urealp;