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