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