gcc/ada/eval_fat.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E V A L _ F A T                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.33 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Einfo;    use Einfo;
  30 with Sem_Util; use Sem_Util;
  31 with Ttypef;   use Ttypef;
  32 with Targparm; use Targparm;
  33
  34 package body Eval_Fat is
  35
  36    Radix : constant Int := 2;
  37    --  This code is currently only correct for the radix 2 case. We use
  38    --  the symbolic value Radix where possible to help in the unlikely
  39    --  case of anyone ever having to adjust this code for another value,
  40    --  and for documentation purposes.
  41
  42    type Radix_Power_Table is array (Int range 1 .. 4) of Int;
  43
  44    Radix_Powers : constant Radix_Power_Table
  45      := (Radix**1, Radix**2, Radix**3, Radix**4);
  46
  47    function Float_Radix return T renames Ureal_2;
  48    --  Radix expressed in real form
  49
  50    -----------------------
  51    -- Local Subprograms --
  52    -----------------------
  53
  54    procedure Decompose
  55      (RT       : R;
  56       X        : in T;
  57       Fraction : out T;
  58       Exponent : out UI;
  59       Mode     : Rounding_Mode := Round);
  60    --  Decomposes a non-zero floating-point number into fraction and
  61    --  exponent parts. The fraction is in the interval 1.0 / Radix ..
  62    --  T'Pred (1.0) and uses Rbase = Radix.
  63    --  The result is rounded to a nearest machine number.
  64
  65    procedure Decompose_Int
  66      (RT               : R;
  67       X                : in T;
  68       Fraction         : out UI;
  69       Exponent         : out UI;
  70       Mode             : Rounding_Mode);
  71    --  This is similar to Decompose, except that the Fraction value returned
  72    --  is an integer representing the value Fraction * Scale, where Scale is
  73    --  the value (Radix ** Machine_Mantissa (RT)). The value is obtained by
  74    --  using biased rounding (halfway cases round away from zero), round to
  75    --  even, a floor operation or a ceiling operation depending on the setting
  76    --  of Mode (see corresponding descriptions in Urealp).
  77    --  In case rounding was specified, Rounding_Was_Biased is set True
  78    --  if the input was indeed halfway between to machine numbers and
  79    --  got rounded away from zero to an odd number.
  80
  81    function Eps_Model (RT : R) return T;
  82    --  Return the smallest model number of R.
  83
  84    function Eps_Denorm (RT : R) return T;
  85    --  Return the smallest denormal of type R.
  86
  87    function Machine_Mantissa (RT : R) return Nat;
  88    --  Get value of machine mantissa
  89
  90    --------------
  91    -- Adjacent --
  92    --------------
  93
  94    function Adjacent (RT : R; X, Towards : T) return T is
  95    begin
  96       if Towards = X then
  97          return X;
  98
  99       elsif Towards > X then
 100          return Succ (RT, X);
 101
 102       else
 103          return Pred (RT, X);
 104       end if;
 105    end Adjacent;
 106
 107    -------------
 108    -- Ceiling --
 109    -------------
 110
 111    function Ceiling (RT : R; X : T) return T is
 112       XT : constant T := Truncation (RT, X);
 113
 114    begin
 115       if UR_Is_Negative (X) then
 116          return XT;
 117
 118       elsif X = XT then
 119          return X;
 120
 121       else
 122          return XT + Ureal_1;
 123       end if;
 124    end Ceiling;
 125
 126    -------------
 127    -- Compose --
 128    -------------
 129
 130    function Compose (RT : R; Fraction : T; Exponent : UI) return T is
 131       Arg_Frac : T;
 132       Arg_Exp  : UI;
 133
 134    begin
 135       if UR_Is_Zero (Fraction) then
 136          return Fraction;
 137       else
 138          Decompose (RT, Fraction, Arg_Frac, Arg_Exp);
 139          return Scaling (RT, Arg_Frac, Exponent);
 140       end if;
 141    end Compose;
 142
 143    ---------------
 144    -- Copy_Sign --
 145    ---------------
 146
 147    function Copy_Sign (RT : R; Value, Sign : T) return T is
 148       Result : T;
 149
 150    begin
 151       Result := abs Value;
 152
 153       if UR_Is_Negative (Sign) then
 154          return -Result;
 155       else
 156          return Result;
 157       end if;
 158    end Copy_Sign;
 159
 160    ---------------
 161    -- Decompose --
 162    ---------------
 163
 164    procedure Decompose
 165      (RT       : R;
 166       X        : in T;
 167       Fraction : out T;
 168       Exponent : out UI;
 169       Mode     : Rounding_Mode := Round)
 170    is
 171       Int_F : UI;
 172
 173    begin
 174       Decompose_Int (RT, abs X, Int_F, Exponent, Mode);
 175
 176       Fraction := UR_From_Components
 177        (Num      => Int_F,
 178         Den      => UI_From_Int (Machine_Mantissa (RT)),
 179         Rbase    => Radix,
 180         Negative => False);
 181
 182       if UR_Is_Negative (X) then
 183          Fraction := -Fraction;
 184       end if;
 185
 186       return;
 187    end Decompose;
 188
 189    -------------------
 190    -- Decompose_Int --
 191    -------------------
 192
 193    --  This procedure should be modified with care, as there
 194    --  are many non-obvious details that may cause problems
 195    --  that are hard to detect. The cases of positive and
 196    --  negative zeroes are also special and should be
 197    --  verified separately.
 198
 199    procedure Decompose_Int
 200      (RT               : R;
 201       X                : in T;
 202       Fraction         : out UI;
 203       Exponent         : out UI;
 204       Mode             : Rounding_Mode)
 205    is
 206       Base : Int := Rbase (X);
 207       N    : UI  := abs Numerator (X);
 208       D    : UI  := Denominator (X);
 209
 210       N_Times_Radix : UI;
 211
 212       Even : Boolean;
 213       --  True iff Fraction is even
 214
 215       Most_Significant_Digit : constant UI :=
 216                                  Radix ** (Machine_Mantissa (RT) - 1);
 217
 218       Uintp_Mark : Uintp.Save_Mark;
 219       --  The code is divided into blocks that systematically release
 220       --  intermediate values (this routine generates lots of junk!)
 221
 222    begin
 223       Calculate_D_And_Exponent_1 : begin
 224          Uintp_Mark := Mark;
 225          Exponent := Uint_0;
 226
 227          --  In cases where Base > 1, the actual denominator is
 228          --  Base**D. For cases where Base is a power of Radix, use
 229          --  the value 1 for the Denominator and adjust the exponent.
 230
 231          --  Note: Exponent has different sign from D, because D is a divisor
 232
 233          for Power in 1 .. Radix_Powers'Last loop
 234             if Base = Radix_Powers (Power) then
 235                Exponent := -D * Power;
 236                Base := 0;
 237                D := Uint_1;
 238                exit;
 239             end if;
 240          end loop;
 241
 242          Release_And_Save (Uintp_Mark, D, Exponent);
 243       end Calculate_D_And_Exponent_1;
 244
 245       if Base > 0 then
 246          Calculate_Exponent : begin
 247             Uintp_Mark := Mark;
 248
 249             --  For bases that are a multiple of the Radix, divide
 250             --  the base by Radix and adjust the Exponent. This will
 251             --  help because D will be much smaller and faster to process.
 252
 253             --  This occurs for decimal bases on a machine with binary
 254             --  floating-point for example. When calculating 1E40,
 255             --  with Radix = 2, N will be 93 bits instead of 133.
 256
 257             --        N            E
 258             --      ------  * Radix
 259             --           D
 260             --       Base
 261
 262             --                  N                        E
 263             --    =  --------------------------  *  Radix
 264             --                     D        D
 265             --         (Base/Radix)  * Radix
 266
 267             --             N                  E-D
 268             --    =  ---------------  *  Radix
 269             --                    D
 270             --        (Base/Radix)
 271
 272             --  This code is commented out, because it causes numerous
 273             --  failures in the regression suite. To be studied ???
 274
 275             while False and then Base > 0 and then Base mod Radix = 0 loop
 276                Base := Base / Radix;
 277                Exponent := Exponent + D;
 278             end loop;
 279
 280             Release_And_Save (Uintp_Mark, Exponent);
 281          end Calculate_Exponent;
 282
 283          --  For remaining bases we must actually compute
 284          --  the exponentiation.
 285
 286          --  Because the exponentiation can be negative, and D must
 287          --  be integer, the numerator is corrected instead.
 288
 289          Calculate_N_And_D : begin
 290             Uintp_Mark := Mark;
 291
 292             if D < 0 then
 293                N := N * Base ** (-D);
 294                D := Uint_1;
 295             else
 296                D := Base ** D;
 297             end if;
 298
 299             Release_And_Save (Uintp_Mark, N, D);
 300          end Calculate_N_And_D;
 301
 302          Base := 0;
 303       end if;
 304
 305       --  Now scale N and D so that N / D is a value in the
 306       --  interval [1.0 / Radix, 1.0) and adjust Exponent accordingly,
 307       --  so the value N / D * Radix ** Exponent remains unchanged.
 308
 309       --  Step 1 - Adjust N so N / D >= 1 / Radix, or N = 0
 310
 311       --  N and D are positive, so N / D >= 1 / Radix implies N * Radix >= D.
 312       --  This scaling is not possible for N is Uint_0 as there
 313       --  is no way to scale Uint_0 so the first digit is non-zero.
 314
 315       Calculate_N_And_Exponent : begin
 316          Uintp_Mark := Mark;
 317
 318          N_Times_Radix := N * Radix;
 319
 320          if N /= Uint_0 then
 321             while not (N_Times_Radix >= D) loop
 322                N := N_Times_Radix;
 323                Exponent := Exponent - 1;
 324
 325                N_Times_Radix := N * Radix;
 326             end loop;
 327          end if;
 328
 329          Release_And_Save (Uintp_Mark, N, Exponent);
 330       end Calculate_N_And_Exponent;
 331
 332       --  Step 2 - Adjust D so N / D < 1
 333
 334       --  Scale up D so N / D < 1, so N < D
 335
 336       Calculate_D_And_Exponent_2 : begin
 337          Uintp_Mark := Mark;
 338
 339          while not (N < D) loop
 340
 341             --  As N / D >= 1, N / (D * Radix) will be at least 1 / Radix,
 342             --  so the result of Step 1 stays valid
 343
 344             D := D * Radix;
 345             Exponent := Exponent + 1;
 346          end loop;
 347
 348          Release_And_Save (Uintp_Mark, D, Exponent);
 349       end Calculate_D_And_Exponent_2;
 350
 351       --  Here the value N / D is in the range [1.0 / Radix .. 1.0)
 352
 353       --  Now find the fraction by doing a very simple-minded
 354       --  division until enough digits have been computed.
 355
 356       --  This division works for all radices, but is only efficient for
 357       --  a binary radix. It is just like a manual division algorithm,
 358       --  but instead of moving the denominator one digit right, we move
 359       --  the numerator one digit left so the numerator and denominator
 360       --  remain integral.
 361
 362       Fraction := Uint_0;
 363       Even := True;
 364
 365       Calculate_Fraction_And_N : begin
 366          Uintp_Mark := Mark;
 367
 368          loop
 369             while N >= D loop
 370                N := N - D;
 371                Fraction := Fraction + 1;
 372                Even := not Even;
 373             end loop;
 374
 375             --  Stop when the result is in [1.0 / Radix, 1.0)
 376
 377             exit when Fraction >= Most_Significant_Digit;
 378
 379             N := N * Radix;
 380             Fraction := Fraction * Radix;
 381             Even := True;
 382          end loop;
 383
 384          Release_And_Save (Uintp_Mark, Fraction, N);
 385       end Calculate_Fraction_And_N;
 386
 387       Calculate_Fraction_And_Exponent : begin
 388          Uintp_Mark := Mark;
 389
 390          --  Put back sign before applying the rounding.
 391
 392          if UR_Is_Negative (X) then
 393             Fraction := -Fraction;
 394          end if;
 395
 396          --  Determine correct rounding based on the remainder
 397          --  which is in N and the divisor D.
 398
 399          Rounding_Was_Biased := False; -- Until proven otherwise
 400
 401          case Mode is
 402             when Round_Even =>
 403
 404                --  This rounding mode should not be used for static
 405                --  expressions, but only for compile-time evaluation
 406                --  of non-static expressions.
 407
 408                if (Even and then N * 2 > D)
 409                      or else
 410                   (not Even and then N * 2 >= D)
 411                then
 412                   Fraction := Fraction + 1;
 413                end if;
 414
 415             when Round   =>
 416
 417                --  Do not round to even as is done with IEEE arithmetic,
 418                --  but instead round away from zero when the result is
 419                --  exactly between two machine numbers. See RM 4.9(38).
 420
 421                if N * 2 >= D then
 422                   Fraction := Fraction + 1;
 423
 424                   Rounding_Was_Biased := Even and then N * 2 = D;
 425                   --  Check for the case where the result is actually
 426                   --  different from Round_Even.
 427                end if;
 428
 429             when Ceiling =>
 430                if N > Uint_0 then
 431                   Fraction := Fraction + 1;
 432                end if;
 433
 434             when Floor   => null;
 435          end case;
 436
 437          --  The result must be normalized to [1.0/Radix, 1.0),
 438          --  so adjust if the result is 1.0 because of rounding.
 439
 440          if Fraction = Most_Significant_Digit * Radix then
 441             Fraction := Most_Significant_Digit;
 442             Exponent := Exponent + 1;
 443          end if;
 444
 445          Release_And_Save (Uintp_Mark, Fraction, Exponent);
 446       end Calculate_Fraction_And_Exponent;
 447
 448    end Decompose_Int;
 449
 450    ----------------
 451    -- Eps_Denorm --
 452    ----------------
 453
 454    function Eps_Denorm (RT : R) return T is
 455       Digs : constant UI := Digits_Value (RT);
 456       Emin : Int;
 457       Mant : Int;
 458
 459    begin
 460       if Vax_Float (RT) then
 461          if Digs = VAXFF_Digits then
 462             Emin := VAXFF_Machine_Emin;
 463             Mant := VAXFF_Machine_Mantissa;
 464
 465          elsif Digs = VAXDF_Digits then
 466             Emin := VAXDF_Machine_Emin;
 467             Mant := VAXDF_Machine_Mantissa;
 468
 469          else
 470             pragma Assert (Digs = VAXGF_Digits);
 471             Emin := VAXGF_Machine_Emin;
 472             Mant := VAXGF_Machine_Mantissa;
 473          end if;
 474
 475       elsif Is_AAMP_Float (RT) then
 476          if Digs = AAMPS_Digits then
 477             Emin := AAMPS_Machine_Emin;
 478             Mant := AAMPS_Machine_Mantissa;
 479
 480          else
 481             pragma Assert (Digs = AAMPL_Digits);
 482             Emin := AAMPL_Machine_Emin;
 483             Mant := AAMPL_Machine_Mantissa;
 484          end if;
 485
 486       else
 487          if Digs = IEEES_Digits then
 488             Emin := IEEES_Machine_Emin;
 489             Mant := IEEES_Machine_Mantissa;
 490
 491          elsif Digs = IEEEL_Digits then
 492             Emin := IEEEL_Machine_Emin;
 493             Mant := IEEEL_Machine_Mantissa;
 494
 495          else
 496             pragma Assert (Digs = IEEEX_Digits);
 497             Emin := IEEEX_Machine_Emin;
 498             Mant := IEEEX_Machine_Mantissa;
 499          end if;
 500       end if;
 501
 502       return Float_Radix ** UI_From_Int (Emin - Mant);
 503    end Eps_Denorm;
 504
 505    ---------------
 506    -- Eps_Model --
 507    ---------------
 508
 509    function Eps_Model (RT : R) return T is
 510       Digs : constant UI := Digits_Value (RT);
 511       Emin : Int;
 512
 513    begin
 514       if Vax_Float (RT) then
 515          if Digs = VAXFF_Digits then
 516             Emin := VAXFF_Machine_Emin;
 517
 518          elsif Digs = VAXDF_Digits then
 519             Emin := VAXDF_Machine_Emin;
 520
 521          else
 522             pragma Assert (Digs = VAXGF_Digits);
 523             Emin := VAXGF_Machine_Emin;
 524          end if;
 525
 526       elsif Is_AAMP_Float (RT) then
 527          if Digs = AAMPS_Digits then
 528             Emin := AAMPS_Machine_Emin;
 529
 530          else
 531             pragma Assert (Digs = AAMPL_Digits);
 532             Emin := AAMPL_Machine_Emin;
 533          end if;
 534
 535       else
 536          if Digs = IEEES_Digits then
 537             Emin := IEEES_Machine_Emin;
 538
 539          elsif Digs = IEEEL_Digits then
 540             Emin := IEEEL_Machine_Emin;
 541
 542          else
 543             pragma Assert (Digs = IEEEX_Digits);
 544             Emin := IEEEX_Machine_Emin;
 545          end if;
 546       end if;
 547
 548       return Float_Radix ** UI_From_Int (Emin);
 549    end Eps_Model;
 550
 551    --------------
 552    -- Exponent --
 553    --------------
 554
 555    function Exponent (RT : R; X : T) return UI is
 556       X_Frac : UI;
 557       X_Exp  : UI;
 558
 559    begin
 560       if UR_Is_Zero (X) then
 561          return Uint_0;
 562       else
 563          Decompose_Int (RT, X, X_Frac, X_Exp, Round_Even);
 564          return X_Exp;
 565       end if;
 566    end Exponent;
 567
 568    -----------
 569    -- Floor --
 570    -----------
 571
 572    function Floor (RT : R; X : T) return T is
 573       XT : constant T := Truncation (RT, X);
 574
 575    begin
 576       if UR_Is_Positive (X) then
 577          return XT;
 578
 579       elsif XT = X then
 580          return X;
 581
 582       else
 583          return XT - Ureal_1;
 584       end if;
 585    end Floor;
 586
 587    --------------
 588    -- Fraction --
 589    --------------
 590
 591    function Fraction (RT : R; X : T) return T is
 592       X_Frac : T;
 593       X_Exp  : UI;
 594
 595    begin
 596       if UR_Is_Zero (X) then
 597          return X;
 598       else
 599          Decompose (RT, X, X_Frac, X_Exp);
 600          return X_Frac;
 601       end if;
 602    end Fraction;
 603
 604    ------------------
 605    -- Leading_Part --
 606    ------------------
 607
 608    function Leading_Part (RT : R; X : T; Radix_Digits : UI) return T is
 609       L    : UI;
 610       Y, Z : T;
 611
 612    begin
 613       if Radix_Digits >= Machine_Mantissa (RT) then
 614          return X;
 615
 616       else
 617          L := Exponent (RT, X) - Radix_Digits;
 618          Y := Truncation (RT, Scaling (RT, X, -L));
 619          Z := Scaling (RT, Y, L);
 620          return Z;
 621       end if;
 622
 623    end Leading_Part;
 624
 625    -------------
 626    -- Machine --
 627    -------------
 628
 629    function Machine (RT : R; X : T; Mode : Rounding_Mode) return T is
 630       X_Frac : T;
 631       X_Exp  : UI;
 632
 633    begin
 634       if UR_Is_Zero (X) then
 635          return X;
 636       else
 637          Decompose (RT, X, X_Frac, X_Exp, Mode);
 638          return Scaling (RT, X_Frac, X_Exp);
 639       end if;
 640    end Machine;
 641
 642    ----------------------
 643    -- Machine_Mantissa --
 644    ----------------------
 645
 646    function Machine_Mantissa (RT : R) return Nat is
 647       Digs : constant UI := Digits_Value (RT);
 648       Mant : Nat;
 649
 650    begin
 651       if Vax_Float (RT) then
 652          if Digs = VAXFF_Digits then
 653             Mant := VAXFF_Machine_Mantissa;
 654
 655          elsif Digs = VAXDF_Digits then
 656             Mant := VAXDF_Machine_Mantissa;
 657
 658          else
 659             pragma Assert (Digs = VAXGF_Digits);
 660             Mant := VAXGF_Machine_Mantissa;
 661          end if;
 662
 663       elsif Is_AAMP_Float (RT) then
 664          if Digs = AAMPS_Digits then
 665             Mant := AAMPS_Machine_Mantissa;
 666
 667          else
 668             pragma Assert (Digs = AAMPL_Digits);
 669             Mant := AAMPL_Machine_Mantissa;
 670          end if;
 671
 672       else
 673          if Digs = IEEES_Digits then
 674             Mant := IEEES_Machine_Mantissa;
 675
 676          elsif Digs = IEEEL_Digits then
 677             Mant := IEEEL_Machine_Mantissa;
 678
 679          else
 680             pragma Assert (Digs = IEEEX_Digits);
 681             Mant := IEEEX_Machine_Mantissa;
 682          end if;
 683       end if;
 684
 685       return Mant;
 686    end Machine_Mantissa;
 687
 688    -----------
 689    -- Model --
 690    -----------
 691
 692    function Model (RT : R; X : T) return T is
 693       X_Frac : T;
 694       X_Exp  : UI;
 695
 696    begin
 697       Decompose (RT, X, X_Frac, X_Exp);
 698       return Compose (RT, X_Frac, X_Exp);
 699    end Model;
 700
 701    ----------
 702    -- Pred --
 703    ----------
 704
 705    function Pred (RT : R; X : T) return T is
 706       Result_F : UI;
 707       Result_X : UI;
 708
 709    begin
 710       if abs X < Eps_Model (RT) then
 711          if Denorm_On_Target then
 712             return X - Eps_Denorm (RT);
 713
 714          elsif X > Ureal_0 then
 715             --  Target does not support denorms, so predecessor is 0.0
 716             return Ureal_0;
 717
 718          else
 719             --  Target does not support denorms, and X is 0.0
 720             --  or at least bigger than -Eps_Model (RT)
 721
 722             return -Eps_Model (RT);
 723          end if;
 724
 725       else
 726          Decompose_Int (RT, X, Result_F,  Result_X, Ceiling);
 727          return UR_From_Components
 728            (Num      => Result_F - 1,
 729             Den      => Machine_Mantissa (RT) - Result_X,
 730             Rbase    => Radix,
 731             Negative => False);
 732          --  Result_F may be false, but this is OK as UR_From_Components
 733          --  handles that situation.
 734       end if;
 735    end Pred;
 736
 737    ---------------
 738    -- Remainder --
 739    ---------------
 740
 741    function Remainder (RT : R; X, Y : T) return T is
 742       A        : T;
 743       B        : T;
 744       Arg      : T;
 745       P        : T;
 746       Arg_Frac : T;
 747       P_Frac   : T;
 748       Sign_X   : T;
 749       IEEE_Rem : T;
 750       Arg_Exp  : UI;
 751       P_Exp    : UI;
 752       K        : UI;
 753       P_Even   : Boolean;
 754
 755    begin
 756       if UR_Is_Positive (X) then
 757          Sign_X :=  Ureal_1;
 758       else
 759          Sign_X := -Ureal_1;
 760       end if;
 761
 762       Arg := abs X;
 763       P   := abs Y;
 764
 765       if Arg < P then
 766          P_Even := True;
 767          IEEE_Rem := Arg;
 768          P_Exp := Exponent (RT, P);
 769
 770       else
 771          --  ??? what about zero cases?
 772          Decompose (RT, Arg, Arg_Frac, Arg_Exp);
 773          Decompose (RT, P,   P_Frac,   P_Exp);
 774
 775          P := Compose (RT, P_Frac, Arg_Exp);
 776          K := Arg_Exp - P_Exp;
 777          P_Even := True;
 778          IEEE_Rem := Arg;
 779
 780          for Cnt in reverse 0 .. UI_To_Int (K) loop
 781             if IEEE_Rem >= P then
 782                P_Even := False;
 783                IEEE_Rem := IEEE_Rem - P;
 784             else
 785                P_Even := True;
 786             end if;
 787
 788             P := P * Ureal_Half;
 789          end loop;
 790       end if;
 791
 792       --  That completes the calculation of modulus remainder. The final step
 793       --  is get the IEEE remainder. Here we compare Rem with (abs Y) / 2.
 794
 795       if P_Exp >= 0 then
 796          A := IEEE_Rem;
 797          B := abs Y * Ureal_Half;
 798
 799       else
 800          A := IEEE_Rem * Ureal_2;
 801          B := abs Y;
 802       end if;
 803
 804       if A > B or else (A = B and then not P_Even) then
 805          IEEE_Rem := IEEE_Rem - abs Y;
 806       end if;
 807
 808       return Sign_X * IEEE_Rem;
 809
 810    end Remainder;
 811
 812    --------------
 813    -- Rounding --
 814    --------------
 815
 816    function Rounding (RT : R; X : T) return T is
 817       Result : T;
 818       Tail   : T;
 819
 820    begin
 821       Result := Truncation (RT, abs X);
 822       Tail   := abs X - Result;
 823
 824       if Tail >= Ureal_Half  then
 825          Result := Result + Ureal_1;
 826       end if;
 827
 828       if UR_Is_Negative (X) then
 829          return -Result;
 830       else
 831          return Result;
 832       end if;
 833
 834    end Rounding;
 835
 836    -------------
 837    -- Scaling --
 838    -------------
 839
 840    function Scaling (RT : R; X : T; Adjustment : UI) return T is
 841    begin
 842       if Rbase (X) = Radix then
 843          return UR_From_Components
 844            (Num      => Numerator (X),
 845             Den      => Denominator (X) - Adjustment,
 846             Rbase    => Radix,
 847             Negative => UR_Is_Negative (X));
 848
 849       elsif Adjustment >= 0 then
 850          return X * Radix ** Adjustment;
 851       else
 852          return X / Radix ** (-Adjustment);
 853       end if;
 854    end Scaling;
 855
 856    ----------
 857    -- Succ --
 858    ----------
 859
 860    function Succ (RT : R; X : T) return T is
 861       Result_F : UI;
 862       Result_X : UI;
 863
 864    begin
 865       if abs X < Eps_Model (RT) then
 866          if Denorm_On_Target then
 867             return X + Eps_Denorm (RT);
 868
 869          elsif X < Ureal_0 then
 870             --  Target does not support denorms, so successor is 0.0
 871             return Ureal_0;
 872
 873          else
 874             --  Target does not support denorms, and X is 0.0
 875             --  or at least smaller than Eps_Model (RT)
 876
 877             return Eps_Model (RT);
 878          end if;
 879
 880       else
 881          Decompose_Int (RT, X, Result_F, Result_X, Floor);
 882          return UR_From_Components
 883            (Num      => Result_F + 1,
 884             Den      => Machine_Mantissa (RT) - Result_X,
 885             Rbase    => Radix,
 886             Negative => False);
 887          --  Result_F may be false, but this is OK as UR_From_Components
 888          --  handles that situation.
 889       end if;
 890    end Succ;
 891
 892    ----------------
 893    -- Truncation --
 894    ----------------
 895
 896    function Truncation (RT : R; X : T) return T is
 897    begin
 898       return UR_From_Uint (UR_Trunc (X));
 899    end Truncation;
 900
 901    -----------------------
 902    -- Unbiased_Rounding --
 903    -----------------------
 904
 905    function Unbiased_Rounding (RT : R; X : T) return T is
 906       Abs_X  : constant T := abs X;
 907       Result : T;
 908       Tail   : T;
 909
 910    begin
 911       Result := Truncation (RT, Abs_X);
 912       Tail   := Abs_X - Result;
 913
 914       if Tail > Ureal_Half  then
 915          Result := Result + Ureal_1;
 916
 917       elsif Tail = Ureal_Half then
 918          Result := Ureal_2 *
 919                      Truncation (RT, (Result / Ureal_2) + Ureal_Half);
 920       end if;
 921
 922       if UR_Is_Negative (X) then
 923          return -Result;
 924       elsif UR_Is_Positive (X) then
 925          return Result;
 926
 927       --  For zero case, make sure sign of zero is preserved
 928
 929       else
 930          return X;
 931       end if;
 932
 933    end Unbiased_Rounding;
 934
 935 end Eval_Fat;