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