2008-05-30 Vladimir Makarov <vmakarov@redhat.com>
[official-gcc.git] / gcc / ada / urealp.adb
blob17dd9178e2c3511ac66e3e968567f5746e073eba
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- U R E A L P --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 with Alloc;
35 with Output; use Output;
36 with Table;
37 with Tree_IO; use Tree_IO;
39 package body Urealp is
41 Ureal_First_Entry : constant Ureal := Ureal'Succ (No_Ureal);
42 -- First subscript allocated in Ureal table (note that we can't just
43 -- add 1 to No_Ureal, since "+" means something different for Ureals!
45 type Ureal_Entry is record
46 Num : Uint;
47 -- Numerator (always non-negative)
49 Den : Uint;
50 -- Denominator (always non-zero, always positive if base is zero)
52 Rbase : Nat;
53 -- Base value. If Rbase is zero, then the value is simply Num / Den.
54 -- If Rbase is non-zero, then the value is Num / (Rbase ** Den)
56 Negative : Boolean;
57 -- Flag set if value is negative
58 end record;
60 -- The following representation clause ensures that the above record
61 -- has no holes. We do this so that when instances of this record are
62 -- written by Tree_Gen, we do not write uninitialized values to the file.
64 for Ureal_Entry use record
65 Num at 0 range 0 .. 31;
66 Den at 4 range 0 .. 31;
67 Rbase at 8 range 0 .. 31;
68 Negative at 12 range 0 .. 31;
69 end record;
71 for Ureal_Entry'Size use 16 * 8;
72 -- This ensures that we did not leave out any fields
74 package Ureals is new Table.Table (
75 Table_Component_Type => Ureal_Entry,
76 Table_Index_Type => Ureal'Base,
77 Table_Low_Bound => Ureal_First_Entry,
78 Table_Initial => Alloc.Ureals_Initial,
79 Table_Increment => Alloc.Ureals_Increment,
80 Table_Name => "Ureals");
82 -- The following universal reals are the values returned by the constant
83 -- functions. They are initialized by the initialization procedure.
85 UR_0 : Ureal;
86 UR_M_0 : Ureal;
87 UR_Tenth : Ureal;
88 UR_Half : Ureal;
89 UR_1 : Ureal;
90 UR_2 : Ureal;
91 UR_10 : Ureal;
92 UR_10_36 : Ureal;
93 UR_M_10_36 : Ureal;
94 UR_100 : Ureal;
95 UR_2_128 : Ureal;
96 UR_2_80 : Ureal;
97 UR_2_M_128 : Ureal;
98 UR_2_M_80 : Ureal;
100 Num_Ureal_Constants : constant := 10;
101 -- This is used for an assertion check in Tree_Read and Tree_Write to
102 -- help remember to add values to these routines when we add to the list.
104 Normalized_Real : Ureal := No_Ureal;
105 -- Used to memoize Norm_Num and Norm_Den, if either of these functions
106 -- is called, this value is set and Normalized_Entry contains the result
107 -- of the normalization. On subsequent calls, this is used to avoid the
108 -- call to Normalize if it has already been made.
110 Normalized_Entry : Ureal_Entry;
111 -- Entry built by most recent call to Normalize
113 -----------------------
114 -- Local Subprograms --
115 -----------------------
117 function Decimal_Exponent_Hi (V : Ureal) return Int;
118 -- Returns an estimate of the exponent of Val represented as a normalized
119 -- decimal number (non-zero digit before decimal point), The estimate is
120 -- either correct, or high, but never low. The accuracy of the estimate
121 -- affects only the efficiency of the comparison routines.
123 function Decimal_Exponent_Lo (V : Ureal) return Int;
124 -- Returns an estimate of the exponent of Val represented as a normalized
125 -- decimal number (non-zero digit before decimal point), The estimate is
126 -- either correct, or low, but never high. The accuracy of the estimate
127 -- affects only the efficiency of the comparison routines.
129 function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int;
130 -- U is a Ureal entry for which the base value is non-zero, the value
131 -- returned is the equivalent decimal exponent value, i.e. the value of
132 -- Den, adjusted as though the base were base 10. The value is rounded
133 -- to the nearest integer, and so can be one off.
135 function Is_Integer (Num, Den : Uint) return Boolean;
136 -- Return true if the real quotient of Num / Den is an integer value
138 function Normalize (Val : Ureal_Entry) return Ureal_Entry;
139 -- Normalizes the Ureal_Entry by reducing it to lowest terms (with a
140 -- base value of 0).
142 function Same (U1, U2 : Ureal) return Boolean;
143 pragma Inline (Same);
144 -- Determines if U1 and U2 are the same Ureal. Note that we cannot use
145 -- the equals operator for this test, since that tests for equality,
146 -- not identity.
148 function Store_Ureal (Val : Ureal_Entry) return Ureal;
149 -- This store a new entry in the universal reals table and return
150 -- its index in the table.
152 -------------------------
153 -- Decimal_Exponent_Hi --
154 -------------------------
156 function Decimal_Exponent_Hi (V : Ureal) return Int is
157 Val : constant Ureal_Entry := Ureals.Table (V);
159 begin
160 -- Zero always returns zero
162 if UR_Is_Zero (V) then
163 return 0;
165 -- For numbers in rational form, get the maximum number of digits in the
166 -- numerator and the minimum number of digits in the denominator, and
167 -- subtract. For example:
169 -- 1000 / 99 = 1.010E+1
170 -- 9999 / 10 = 9.999E+2
172 -- This estimate may of course be high, but that is acceptable
174 elsif Val.Rbase = 0 then
175 return UI_Decimal_Digits_Hi (Val.Num) -
176 UI_Decimal_Digits_Lo (Val.Den);
178 -- For based numbers, just subtract the decimal exponent from the
179 -- high estimate of the number of digits in the numerator and add
180 -- one to accommodate possible round off errors for non-decimal
181 -- bases. For example:
183 -- 1_500_000 / 10**4 = 1.50E-2
185 else -- Val.Rbase /= 0
186 return UI_Decimal_Digits_Hi (Val.Num) -
187 Equivalent_Decimal_Exponent (Val) + 1;
188 end if;
189 end Decimal_Exponent_Hi;
191 -------------------------
192 -- Decimal_Exponent_Lo --
193 -------------------------
195 function Decimal_Exponent_Lo (V : Ureal) return Int is
196 Val : constant Ureal_Entry := Ureals.Table (V);
198 begin
199 -- Zero always returns zero
201 if UR_Is_Zero (V) then
202 return 0;
204 -- For numbers in rational form, get min digits in numerator, max digits
205 -- in denominator, and subtract and subtract one more for possible loss
206 -- during the division. For example:
208 -- 1000 / 99 = 1.010E+1
209 -- 9999 / 10 = 9.999E+2
211 -- This estimate may of course be low, but that is acceptable
213 elsif Val.Rbase = 0 then
214 return UI_Decimal_Digits_Lo (Val.Num) -
215 UI_Decimal_Digits_Hi (Val.Den) - 1;
217 -- For based numbers, just subtract the decimal exponent from the
218 -- low estimate of the number of digits in the numerator and subtract
219 -- one to accommodate possible round off errors for non-decimal
220 -- bases. For example:
222 -- 1_500_000 / 10**4 = 1.50E-2
224 else -- Val.Rbase /= 0
225 return UI_Decimal_Digits_Lo (Val.Num) -
226 Equivalent_Decimal_Exponent (Val) - 1;
227 end if;
228 end Decimal_Exponent_Lo;
230 -----------------
231 -- Denominator --
232 -----------------
234 function Denominator (Real : Ureal) return Uint is
235 begin
236 return Ureals.Table (Real).Den;
237 end Denominator;
239 ---------------------------------
240 -- Equivalent_Decimal_Exponent --
241 ---------------------------------
243 function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int is
245 -- The following table is a table of logs to the base 10
247 Logs : constant array (Nat range 1 .. 16) of Long_Float := (
248 1 => 0.000000000000000,
249 2 => 0.301029995663981,
250 3 => 0.477121254719662,
251 4 => 0.602059991327962,
252 5 => 0.698970004336019,
253 6 => 0.778151250383644,
254 7 => 0.845098040014257,
255 8 => 0.903089986991944,
256 9 => 0.954242509439325,
257 10 => 1.000000000000000,
258 11 => 1.041392685158230,
259 12 => 1.079181246047620,
260 13 => 1.113943352306840,
261 14 => 1.146128035678240,
262 15 => 1.176091259055680,
263 16 => 1.204119982655920);
265 begin
266 pragma Assert (U.Rbase /= 0);
267 return Int (Long_Float (UI_To_Int (U.Den)) * Logs (U.Rbase));
268 end Equivalent_Decimal_Exponent;
270 ----------------
271 -- Initialize --
272 ----------------
274 procedure Initialize is
275 begin
276 Ureals.Init;
277 UR_0 := UR_From_Components (Uint_0, Uint_1, 0, False);
278 UR_M_0 := UR_From_Components (Uint_0, Uint_1, 0, True);
279 UR_Half := UR_From_Components (Uint_1, Uint_1, 2, False);
280 UR_Tenth := UR_From_Components (Uint_1, Uint_1, 10, False);
281 UR_1 := UR_From_Components (Uint_1, Uint_1, 0, False);
282 UR_2 := UR_From_Components (Uint_1, Uint_Minus_1, 2, False);
283 UR_10 := UR_From_Components (Uint_1, Uint_Minus_1, 10, False);
284 UR_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, False);
285 UR_M_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, True);
286 UR_100 := UR_From_Components (Uint_1, Uint_Minus_2, 10, False);
287 UR_2_128 := UR_From_Components (Uint_1, Uint_Minus_128, 2, False);
288 UR_2_M_128 := UR_From_Components (Uint_1, Uint_128, 2, False);
289 UR_2_80 := UR_From_Components (Uint_1, Uint_Minus_80, 2, False);
290 UR_2_M_80 := UR_From_Components (Uint_1, Uint_80, 2, False);
291 end Initialize;
293 ----------------
294 -- Is_Integer --
295 ----------------
297 function Is_Integer (Num, Den : Uint) return Boolean is
298 begin
299 return (Num / Den) * Den = Num;
300 end Is_Integer;
302 ----------
303 -- Mark --
304 ----------
306 function Mark return Save_Mark is
307 begin
308 return Save_Mark (Ureals.Last);
309 end Mark;
311 --------------
312 -- Norm_Den --
313 --------------
315 function Norm_Den (Real : Ureal) return Uint is
316 begin
317 if not Same (Real, Normalized_Real) then
318 Normalized_Real := Real;
319 Normalized_Entry := Normalize (Ureals.Table (Real));
320 end if;
322 return Normalized_Entry.Den;
323 end Norm_Den;
325 --------------
326 -- Norm_Num --
327 --------------
329 function Norm_Num (Real : Ureal) return Uint is
330 begin
331 if not Same (Real, Normalized_Real) then
332 Normalized_Real := Real;
333 Normalized_Entry := Normalize (Ureals.Table (Real));
334 end if;
336 return Normalized_Entry.Num;
337 end Norm_Num;
339 ---------------
340 -- Normalize --
341 ---------------
343 function Normalize (Val : Ureal_Entry) return Ureal_Entry is
344 J : Uint;
345 K : Uint;
346 Tmp : Uint;
347 Num : Uint;
348 Den : Uint;
349 M : constant Uintp.Save_Mark := Uintp.Mark;
351 begin
352 -- Start by setting J to the greatest of the absolute values of the
353 -- numerator and the denominator (taking into account the base value),
354 -- and K to the lesser of the two absolute values. The gcd of Num and
355 -- Den is the gcd of J and K.
357 if Val.Rbase = 0 then
358 J := Val.Num;
359 K := Val.Den;
361 elsif Val.Den < 0 then
362 J := Val.Num * Val.Rbase ** (-Val.Den);
363 K := Uint_1;
365 else
366 J := Val.Num;
367 K := Val.Rbase ** Val.Den;
368 end if;
370 Num := J;
371 Den := K;
373 if K > J then
374 Tmp := J;
375 J := K;
376 K := Tmp;
377 end if;
379 J := UI_GCD (J, K);
380 Num := Num / J;
381 Den := Den / J;
382 Uintp.Release_And_Save (M, Num, Den);
384 -- Divide numerator and denominator by gcd and return result
386 return (Num => Num,
387 Den => Den,
388 Rbase => 0,
389 Negative => Val.Negative);
390 end Normalize;
392 ---------------
393 -- Numerator --
394 ---------------
396 function Numerator (Real : Ureal) return Uint is
397 begin
398 return Ureals.Table (Real).Num;
399 end Numerator;
401 --------
402 -- pr --
403 --------
405 procedure pr (Real : Ureal) is
406 begin
407 UR_Write (Real);
408 Write_Eol;
409 end pr;
411 -----------
412 -- Rbase --
413 -----------
415 function Rbase (Real : Ureal) return Nat is
416 begin
417 return Ureals.Table (Real).Rbase;
418 end Rbase;
420 -------------
421 -- Release --
422 -------------
424 procedure Release (M : Save_Mark) is
425 begin
426 Ureals.Set_Last (Ureal (M));
427 end Release;
429 ----------
430 -- Same --
431 ----------
433 function Same (U1, U2 : Ureal) return Boolean is
434 begin
435 return Int (U1) = Int (U2);
436 end Same;
438 -----------------
439 -- Store_Ureal --
440 -----------------
442 function Store_Ureal (Val : Ureal_Entry) return Ureal is
443 begin
444 Ureals.Append (Val);
446 -- Normalize representation of signed values
448 if Val.Num < 0 then
449 Ureals.Table (Ureals.Last).Negative := True;
450 Ureals.Table (Ureals.Last).Num := -Val.Num;
451 end if;
453 return Ureals.Last;
454 end Store_Ureal;
456 ---------------
457 -- Tree_Read --
458 ---------------
460 procedure Tree_Read is
461 begin
462 pragma Assert (Num_Ureal_Constants = 10);
464 Ureals.Tree_Read;
465 Tree_Read_Int (Int (UR_0));
466 Tree_Read_Int (Int (UR_M_0));
467 Tree_Read_Int (Int (UR_Tenth));
468 Tree_Read_Int (Int (UR_Half));
469 Tree_Read_Int (Int (UR_1));
470 Tree_Read_Int (Int (UR_2));
471 Tree_Read_Int (Int (UR_10));
472 Tree_Read_Int (Int (UR_100));
473 Tree_Read_Int (Int (UR_2_128));
474 Tree_Read_Int (Int (UR_2_M_128));
476 -- Clear the normalization cache
478 Normalized_Real := No_Ureal;
479 end Tree_Read;
481 ----------------
482 -- Tree_Write --
483 ----------------
485 procedure Tree_Write is
486 begin
487 pragma Assert (Num_Ureal_Constants = 10);
489 Ureals.Tree_Write;
490 Tree_Write_Int (Int (UR_0));
491 Tree_Write_Int (Int (UR_M_0));
492 Tree_Write_Int (Int (UR_Tenth));
493 Tree_Write_Int (Int (UR_Half));
494 Tree_Write_Int (Int (UR_1));
495 Tree_Write_Int (Int (UR_2));
496 Tree_Write_Int (Int (UR_10));
497 Tree_Write_Int (Int (UR_100));
498 Tree_Write_Int (Int (UR_2_128));
499 Tree_Write_Int (Int (UR_2_M_128));
500 end Tree_Write;
502 ------------
503 -- UR_Abs --
504 ------------
506 function UR_Abs (Real : Ureal) return Ureal is
507 Val : constant Ureal_Entry := Ureals.Table (Real);
509 begin
510 return Store_Ureal (
511 (Num => Val.Num,
512 Den => Val.Den,
513 Rbase => Val.Rbase,
514 Negative => False));
515 end UR_Abs;
517 ------------
518 -- UR_Add --
519 ------------
521 function UR_Add (Left : Uint; Right : Ureal) return Ureal is
522 begin
523 return UR_From_Uint (Left) + Right;
524 end UR_Add;
526 function UR_Add (Left : Ureal; Right : Uint) return Ureal is
527 begin
528 return Left + UR_From_Uint (Right);
529 end UR_Add;
531 function UR_Add (Left : Ureal; Right : Ureal) return Ureal is
532 Lval : Ureal_Entry := Ureals.Table (Left);
533 Rval : Ureal_Entry := Ureals.Table (Right);
535 Num : Uint;
537 begin
538 -- Note, in the temporary Ureal_Entry values used in this procedure,
539 -- we store the sign as the sign of the numerator (i.e. xxx.Num may
540 -- be negative, even though in stored entries this can never be so)
542 if Lval.Rbase /= 0 and then Lval.Rbase = Rval.Rbase then
544 declare
545 Opd_Min, Opd_Max : Ureal_Entry;
546 Exp_Min, Exp_Max : Uint;
548 begin
549 if Lval.Negative then
550 Lval.Num := (-Lval.Num);
551 end if;
553 if Rval.Negative then
554 Rval.Num := (-Rval.Num);
555 end if;
557 if Lval.Den < Rval.Den then
558 Exp_Min := Lval.Den;
559 Exp_Max := Rval.Den;
560 Opd_Min := Lval;
561 Opd_Max := Rval;
562 else
563 Exp_Min := Rval.Den;
564 Exp_Max := Lval.Den;
565 Opd_Min := Rval;
566 Opd_Max := Lval;
567 end if;
569 Num :=
570 Opd_Min.Num * Lval.Rbase ** (Exp_Max - Exp_Min) + Opd_Max.Num;
572 if Num = 0 then
573 return Store_Ureal (
574 (Num => Uint_0,
575 Den => Uint_1,
576 Rbase => 0,
577 Negative => Lval.Negative));
579 else
580 return Store_Ureal (
581 (Num => abs Num,
582 Den => Exp_Max,
583 Rbase => Lval.Rbase,
584 Negative => (Num < 0)));
585 end if;
586 end;
588 else
589 declare
590 Ln : Ureal_Entry := Normalize (Lval);
591 Rn : Ureal_Entry := Normalize (Rval);
593 begin
594 if Ln.Negative then
595 Ln.Num := (-Ln.Num);
596 end if;
598 if Rn.Negative then
599 Rn.Num := (-Rn.Num);
600 end if;
602 Num := (Ln.Num * Rn.Den) + (Rn.Num * Ln.Den);
604 if Num = 0 then
605 return Store_Ureal (
606 (Num => Uint_0,
607 Den => Uint_1,
608 Rbase => 0,
609 Negative => Lval.Negative));
611 else
612 return Store_Ureal (
613 Normalize (
614 (Num => abs Num,
615 Den => Ln.Den * Rn.Den,
616 Rbase => 0,
617 Negative => (Num < 0))));
618 end if;
619 end;
620 end if;
621 end UR_Add;
623 ----------------
624 -- UR_Ceiling --
625 ----------------
627 function UR_Ceiling (Real : Ureal) return Uint is
628 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
630 begin
631 if Val.Negative then
632 return UI_Negate (Val.Num / Val.Den);
633 else
634 return (Val.Num + Val.Den - 1) / Val.Den;
635 end if;
636 end UR_Ceiling;
638 ------------
639 -- UR_Div --
640 ------------
642 function UR_Div (Left : Uint; Right : Ureal) return Ureal is
643 begin
644 return UR_From_Uint (Left) / Right;
645 end UR_Div;
647 function UR_Div (Left : Ureal; Right : Uint) return Ureal is
648 begin
649 return Left / UR_From_Uint (Right);
650 end UR_Div;
652 function UR_Div (Left, Right : Ureal) return Ureal is
653 Lval : constant Ureal_Entry := Ureals.Table (Left);
654 Rval : constant Ureal_Entry := Ureals.Table (Right);
655 Rneg : constant Boolean := Rval.Negative xor Lval.Negative;
657 begin
658 pragma Assert (Rval.Num /= Uint_0);
660 if Lval.Rbase = 0 then
662 if Rval.Rbase = 0 then
663 return Store_Ureal (
664 Normalize (
665 (Num => Lval.Num * Rval.Den,
666 Den => Lval.Den * Rval.Num,
667 Rbase => 0,
668 Negative => Rneg)));
670 elsif Is_Integer (Lval.Num, Rval.Num * Lval.Den) then
671 return Store_Ureal (
672 (Num => Lval.Num / (Rval.Num * Lval.Den),
673 Den => (-Rval.Den),
674 Rbase => Rval.Rbase,
675 Negative => Rneg));
677 elsif Rval.Den < 0 then
678 return Store_Ureal (
679 Normalize (
680 (Num => Lval.Num,
681 Den => Rval.Rbase ** (-Rval.Den) *
682 Rval.Num *
683 Lval.Den,
684 Rbase => 0,
685 Negative => Rneg)));
687 else
688 return Store_Ureal (
689 Normalize (
690 (Num => Lval.Num * Rval.Rbase ** Rval.Den,
691 Den => Rval.Num * Lval.Den,
692 Rbase => 0,
693 Negative => Rneg)));
694 end if;
696 elsif Is_Integer (Lval.Num, Rval.Num) then
698 if Rval.Rbase = Lval.Rbase then
699 return Store_Ureal (
700 (Num => Lval.Num / Rval.Num,
701 Den => Lval.Den - Rval.Den,
702 Rbase => Lval.Rbase,
703 Negative => Rneg));
705 elsif Rval.Rbase = 0 then
706 return Store_Ureal (
707 (Num => (Lval.Num / Rval.Num) * Rval.Den,
708 Den => Lval.Den,
709 Rbase => Lval.Rbase,
710 Negative => Rneg));
712 elsif Rval.Den < 0 then
713 declare
714 Num, Den : Uint;
716 begin
717 if Lval.Den < 0 then
718 Num := (Lval.Num / Rval.Num) * (Lval.Rbase ** (-Lval.Den));
719 Den := Rval.Rbase ** (-Rval.Den);
720 else
721 Num := Lval.Num / Rval.Num;
722 Den := (Lval.Rbase ** Lval.Den) *
723 (Rval.Rbase ** (-Rval.Den));
724 end if;
726 return Store_Ureal (
727 (Num => Num,
728 Den => Den,
729 Rbase => 0,
730 Negative => Rneg));
731 end;
733 else
734 return Store_Ureal (
735 (Num => (Lval.Num / Rval.Num) *
736 (Rval.Rbase ** Rval.Den),
737 Den => Lval.Den,
738 Rbase => Lval.Rbase,
739 Negative => Rneg));
740 end if;
742 else
743 declare
744 Num, Den : Uint;
746 begin
747 if Lval.Den < 0 then
748 Num := Lval.Num * (Lval.Rbase ** (-Lval.Den));
749 Den := Rval.Num;
751 else
752 Num := Lval.Num;
753 Den := Rval.Num * (Lval.Rbase ** Lval.Den);
754 end if;
756 if Rval.Rbase /= 0 then
757 if Rval.Den < 0 then
758 Den := Den * (Rval.Rbase ** (-Rval.Den));
759 else
760 Num := Num * (Rval.Rbase ** Rval.Den);
761 end if;
763 else
764 Num := Num * Rval.Den;
765 end if;
767 return Store_Ureal (
768 Normalize (
769 (Num => Num,
770 Den => Den,
771 Rbase => 0,
772 Negative => Rneg)));
773 end;
774 end if;
775 end UR_Div;
777 -----------
778 -- UR_Eq --
779 -----------
781 function UR_Eq (Left, Right : Ureal) return Boolean is
782 begin
783 return not UR_Ne (Left, Right);
784 end UR_Eq;
786 ---------------------
787 -- UR_Exponentiate --
788 ---------------------
790 function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal is
791 X : constant Uint := abs N;
792 Bas : Ureal;
793 Val : Ureal_Entry;
794 Neg : Boolean;
795 IBas : Uint;
797 begin
798 -- If base is negative, then the resulting sign depends on whether
799 -- the exponent is even or odd (even => positive, odd = negative)
801 if UR_Is_Negative (Real) then
802 Neg := (N mod 2) /= 0;
803 Bas := UR_Negate (Real);
804 else
805 Neg := False;
806 Bas := Real;
807 end if;
809 Val := Ureals.Table (Bas);
811 -- If the base is a small integer, then we can return the result in
812 -- exponential form, which can save a lot of time for junk exponents.
814 IBas := UR_Trunc (Bas);
816 if IBas <= 16
817 and then UR_From_Uint (IBas) = Bas
818 then
819 return Store_Ureal (
820 (Num => Uint_1,
821 Den => -N,
822 Rbase => UI_To_Int (UR_Trunc (Bas)),
823 Negative => Neg));
825 -- If the exponent is negative then we raise the numerator and the
826 -- denominator (after normalization) to the absolute value of the
827 -- exponent and we return the reciprocal. An assert error will happen
828 -- if the numerator is zero.
830 elsif N < 0 then
831 pragma Assert (Val.Num /= 0);
832 Val := Normalize (Val);
834 return Store_Ureal (
835 (Num => Val.Den ** X,
836 Den => Val.Num ** X,
837 Rbase => 0,
838 Negative => Neg));
840 -- If positive, we distinguish the case when the base is not zero, in
841 -- which case the new denominator is just the product of the old one
842 -- with the exponent,
844 else
845 if Val.Rbase /= 0 then
847 return Store_Ureal (
848 (Num => Val.Num ** X,
849 Den => Val.Den * X,
850 Rbase => Val.Rbase,
851 Negative => Neg));
853 -- And when the base is zero, in which case we exponentiate
854 -- the old denominator.
856 else
857 return Store_Ureal (
858 (Num => Val.Num ** X,
859 Den => Val.Den ** X,
860 Rbase => 0,
861 Negative => Neg));
862 end if;
863 end if;
864 end UR_Exponentiate;
866 --------------
867 -- UR_Floor --
868 --------------
870 function UR_Floor (Real : Ureal) return Uint is
871 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
873 begin
874 if Val.Negative then
875 return UI_Negate ((Val.Num + Val.Den - 1) / Val.Den);
876 else
877 return Val.Num / Val.Den;
878 end if;
879 end UR_Floor;
881 ------------------------
882 -- UR_From_Components --
883 ------------------------
885 function UR_From_Components
886 (Num : Uint;
887 Den : Uint;
888 Rbase : Nat := 0;
889 Negative : Boolean := False)
890 return Ureal
892 begin
893 return Store_Ureal (
894 (Num => Num,
895 Den => Den,
896 Rbase => Rbase,
897 Negative => Negative));
898 end UR_From_Components;
900 ------------------
901 -- UR_From_Uint --
902 ------------------
904 function UR_From_Uint (UI : Uint) return Ureal is
905 begin
906 return UR_From_Components
907 (abs UI, Uint_1, Negative => (UI < 0));
908 end UR_From_Uint;
910 -----------
911 -- UR_Ge --
912 -----------
914 function UR_Ge (Left, Right : Ureal) return Boolean is
915 begin
916 return not (Left < Right);
917 end UR_Ge;
919 -----------
920 -- UR_Gt --
921 -----------
923 function UR_Gt (Left, Right : Ureal) return Boolean is
924 begin
925 return (Right < Left);
926 end UR_Gt;
928 --------------------
929 -- UR_Is_Negative --
930 --------------------
932 function UR_Is_Negative (Real : Ureal) return Boolean is
933 begin
934 return Ureals.Table (Real).Negative;
935 end UR_Is_Negative;
937 --------------------
938 -- UR_Is_Positive --
939 --------------------
941 function UR_Is_Positive (Real : Ureal) return Boolean is
942 begin
943 return not Ureals.Table (Real).Negative
944 and then Ureals.Table (Real).Num /= 0;
945 end UR_Is_Positive;
947 ----------------
948 -- UR_Is_Zero --
949 ----------------
951 function UR_Is_Zero (Real : Ureal) return Boolean is
952 begin
953 return Ureals.Table (Real).Num = 0;
954 end UR_Is_Zero;
956 -----------
957 -- UR_Le --
958 -----------
960 function UR_Le (Left, Right : Ureal) return Boolean is
961 begin
962 return not (Right < Left);
963 end UR_Le;
965 -----------
966 -- UR_Lt --
967 -----------
969 function UR_Lt (Left, Right : Ureal) return Boolean is
970 begin
971 -- An operand is not less than itself
973 if Same (Left, Right) then
974 return False;
976 -- Deal with zero cases
978 elsif UR_Is_Zero (Left) then
979 return UR_Is_Positive (Right);
981 elsif UR_Is_Zero (Right) then
982 return Ureals.Table (Left).Negative;
984 -- Different signs are decisive (note we dealt with zero cases)
986 elsif Ureals.Table (Left).Negative
987 and then not Ureals.Table (Right).Negative
988 then
989 return True;
991 elsif not Ureals.Table (Left).Negative
992 and then Ureals.Table (Right).Negative
993 then
994 return False;
996 -- Signs are same, do rapid check based on worst case estimates of
997 -- decimal exponent, which will often be decisive. Precise test
998 -- depends on whether operands are positive or negative.
1000 elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) then
1001 return UR_Is_Positive (Left);
1003 elsif Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right) then
1004 return UR_Is_Negative (Left);
1006 -- If we fall through, full gruesome test is required. This happens
1007 -- if the numbers are close together, or in some weird (/=10) base.
1009 else
1010 declare
1011 Imrk : constant Uintp.Save_Mark := Mark;
1012 Rmrk : constant Urealp.Save_Mark := Mark;
1013 Lval : Ureal_Entry;
1014 Rval : Ureal_Entry;
1015 Result : Boolean;
1017 begin
1018 Lval := Ureals.Table (Left);
1019 Rval := Ureals.Table (Right);
1021 -- An optimization. If both numbers are based, then subtract
1022 -- common value of base to avoid unnecessarily giant numbers
1024 if Lval.Rbase = Rval.Rbase and then Lval.Rbase /= 0 then
1025 if Lval.Den < Rval.Den then
1026 Rval.Den := Rval.Den - Lval.Den;
1027 Lval.Den := Uint_0;
1028 else
1029 Lval.Den := Lval.Den - Rval.Den;
1030 Rval.Den := Uint_0;
1031 end if;
1032 end if;
1034 Lval := Normalize (Lval);
1035 Rval := Normalize (Rval);
1037 if Lval.Negative then
1038 Result := (Lval.Num * Rval.Den) > (Rval.Num * Lval.Den);
1039 else
1040 Result := (Lval.Num * Rval.Den) < (Rval.Num * Lval.Den);
1041 end if;
1043 Release (Imrk);
1044 Release (Rmrk);
1045 return Result;
1046 end;
1047 end if;
1048 end UR_Lt;
1050 ------------
1051 -- UR_Max --
1052 ------------
1054 function UR_Max (Left, Right : Ureal) return Ureal is
1055 begin
1056 if Left >= Right then
1057 return Left;
1058 else
1059 return Right;
1060 end if;
1061 end UR_Max;
1063 ------------
1064 -- UR_Min --
1065 ------------
1067 function UR_Min (Left, Right : Ureal) return Ureal is
1068 begin
1069 if Left <= Right then
1070 return Left;
1071 else
1072 return Right;
1073 end if;
1074 end UR_Min;
1076 ------------
1077 -- UR_Mul --
1078 ------------
1080 function UR_Mul (Left : Uint; Right : Ureal) return Ureal is
1081 begin
1082 return UR_From_Uint (Left) * Right;
1083 end UR_Mul;
1085 function UR_Mul (Left : Ureal; Right : Uint) return Ureal is
1086 begin
1087 return Left * UR_From_Uint (Right);
1088 end UR_Mul;
1090 function UR_Mul (Left, Right : Ureal) return Ureal is
1091 Lval : constant Ureal_Entry := Ureals.Table (Left);
1092 Rval : constant Ureal_Entry := Ureals.Table (Right);
1093 Num : Uint := Lval.Num * Rval.Num;
1094 Den : Uint;
1095 Rneg : constant Boolean := Lval.Negative xor Rval.Negative;
1097 begin
1098 if Lval.Rbase = 0 then
1099 if Rval.Rbase = 0 then
1100 return Store_Ureal (
1101 Normalize (
1102 (Num => Num,
1103 Den => Lval.Den * Rval.Den,
1104 Rbase => 0,
1105 Negative => Rneg)));
1107 elsif Is_Integer (Num, Lval.Den) then
1108 return Store_Ureal (
1109 (Num => Num / Lval.Den,
1110 Den => Rval.Den,
1111 Rbase => Rval.Rbase,
1112 Negative => Rneg));
1114 elsif Rval.Den < 0 then
1115 return Store_Ureal (
1116 Normalize (
1117 (Num => Num * (Rval.Rbase ** (-Rval.Den)),
1118 Den => Lval.Den,
1119 Rbase => 0,
1120 Negative => Rneg)));
1122 else
1123 return Store_Ureal (
1124 Normalize (
1125 (Num => Num,
1126 Den => Lval.Den * (Rval.Rbase ** Rval.Den),
1127 Rbase => 0,
1128 Negative => Rneg)));
1129 end if;
1131 elsif Lval.Rbase = Rval.Rbase then
1132 return Store_Ureal (
1133 (Num => Num,
1134 Den => Lval.Den + Rval.Den,
1135 Rbase => Lval.Rbase,
1136 Negative => Rneg));
1138 elsif Rval.Rbase = 0 then
1139 if Is_Integer (Num, Rval.Den) then
1140 return Store_Ureal (
1141 (Num => Num / Rval.Den,
1142 Den => Lval.Den,
1143 Rbase => Lval.Rbase,
1144 Negative => Rneg));
1146 elsif Lval.Den < 0 then
1147 return Store_Ureal (
1148 Normalize (
1149 (Num => Num * (Lval.Rbase ** (-Lval.Den)),
1150 Den => Rval.Den,
1151 Rbase => 0,
1152 Negative => Rneg)));
1154 else
1155 return Store_Ureal (
1156 Normalize (
1157 (Num => Num,
1158 Den => Rval.Den * (Lval.Rbase ** Lval.Den),
1159 Rbase => 0,
1160 Negative => Rneg)));
1161 end if;
1163 else
1164 Den := Uint_1;
1166 if Lval.Den < 0 then
1167 Num := Num * (Lval.Rbase ** (-Lval.Den));
1168 else
1169 Den := Den * (Lval.Rbase ** Lval.Den);
1170 end if;
1172 if Rval.Den < 0 then
1173 Num := Num * (Rval.Rbase ** (-Rval.Den));
1174 else
1175 Den := Den * (Rval.Rbase ** Rval.Den);
1176 end if;
1178 return Store_Ureal (
1179 Normalize (
1180 (Num => Num,
1181 Den => Den,
1182 Rbase => 0,
1183 Negative => Rneg)));
1184 end if;
1185 end UR_Mul;
1187 -----------
1188 -- UR_Ne --
1189 -----------
1191 function UR_Ne (Left, Right : Ureal) return Boolean is
1192 begin
1193 -- Quick processing for case of identical Ureal values (note that
1194 -- this also deals with comparing two No_Ureal values).
1196 if Same (Left, Right) then
1197 return False;
1199 -- Deal with case of one or other operand is No_Ureal, but not both
1201 elsif Same (Left, No_Ureal) or else Same (Right, No_Ureal) then
1202 return True;
1204 -- Do quick check based on number of decimal digits
1206 elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) or else
1207 Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right)
1208 then
1209 return True;
1211 -- Otherwise full comparison is required
1213 else
1214 declare
1215 Imrk : constant Uintp.Save_Mark := Mark;
1216 Rmrk : constant Urealp.Save_Mark := Mark;
1217 Lval : constant Ureal_Entry := Normalize (Ureals.Table (Left));
1218 Rval : constant Ureal_Entry := Normalize (Ureals.Table (Right));
1219 Result : Boolean;
1221 begin
1222 if UR_Is_Zero (Left) then
1223 return not UR_Is_Zero (Right);
1225 elsif UR_Is_Zero (Right) then
1226 return not UR_Is_Zero (Left);
1228 -- Both operands are non-zero
1230 else
1231 Result :=
1232 Rval.Negative /= Lval.Negative
1233 or else Rval.Num /= Lval.Num
1234 or else Rval.Den /= Lval.Den;
1235 Release (Imrk);
1236 Release (Rmrk);
1237 return Result;
1238 end if;
1239 end;
1240 end if;
1241 end UR_Ne;
1243 ---------------
1244 -- UR_Negate --
1245 ---------------
1247 function UR_Negate (Real : Ureal) return Ureal is
1248 begin
1249 return Store_Ureal (
1250 (Num => Ureals.Table (Real).Num,
1251 Den => Ureals.Table (Real).Den,
1252 Rbase => Ureals.Table (Real).Rbase,
1253 Negative => not Ureals.Table (Real).Negative));
1254 end UR_Negate;
1256 ------------
1257 -- UR_Sub --
1258 ------------
1260 function UR_Sub (Left : Uint; Right : Ureal) return Ureal is
1261 begin
1262 return UR_From_Uint (Left) + UR_Negate (Right);
1263 end UR_Sub;
1265 function UR_Sub (Left : Ureal; Right : Uint) return Ureal is
1266 begin
1267 return Left + UR_From_Uint (-Right);
1268 end UR_Sub;
1270 function UR_Sub (Left, Right : Ureal) return Ureal is
1271 begin
1272 return Left + UR_Negate (Right);
1273 end UR_Sub;
1275 ----------------
1276 -- UR_To_Uint --
1277 ----------------
1279 function UR_To_Uint (Real : Ureal) return Uint is
1280 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
1281 Res : Uint;
1283 begin
1284 Res := (Val.Num + (Val.Den / 2)) / Val.Den;
1286 if Val.Negative then
1287 return UI_Negate (Res);
1288 else
1289 return Res;
1290 end if;
1291 end UR_To_Uint;
1293 --------------
1294 -- UR_Trunc --
1295 --------------
1297 function UR_Trunc (Real : Ureal) return Uint is
1298 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
1300 begin
1301 if Val.Negative then
1302 return -(Val.Num / Val.Den);
1303 else
1304 return Val.Num / Val.Den;
1305 end if;
1306 end UR_Trunc;
1308 --------------
1309 -- UR_Write --
1310 --------------
1312 procedure UR_Write (Real : Ureal) is
1313 Val : constant Ureal_Entry := Ureals.Table (Real);
1315 begin
1316 -- If value is negative, we precede the constant by a minus sign
1317 -- and add an extra layer of parentheses on the outside since the
1318 -- minus sign is part of the value, not a negation operator.
1320 if Val.Negative then
1321 Write_Str ("(-");
1322 end if;
1324 -- Constants in base 10 can be written in normal Ada literal style
1326 if Val.Rbase = 10 then
1327 UI_Write (Val.Num / 10);
1328 Write_Char ('.');
1329 UI_Write (Val.Num mod 10);
1331 if Val.Den /= 0 then
1332 Write_Char ('E');
1333 UI_Write (1 - Val.Den);
1334 end if;
1336 -- Constants in a base other than 10 can still be easily written
1337 -- in normal Ada literal style if the numerator is one.
1339 elsif Val.Rbase /= 0 and then Val.Num = 1 then
1340 Write_Int (Val.Rbase);
1341 Write_Str ("#1.0#E");
1342 UI_Write (-Val.Den);
1344 -- Other constants with a base other than 10 are written using one
1345 -- of the following forms, depending on the sign of the number
1346 -- and the sign of the exponent (= minus denominator value)
1348 -- (numerator.0*base**exponent)
1349 -- (numerator.0*base**(-exponent))
1351 elsif Val.Rbase /= 0 then
1352 Write_Char ('(');
1353 UI_Write (Val.Num, Decimal);
1354 Write_Str (".0*");
1355 Write_Int (Val.Rbase);
1356 Write_Str ("**");
1358 if Val.Den <= 0 then
1359 UI_Write (-Val.Den, Decimal);
1361 else
1362 Write_Str ("(-");
1363 UI_Write (Val.Den, Decimal);
1364 Write_Char (')');
1365 end if;
1367 Write_Char (')');
1369 -- Rational constants with a denominator of 1 can be written as
1370 -- a real literal for the numerator integer.
1372 elsif Val.Den = 1 then
1373 UI_Write (Val.Num, Decimal);
1374 Write_Str (".0");
1376 -- Non-based (rational) constants are written in (num/den) style
1378 else
1379 Write_Char ('(');
1380 UI_Write (Val.Num, Decimal);
1381 Write_Str (".0/");
1382 UI_Write (Val.Den, Decimal);
1383 Write_Str (".0)");
1384 end if;
1386 -- Add trailing paren for negative values
1388 if Val.Negative then
1389 Write_Char (')');
1390 end if;
1391 end UR_Write;
1393 -------------
1394 -- Ureal_0 --
1395 -------------
1397 function Ureal_0 return Ureal is
1398 begin
1399 return UR_0;
1400 end Ureal_0;
1402 -------------
1403 -- Ureal_1 --
1404 -------------
1406 function Ureal_1 return Ureal is
1407 begin
1408 return UR_1;
1409 end Ureal_1;
1411 -------------
1412 -- Ureal_2 --
1413 -------------
1415 function Ureal_2 return Ureal is
1416 begin
1417 return UR_2;
1418 end Ureal_2;
1420 --------------
1421 -- Ureal_10 --
1422 --------------
1424 function Ureal_10 return Ureal is
1425 begin
1426 return UR_10;
1427 end Ureal_10;
1429 ---------------
1430 -- Ureal_100 --
1431 ---------------
1433 function Ureal_100 return Ureal is
1434 begin
1435 return UR_100;
1436 end Ureal_100;
1438 -----------------
1439 -- Ureal_10_36 --
1440 -----------------
1442 function Ureal_10_36 return Ureal is
1443 begin
1444 return UR_10_36;
1445 end Ureal_10_36;
1447 ----------------
1448 -- Ureal_2_80 --
1449 ----------------
1451 function Ureal_2_80 return Ureal is
1452 begin
1453 return UR_2_80;
1454 end Ureal_2_80;
1456 -----------------
1457 -- Ureal_2_128 --
1458 -----------------
1460 function Ureal_2_128 return Ureal is
1461 begin
1462 return UR_2_128;
1463 end Ureal_2_128;
1465 -------------------
1466 -- Ureal_2_M_80 --
1467 -------------------
1469 function Ureal_2_M_80 return Ureal is
1470 begin
1471 return UR_2_M_80;
1472 end Ureal_2_M_80;
1474 -------------------
1475 -- Ureal_2_M_128 --
1476 -------------------
1478 function Ureal_2_M_128 return Ureal is
1479 begin
1480 return UR_2_M_128;
1481 end Ureal_2_M_128;
1483 ----------------
1484 -- Ureal_Half --
1485 ----------------
1487 function Ureal_Half return Ureal is
1488 begin
1489 return UR_Half;
1490 end Ureal_Half;
1492 ---------------
1493 -- Ureal_M_0 --
1494 ---------------
1496 function Ureal_M_0 return Ureal is
1497 begin
1498 return UR_M_0;
1499 end Ureal_M_0;
1501 -------------------
1502 -- Ureal_M_10_36 --
1503 -------------------
1505 function Ureal_M_10_36 return Ureal is
1506 begin
1507 return UR_M_10_36;
1508 end Ureal_M_10_36;
1510 -----------------
1511 -- Ureal_Tenth --
1512 -----------------
1514 function Ureal_Tenth return Ureal is
1515 begin
1516 return UR_Tenth;
1517 end Ureal_Tenth;
1519 end Urealp;