OSDN Git Service

Add Fariborz to my last change.
[pf3gnuchains/gcc-fork.git] / gcc / ada / urealp.adb
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 ------------------------------------------------------------------------------
33
34 with Alloc;
35 with Output;  use Output;
36 with Table;
37 with Tree_IO; use Tree_IO;
38
39 package body Urealp is
40
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!
44
45    type Ureal_Entry is record
46       Num  : Uint;
47       --  Numerator (always non-negative)
48
49       Den  : Uint;
50       --  Denominator (always non-zero, always positive if base is zero)
51
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)
55
56       Negative : Boolean;
57       --  Flag set if value is negative
58    end record;
59
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");
67
68    --  The following universal reals are the values returned by the constant
69    --  functions. They are initialized by the initialization procedure.
70
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;
85
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.
89
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.
95
96    Normalized_Entry : Ureal_Entry;
97    --  Entry built by most recent call to Normalize
98
99    -----------------------
100    -- Local Subprograms --
101    -----------------------
102
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.
108
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.
114
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.
120
121    function Is_Integer (Num, Den : Uint) return Boolean;
122    --  Return true if the real quotient of Num / Den is an integer value
123
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).
127
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.
133
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.
137
138    -------------------------
139    -- Decimal_Exponent_Hi --
140    -------------------------
141
142    function Decimal_Exponent_Hi (V : Ureal) return Int is
143       Val : constant Ureal_Entry := Ureals.Table (V);
144
145    begin
146       --  Zero always returns zero
147
148       if UR_Is_Zero (V) then
149          return 0;
150
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:
154
155       --     1000 / 99 = 1.010E+1
156       --     9999 / 10 = 9.999E+2
157
158       --  This estimate may of course be high, but that is acceptable
159
160       elsif Val.Rbase = 0 then
161          return UI_Decimal_Digits_Hi (Val.Num) -
162                 UI_Decimal_Digits_Lo (Val.Den);
163
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:
168
169       --     1_500_000 / 10**4 = 1.50E-2
170
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;
176
177    -------------------------
178    -- Decimal_Exponent_Lo --
179    -------------------------
180
181    function Decimal_Exponent_Lo (V : Ureal) return Int is
182       Val : constant Ureal_Entry := Ureals.Table (V);
183
184    begin
185       --  Zero always returns zero
186
187       if UR_Is_Zero (V) then
188          return 0;
189
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:
193
194       --     1000 / 99 = 1.010E+1
195       --     9999 / 10 = 9.999E+2
196
197       --  This estimate may of course be low, but that is acceptable
198
199       elsif Val.Rbase = 0 then
200          return UI_Decimal_Digits_Lo (Val.Num) -
201                 UI_Decimal_Digits_Hi (Val.Den) - 1;
202
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:
207
208       --     1_500_000 / 10**4 = 1.50E-2
209
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;
215
216    -----------------
217    -- Denominator --
218    -----------------
219
220    function Denominator (Real : Ureal) return Uint is
221    begin
222       return Ureals.Table (Real).Den;
223    end Denominator;
224
225    ---------------------------------
226    -- Equivalent_Decimal_Exponent --
227    ---------------------------------
228
229    function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int is
230
231       --  The following table is a table of logs to the base 10
232
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);
250
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;
255
256    ----------------
257    -- Initialize --
258    ----------------
259
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;
278
279    ----------------
280    -- Is_Integer --
281    ----------------
282
283    function Is_Integer (Num, Den : Uint) return Boolean is
284    begin
285       return (Num / Den) * Den = Num;
286    end Is_Integer;
287
288    ----------
289    -- Mark --
290    ----------
291
292    function Mark return Save_Mark is
293    begin
294       return Save_Mark (Ureals.Last);
295    end Mark;
296
297    --------------
298    -- Norm_Den --
299    --------------
300
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;
307
308       return Normalized_Entry.Den;
309    end Norm_Den;
310
311    --------------
312    -- Norm_Num --
313    --------------
314
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;
321
322       return Normalized_Entry.Num;
323    end Norm_Num;
324
325    ---------------
326    -- Normalize --
327    ---------------
328
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;
336
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.
342
343       if Val.Rbase = 0 then
344          J := Val.Num;
345          K := Val.Den;
346
347       elsif Val.Den < 0 then
348          J := Val.Num * Val.Rbase ** (-Val.Den);
349          K := Uint_1;
350
351       else
352          J := Val.Num;
353          K := Val.Rbase ** Val.Den;
354       end if;
355
356       Num := J;
357       Den := K;
358
359       if K > J then
360          Tmp := J;
361          J := K;
362          K := Tmp;
363       end if;
364
365       J := UI_GCD (J, K);
366       Num := Num / J;
367       Den := Den / J;
368       Uintp.Release_And_Save (M, Num, Den);
369
370       --  Divide numerator and denominator by gcd and return result
371
372       return (Num      => Num,
373               Den      => Den,
374               Rbase    => 0,
375               Negative => Val.Negative);
376    end Normalize;
377
378    ---------------
379    -- Numerator --
380    ---------------
381
382    function Numerator (Real : Ureal) return Uint is
383    begin
384       return Ureals.Table (Real).Num;
385    end Numerator;
386
387    --------
388    -- pr --
389    --------
390
391    procedure pr (Real : Ureal) is
392    begin
393       UR_Write (Real);
394       Write_Eol;
395    end pr;
396
397    -----------
398    -- Rbase --
399    -----------
400
401    function Rbase (Real : Ureal) return Nat is
402    begin
403       return Ureals.Table (Real).Rbase;
404    end Rbase;
405
406    -------------
407    -- Release --
408    -------------
409
410    procedure Release (M : Save_Mark) is
411    begin
412       Ureals.Set_Last (Ureal (M));
413    end Release;
414
415    ----------
416    -- Same --
417    ----------
418
419    function Same (U1, U2 : Ureal) return Boolean is
420    begin
421       return Int (U1) = Int (U2);
422    end Same;
423
424    -----------------
425    -- Store_Ureal --
426    -----------------
427
428    function Store_Ureal (Val : Ureal_Entry) return Ureal is
429    begin
430       Ureals.Increment_Last;
431       Ureals.Table (Ureals.Last) := Val;
432
433       --  Normalize representation of signed values
434
435       if Val.Num < 0 then
436          Ureals.Table (Ureals.Last).Negative := True;
437          Ureals.Table (Ureals.Last).Num := -Val.Num;
438       end if;
439
440       return Ureals.Last;
441    end Store_Ureal;
442
443    ---------------
444    -- Tree_Read --
445    ---------------
446
447    procedure Tree_Read is
448    begin
449       pragma Assert (Num_Ureal_Constants = 10);
450
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));
462
463       --  Clear the normalization cache
464
465       Normalized_Real := No_Ureal;
466    end Tree_Read;
467
468    ----------------
469    -- Tree_Write --
470    ----------------
471
472    procedure Tree_Write is
473    begin
474       pragma Assert (Num_Ureal_Constants = 10);
475
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;
488
489    ------------
490    -- UR_Abs --
491    ------------
492
493    function UR_Abs (Real : Ureal) return Ureal is
494       Val : constant Ureal_Entry := Ureals.Table (Real);
495
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;
503
504    ------------
505    -- UR_Add --
506    ------------
507
508    function UR_Add (Left : Uint; Right : Ureal) return Ureal is
509    begin
510       return UR_From_Uint (Left) + Right;
511    end UR_Add;
512
513    function UR_Add (Left : Ureal; Right : Uint) return Ureal is
514    begin
515       return Left + UR_From_Uint (Right);
516    end UR_Add;
517
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);
521
522       Num  : Uint;
523
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)
528
529       if Lval.Rbase /= 0 and then Lval.Rbase = Rval.Rbase then
530
531          declare
532             Opd_Min, Opd_Max   : Ureal_Entry;
533             Exp_Min, Exp_Max   : Uint;
534
535          begin
536             if Lval.Negative then
537                Lval.Num := (-Lval.Num);
538             end if;
539
540             if Rval.Negative then
541                Rval.Num := (-Rval.Num);
542             end if;
543
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;
555
556             Num :=
557               Opd_Min.Num * Lval.Rbase ** (Exp_Max - Exp_Min) + Opd_Max.Num;
558
559             if Num = 0 then
560                return Store_Ureal (
561                         (Num      => Uint_0,
562                          Den      => Uint_1,
563                          Rbase    => 0,
564                          Negative => Lval.Negative));
565
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;
574
575       else
576          declare
577             Ln : Ureal_Entry := Normalize (Lval);
578             Rn : Ureal_Entry := Normalize (Rval);
579
580          begin
581             if Ln.Negative then
582                Ln.Num := (-Ln.Num);
583             end if;
584
585             if Rn.Negative then
586                Rn.Num := (-Rn.Num);
587             end if;
588
589             Num := (Ln.Num * Rn.Den) + (Rn.Num * Ln.Den);
590
591             if Num = 0 then
592                return Store_Ureal (
593                         (Num      => Uint_0,
594                          Den      => Uint_1,
595                          Rbase    => 0,
596                          Negative => Lval.Negative));
597
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;
609
610    ----------------
611    -- UR_Ceiling --
612    ----------------
613
614    function UR_Ceiling (Real : Ureal) return Uint is
615       Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
616
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;
624
625    ------------
626    -- UR_Div --
627    ------------
628
629    function UR_Div (Left : Uint; Right : Ureal) return Ureal is
630    begin
631       return UR_From_Uint (Left) / Right;
632    end UR_Div;
633
634    function UR_Div (Left : Ureal; Right : Uint) return Ureal is
635    begin
636       return Left / UR_From_Uint (Right);
637    end UR_Div;
638
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;
643
644    begin
645       pragma Assert (Rval.Num /= Uint_0);
646
647       if Lval.Rbase = 0 then
648
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)));
656
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));
663
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)));
673
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;
682
683       elsif Is_Integer (Lval.Num, Rval.Num) then
684
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));
691
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));
698
699          elsif Rval.Den < 0 then
700             declare
701                Num, Den : Uint;
702
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;
712
713                return Store_Ureal (
714                         (Num      => Num,
715                          Den      => Den,
716                          Rbase    => 0,
717                          Negative => Rneg));
718             end;
719
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;
728
729       else
730          declare
731             Num, Den : Uint;
732
733          begin
734             if Lval.Den < 0 then
735                Num := Lval.Num * (Lval.Rbase ** (-Lval.Den));
736                Den := Rval.Num;
737
738             else
739                Num := Lval.Num;
740                Den := Rval.Num * (Lval.Rbase ** Lval.Den);
741             end if;
742
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;
749
750             else
751                Num := Num * Rval.Den;
752             end if;
753
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;
763
764    -----------
765    -- UR_Eq --
766    -----------
767
768    function UR_Eq (Left, Right : Ureal) return Boolean is
769    begin
770       return not UR_Ne (Left, Right);
771    end UR_Eq;
772
773    ---------------------
774    -- UR_Exponentiate --
775    ---------------------
776
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;
783
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)
787
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;
795
796       Val := Ureals.Table (Bas);
797
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.
800
801       IBas := UR_Trunc (Bas);
802
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));
811
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.
816
817       elsif N < 0 then
818          pragma Assert (Val.Num /= 0);
819          Val := Normalize (Val);
820
821          return Store_Ureal (
822                  (Num      => Val.Den ** X,
823                   Den      => Val.Num ** X,
824                   Rbase    => 0,
825                   Negative => Neg));
826
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,
830
831       else
832          if Val.Rbase /= 0 then
833
834             return Store_Ureal (
835                     (Num      => Val.Num ** X,
836                      Den      => Val.Den * X,
837                      Rbase    => Val.Rbase,
838                      Negative => Neg));
839
840          --  And when the base is zero, in which case we exponentiate
841          --  the old denominator.
842
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;
852
853    --------------
854    -- UR_Floor --
855    --------------
856
857    function UR_Floor (Real : Ureal) return Uint is
858       Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
859
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;
867
868    ------------------------
869    -- UR_From_Components --
870    ------------------------
871
872    function UR_From_Components
873      (Num      : Uint;
874       Den      : Uint;
875       Rbase    : Nat := 0;
876       Negative : Boolean := False)
877       return     Ureal
878    is
879    begin
880       return Store_Ureal (
881                (Num      => Num,
882                 Den      => Den,
883                 Rbase    => Rbase,
884                 Negative => Negative));
885    end UR_From_Components;
886
887    ------------------
888    -- UR_From_Uint --
889    ------------------
890
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;
896
897    -----------
898    -- UR_Ge --
899    -----------
900
901    function UR_Ge (Left, Right : Ureal) return Boolean is
902    begin
903       return not (Left < Right);
904    end UR_Ge;
905
906    -----------
907    -- UR_Gt --
908    -----------
909
910    function UR_Gt (Left, Right : Ureal) return Boolean is
911    begin
912       return (Right < Left);
913    end UR_Gt;
914
915    --------------------
916    -- UR_Is_Negative --
917    --------------------
918
919    function UR_Is_Negative (Real : Ureal) return Boolean is
920    begin
921       return Ureals.Table (Real).Negative;
922    end UR_Is_Negative;
923
924    --------------------
925    -- UR_Is_Positive --
926    --------------------
927
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;
933
934    ----------------
935    -- UR_Is_Zero --
936    ----------------
937
938    function UR_Is_Zero (Real : Ureal) return Boolean is
939    begin
940       return Ureals.Table (Real).Num = 0;
941    end UR_Is_Zero;
942
943    -----------
944    -- UR_Le --
945    -----------
946
947    function UR_Le (Left, Right : Ureal) return Boolean is
948    begin
949       return not (Right < Left);
950    end UR_Le;
951
952    -----------
953    -- UR_Lt --
954    -----------
955
956    function UR_Lt (Left, Right : Ureal) return Boolean is
957    begin
958       --  An operand is not less than itself
959
960       if Same (Left, Right) then
961          return False;
962
963       --  Deal with zero cases
964
965       elsif UR_Is_Zero (Left) then
966          return UR_Is_Positive (Right);
967
968       elsif UR_Is_Zero (Right) then
969          return Ureals.Table (Left).Negative;
970
971       --  Different signs are decisive (note we dealt with zero cases)
972
973       elsif Ureals.Table (Left).Negative
974         and then not Ureals.Table (Right).Negative
975       then
976          return True;
977
978       elsif not Ureals.Table (Left).Negative
979         and then Ureals.Table (Right).Negative
980       then
981          return False;
982
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.
986
987       elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) then
988          return UR_Is_Positive (Left);
989
990       elsif Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right) then
991          return UR_Is_Negative (Left);
992
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.
995
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;
1003
1004          begin
1005             Lval := Ureals.Table (Left);
1006             Rval := Ureals.Table (Right);
1007
1008             --  An optimization. If both numbers are based, then subtract
1009             --  common value of base to avoid unnecessarily giant numbers
1010
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;
1020
1021             Lval := Normalize (Lval);
1022             Rval := Normalize (Rval);
1023
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;
1029
1030             Release (Imrk);
1031             Release (Rmrk);
1032             return Result;
1033          end;
1034       end if;
1035    end UR_Lt;
1036
1037    ------------
1038    -- UR_Max --
1039    ------------
1040
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;
1049
1050    ------------
1051    -- UR_Min --
1052    ------------
1053
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;
1062
1063    ------------
1064    -- UR_Mul --
1065    ------------
1066
1067    function UR_Mul (Left : Uint; Right : Ureal) return Ureal is
1068    begin
1069       return UR_From_Uint (Left) * Right;
1070    end UR_Mul;
1071
1072    function UR_Mul (Left : Ureal; Right : Uint) return Ureal is
1073    begin
1074       return Left * UR_From_Uint (Right);
1075    end UR_Mul;
1076
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;
1083
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)));
1093
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));
1100
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)));
1108
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;
1117
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));
1124
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));
1132
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)));
1140
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;
1149
1150       else
1151          Den := Uint_1;
1152
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;
1158
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;
1164
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;
1173
1174    -----------
1175    -- UR_Ne --
1176    -----------
1177
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).
1182
1183       if Same (Left, Right) then
1184          return False;
1185
1186       --  Deal with case of one or other operand is No_Ureal, but not both
1187
1188       elsif Same (Left, No_Ureal) or else Same (Right, No_Ureal) then
1189          return True;
1190
1191       --  Do quick check based on number of decimal digits
1192
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;
1197
1198       --  Otherwise full comparison is required
1199
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;
1207
1208          begin
1209             if UR_Is_Zero (Left) then
1210                return not UR_Is_Zero (Right);
1211
1212             elsif UR_Is_Zero (Right) then
1213                return not UR_Is_Zero (Left);
1214
1215             --  Both operands are non-zero
1216
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;
1229
1230    ---------------
1231    -- UR_Negate --
1232    ---------------
1233
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;
1242
1243    ------------
1244    -- UR_Sub --
1245    ------------
1246
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;
1251
1252    function UR_Sub (Left : Ureal; Right : Uint) return Ureal is
1253    begin
1254       return Left + UR_From_Uint (-Right);
1255    end UR_Sub;
1256
1257    function UR_Sub (Left, Right : Ureal) return Ureal is
1258    begin
1259       return Left + UR_Negate (Right);
1260    end UR_Sub;
1261
1262    ----------------
1263    -- UR_To_Uint --
1264    ----------------
1265
1266    function UR_To_Uint (Real : Ureal) return Uint is
1267       Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
1268       Res : Uint;
1269
1270    begin
1271       Res := (Val.Num + (Val.Den / 2)) / Val.Den;
1272
1273       if Val.Negative then
1274          return UI_Negate (Res);
1275       else
1276          return Res;
1277       end if;
1278    end UR_To_Uint;
1279
1280    --------------
1281    -- UR_Trunc --
1282    --------------
1283
1284    function UR_Trunc (Real : Ureal) return Uint is
1285       Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
1286
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;
1294
1295    --------------
1296    -- UR_Write --
1297    --------------
1298
1299    procedure UR_Write (Real : Ureal) is
1300       Val : constant Ureal_Entry := Ureals.Table (Real);
1301
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.
1306
1307       if Val.Negative then
1308          Write_Str ("(-");
1309       end if;
1310
1311       --  Constants in base 10 can be written in normal Ada literal style
1312
1313       if Val.Rbase = 10 then
1314          UI_Write (Val.Num / 10);
1315          Write_Char ('.');
1316          UI_Write (Val.Num mod 10);
1317
1318          if Val.Den /= 0 then
1319             Write_Char ('E');
1320             UI_Write (1 - Val.Den);
1321          end if;
1322
1323       --  Constants in a base other than 10 can still be easily written
1324       --  in normal Ada literal style if the numerator is one.
1325
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);
1330
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)
1334
1335       --    (numerator.0*base**exponent)
1336       --    (numerator.0*base**(-exponent))
1337
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 ("**");
1344
1345          if Val.Den <= 0 then
1346             UI_Write (-Val.Den, Decimal);
1347
1348          else
1349             Write_Str ("(-");
1350             UI_Write (Val.Den, Decimal);
1351             Write_Char (')');
1352          end if;
1353
1354          Write_Char (')');
1355
1356       --  Rational constants with a denominator of 1 can be written as
1357       --  a real literal for the numerator integer.
1358
1359       elsif Val.Den = 1 then
1360          UI_Write (Val.Num, Decimal);
1361          Write_Str (".0");
1362
1363       --  Non-based (rational) constants are written in (num/den) style
1364
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;
1372
1373       --  Add trailing paren for negative values
1374
1375       if Val.Negative then
1376          Write_Char (')');
1377       end if;
1378    end UR_Write;
1379
1380    -------------
1381    -- Ureal_0 --
1382    -------------
1383
1384    function Ureal_0 return Ureal is
1385    begin
1386       return UR_0;
1387    end Ureal_0;
1388
1389    -------------
1390    -- Ureal_1 --
1391    -------------
1392
1393    function Ureal_1 return Ureal is
1394    begin
1395       return UR_1;
1396    end Ureal_1;
1397
1398    -------------
1399    -- Ureal_2 --
1400    -------------
1401
1402    function Ureal_2 return Ureal is
1403    begin
1404       return UR_2;
1405    end Ureal_2;
1406
1407    --------------
1408    -- Ureal_10 --
1409    --------------
1410
1411    function Ureal_10 return Ureal is
1412    begin
1413       return UR_10;
1414    end Ureal_10;
1415
1416    ---------------
1417    -- Ureal_100 --
1418    ---------------
1419
1420    function Ureal_100 return Ureal is
1421    begin
1422       return UR_100;
1423    end Ureal_100;
1424
1425    -----------------
1426    -- Ureal_10_36 --
1427    -----------------
1428
1429    function Ureal_10_36 return Ureal is
1430    begin
1431       return UR_10_36;
1432    end Ureal_10_36;
1433
1434    -------------------
1435    -- Ureal_M_10_36 --
1436    -------------------
1437
1438    function Ureal_M_10_36 return Ureal is
1439    begin
1440       return UR_M_10_36;
1441    end Ureal_M_10_36;
1442
1443    -----------------
1444    -- Ureal_2_128 --
1445    -----------------
1446
1447    function Ureal_2_128 return Ureal is
1448    begin
1449       return UR_2_128;
1450    end Ureal_2_128;
1451
1452    ----------------
1453    -- Ureal_2_80 --
1454    ----------------
1455
1456    function Ureal_2_80 return Ureal is
1457    begin
1458       return UR_2_80;
1459    end Ureal_2_80;
1460
1461    -------------------
1462    -- Ureal_2_M_128 --
1463    -------------------
1464
1465    function Ureal_2_M_128 return Ureal is
1466    begin
1467       return UR_2_M_128;
1468    end Ureal_2_M_128;
1469
1470    -------------------
1471    -- Ureal_2_M_80 --
1472    -------------------
1473
1474    function Ureal_2_M_80 return Ureal is
1475    begin
1476       return UR_2_M_80;
1477    end Ureal_2_M_80;
1478
1479    ----------------
1480    -- Ureal_Half --
1481    ----------------
1482
1483    function Ureal_Half return Ureal is
1484    begin
1485       return UR_Half;
1486    end Ureal_Half;
1487
1488    ---------------
1489    -- Ureal_M_0 --
1490    ---------------
1491
1492    function Ureal_M_0 return Ureal is
1493    begin
1494       return UR_M_0;
1495    end Ureal_M_0;
1496
1497    -----------------
1498    -- Ureal_Tenth --
1499    -----------------
1500
1501    function Ureal_Tenth return Ureal is
1502    begin
1503       return UR_Tenth;
1504    end Ureal_Tenth;
1505
1506 end Urealp;