1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 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 ------------------------------------------------------------------------------
36 with Output
; use Output
;
38 with Tree_IO
; use Tree_IO
;
40 package body Urealp
is
42 Ureal_First_Entry
: constant Ureal
:= Ureal
'Succ (No_Ureal
);
43 -- First subscript allocated in Ureal table (note that we can't just
44 -- add 1 to No_Ureal, since "+" means something different for Ureals!
46 type Ureal_Entry
is record
48 -- Numerator (always non-negative)
51 -- Denominator (always non-zero, always positive if base is zero)
54 -- Base value. If Rbase is zero, then the value is simply Num / Den.
55 -- If Rbase is non-zero, then the value is Num / (Rbase ** Den)
58 -- Flag set if value is negative
62 package Ureals
is new Table
.Table
(
63 Table_Component_Type
=> Ureal_Entry
,
64 Table_Index_Type
=> Ureal
,
65 Table_Low_Bound
=> Ureal_First_Entry
,
66 Table_Initial
=> Alloc
.Ureals_Initial
,
67 Table_Increment
=> Alloc
.Ureals_Increment
,
68 Table_Name
=> "Ureals");
70 -- The following universal reals are the values returned by the constant
71 -- functions. They are initialized by the initialization procedure.
84 Num_Ureal_Constants
: constant := 10;
85 -- This is used for an assertion check in Tree_Read and Tree_Write to
86 -- help remember to add values to these routines when we add to the list.
88 Normalized_Real
: Ureal
:= No_Ureal
;
89 -- Used to memoize Norm_Num and Norm_Den, if either of these functions
90 -- is called, this value is set and Normalized_Entry contains the result
91 -- of the normalization. On subsequent calls, this is used to avoid the
92 -- call to Normalize if it has already been made.
94 Normalized_Entry
: Ureal_Entry
;
95 -- Entry built by most recent call to Normalize
97 -----------------------
98 -- Local Subprograms --
99 -----------------------
101 function Decimal_Exponent_Hi
(V
: Ureal
) return Int
;
102 -- Returns an estimate of the exponent of Val represented as a normalized
103 -- decimal number (non-zero digit before decimal point), The estimate is
104 -- either correct, or high, but never low. The accuracy of the estimate
105 -- affects only the efficiency of the comparison routines.
107 function Decimal_Exponent_Lo
(V
: Ureal
) return Int
;
108 -- Returns an estimate of the exponent of Val represented as a normalized
109 -- decimal number (non-zero digit before decimal point), The estimate is
110 -- either correct, or low, but never high. The accuracy of the estimate
111 -- affects only the efficiency of the comparison routines.
113 function Equivalent_Decimal_Exponent
(U
: Ureal_Entry
) return Int
;
114 -- U is a Ureal entry for which the base value is non-zero, the value
115 -- returned is the equivalent decimal exponent value, i.e. the value of
116 -- Den, adjusted as though the base were base 10. The value is rounded
117 -- to the nearest integer, and so can be one off.
119 function Is_Integer
(Num
, Den
: Uint
) return Boolean;
120 -- Return true if the real quotient of Num / Den is an integer value
122 function Normalize
(Val
: Ureal_Entry
) return Ureal_Entry
;
123 -- Normalizes the Ureal_Entry by reducing it to lowest terms (with a
126 function Same
(U1
, U2
: Ureal
) return Boolean;
127 pragma Inline
(Same
);
128 -- Determines if U1 and U2 are the same Ureal. Note that we cannot use
129 -- the equals operator for this test, since that tests for equality,
132 function Store_Ureal
(Val
: Ureal_Entry
) return Ureal
;
133 -- This store a new entry in the universal reals table and return
134 -- its index in the table.
136 -------------------------
137 -- Decimal_Exponent_Hi --
138 -------------------------
140 function Decimal_Exponent_Hi
(V
: Ureal
) return Int
is
141 Val
: constant Ureal_Entry
:= Ureals
.Table
(V
);
144 -- Zero always returns zero
146 if UR_Is_Zero
(V
) then
149 -- For numbers in rational form, get the maximum number of digits in the
150 -- numerator and the minimum number of digits in the denominator, and
151 -- subtract. For example:
153 -- 1000 / 99 = 1.010E+1
154 -- 9999 / 10 = 9.999E+2
156 -- This estimate may of course be high, but that is acceptable
158 elsif Val
.Rbase
= 0 then
159 return UI_Decimal_Digits_Hi
(Val
.Num
) -
160 UI_Decimal_Digits_Lo
(Val
.Den
);
162 -- For based numbers, just subtract the decimal exponent from the
163 -- high estimate of the number of digits in the numerator and add
164 -- one to accommodate possible round off errors for non-decimal
165 -- bases. For example:
167 -- 1_500_000 / 10**4 = 1.50E-2
169 else -- Val.Rbase /= 0
170 return UI_Decimal_Digits_Hi
(Val
.Num
) -
171 Equivalent_Decimal_Exponent
(Val
) + 1;
174 end Decimal_Exponent_Hi
;
176 -------------------------
177 -- Decimal_Exponent_Lo --
178 -------------------------
180 function Decimal_Exponent_Lo
(V
: Ureal
) return Int
is
181 Val
: constant Ureal_Entry
:= Ureals
.Table
(V
);
184 -- Zero always returns zero
186 if UR_Is_Zero
(V
) then
189 -- For numbers in rational form, get min digits in numerator, max digits
190 -- in denominator, and subtract and subtract one more for possible loss
191 -- during the division. For example:
193 -- 1000 / 99 = 1.010E+1
194 -- 9999 / 10 = 9.999E+2
196 -- This estimate may of course be low, but that is acceptable
198 elsif Val
.Rbase
= 0 then
199 return UI_Decimal_Digits_Lo
(Val
.Num
) -
200 UI_Decimal_Digits_Hi
(Val
.Den
) - 1;
202 -- For based numbers, just subtract the decimal exponent from the
203 -- low estimate of the number of digits in the numerator and subtract
204 -- one to accommodate possible round off errors for non-decimal
205 -- bases. For example:
207 -- 1_500_000 / 10**4 = 1.50E-2
209 else -- Val.Rbase /= 0
210 return UI_Decimal_Digits_Lo
(Val
.Num
) -
211 Equivalent_Decimal_Exponent
(Val
) - 1;
214 end Decimal_Exponent_Lo
;
220 function Denominator
(Real
: Ureal
) return Uint
is
222 return Ureals
.Table
(Real
).Den
;
225 ---------------------------------
226 -- Equivalent_Decimal_Exponent --
227 ---------------------------------
229 function Equivalent_Decimal_Exponent
(U
: Ureal_Entry
) return Int
is
231 -- The following table is a table of logs to the base 10
233 Logs
: constant array (Nat
range 1 .. 16) of Long_Float := (
234 1 => 0.000000000000000,
235 2 => 0.301029995663981,
236 3 => 0.477121254719662,
237 4 => 0.602059991327962,
238 5 => 0.698970004336019,
239 6 => 0.778151250383644,
240 7 => 0.845098040014257,
241 8 => 0.903089986991944,
242 9 => 0.954242509439325,
243 10 => 1.000000000000000,
244 11 => 1.041392685158230,
245 12 => 1.079181246047620,
246 13 => 1.113943352306840,
247 14 => 1.146128035678240,
248 15 => 1.176091259055680,
249 16 => 1.204119982655920);
252 pragma Assert
(U
.Rbase
/= 0);
253 return Int
(Long_Float (UI_To_Int
(U
.Den
)) * Logs
(U
.Rbase
));
254 end Equivalent_Decimal_Exponent
;
260 procedure Initialize
is
263 UR_0
:= UR_From_Components
(Uint_0
, Uint_1
, 0, False);
264 UR_M_0
:= UR_From_Components
(Uint_0
, Uint_1
, 0, True);
265 UR_Half
:= UR_From_Components
(Uint_1
, Uint_1
, 2, False);
266 UR_Tenth
:= UR_From_Components
(Uint_1
, Uint_1
, 10, False);
267 UR_1
:= UR_From_Components
(Uint_1
, Uint_1
, 0, False);
268 UR_2
:= UR_From_Components
(Uint_1
, Uint_Minus_1
, 2, False);
269 UR_10
:= UR_From_Components
(Uint_1
, Uint_Minus_1
, 10, False);
270 UR_100
:= UR_From_Components
(Uint_1
, Uint_Minus_2
, 10, False);
271 UR_2_128
:= UR_From_Components
(Uint_1
, Uint_Minus_128
, 2, False);
272 UR_2_M_128
:= UR_From_Components
(Uint_1
, Uint_128
, 2, False);
279 function Is_Integer
(Num
, Den
: Uint
) return Boolean is
281 return (Num
/ Den
) * Den
= Num
;
288 function Mark
return Save_Mark
is
290 return Save_Mark
(Ureals
.Last
);
297 function Norm_Den
(Real
: Ureal
) return Uint
is
299 if not Same
(Real
, Normalized_Real
) then
300 Normalized_Real
:= Real
;
301 Normalized_Entry
:= Normalize
(Ureals
.Table
(Real
));
304 return Normalized_Entry
.Den
;
311 function Norm_Num
(Real
: Ureal
) return Uint
is
313 if not Same
(Real
, Normalized_Real
) then
314 Normalized_Real
:= Real
;
315 Normalized_Entry
:= Normalize
(Ureals
.Table
(Real
));
318 return Normalized_Entry
.Num
;
325 function Normalize
(Val
: Ureal_Entry
) return Ureal_Entry
is
331 M
: constant Uintp
.Save_Mark
:= Uintp
.Mark
;
334 -- Start by setting J to the greatest of the absolute values of the
335 -- numerator and the denominator (taking into account the base value),
336 -- and K to the lesser of the two absolute values. The gcd of Num and
337 -- Den is the gcd of J and K.
339 if Val
.Rbase
= 0 then
343 elsif Val
.Den
< 0 then
344 J
:= Val
.Num
* Val
.Rbase
** (-Val
.Den
);
349 K
:= Val
.Rbase
** Val
.Den
;
364 Uintp
.Release_And_Save
(M
, Num
, Den
);
366 -- Divide numerator and denominator by gcd and return result
371 Negative
=> Val
.Negative
);
378 function Numerator
(Real
: Ureal
) return Uint
is
380 return Ureals
.Table
(Real
).Num
;
387 procedure pr
(Real
: Ureal
) is
397 function Rbase
(Real
: Ureal
) return Nat
is
399 return Ureals
.Table
(Real
).Rbase
;
406 procedure Release
(M
: Save_Mark
) is
408 Ureals
.Set_Last
(Ureal
(M
));
415 function Same
(U1
, U2
: Ureal
) return Boolean is
417 return Int
(U1
) = Int
(U2
);
424 function Store_Ureal
(Val
: Ureal_Entry
) return Ureal
is
426 Ureals
.Increment_Last
;
427 Ureals
.Table
(Ureals
.Last
) := Val
;
429 -- Normalize representation of signed values
432 Ureals
.Table
(Ureals
.Last
).Negative
:= True;
433 Ureals
.Table
(Ureals
.Last
).Num
:= -Val
.Num
;
443 procedure Tree_Read
is
445 pragma Assert
(Num_Ureal_Constants
= 10);
448 Tree_Read_Int
(Int
(UR_0
));
449 Tree_Read_Int
(Int
(UR_M_0
));
450 Tree_Read_Int
(Int
(UR_Tenth
));
451 Tree_Read_Int
(Int
(UR_Half
));
452 Tree_Read_Int
(Int
(UR_1
));
453 Tree_Read_Int
(Int
(UR_2
));
454 Tree_Read_Int
(Int
(UR_10
));
455 Tree_Read_Int
(Int
(UR_100
));
456 Tree_Read_Int
(Int
(UR_2_128
));
457 Tree_Read_Int
(Int
(UR_2_M_128
));
459 -- Clear the normalization cache
461 Normalized_Real
:= No_Ureal
;
468 procedure Tree_Write
is
470 pragma Assert
(Num_Ureal_Constants
= 10);
473 Tree_Write_Int
(Int
(UR_0
));
474 Tree_Write_Int
(Int
(UR_M_0
));
475 Tree_Write_Int
(Int
(UR_Tenth
));
476 Tree_Write_Int
(Int
(UR_Half
));
477 Tree_Write_Int
(Int
(UR_1
));
478 Tree_Write_Int
(Int
(UR_2
));
479 Tree_Write_Int
(Int
(UR_10
));
480 Tree_Write_Int
(Int
(UR_100
));
481 Tree_Write_Int
(Int
(UR_2_128
));
482 Tree_Write_Int
(Int
(UR_2_M_128
));
489 function UR_Abs
(Real
: Ureal
) return Ureal
is
490 Val
: constant Ureal_Entry
:= Ureals
.Table
(Real
);
504 function UR_Add
(Left
: Uint
; Right
: Ureal
) return Ureal
is
506 return UR_From_Uint
(Left
) + Right
;
509 function UR_Add
(Left
: Ureal
; Right
: Uint
) return Ureal
is
511 return Left
+ UR_From_Uint
(Right
);
514 function UR_Add
(Left
: Ureal
; Right
: Ureal
) return Ureal
is
515 Lval
: Ureal_Entry
:= Ureals
.Table
(Left
);
516 Rval
: Ureal_Entry
:= Ureals
.Table
(Right
);
521 -- Note, in the temporary Ureal_Entry values used in this procedure,
522 -- we store the sign as the sign of the numerator (i.e. xxx.Num may
523 -- be negative, even though in stored entries this can never be so)
525 if Lval
.Rbase
/= 0 and then Lval
.Rbase
= Rval
.Rbase
then
528 Opd_Min
, Opd_Max
: Ureal_Entry
;
529 Exp_Min
, Exp_Max
: Uint
;
532 if Lval
.Negative
then
533 Lval
.Num
:= (-Lval
.Num
);
536 if Rval
.Negative
then
537 Rval
.Num
:= (-Rval
.Num
);
540 if Lval
.Den
< Rval
.Den
then
553 Opd_Min
.Num
* Lval
.Rbase
** (Exp_Max
- Exp_Min
) + Opd_Max
.Num
;
560 Negative
=> Lval
.Negative
));
567 Negative
=> (Num
< 0)));
573 Ln
: Ureal_Entry
:= Normalize
(Lval
);
574 Rn
: Ureal_Entry
:= Normalize
(Rval
);
585 Num
:= (Ln
.Num
* Rn
.Den
) + (Rn
.Num
* Ln
.Den
);
592 Negative
=> Lval
.Negative
));
598 Den
=> Ln
.Den
* Rn
.Den
,
600 Negative
=> (Num
< 0))));
610 function UR_Ceiling
(Real
: Ureal
) return Uint
is
611 Val
: Ureal_Entry
:= Normalize
(Ureals
.Table
(Real
));
615 return UI_Negate
(Val
.Num
/ Val
.Den
);
617 return (Val
.Num
+ Val
.Den
- 1) / Val
.Den
;
625 function UR_Div
(Left
: Uint
; Right
: Ureal
) return Ureal
is
627 return UR_From_Uint
(Left
) / Right
;
630 function UR_Div
(Left
: Ureal
; Right
: Uint
) return Ureal
is
632 return Left
/ UR_From_Uint
(Right
);
635 function UR_Div
(Left
, Right
: Ureal
) return Ureal
is
636 Lval
: constant Ureal_Entry
:= Ureals
.Table
(Left
);
637 Rval
: constant Ureal_Entry
:= Ureals
.Table
(Right
);
638 Rneg
: constant Boolean := Rval
.Negative
xor Lval
.Negative
;
641 pragma Assert
(Rval
.Num
/= Uint_0
);
643 if Lval
.Rbase
= 0 then
645 if Rval
.Rbase
= 0 then
648 (Num
=> Lval
.Num
* Rval
.Den
,
649 Den
=> Lval
.Den
* Rval
.Num
,
653 elsif Is_Integer
(Lval
.Num
, Rval
.Num
* Lval
.Den
) then
655 (Num
=> Lval
.Num
/ (Rval
.Num
* Lval
.Den
),
660 elsif Rval
.Den
< 0 then
664 Den
=> Rval
.Rbase
** (-Rval
.Den
) *
673 (Num
=> Lval
.Num
* Rval
.Rbase
** Rval
.Den
,
674 Den
=> Rval
.Num
* Lval
.Den
,
679 elsif Is_Integer
(Lval
.Num
, Rval
.Num
) then
681 if Rval
.Rbase
= Lval
.Rbase
then
683 (Num
=> Lval
.Num
/ Rval
.Num
,
684 Den
=> Lval
.Den
- Rval
.Den
,
688 elsif Rval
.Rbase
= 0 then
690 (Num
=> (Lval
.Num
/ Rval
.Num
) * Rval
.Den
,
695 elsif Rval
.Den
< 0 then
701 Num
:= (Lval
.Num
/ Rval
.Num
) * (Lval
.Rbase
** (-Lval
.Den
));
702 Den
:= Rval
.Rbase
** (-Rval
.Den
);
704 Num
:= Lval
.Num
/ Rval
.Num
;
705 Den
:= (Lval
.Rbase
** Lval
.Den
) *
706 (Rval
.Rbase
** (-Rval
.Den
));
718 (Num
=> (Lval
.Num
/ Rval
.Num
) *
719 (Rval
.Rbase
** Rval
.Den
),
731 Num
:= Lval
.Num
* (Lval
.Rbase
** (-Lval
.Den
));
736 Den
:= Rval
.Num
* (Lval
.Rbase
** Lval
.Den
);
739 if Rval
.Rbase
/= 0 then
741 Den
:= Den
* (Rval
.Rbase
** (-Rval
.Den
));
743 Num
:= Num
* (Rval
.Rbase
** Rval
.Den
);
747 Num
:= Num
* Rval
.Den
;
764 function UR_Eq
(Left
, Right
: Ureal
) return Boolean is
766 return not UR_Ne
(Left
, Right
);
769 ---------------------
770 -- UR_Exponentiate --
771 ---------------------
773 function UR_Exponentiate
(Real
: Ureal
; N
: Uint
) return Ureal
is
781 -- If base is negative, then the resulting sign depends on whether
782 -- the exponent is even or odd (even => positive, odd = negative)
784 if UR_Is_Negative
(Real
) then
785 Neg
:= (N
mod 2) /= 0;
786 Bas
:= UR_Negate
(Real
);
792 Val
:= Ureals
.Table
(Bas
);
794 -- If the base is a small integer, then we can return the result in
795 -- exponential form, which can save a lot of time for junk exponents.
797 IBas
:= UR_Trunc
(Bas
);
800 and then UR_From_Uint
(IBas
) = Bas
805 Rbase
=> UI_To_Int
(UR_Trunc
(Bas
)),
808 -- If the exponent is negative then we raise the numerator and the
809 -- denominator (after normalization) to the absolute value of the
810 -- exponent and we return the reciprocal. An assert error will happen
811 -- if the numerator is zero.
814 pragma Assert
(Val
.Num
/= 0);
815 Val
:= Normalize
(Val
);
818 (Num
=> Val
.Den
** X
,
823 -- If positive, we distinguish the case when the base is not zero, in
824 -- which case the new denominator is just the product of the old one
825 -- with the exponent,
828 if Val
.Rbase
/= 0 then
831 (Num
=> Val
.Num
** X
,
836 -- And when the base is zero, in which case we exponentiate
837 -- the old denominator.
841 (Num
=> Val
.Num
** X
,
853 function UR_Floor
(Real
: Ureal
) return Uint
is
854 Val
: Ureal_Entry
:= Normalize
(Ureals
.Table
(Real
));
858 return UI_Negate
((Val
.Num
+ Val
.Den
- 1) / Val
.Den
);
860 return Val
.Num
/ Val
.Den
;
864 -------------------------
865 -- UR_From_Components --
866 -------------------------
868 function UR_From_Components
872 Negative
: Boolean := False)
880 Negative
=> Negative
));
881 end UR_From_Components
;
887 function UR_From_Uint
(UI
: Uint
) return Ureal
is
889 return UR_From_Components
890 (abs UI
, Uint_1
, Negative
=> (UI
< 0));
897 function UR_Ge
(Left
, Right
: Ureal
) return Boolean is
899 return not (Left
< Right
);
906 function UR_Gt
(Left
, Right
: Ureal
) return Boolean is
908 return (Right
< Left
);
915 function UR_Is_Negative
(Real
: Ureal
) return Boolean is
917 return Ureals
.Table
(Real
).Negative
;
924 function UR_Is_Positive
(Real
: Ureal
) return Boolean is
926 return not Ureals
.Table
(Real
).Negative
927 and then Ureals
.Table
(Real
).Num
/= 0;
934 function UR_Is_Zero
(Real
: Ureal
) return Boolean is
936 return Ureals
.Table
(Real
).Num
= 0;
943 function UR_Le
(Left
, Right
: Ureal
) return Boolean is
945 return not (Right
< Left
);
952 function UR_Lt
(Left
, Right
: Ureal
) return Boolean is
954 -- An operand is not less than itself
956 if Same
(Left
, Right
) then
959 -- Deal with zero cases
961 elsif UR_Is_Zero
(Left
) then
962 return UR_Is_Positive
(Right
);
964 elsif UR_Is_Zero
(Right
) then
965 return Ureals
.Table
(Left
).Negative
;
967 -- Different signs are decisive (note we dealt with zero cases)
969 elsif Ureals
.Table
(Left
).Negative
970 and then not Ureals
.Table
(Right
).Negative
974 elsif not Ureals
.Table
(Left
).Negative
975 and then Ureals
.Table
(Right
).Negative
979 -- Signs are same, do rapid check based on worst case estimates of
980 -- decimal exponent, which will often be decisive. Precise test
981 -- depends on whether operands are positive or negative.
983 elsif Decimal_Exponent_Hi
(Left
) < Decimal_Exponent_Lo
(Right
) then
984 return UR_Is_Positive
(Left
);
986 elsif Decimal_Exponent_Lo
(Left
) > Decimal_Exponent_Hi
(Right
) then
987 return UR_Is_Negative
(Left
);
989 -- If we fall through, full gruesome test is required. This happens
990 -- if the numbers are close together, or in some weird (/=10) base.
994 Imrk
: constant Uintp
.Save_Mark
:= Mark
;
995 Rmrk
: constant Urealp
.Save_Mark
:= Mark
;
1001 Lval
:= Ureals
.Table
(Left
);
1002 Rval
:= Ureals
.Table
(Right
);
1004 -- An optimization. If both numbers are based, then subtract
1005 -- common value of base to avoid unnecessarily giant numbers
1007 if Lval
.Rbase
= Rval
.Rbase
and then Lval
.Rbase
/= 0 then
1008 if Lval
.Den
< Rval
.Den
then
1009 Rval
.Den
:= Rval
.Den
- Lval
.Den
;
1012 Lval
.Den
:= Lval
.Den
- Rval
.Den
;
1017 Lval
:= Normalize
(Lval
);
1018 Rval
:= Normalize
(Rval
);
1020 if Lval
.Negative
then
1021 Result
:= (Lval
.Num
* Rval
.Den
) > (Rval
.Num
* Lval
.Den
);
1023 Result
:= (Lval
.Num
* Rval
.Den
) < (Rval
.Num
* Lval
.Den
);
1037 function UR_Max
(Left
, Right
: Ureal
) return Ureal
is
1039 if Left
>= Right
then
1050 function UR_Min
(Left
, Right
: Ureal
) return Ureal
is
1052 if Left
<= Right
then
1063 function UR_Mul
(Left
: Uint
; Right
: Ureal
) return Ureal
is
1065 return UR_From_Uint
(Left
) * Right
;
1068 function UR_Mul
(Left
: Ureal
; Right
: Uint
) return Ureal
is
1070 return Left
* UR_From_Uint
(Right
);
1073 function UR_Mul
(Left
, Right
: Ureal
) return Ureal
is
1074 Lval
: constant Ureal_Entry
:= Ureals
.Table
(Left
);
1075 Rval
: constant Ureal_Entry
:= Ureals
.Table
(Right
);
1076 Num
: Uint
:= Lval
.Num
* Rval
.Num
;
1078 Rneg
: constant Boolean := Lval
.Negative
xor Rval
.Negative
;
1081 if Lval
.Rbase
= 0 then
1082 if Rval
.Rbase
= 0 then
1083 return Store_Ureal
(
1086 Den
=> Lval
.Den
* Rval
.Den
,
1088 Negative
=> Rneg
)));
1090 elsif Is_Integer
(Num
, Lval
.Den
) then
1091 return Store_Ureal
(
1092 (Num
=> Num
/ Lval
.Den
,
1094 Rbase
=> Rval
.Rbase
,
1097 elsif Rval
.Den
< 0 then
1098 return Store_Ureal
(
1100 (Num
=> Num
* (Rval
.Rbase
** (-Rval
.Den
)),
1103 Negative
=> Rneg
)));
1106 return Store_Ureal
(
1109 Den
=> Lval
.Den
* (Rval
.Rbase
** Rval
.Den
),
1111 Negative
=> Rneg
)));
1114 elsif Lval
.Rbase
= Rval
.Rbase
then
1115 return Store_Ureal
(
1117 Den
=> Lval
.Den
+ Rval
.Den
,
1118 Rbase
=> Lval
.Rbase
,
1121 elsif Rval
.Rbase
= 0 then
1122 if Is_Integer
(Num
, Rval
.Den
) then
1123 return Store_Ureal
(
1124 (Num
=> Num
/ Rval
.Den
,
1126 Rbase
=> Lval
.Rbase
,
1129 elsif Lval
.Den
< 0 then
1130 return Store_Ureal
(
1132 (Num
=> Num
* (Lval
.Rbase
** (-Lval
.Den
)),
1135 Negative
=> Rneg
)));
1138 return Store_Ureal
(
1141 Den
=> Rval
.Den
* (Lval
.Rbase
** Lval
.Den
),
1143 Negative
=> Rneg
)));
1149 if Lval
.Den
< 0 then
1150 Num
:= Num
* (Lval
.Rbase
** (-Lval
.Den
));
1152 Den
:= Den
* (Lval
.Rbase
** Lval
.Den
);
1155 if Rval
.Den
< 0 then
1156 Num
:= Num
* (Rval
.Rbase
** (-Rval
.Den
));
1158 Den
:= Den
* (Rval
.Rbase
** Rval
.Den
);
1161 return Store_Ureal
(
1166 Negative
=> Rneg
)));
1175 function UR_Ne
(Left
, Right
: Ureal
) return Boolean is
1177 -- Quick processing for case of identical Ureal values (note that
1178 -- this also deals with comparing two No_Ureal values).
1180 if Same
(Left
, Right
) then
1183 -- Deal with case of one or other operand is No_Ureal, but not both
1185 elsif Same
(Left
, No_Ureal
) or else Same
(Right
, No_Ureal
) then
1188 -- Do quick check based on number of decimal digits
1190 elsif Decimal_Exponent_Hi
(Left
) < Decimal_Exponent_Lo
(Right
) or else
1191 Decimal_Exponent_Lo
(Left
) > Decimal_Exponent_Hi
(Right
)
1195 -- Otherwise full comparison is required
1199 Imrk
: constant Uintp
.Save_Mark
:= Mark
;
1200 Rmrk
: constant Urealp
.Save_Mark
:= Mark
;
1201 Lval
: constant Ureal_Entry
:= Normalize
(Ureals
.Table
(Left
));
1202 Rval
: constant Ureal_Entry
:= Normalize
(Ureals
.Table
(Right
));
1206 if UR_Is_Zero
(Left
) then
1207 return not UR_Is_Zero
(Right
);
1209 elsif UR_Is_Zero
(Right
) then
1210 return not UR_Is_Zero
(Left
);
1212 -- Both operands are non-zero
1216 Rval
.Negative
/= Lval
.Negative
1217 or else Rval
.Num
/= Lval
.Num
1218 or else Rval
.Den
/= Lval
.Den
;
1231 function UR_Negate
(Real
: Ureal
) return Ureal
is
1233 return Store_Ureal
(
1234 (Num
=> Ureals
.Table
(Real
).Num
,
1235 Den
=> Ureals
.Table
(Real
).Den
,
1236 Rbase
=> Ureals
.Table
(Real
).Rbase
,
1237 Negative
=> not Ureals
.Table
(Real
).Negative
));
1244 function UR_Sub
(Left
: Uint
; Right
: Ureal
) return Ureal
is
1246 return UR_From_Uint
(Left
) + UR_Negate
(Right
);
1249 function UR_Sub
(Left
: Ureal
; Right
: Uint
) return Ureal
is
1251 return Left
+ UR_From_Uint
(-Right
);
1254 function UR_Sub
(Left
, Right
: Ureal
) return Ureal
is
1256 return Left
+ UR_Negate
(Right
);
1263 function UR_To_Uint
(Real
: Ureal
) return Uint
is
1264 Val
: Ureal_Entry
:= Normalize
(Ureals
.Table
(Real
));
1268 Res
:= (Val
.Num
+ (Val
.Den
/ 2)) / Val
.Den
;
1270 if Val
.Negative
then
1271 return UI_Negate
(Res
);
1281 function UR_Trunc
(Real
: Ureal
) return Uint
is
1282 Val
: constant Ureal_Entry
:= Normalize
(Ureals
.Table
(Real
));
1285 if Val
.Negative
then
1286 return -(Val
.Num
/ Val
.Den
);
1288 return Val
.Num
/ Val
.Den
;
1296 procedure UR_Write
(Real
: Ureal
) is
1297 Val
: constant Ureal_Entry
:= Ureals
.Table
(Real
);
1300 -- If value is negative, we precede the constant by a minus sign
1301 -- and add an extra layer of parentheses on the outside since the
1302 -- minus sign is part of the value, not a negation operator.
1304 if Val
.Negative
then
1308 -- Constants in base 10 can be written in normal Ada literal style
1309 -- If the literal is negative enclose in parens to emphasize that
1310 -- it is part of the constant, and not a separate negation operator
1312 if Val
.Rbase
= 10 then
1314 UI_Write
(Val
.Num
/ 10);
1316 UI_Write
(Val
.Num
mod 10);
1318 if Val
.Den
/= 0 then
1320 UI_Write
(1 - Val
.Den
);
1323 -- Constants in a base other than 10 can still be easily written
1324 -- in normal Ada literal style if the numerator is one.
1326 elsif Val
.Rbase
/= 0 and then Val
.Num
= 1 then
1327 Write_Int
(Val
.Rbase
);
1328 Write_Str
("#1.0#E");
1329 UI_Write
(-Val
.Den
);
1331 -- Other constants with a base other than 10 are written using one
1332 -- of the following forms, depending on the sign of the number
1333 -- and the sign of the exponent (= minus denominator value)
1335 -- (numerator.0*base**exponent)
1336 -- (numerator.0*base**(-exponent))
1338 elsif Val
.Rbase
/= 0 then
1340 UI_Write
(Val
.Num
, Decimal
);
1342 Write_Int
(Val
.Rbase
);
1345 if Val
.Den
<= 0 then
1346 UI_Write
(-Val
.Den
, Decimal
);
1350 UI_Write
(Val
.Den
, Decimal
);
1356 -- Rational constants with a denominator of 1 can be written as
1357 -- a real literal for the numerator integer.
1359 elsif Val
.Den
= 1 then
1360 UI_Write
(Val
.Num
, Decimal
);
1363 -- Non-based (rational) constants are written in (num/den) style
1367 UI_Write
(Val
.Num
, Decimal
);
1369 UI_Write
(Val
.Den
, Decimal
);
1373 -- Add trailing paren for negative values
1375 if Val
.Negative
then
1385 function Ureal_0
return Ureal
is
1394 function Ureal_1
return Ureal
is
1403 function Ureal_2
return Ureal
is
1412 function Ureal_10
return Ureal
is
1421 function Ureal_100
return Ureal
is
1430 function Ureal_2_128
return Ureal
is
1439 function Ureal_2_M_128
return Ureal
is
1448 function Ureal_Half
return Ureal
is
1457 function Ureal_M_0
return Ureal
is
1466 function Ureal_Tenth
return Ureal
is