1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
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 2, 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. 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 GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
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. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 -- Support for universal real arithmetic
37 with Types
; use Types
;
38 with Uintp
; use Uintp
;
42 ---------------------------------------
43 -- Representation of Universal Reals --
44 ---------------------------------------
46 -- A universal real value is represented by a single value (which is
47 -- an index into an internal table). These values are not hashed, so
48 -- the equality operator should not be used on Ureal values (instead
49 -- use the UR_Eq function).
51 -- A Ureal value represents an arbitrary precision universal real value,
52 -- stored internally using four components
54 -- the numerator (Uint, always non-negative)
55 -- the denominator (Uint, always non-zero, always positive if base = 0)
56 -- a real base (Nat, either zero, or in the range 2 .. 16)
57 -- a sign flag (Boolean), set if negative
59 -- If the base is zero, then the absolute value of the Ureal is simply
60 -- numerator/denominator. If the base is non-zero, then the absolute
61 -- value is num / (rbase ** den).
63 -- Negative numbers are represented by the sign of the numerator being
64 -- negative. The denominator is always positive.
66 -- A normalized Ureal value has base = 0, and numerator/denominator
67 -- reduced to lowest terms, with zero itself being represented as 0/1.
68 -- This is a canonical format, so that for normalized Ureal values it
69 -- is the case that two equal values always have the same denominator
70 -- and numerator values.
72 -- Note: a value of minus zero is legitimate, and the operations in
73 -- Urealp preserve the handling of signed zeroes in accordance with
74 -- the rules of IEEE P754 ("IEEE floating point").
76 ------------------------------
77 -- Types for Urealp Package --
78 ------------------------------
80 type Ureal
is private;
81 -- Type used for representation of universal reals
83 No_Ureal
: constant Ureal
;
84 -- Constant used to indicate missing or unset Ureal value
90 function Ureal_0
return Ureal
;
93 function Ureal_M_0
return Ureal
;
96 function Ureal_Tenth
return Ureal
;
99 function Ureal_Half
return Ureal
;
102 function Ureal_1
return Ureal
;
105 function Ureal_2
return Ureal
;
108 function Ureal_10
return Ureal
;
109 -- Returns value 10.0
111 function Ureal_100
return Ureal
;
112 -- Returns value 100.0
114 function Ureal_2_128
return Ureal
;
115 -- Returns value 2.0 ** 128
117 function Ureal_2_M_128
return Ureal
;
118 -- Returns value 2.0 ** (-128)
124 procedure Initialize
;
125 -- Initialize Ureal tables. Note that Initialize must not be called if
126 -- Tree_Read is used. Note also that there is no Lock routine in this
127 -- unit. These tables are among the few tables that can be expanded
128 -- during Gigi processing.
131 -- Initializes internal tables from current tree file using Tree_Read.
132 -- Note that Initialize should not be called if Tree_Read is used.
133 -- Tree_Read includes all necessary initialization.
135 procedure Tree_Write
;
136 -- Writes out internal tables to current tree file using Tree_Write
138 function Rbase
(Real
: Ureal
) return Nat
;
139 -- Return the base of the universal real.
141 function Denominator
(Real
: Ureal
) return Uint
;
142 -- Return the denominator of the universal real.
144 function Numerator
(Real
: Ureal
) return Uint
;
145 -- Return the numerator of the universal real.
147 function Norm_Den
(Real
: Ureal
) return Uint
;
148 -- Return the denominator of the universal real after a normalization.
150 function Norm_Num
(Real
: Ureal
) return Uint
;
151 -- Return the numerator of the universal real after a normalization.
153 function UR_From_Uint
(UI
: Uint
) return Ureal
;
154 -- Returns real corresponding to universal integer value
156 function UR_To_Uint
(Real
: Ureal
) return Uint
;
157 -- Return integer value obtained by accurate rounding of real value.
158 -- The rounding of values half way between two integers is away from
159 -- zero, as required by normal Ada 95 rounding semantics.
161 function UR_Trunc
(Real
: Ureal
) return Uint
;
162 -- Return integer value obtained by a truncation of real towards zero
164 function UR_Ceiling
(Real
: Ureal
) return Uint
;
165 -- Return value of smallest integer not less than the given value
167 function UR_Floor
(Real
: Ureal
) return Uint
;
168 -- Return value of smallest integer not greater than the given value
170 -- Conversion table for above four functions
172 -- Input To_Uint Trunc Ceiling Floor
184 function UR_From_Components
188 Negative
: Boolean := False)
190 -- Builds real value from given numerator, denominator and base. The
191 -- value is negative if Negative is set to true, and otherwise is
194 function UR_Add
(Left
: Ureal
; Right
: Ureal
) return Ureal
;
195 function UR_Add
(Left
: Ureal
; Right
: Uint
) return Ureal
;
196 function UR_Add
(Left
: Uint
; Right
: Ureal
) return Ureal
;
197 -- Returns real sum of operands
199 function UR_Div
(Left
: Ureal
; Right
: Ureal
) return Ureal
;
200 function UR_Div
(Left
: Uint
; Right
: Ureal
) return Ureal
;
201 function UR_Div
(Left
: Ureal
; Right
: Uint
) return Ureal
;
202 -- Returns real quotient of operands. Fatal error if Right is zero
204 function UR_Mul
(Left
: Ureal
; Right
: Ureal
) return Ureal
;
205 function UR_Mul
(Left
: Uint
; Right
: Ureal
) return Ureal
;
206 function UR_Mul
(Left
: Ureal
; Right
: Uint
) return Ureal
;
207 -- Returns real product of operands
209 function UR_Sub
(Left
: Ureal
; Right
: Ureal
) return Ureal
;
210 function UR_Sub
(Left
: Uint
; Right
: Ureal
) return Ureal
;
211 function UR_Sub
(Left
: Ureal
; Right
: Uint
) return Ureal
;
212 -- Returns real difference of operands
214 function UR_Exponentiate
(Real
: Ureal
; N
: Uint
) return Ureal
;
215 -- Returns result of raising Ureal to Uint power.
216 -- Fatal error if Left is 0 and Right is negative.
218 function UR_Abs
(Real
: Ureal
) return Ureal
;
219 -- Returns abs function of real
221 function UR_Negate
(Real
: Ureal
) return Ureal
;
222 -- Returns negative of real
224 function UR_Eq
(Left
, Right
: Ureal
) return Boolean;
225 -- Compares reals for equality.
227 function UR_Max
(Left
, Right
: Ureal
) return Ureal
;
228 -- Returns the maximum of two reals
230 function UR_Min
(Left
, Right
: Ureal
) return Ureal
;
231 -- Returns the minimum of two reals
233 function UR_Ne
(Left
, Right
: Ureal
) return Boolean;
234 -- Compares reals for inequality.
236 function UR_Lt
(Left
, Right
: Ureal
) return Boolean;
237 -- Compares reals for less than.
239 function UR_Le
(Left
, Right
: Ureal
) return Boolean;
240 -- Compares reals for less than or equal.
242 function UR_Gt
(Left
, Right
: Ureal
) return Boolean;
243 -- Compares reals for greater than.
245 function UR_Ge
(Left
, Right
: Ureal
) return Boolean;
246 -- Compares reals for greater than or equal.
248 function UR_Is_Zero
(Real
: Ureal
) return Boolean;
249 -- Tests if real value is zero
251 function UR_Is_Negative
(Real
: Ureal
) return Boolean;
252 -- Tests if real value is negative, note that negative zero gives true
254 function UR_Is_Positive
(Real
: Ureal
) return Boolean;
255 -- Test if real value is greater than zero
257 procedure UR_Write
(Real
: Ureal
);
258 -- Writes value of Real to standard output. Used only for debugging and
259 -- tree/source output. If the result is easily representable as a standard
260 -- Ada literal, it will be given that way, but as a result of evaluation
261 -- of static expressions, it is possible to generate constants (e.g. 1/13)
262 -- which have no such representation. In such cases (and in cases where it
263 -- is too much work to figure out the Ada literal), the string that is
264 -- output is of the form [numerator/denominator].
266 procedure pr
(Real
: Ureal
);
267 pragma Export
(Ada
, pr
);
268 -- Writes value of Real to standard output with a terminating line return,
269 -- using UR_Write as described above. This is for use from the debugger.
271 ------------------------
272 -- Operator Renamings --
273 ------------------------
275 function "+" (Left
: Ureal
; Right
: Ureal
) return Ureal
renames UR_Add
;
276 function "+" (Left
: Uint
; Right
: Ureal
) return Ureal
renames UR_Add
;
277 function "+" (Left
: Ureal
; Right
: Uint
) return Ureal
renames UR_Add
;
279 function "/" (Left
: Ureal
; Right
: Ureal
) return Ureal
renames UR_Div
;
280 function "/" (Left
: Uint
; Right
: Ureal
) return Ureal
renames UR_Div
;
281 function "/" (Left
: Ureal
; Right
: Uint
) return Ureal
renames UR_Div
;
283 function "*" (Left
: Ureal
; Right
: Ureal
) return Ureal
renames UR_Mul
;
284 function "*" (Left
: Uint
; Right
: Ureal
) return Ureal
renames UR_Mul
;
285 function "*" (Left
: Ureal
; Right
: Uint
) return Ureal
renames UR_Mul
;
287 function "-" (Left
: Ureal
; Right
: Ureal
) return Ureal
renames UR_Sub
;
288 function "-" (Left
: Uint
; Right
: Ureal
) return Ureal
renames UR_Sub
;
289 function "-" (Left
: Ureal
; Right
: Uint
) return Ureal
renames UR_Sub
;
291 function "**" (Real
: Ureal
; N
: Uint
) return Ureal
292 renames UR_Exponentiate
;
294 function "abs" (Real
: Ureal
) return Ureal
renames UR_Abs
;
296 function "-" (Real
: Ureal
) return Ureal
renames UR_Negate
;
298 function "=" (Left
, Right
: Ureal
) return Boolean renames UR_Eq
;
300 function "<" (Left
, Right
: Ureal
) return Boolean renames UR_Lt
;
302 function "<=" (Left
, Right
: Ureal
) return Boolean renames UR_Le
;
304 function ">=" (Left
, Right
: Ureal
) return Boolean renames UR_Ge
;
306 function ">" (Left
, Right
: Ureal
) return Boolean renames UR_Gt
;
308 -----------------------------
309 -- Mark/Release Processing --
310 -----------------------------
312 -- The space used by Ureal data is not automatically reclaimed. However,
313 -- a mark-release regime is implemented which allows storage to be
314 -- released back to a previously noted mark. This is used for example
315 -- when doing comparisons, where only intermediate results get stored
316 -- that do not need to be saved for future use.
318 type Save_Mark
is private;
320 function Mark
return Save_Mark
;
321 -- Note mark point for future release
323 procedure Release
(M
: Save_Mark
);
324 -- Release storage allocated since mark was noted
326 ------------------------------------
327 -- Representation of Ureal Values --
328 ------------------------------------
332 type Ureal
is new Int
range Ureal_Low_Bound
.. Ureal_High_Bound
;
333 for Ureal
'Size use 32;
335 No_Ureal
: constant Ureal
:= Ureal
'First;
337 type Save_Mark
is new Int
;
339 pragma Inline
(Denominator
);
340 pragma Inline
(Mark
);
341 pragma Inline
(Norm_Num
);
342 pragma Inline
(Norm_Den
);
343 pragma Inline
(Numerator
);
344 pragma Inline
(Rbase
);
345 pragma Inline
(Release
);
346 pragma Inline
(Ureal_0
);
347 pragma Inline
(Ureal_M_0
);
348 pragma Inline
(Ureal_Tenth
);
349 pragma Inline
(Ureal_Half
);
350 pragma Inline
(Ureal_1
);
351 pragma Inline
(Ureal_2
);
352 pragma Inline
(Ureal_10
);
353 pragma Inline
(UR_From_Components
);