* options.c (gfc_handle_module_path_options): Fix buffer overrun.
[official-gcc.git] / gcc / ada / urealp.adb
blobb484a135be5f8068a268bb18daab75d137f5d499
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-2003 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 package Ureals is new Table.Table (
61 Table_Component_Type => Ureal_Entry,
62 Table_Index_Type => Ureal,
63 Table_Low_Bound => Ureal_First_Entry,
64 Table_Initial => Alloc.Ureals_Initial,
65 Table_Increment => Alloc.Ureals_Increment,
66 Table_Name => "Ureals");
68 -- The following universal reals are the values returned by the constant
69 -- functions. They are initialized by the initialization procedure.
71 UR_0 : Ureal;
72 UR_M_0 : Ureal;
73 UR_Tenth : Ureal;
74 UR_Half : Ureal;
75 UR_1 : Ureal;
76 UR_2 : Ureal;
77 UR_10 : Ureal;
78 UR_10_36 : Ureal;
79 UR_M_10_36 : Ureal;
80 UR_100 : Ureal;
81 UR_2_128 : Ureal;
82 UR_2_80 : Ureal;
83 UR_2_M_128 : Ureal;
84 UR_2_M_80 : Ureal;
86 Num_Ureal_Constants : constant := 10;
87 -- This is used for an assertion check in Tree_Read and Tree_Write to
88 -- help remember to add values to these routines when we add to the list.
90 Normalized_Real : Ureal := No_Ureal;
91 -- Used to memoize Norm_Num and Norm_Den, if either of these functions
92 -- is called, this value is set and Normalized_Entry contains the result
93 -- of the normalization. On subsequent calls, this is used to avoid the
94 -- call to Normalize if it has already been made.
96 Normalized_Entry : Ureal_Entry;
97 -- Entry built by most recent call to Normalize
99 -----------------------
100 -- Local Subprograms --
101 -----------------------
103 function Decimal_Exponent_Hi (V : Ureal) return Int;
104 -- Returns an estimate of the exponent of Val represented as a normalized
105 -- decimal number (non-zero digit before decimal point), The estimate is
106 -- either correct, or high, but never low. The accuracy of the estimate
107 -- affects only the efficiency of the comparison routines.
109 function Decimal_Exponent_Lo (V : Ureal) return Int;
110 -- Returns an estimate of the exponent of Val represented as a normalized
111 -- decimal number (non-zero digit before decimal point), The estimate is
112 -- either correct, or low, but never high. The accuracy of the estimate
113 -- affects only the efficiency of the comparison routines.
115 function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int;
116 -- U is a Ureal entry for which the base value is non-zero, the value
117 -- returned is the equivalent decimal exponent value, i.e. the value of
118 -- Den, adjusted as though the base were base 10. The value is rounded
119 -- to the nearest integer, and so can be one off.
121 function Is_Integer (Num, Den : Uint) return Boolean;
122 -- Return true if the real quotient of Num / Den is an integer value
124 function Normalize (Val : Ureal_Entry) return Ureal_Entry;
125 -- Normalizes the Ureal_Entry by reducing it to lowest terms (with a
126 -- base value of 0).
128 function Same (U1, U2 : Ureal) return Boolean;
129 pragma Inline (Same);
130 -- Determines if U1 and U2 are the same Ureal. Note that we cannot use
131 -- the equals operator for this test, since that tests for equality,
132 -- not identity.
134 function Store_Ureal (Val : Ureal_Entry) return Ureal;
135 -- This store a new entry in the universal reals table and return
136 -- its index in the table.
138 -------------------------
139 -- Decimal_Exponent_Hi --
140 -------------------------
142 function Decimal_Exponent_Hi (V : Ureal) return Int is
143 Val : constant Ureal_Entry := Ureals.Table (V);
145 begin
146 -- Zero always returns zero
148 if UR_Is_Zero (V) then
149 return 0;
151 -- For numbers in rational form, get the maximum number of digits in the
152 -- numerator and the minimum number of digits in the denominator, and
153 -- subtract. For example:
155 -- 1000 / 99 = 1.010E+1
156 -- 9999 / 10 = 9.999E+2
158 -- This estimate may of course be high, but that is acceptable
160 elsif Val.Rbase = 0 then
161 return UI_Decimal_Digits_Hi (Val.Num) -
162 UI_Decimal_Digits_Lo (Val.Den);
164 -- For based numbers, just subtract the decimal exponent from the
165 -- high estimate of the number of digits in the numerator and add
166 -- one to accommodate possible round off errors for non-decimal
167 -- bases. For example:
169 -- 1_500_000 / 10**4 = 1.50E-2
171 else -- Val.Rbase /= 0
172 return UI_Decimal_Digits_Hi (Val.Num) -
173 Equivalent_Decimal_Exponent (Val) + 1;
174 end if;
175 end Decimal_Exponent_Hi;
177 -------------------------
178 -- Decimal_Exponent_Lo --
179 -------------------------
181 function Decimal_Exponent_Lo (V : Ureal) return Int is
182 Val : constant Ureal_Entry := Ureals.Table (V);
184 begin
185 -- Zero always returns zero
187 if UR_Is_Zero (V) then
188 return 0;
190 -- For numbers in rational form, get min digits in numerator, max digits
191 -- in denominator, and subtract and subtract one more for possible loss
192 -- during the division. For example:
194 -- 1000 / 99 = 1.010E+1
195 -- 9999 / 10 = 9.999E+2
197 -- This estimate may of course be low, but that is acceptable
199 elsif Val.Rbase = 0 then
200 return UI_Decimal_Digits_Lo (Val.Num) -
201 UI_Decimal_Digits_Hi (Val.Den) - 1;
203 -- For based numbers, just subtract the decimal exponent from the
204 -- low estimate of the number of digits in the numerator and subtract
205 -- one to accommodate possible round off errors for non-decimal
206 -- bases. For example:
208 -- 1_500_000 / 10**4 = 1.50E-2
210 else -- Val.Rbase /= 0
211 return UI_Decimal_Digits_Lo (Val.Num) -
212 Equivalent_Decimal_Exponent (Val) - 1;
213 end if;
214 end Decimal_Exponent_Lo;
216 -----------------
217 -- Denominator --
218 -----------------
220 function Denominator (Real : Ureal) return Uint is
221 begin
222 return Ureals.Table (Real).Den;
223 end Denominator;
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);
251 begin
252 pragma Assert (U.Rbase /= 0);
253 return Int (Long_Float (UI_To_Int (U.Den)) * Logs (U.Rbase));
254 end Equivalent_Decimal_Exponent;
256 ----------------
257 -- Initialize --
258 ----------------
260 procedure Initialize is
261 begin
262 Ureals.Init;
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_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, False);
271 UR_M_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, True);
272 UR_100 := UR_From_Components (Uint_1, Uint_Minus_2, 10, False);
273 UR_2_128 := UR_From_Components (Uint_1, Uint_Minus_128, 2, False);
274 UR_2_M_128 := UR_From_Components (Uint_1, Uint_128, 2, False);
275 UR_2_80 := UR_From_Components (Uint_1, Uint_Minus_80, 2, False);
276 UR_2_M_80 := UR_From_Components (Uint_1, Uint_80, 2, False);
277 end Initialize;
279 ----------------
280 -- Is_Integer --
281 ----------------
283 function Is_Integer (Num, Den : Uint) return Boolean is
284 begin
285 return (Num / Den) * Den = Num;
286 end Is_Integer;
288 ----------
289 -- Mark --
290 ----------
292 function Mark return Save_Mark is
293 begin
294 return Save_Mark (Ureals.Last);
295 end Mark;
297 --------------
298 -- Norm_Den --
299 --------------
301 function Norm_Den (Real : Ureal) return Uint is
302 begin
303 if not Same (Real, Normalized_Real) then
304 Normalized_Real := Real;
305 Normalized_Entry := Normalize (Ureals.Table (Real));
306 end if;
308 return Normalized_Entry.Den;
309 end Norm_Den;
311 --------------
312 -- Norm_Num --
313 --------------
315 function Norm_Num (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.Num;
323 end Norm_Num;
325 ---------------
326 -- Normalize --
327 ---------------
329 function Normalize (Val : Ureal_Entry) return Ureal_Entry is
330 J : Uint;
331 K : Uint;
332 Tmp : Uint;
333 Num : Uint;
334 Den : Uint;
335 M : constant Uintp.Save_Mark := Uintp.Mark;
337 begin
338 -- Start by setting J to the greatest of the absolute values of the
339 -- numerator and the denominator (taking into account the base value),
340 -- and K to the lesser of the two absolute values. The gcd of Num and
341 -- Den is the gcd of J and K.
343 if Val.Rbase = 0 then
344 J := Val.Num;
345 K := Val.Den;
347 elsif Val.Den < 0 then
348 J := Val.Num * Val.Rbase ** (-Val.Den);
349 K := Uint_1;
351 else
352 J := Val.Num;
353 K := Val.Rbase ** Val.Den;
354 end if;
356 Num := J;
357 Den := K;
359 if K > J then
360 Tmp := J;
361 J := K;
362 K := Tmp;
363 end if;
365 J := UI_GCD (J, K);
366 Num := Num / J;
367 Den := Den / J;
368 Uintp.Release_And_Save (M, Num, Den);
370 -- Divide numerator and denominator by gcd and return result
372 return (Num => Num,
373 Den => Den,
374 Rbase => 0,
375 Negative => Val.Negative);
376 end Normalize;
378 ---------------
379 -- Numerator --
380 ---------------
382 function Numerator (Real : Ureal) return Uint is
383 begin
384 return Ureals.Table (Real).Num;
385 end Numerator;
387 --------
388 -- pr --
389 --------
391 procedure pr (Real : Ureal) is
392 begin
393 UR_Write (Real);
394 Write_Eol;
395 end pr;
397 -----------
398 -- Rbase --
399 -----------
401 function Rbase (Real : Ureal) return Nat is
402 begin
403 return Ureals.Table (Real).Rbase;
404 end Rbase;
406 -------------
407 -- Release --
408 -------------
410 procedure Release (M : Save_Mark) is
411 begin
412 Ureals.Set_Last (Ureal (M));
413 end Release;
415 ----------
416 -- Same --
417 ----------
419 function Same (U1, U2 : Ureal) return Boolean is
420 begin
421 return Int (U1) = Int (U2);
422 end Same;
424 -----------------
425 -- Store_Ureal --
426 -----------------
428 function Store_Ureal (Val : Ureal_Entry) return Ureal is
429 begin
430 Ureals.Increment_Last;
431 Ureals.Table (Ureals.Last) := Val;
433 -- Normalize representation of signed values
435 if Val.Num < 0 then
436 Ureals.Table (Ureals.Last).Negative := True;
437 Ureals.Table (Ureals.Last).Num := -Val.Num;
438 end if;
440 return Ureals.Last;
441 end Store_Ureal;
443 ---------------
444 -- Tree_Read --
445 ---------------
447 procedure Tree_Read is
448 begin
449 pragma Assert (Num_Ureal_Constants = 10);
451 Ureals.Tree_Read;
452 Tree_Read_Int (Int (UR_0));
453 Tree_Read_Int (Int (UR_M_0));
454 Tree_Read_Int (Int (UR_Tenth));
455 Tree_Read_Int (Int (UR_Half));
456 Tree_Read_Int (Int (UR_1));
457 Tree_Read_Int (Int (UR_2));
458 Tree_Read_Int (Int (UR_10));
459 Tree_Read_Int (Int (UR_100));
460 Tree_Read_Int (Int (UR_2_128));
461 Tree_Read_Int (Int (UR_2_M_128));
463 -- Clear the normalization cache
465 Normalized_Real := No_Ureal;
466 end Tree_Read;
468 ----------------
469 -- Tree_Write --
470 ----------------
472 procedure Tree_Write is
473 begin
474 pragma Assert (Num_Ureal_Constants = 10);
476 Ureals.Tree_Write;
477 Tree_Write_Int (Int (UR_0));
478 Tree_Write_Int (Int (UR_M_0));
479 Tree_Write_Int (Int (UR_Tenth));
480 Tree_Write_Int (Int (UR_Half));
481 Tree_Write_Int (Int (UR_1));
482 Tree_Write_Int (Int (UR_2));
483 Tree_Write_Int (Int (UR_10));
484 Tree_Write_Int (Int (UR_100));
485 Tree_Write_Int (Int (UR_2_128));
486 Tree_Write_Int (Int (UR_2_M_128));
487 end Tree_Write;
489 ------------
490 -- UR_Abs --
491 ------------
493 function UR_Abs (Real : Ureal) return Ureal is
494 Val : constant Ureal_Entry := Ureals.Table (Real);
496 begin
497 return Store_Ureal (
498 (Num => Val.Num,
499 Den => Val.Den,
500 Rbase => Val.Rbase,
501 Negative => False));
502 end UR_Abs;
504 ------------
505 -- UR_Add --
506 ------------
508 function UR_Add (Left : Uint; Right : Ureal) return Ureal is
509 begin
510 return UR_From_Uint (Left) + Right;
511 end UR_Add;
513 function UR_Add (Left : Ureal; Right : Uint) return Ureal is
514 begin
515 return Left + UR_From_Uint (Right);
516 end UR_Add;
518 function UR_Add (Left : Ureal; Right : Ureal) return Ureal is
519 Lval : Ureal_Entry := Ureals.Table (Left);
520 Rval : Ureal_Entry := Ureals.Table (Right);
522 Num : Uint;
524 begin
525 -- Note, in the temporary Ureal_Entry values used in this procedure,
526 -- we store the sign as the sign of the numerator (i.e. xxx.Num may
527 -- be negative, even though in stored entries this can never be so)
529 if Lval.Rbase /= 0 and then Lval.Rbase = Rval.Rbase then
531 declare
532 Opd_Min, Opd_Max : Ureal_Entry;
533 Exp_Min, Exp_Max : Uint;
535 begin
536 if Lval.Negative then
537 Lval.Num := (-Lval.Num);
538 end if;
540 if Rval.Negative then
541 Rval.Num := (-Rval.Num);
542 end if;
544 if Lval.Den < Rval.Den then
545 Exp_Min := Lval.Den;
546 Exp_Max := Rval.Den;
547 Opd_Min := Lval;
548 Opd_Max := Rval;
549 else
550 Exp_Min := Rval.Den;
551 Exp_Max := Lval.Den;
552 Opd_Min := Rval;
553 Opd_Max := Lval;
554 end if;
556 Num :=
557 Opd_Min.Num * Lval.Rbase ** (Exp_Max - Exp_Min) + Opd_Max.Num;
559 if Num = 0 then
560 return Store_Ureal (
561 (Num => Uint_0,
562 Den => Uint_1,
563 Rbase => 0,
564 Negative => Lval.Negative));
566 else
567 return Store_Ureal (
568 (Num => abs Num,
569 Den => Exp_Max,
570 Rbase => Lval.Rbase,
571 Negative => (Num < 0)));
572 end if;
573 end;
575 else
576 declare
577 Ln : Ureal_Entry := Normalize (Lval);
578 Rn : Ureal_Entry := Normalize (Rval);
580 begin
581 if Ln.Negative then
582 Ln.Num := (-Ln.Num);
583 end if;
585 if Rn.Negative then
586 Rn.Num := (-Rn.Num);
587 end if;
589 Num := (Ln.Num * Rn.Den) + (Rn.Num * Ln.Den);
591 if Num = 0 then
592 return Store_Ureal (
593 (Num => Uint_0,
594 Den => Uint_1,
595 Rbase => 0,
596 Negative => Lval.Negative));
598 else
599 return Store_Ureal (
600 Normalize (
601 (Num => abs Num,
602 Den => Ln.Den * Rn.Den,
603 Rbase => 0,
604 Negative => (Num < 0))));
605 end if;
606 end;
607 end if;
608 end UR_Add;
610 ----------------
611 -- UR_Ceiling --
612 ----------------
614 function UR_Ceiling (Real : Ureal) return Uint is
615 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
617 begin
618 if Val.Negative then
619 return UI_Negate (Val.Num / Val.Den);
620 else
621 return (Val.Num + Val.Den - 1) / Val.Den;
622 end if;
623 end UR_Ceiling;
625 ------------
626 -- UR_Div --
627 ------------
629 function UR_Div (Left : Uint; Right : Ureal) return Ureal is
630 begin
631 return UR_From_Uint (Left) / Right;
632 end UR_Div;
634 function UR_Div (Left : Ureal; Right : Uint) return Ureal is
635 begin
636 return Left / UR_From_Uint (Right);
637 end UR_Div;
639 function UR_Div (Left, Right : Ureal) return Ureal is
640 Lval : constant Ureal_Entry := Ureals.Table (Left);
641 Rval : constant Ureal_Entry := Ureals.Table (Right);
642 Rneg : constant Boolean := Rval.Negative xor Lval.Negative;
644 begin
645 pragma Assert (Rval.Num /= Uint_0);
647 if Lval.Rbase = 0 then
649 if Rval.Rbase = 0 then
650 return Store_Ureal (
651 Normalize (
652 (Num => Lval.Num * Rval.Den,
653 Den => Lval.Den * Rval.Num,
654 Rbase => 0,
655 Negative => Rneg)));
657 elsif Is_Integer (Lval.Num, Rval.Num * Lval.Den) then
658 return Store_Ureal (
659 (Num => Lval.Num / (Rval.Num * Lval.Den),
660 Den => (-Rval.Den),
661 Rbase => Rval.Rbase,
662 Negative => Rneg));
664 elsif Rval.Den < 0 then
665 return Store_Ureal (
666 Normalize (
667 (Num => Lval.Num,
668 Den => Rval.Rbase ** (-Rval.Den) *
669 Rval.Num *
670 Lval.Den,
671 Rbase => 0,
672 Negative => Rneg)));
674 else
675 return Store_Ureal (
676 Normalize (
677 (Num => Lval.Num * Rval.Rbase ** Rval.Den,
678 Den => Rval.Num * Lval.Den,
679 Rbase => 0,
680 Negative => Rneg)));
681 end if;
683 elsif Is_Integer (Lval.Num, Rval.Num) then
685 if Rval.Rbase = Lval.Rbase then
686 return Store_Ureal (
687 (Num => Lval.Num / Rval.Num,
688 Den => Lval.Den - Rval.Den,
689 Rbase => Lval.Rbase,
690 Negative => Rneg));
692 elsif Rval.Rbase = 0 then
693 return Store_Ureal (
694 (Num => (Lval.Num / Rval.Num) * Rval.Den,
695 Den => Lval.Den,
696 Rbase => Lval.Rbase,
697 Negative => Rneg));
699 elsif Rval.Den < 0 then
700 declare
701 Num, Den : Uint;
703 begin
704 if Lval.Den < 0 then
705 Num := (Lval.Num / Rval.Num) * (Lval.Rbase ** (-Lval.Den));
706 Den := Rval.Rbase ** (-Rval.Den);
707 else
708 Num := Lval.Num / Rval.Num;
709 Den := (Lval.Rbase ** Lval.Den) *
710 (Rval.Rbase ** (-Rval.Den));
711 end if;
713 return Store_Ureal (
714 (Num => Num,
715 Den => Den,
716 Rbase => 0,
717 Negative => Rneg));
718 end;
720 else
721 return Store_Ureal (
722 (Num => (Lval.Num / Rval.Num) *
723 (Rval.Rbase ** Rval.Den),
724 Den => Lval.Den,
725 Rbase => Lval.Rbase,
726 Negative => Rneg));
727 end if;
729 else
730 declare
731 Num, Den : Uint;
733 begin
734 if Lval.Den < 0 then
735 Num := Lval.Num * (Lval.Rbase ** (-Lval.Den));
736 Den := Rval.Num;
738 else
739 Num := Lval.Num;
740 Den := Rval.Num * (Lval.Rbase ** Lval.Den);
741 end if;
743 if Rval.Rbase /= 0 then
744 if Rval.Den < 0 then
745 Den := Den * (Rval.Rbase ** (-Rval.Den));
746 else
747 Num := Num * (Rval.Rbase ** Rval.Den);
748 end if;
750 else
751 Num := Num * Rval.Den;
752 end if;
754 return Store_Ureal (
755 Normalize (
756 (Num => Num,
757 Den => Den,
758 Rbase => 0,
759 Negative => Rneg)));
760 end;
761 end if;
762 end UR_Div;
764 -----------
765 -- UR_Eq --
766 -----------
768 function UR_Eq (Left, Right : Ureal) return Boolean is
769 begin
770 return not UR_Ne (Left, Right);
771 end UR_Eq;
773 ---------------------
774 -- UR_Exponentiate --
775 ---------------------
777 function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal is
778 X : constant Uint := abs N;
779 Bas : Ureal;
780 Val : Ureal_Entry;
781 Neg : Boolean;
782 IBas : Uint;
784 begin
785 -- If base is negative, then the resulting sign depends on whether
786 -- the exponent is even or odd (even => positive, odd = negative)
788 if UR_Is_Negative (Real) then
789 Neg := (N mod 2) /= 0;
790 Bas := UR_Negate (Real);
791 else
792 Neg := False;
793 Bas := Real;
794 end if;
796 Val := Ureals.Table (Bas);
798 -- If the base is a small integer, then we can return the result in
799 -- exponential form, which can save a lot of time for junk exponents.
801 IBas := UR_Trunc (Bas);
803 if IBas <= 16
804 and then UR_From_Uint (IBas) = Bas
805 then
806 return Store_Ureal (
807 (Num => Uint_1,
808 Den => -N,
809 Rbase => UI_To_Int (UR_Trunc (Bas)),
810 Negative => Neg));
812 -- If the exponent is negative then we raise the numerator and the
813 -- denominator (after normalization) to the absolute value of the
814 -- exponent and we return the reciprocal. An assert error will happen
815 -- if the numerator is zero.
817 elsif N < 0 then
818 pragma Assert (Val.Num /= 0);
819 Val := Normalize (Val);
821 return Store_Ureal (
822 (Num => Val.Den ** X,
823 Den => Val.Num ** X,
824 Rbase => 0,
825 Negative => Neg));
827 -- If positive, we distinguish the case when the base is not zero, in
828 -- which case the new denominator is just the product of the old one
829 -- with the exponent,
831 else
832 if Val.Rbase /= 0 then
834 return Store_Ureal (
835 (Num => Val.Num ** X,
836 Den => Val.Den * X,
837 Rbase => Val.Rbase,
838 Negative => Neg));
840 -- And when the base is zero, in which case we exponentiate
841 -- the old denominator.
843 else
844 return Store_Ureal (
845 (Num => Val.Num ** X,
846 Den => Val.Den ** X,
847 Rbase => 0,
848 Negative => Neg));
849 end if;
850 end if;
851 end UR_Exponentiate;
853 --------------
854 -- UR_Floor --
855 --------------
857 function UR_Floor (Real : Ureal) return Uint is
858 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
860 begin
861 if Val.Negative then
862 return UI_Negate ((Val.Num + Val.Den - 1) / Val.Den);
863 else
864 return Val.Num / Val.Den;
865 end if;
866 end UR_Floor;
868 ------------------------
869 -- UR_From_Components --
870 ------------------------
872 function UR_From_Components
873 (Num : Uint;
874 Den : Uint;
875 Rbase : Nat := 0;
876 Negative : Boolean := False)
877 return Ureal
879 begin
880 return Store_Ureal (
881 (Num => Num,
882 Den => Den,
883 Rbase => Rbase,
884 Negative => Negative));
885 end UR_From_Components;
887 ------------------
888 -- UR_From_Uint --
889 ------------------
891 function UR_From_Uint (UI : Uint) return Ureal is
892 begin
893 return UR_From_Components
894 (abs UI, Uint_1, Negative => (UI < 0));
895 end UR_From_Uint;
897 -----------
898 -- UR_Ge --
899 -----------
901 function UR_Ge (Left, Right : Ureal) return Boolean is
902 begin
903 return not (Left < Right);
904 end UR_Ge;
906 -----------
907 -- UR_Gt --
908 -----------
910 function UR_Gt (Left, Right : Ureal) return Boolean is
911 begin
912 return (Right < Left);
913 end UR_Gt;
915 --------------------
916 -- UR_Is_Negative --
917 --------------------
919 function UR_Is_Negative (Real : Ureal) return Boolean is
920 begin
921 return Ureals.Table (Real).Negative;
922 end UR_Is_Negative;
924 --------------------
925 -- UR_Is_Positive --
926 --------------------
928 function UR_Is_Positive (Real : Ureal) return Boolean is
929 begin
930 return not Ureals.Table (Real).Negative
931 and then Ureals.Table (Real).Num /= 0;
932 end UR_Is_Positive;
934 ----------------
935 -- UR_Is_Zero --
936 ----------------
938 function UR_Is_Zero (Real : Ureal) return Boolean is
939 begin
940 return Ureals.Table (Real).Num = 0;
941 end UR_Is_Zero;
943 -----------
944 -- UR_Le --
945 -----------
947 function UR_Le (Left, Right : Ureal) return Boolean is
948 begin
949 return not (Right < Left);
950 end UR_Le;
952 -----------
953 -- UR_Lt --
954 -----------
956 function UR_Lt (Left, Right : Ureal) return Boolean is
957 begin
958 -- An operand is not less than itself
960 if Same (Left, Right) then
961 return False;
963 -- Deal with zero cases
965 elsif UR_Is_Zero (Left) then
966 return UR_Is_Positive (Right);
968 elsif UR_Is_Zero (Right) then
969 return Ureals.Table (Left).Negative;
971 -- Different signs are decisive (note we dealt with zero cases)
973 elsif Ureals.Table (Left).Negative
974 and then not Ureals.Table (Right).Negative
975 then
976 return True;
978 elsif not Ureals.Table (Left).Negative
979 and then Ureals.Table (Right).Negative
980 then
981 return False;
983 -- Signs are same, do rapid check based on worst case estimates of
984 -- decimal exponent, which will often be decisive. Precise test
985 -- depends on whether operands are positive or negative.
987 elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) then
988 return UR_Is_Positive (Left);
990 elsif Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right) then
991 return UR_Is_Negative (Left);
993 -- If we fall through, full gruesome test is required. This happens
994 -- if the numbers are close together, or in some weird (/=10) base.
996 else
997 declare
998 Imrk : constant Uintp.Save_Mark := Mark;
999 Rmrk : constant Urealp.Save_Mark := Mark;
1000 Lval : Ureal_Entry;
1001 Rval : Ureal_Entry;
1002 Result : Boolean;
1004 begin
1005 Lval := Ureals.Table (Left);
1006 Rval := Ureals.Table (Right);
1008 -- An optimization. If both numbers are based, then subtract
1009 -- common value of base to avoid unnecessarily giant numbers
1011 if Lval.Rbase = Rval.Rbase and then Lval.Rbase /= 0 then
1012 if Lval.Den < Rval.Den then
1013 Rval.Den := Rval.Den - Lval.Den;
1014 Lval.Den := Uint_0;
1015 else
1016 Lval.Den := Lval.Den - Rval.Den;
1017 Rval.Den := Uint_0;
1018 end if;
1019 end if;
1021 Lval := Normalize (Lval);
1022 Rval := Normalize (Rval);
1024 if Lval.Negative then
1025 Result := (Lval.Num * Rval.Den) > (Rval.Num * Lval.Den);
1026 else
1027 Result := (Lval.Num * Rval.Den) < (Rval.Num * Lval.Den);
1028 end if;
1030 Release (Imrk);
1031 Release (Rmrk);
1032 return Result;
1033 end;
1034 end if;
1035 end UR_Lt;
1037 ------------
1038 -- UR_Max --
1039 ------------
1041 function UR_Max (Left, Right : Ureal) return Ureal is
1042 begin
1043 if Left >= Right then
1044 return Left;
1045 else
1046 return Right;
1047 end if;
1048 end UR_Max;
1050 ------------
1051 -- UR_Min --
1052 ------------
1054 function UR_Min (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_Min;
1063 ------------
1064 -- UR_Mul --
1065 ------------
1067 function UR_Mul (Left : Uint; Right : Ureal) return Ureal is
1068 begin
1069 return UR_From_Uint (Left) * Right;
1070 end UR_Mul;
1072 function UR_Mul (Left : Ureal; Right : Uint) return Ureal is
1073 begin
1074 return Left * UR_From_Uint (Right);
1075 end UR_Mul;
1077 function UR_Mul (Left, Right : Ureal) return Ureal is
1078 Lval : constant Ureal_Entry := Ureals.Table (Left);
1079 Rval : constant Ureal_Entry := Ureals.Table (Right);
1080 Num : Uint := Lval.Num * Rval.Num;
1081 Den : Uint;
1082 Rneg : constant Boolean := Lval.Negative xor Rval.Negative;
1084 begin
1085 if Lval.Rbase = 0 then
1086 if Rval.Rbase = 0 then
1087 return Store_Ureal (
1088 Normalize (
1089 (Num => Num,
1090 Den => Lval.Den * Rval.Den,
1091 Rbase => 0,
1092 Negative => Rneg)));
1094 elsif Is_Integer (Num, Lval.Den) then
1095 return Store_Ureal (
1096 (Num => Num / Lval.Den,
1097 Den => Rval.Den,
1098 Rbase => Rval.Rbase,
1099 Negative => Rneg));
1101 elsif Rval.Den < 0 then
1102 return Store_Ureal (
1103 Normalize (
1104 (Num => Num * (Rval.Rbase ** (-Rval.Den)),
1105 Den => Lval.Den,
1106 Rbase => 0,
1107 Negative => Rneg)));
1109 else
1110 return Store_Ureal (
1111 Normalize (
1112 (Num => Num,
1113 Den => Lval.Den * (Rval.Rbase ** Rval.Den),
1114 Rbase => 0,
1115 Negative => Rneg)));
1116 end if;
1118 elsif Lval.Rbase = Rval.Rbase then
1119 return Store_Ureal (
1120 (Num => Num,
1121 Den => Lval.Den + Rval.Den,
1122 Rbase => Lval.Rbase,
1123 Negative => Rneg));
1125 elsif Rval.Rbase = 0 then
1126 if Is_Integer (Num, Rval.Den) then
1127 return Store_Ureal (
1128 (Num => Num / Rval.Den,
1129 Den => Lval.Den,
1130 Rbase => Lval.Rbase,
1131 Negative => Rneg));
1133 elsif Lval.Den < 0 then
1134 return Store_Ureal (
1135 Normalize (
1136 (Num => Num * (Lval.Rbase ** (-Lval.Den)),
1137 Den => Rval.Den,
1138 Rbase => 0,
1139 Negative => Rneg)));
1141 else
1142 return Store_Ureal (
1143 Normalize (
1144 (Num => Num,
1145 Den => Rval.Den * (Lval.Rbase ** Lval.Den),
1146 Rbase => 0,
1147 Negative => Rneg)));
1148 end if;
1150 else
1151 Den := Uint_1;
1153 if Lval.Den < 0 then
1154 Num := Num * (Lval.Rbase ** (-Lval.Den));
1155 else
1156 Den := Den * (Lval.Rbase ** Lval.Den);
1157 end if;
1159 if Rval.Den < 0 then
1160 Num := Num * (Rval.Rbase ** (-Rval.Den));
1161 else
1162 Den := Den * (Rval.Rbase ** Rval.Den);
1163 end if;
1165 return Store_Ureal (
1166 Normalize (
1167 (Num => Num,
1168 Den => Den,
1169 Rbase => 0,
1170 Negative => Rneg)));
1171 end if;
1172 end UR_Mul;
1174 -----------
1175 -- UR_Ne --
1176 -----------
1178 function UR_Ne (Left, Right : Ureal) return Boolean is
1179 begin
1180 -- Quick processing for case of identical Ureal values (note that
1181 -- this also deals with comparing two No_Ureal values).
1183 if Same (Left, Right) then
1184 return False;
1186 -- Deal with case of one or other operand is No_Ureal, but not both
1188 elsif Same (Left, No_Ureal) or else Same (Right, No_Ureal) then
1189 return True;
1191 -- Do quick check based on number of decimal digits
1193 elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) or else
1194 Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right)
1195 then
1196 return True;
1198 -- Otherwise full comparison is required
1200 else
1201 declare
1202 Imrk : constant Uintp.Save_Mark := Mark;
1203 Rmrk : constant Urealp.Save_Mark := Mark;
1204 Lval : constant Ureal_Entry := Normalize (Ureals.Table (Left));
1205 Rval : constant Ureal_Entry := Normalize (Ureals.Table (Right));
1206 Result : Boolean;
1208 begin
1209 if UR_Is_Zero (Left) then
1210 return not UR_Is_Zero (Right);
1212 elsif UR_Is_Zero (Right) then
1213 return not UR_Is_Zero (Left);
1215 -- Both operands are non-zero
1217 else
1218 Result :=
1219 Rval.Negative /= Lval.Negative
1220 or else Rval.Num /= Lval.Num
1221 or else Rval.Den /= Lval.Den;
1222 Release (Imrk);
1223 Release (Rmrk);
1224 return Result;
1225 end if;
1226 end;
1227 end if;
1228 end UR_Ne;
1230 ---------------
1231 -- UR_Negate --
1232 ---------------
1234 function UR_Negate (Real : Ureal) return Ureal is
1235 begin
1236 return Store_Ureal (
1237 (Num => Ureals.Table (Real).Num,
1238 Den => Ureals.Table (Real).Den,
1239 Rbase => Ureals.Table (Real).Rbase,
1240 Negative => not Ureals.Table (Real).Negative));
1241 end UR_Negate;
1243 ------------
1244 -- UR_Sub --
1245 ------------
1247 function UR_Sub (Left : Uint; Right : Ureal) return Ureal is
1248 begin
1249 return UR_From_Uint (Left) + UR_Negate (Right);
1250 end UR_Sub;
1252 function UR_Sub (Left : Ureal; Right : Uint) return Ureal is
1253 begin
1254 return Left + UR_From_Uint (-Right);
1255 end UR_Sub;
1257 function UR_Sub (Left, Right : Ureal) return Ureal is
1258 begin
1259 return Left + UR_Negate (Right);
1260 end UR_Sub;
1262 ----------------
1263 -- UR_To_Uint --
1264 ----------------
1266 function UR_To_Uint (Real : Ureal) return Uint is
1267 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
1268 Res : Uint;
1270 begin
1271 Res := (Val.Num + (Val.Den / 2)) / Val.Den;
1273 if Val.Negative then
1274 return UI_Negate (Res);
1275 else
1276 return Res;
1277 end if;
1278 end UR_To_Uint;
1280 --------------
1281 -- UR_Trunc --
1282 --------------
1284 function UR_Trunc (Real : Ureal) return Uint is
1285 Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
1287 begin
1288 if Val.Negative then
1289 return -(Val.Num / Val.Den);
1290 else
1291 return Val.Num / Val.Den;
1292 end if;
1293 end UR_Trunc;
1295 --------------
1296 -- UR_Write --
1297 --------------
1299 procedure UR_Write (Real : Ureal) is
1300 Val : constant Ureal_Entry := Ureals.Table (Real);
1302 begin
1303 -- If value is negative, we precede the constant by a minus sign
1304 -- and add an extra layer of parentheses on the outside since the
1305 -- minus sign is part of the value, not a negation operator.
1307 if Val.Negative then
1308 Write_Str ("(-");
1309 end if;
1311 -- Constants in base 10 can be written in normal Ada literal style
1313 if Val.Rbase = 10 then
1314 UI_Write (Val.Num / 10);
1315 Write_Char ('.');
1316 UI_Write (Val.Num mod 10);
1318 if Val.Den /= 0 then
1319 Write_Char ('E');
1320 UI_Write (1 - Val.Den);
1321 end if;
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
1339 Write_Char ('(');
1340 UI_Write (Val.Num, Decimal);
1341 Write_Str (".0*");
1342 Write_Int (Val.Rbase);
1343 Write_Str ("**");
1345 if Val.Den <= 0 then
1346 UI_Write (-Val.Den, Decimal);
1348 else
1349 Write_Str ("(-");
1350 UI_Write (Val.Den, Decimal);
1351 Write_Char (')');
1352 end if;
1354 Write_Char (')');
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);
1361 Write_Str (".0");
1363 -- Non-based (rational) constants are written in (num/den) style
1365 else
1366 Write_Char ('(');
1367 UI_Write (Val.Num, Decimal);
1368 Write_Str (".0/");
1369 UI_Write (Val.Den, Decimal);
1370 Write_Str (".0)");
1371 end if;
1373 -- Add trailing paren for negative values
1375 if Val.Negative then
1376 Write_Char (')');
1377 end if;
1378 end UR_Write;
1380 -------------
1381 -- Ureal_0 --
1382 -------------
1384 function Ureal_0 return Ureal is
1385 begin
1386 return UR_0;
1387 end Ureal_0;
1389 -------------
1390 -- Ureal_1 --
1391 -------------
1393 function Ureal_1 return Ureal is
1394 begin
1395 return UR_1;
1396 end Ureal_1;
1398 -------------
1399 -- Ureal_2 --
1400 -------------
1402 function Ureal_2 return Ureal is
1403 begin
1404 return UR_2;
1405 end Ureal_2;
1407 --------------
1408 -- Ureal_10 --
1409 --------------
1411 function Ureal_10 return Ureal is
1412 begin
1413 return UR_10;
1414 end Ureal_10;
1416 ---------------
1417 -- Ureal_100 --
1418 ---------------
1420 function Ureal_100 return Ureal is
1421 begin
1422 return UR_100;
1423 end Ureal_100;
1425 -----------------
1426 -- Ureal_10_36 --
1427 -----------------
1429 function Ureal_10_36 return Ureal is
1430 begin
1431 return UR_10_36;
1432 end Ureal_10_36;
1434 -------------------
1435 -- Ureal_M_10_36 --
1436 -------------------
1438 function Ureal_M_10_36 return Ureal is
1439 begin
1440 return UR_M_10_36;
1441 end Ureal_M_10_36;
1443 -----------------
1444 -- Ureal_2_128 --
1445 -----------------
1447 function Ureal_2_128 return Ureal is
1448 begin
1449 return UR_2_128;
1450 end Ureal_2_128;
1452 ----------------
1453 -- Ureal_2_80 --
1454 ----------------
1456 function Ureal_2_80 return Ureal is
1457 begin
1458 return UR_2_80;
1459 end Ureal_2_80;
1461 -------------------
1462 -- Ureal_2_M_128 --
1463 -------------------
1465 function Ureal_2_M_128 return Ureal is
1466 begin
1467 return UR_2_M_128;
1468 end Ureal_2_M_128;
1470 -------------------
1471 -- Ureal_2_M_80 --
1472 -------------------
1474 function Ureal_2_M_80 return Ureal is
1475 begin
1476 return UR_2_M_80;
1477 end Ureal_2_M_80;
1479 ----------------
1480 -- Ureal_Half --
1481 ----------------
1483 function Ureal_Half return Ureal is
1484 begin
1485 return UR_Half;
1486 end Ureal_Half;
1488 ---------------
1489 -- Ureal_M_0 --
1490 ---------------
1492 function Ureal_M_0 return Ureal is
1493 begin
1494 return UR_M_0;
1495 end Ureal_M_0;
1497 -----------------
1498 -- Ureal_Tenth --
1499 -----------------
1501 function Ureal_Tenth return Ureal is
1502 begin
1503 return UR_Tenth;
1504 end Ureal_Tenth;
1506 end Urealp;