OSDN Git Service

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