gcc/ada/libgnat/s-valuef.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                       S Y S T E M . V A L U E _ F                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 2020-2024, Free Software Foundation, Inc.       --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with System.Unsigned_Types; use System.Unsigned_Types;
  33 with System.Val_Util;       use System.Val_Util;
  34 with System.Value_R;
  35
  36 package body System.Value_F is
  37
  38    --  The prerequisite of the implementation is that the computation of the
  39    --  operands of the scaled divide does not unduly overflow when the small
  40    --  is neither an integer nor the reciprocal of an integer, which means
  41    --  that its numerator and denominator must be both not larger than the
  42    --  smallest divide 2**(Int'Size - 1) / Base where Base ranges over the
  43    --  supported values for the base of the literal. Given that the largest
  44    --  supported base is 16, this gives a limit of 2**(Int'Size - 5).
  45
  46    pragma Assert (Int'Size <= Uns'Size);
  47    --  We need an unsigned type large enough to represent the mantissa
  48
  49    package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1), Round => True);
  50    --  We use the Extra digit for ordinary fixed-point types
  51
  52    function Integer_To_Fixed
  53      (Str    : String;
  54       Val    : Uns;
  55       Base   : Unsigned;
  56       ScaleB : Integer;
  57       Extra  : Unsigned;
  58       Minus  : Boolean;
  59       Num    : Int;
  60       Den    : Int) return Int;
  61    --  Convert the real value from integer to fixed point representation
  62
  63    --  The goal is to compute Val * (Base ** ScaleB) / (Num / Den) with correct
  64    --  rounding for all decimal values output by Typ'Image, that is to say up
  65    --  to Typ'Aft decimal digits. Unlike for the output, the RM does not say
  66    --  what the rounding must be for the input, but a reasonable exegesis of
  67    --  the intent is that Typ'Value o Typ'Image should be the identity, which
  68    --  is made possible because 'Aft is defined such that 'Image is injective.
  69
  70    --  For a type with a mantissa of M bits including the sign, the number N1
  71    --  of decimal digits required to represent all the numbers is given by:
  72
  73    --    N1 = ceil ((M - 1) * log 2 / log 10) [N1 = 10/19/39 for M = 32/64/128]
  74
  75    --  but this mantissa can represent any set of contiguous numbers with only
  76    --  N2 different decimal digits where:
  77
  78    --    N2 = floor ((M - 1) * log 2 / log 10) [N2 = 9/18/38 for M = 32/64/128]
  79
  80    --  Of course N1 = N2 + 1 holds, which means both that Val may not contain
  81    --  enough significant bits to represent all the values of the type and that
  82    --  1 extra decimal digit contains the information for the missing bits.
  83
  84    --  Therefore the actual computation to be performed is
  85
  86    --    V = (Val * Base + Extra) * (Base ** (ScaleB - 1)) / (Num / Den)
  87
  88    --  using two steps of scaled divide if Extra is positive and ScaleB too
  89
  90    --    (1)  Val * (Den * (Base ** ScaleB)) = Q1 * Num + R1
  91
  92    --    (2)  Extra * (Den * (Base ** ScaleB)) = Q2 * -Base + R2
  93
  94    --  which yields after dividing (1) by Num and (2) by Num * Base and summing
  95
  96    --    V = Q1 + (R1 - Q2) / Num + R2 / (Num * Base)
  97
  98    --  but we get rid of the third term by using a rounding divide for (2).
  99
 100    --  This works only if Den * (Base ** ScaleB) does not overflow for inputs
 101    --  corresponding to 'Image. Let S = Num / Den, B = Base and N the scale in
 102    --  base B of S, i.e. the smallest integer such that B**N * S >= 1. Then,
 103    --  for X a positive of the mantissa, i.e. 1 <= X <= 2**(M-1), we have
 104
 105    --    1/B <= X * S * B**(N-1) < 2**(M-1)
 106
 107    --  which means that the inputs corresponding to the output of 'Image have a
 108    --  ScaleB equal either to 1 - N or (after multiplying the inequality by B)
 109    --  to -N, possibly after renormalizing X, i.e. multiplying it by a suitable
 110    --  power of B. Therefore
 111
 112    --    Den * (Base ** ScaleB) <= Den * (B ** (1 - N)) < Num * B
 113
 114    --  which means that the product does not overflow if Num <= 2**(M-1) / B.
 115
 116    --  On the other hand, if Extra is positive and ScaleB negative, the above
 117    --  two steps are
 118
 119    --   (1b)  Val * Den = Q1 * (Num * (Base ** -ScaleB)) + R1
 120
 121    --   (2b)  Extra * Den = Q2 * -Base + R2
 122
 123    --  which yields after dividing (1b) by Num * (Base ** -ScaleB) and (2b) by
 124    --  Num * (Base ** (1 - ScaleB)) and summing
 125
 126    --    V = Q1 + (R1 - Q2) / (Num * (Base ** -ScaleB)) + R2 / ...
 127
 128    --  but we get rid of the third term by using a rounding divide for (2b).
 129
 130    --  This works only if Num * (Base ** -ScaleB) does not overflow for inputs
 131    --  corresponding to 'Image. With the determination of ScaleB above, we have
 132
 133    --    Num * (Base ** -ScaleB) <= Num * (B ** N) < Den * B
 134
 135    --  which means that the product does not overflow if Den <= 2**(M-1) / B.
 136
 137    ----------------------
 138    -- Integer_To_Fixed --
 139    ----------------------
 140
 141    function Integer_To_Fixed
 142      (Str    : String;
 143       Val    : Uns;
 144       Base   : Unsigned;
 145       ScaleB : Integer;
 146       Extra  : Unsigned;
 147       Minus  : Boolean;
 148       Num    : Int;
 149       Den    : Int) return Int
 150    is
 151       pragma Assert (Base in 2 .. 16);
 152
 153       pragma Assert (Extra < Base);
 154       --  Accept only one extra digit after those used for Val
 155
 156       pragma Assert (Num < 0 and then Den < 0);
 157       --  Accept only negative numbers to allow -2**(Int'Size - 1)
 158
 159       function Safe_Expont
 160         (Base   : Int;
 161          Exp    : in out Natural;
 162          Factor : Int) return Int;
 163       --  Return (Base ** Exp) * Factor if the computation does not overflow,
 164       --  or else the number of the form (Base ** K) * Factor with the largest
 165       --  magnitude if the former computation overflows. In both cases, Exp is
 166       --  updated to contain the remaining power in the computation. Note that
 167       --  Factor is expected to be negative in this context.
 168
 169       function Unsigned_To_Signed (Val : Uns) return Int;
 170       --  Convert an integer value from unsigned to signed representation
 171
 172       -----------------
 173       -- Safe_Expont --
 174       -----------------
 175
 176       function Safe_Expont
 177         (Base   : Int;
 178          Exp    : in out Natural;
 179          Factor : Int) return Int
 180       is
 181          pragma Assert (Base /= 0 and then Factor < 0);
 182
 183          Min : constant Int := Int'First / Base;
 184
 185          Result : Int := Factor;
 186
 187       begin
 188          while Exp > 0 and then Result >= Min loop
 189             Result := Result * Base;
 190             Exp    := Exp - 1;
 191          end loop;
 192
 193          return Result;
 194       end Safe_Expont;
 195
 196       ------------------------
 197       -- Unsigned_To_Signed --
 198       ------------------------
 199
 200       function Unsigned_To_Signed (Val : Uns) return Int is
 201       begin
 202          --  Deal with overflow cases, and also with largest negative number
 203
 204          if Val > Uns (Int'Last) then
 205             if Minus and then Val = Uns (-(Int'First)) then
 206                return Int'First;
 207             else
 208                Bad_Value (Str);
 209             end if;
 210
 211          --  Negative values
 212
 213          elsif Minus then
 214             return -(Int (Val));
 215
 216          --  Positive values
 217
 218          else
 219             return Int (Val);
 220          end if;
 221       end Unsigned_To_Signed;
 222
 223       --  Local variables
 224
 225       B : constant Int := Int (Base);
 226
 227       V : Uns := Val;
 228       E : Uns := Uns (Extra);
 229
 230       Y, Z, Q1, R1, Q2, R2 : Int;
 231
 232    begin
 233       --  We will use a scaled divide operation for which we must control the
 234       --  magnitude of operands so that an overflow exception is not unduly
 235       --  raised during the computation. The only real concern is the exponent.
 236
 237       --  If ScaleB is too negative, then drop trailing digits, but preserve
 238       --  the last dropped digit.
 239
 240       if ScaleB < 0 then
 241          declare
 242             LS : Integer := -ScaleB;
 243
 244          begin
 245             Y := Den;
 246             Z := Safe_Expont (B, LS, Num);
 247
 248             for J in 1 .. LS loop
 249                E := V rem Uns (B);
 250                V := V / Uns (B);
 251             end loop;
 252          end;
 253
 254       --  If ScaleB is too positive, then scale V up, which may then overflow
 255
 256       elsif ScaleB > 0 then
 257          declare
 258             LS : Integer := ScaleB;
 259
 260          begin
 261             Y := Safe_Expont (B, LS, Den);
 262             Z := Num;
 263
 264             for J in 1 .. LS loop
 265                if V <= (Uns'Last - E) / Uns (B) then
 266                   V := V * Uns (B) + E;
 267                   E := 0;
 268                else
 269                   Bad_Value (Str);
 270                end if;
 271             end loop;
 272          end;
 273
 274       --  If ScaleB is zero, then proceed directly
 275
 276       else
 277          Y := Den;
 278          Z := Num;
 279       end if;
 280
 281       --  Perform a scaled divide operation with final rounding to match Image
 282       --  using two steps if there is an extra digit available. The second and
 283       --  third operands are always negative so the sign of the quotient is the
 284       --  sign of the first operand and the sign of the remainder the opposite.
 285
 286       if E > 0 then
 287          Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q1, R1, Round => False);
 288          Scaled_Divide (Unsigned_To_Signed (E), Y, -B, Q2, R2, Round => True);
 289
 290          --  Avoid an overflow during the subtraction. Note that Q2 is smaller
 291          --  than Y and R1 smaller than Z in magnitude, so it is safe to take
 292          --  their absolute value.
 293
 294          if abs Q2 >= 2 ** (Int'Size - 2)
 295            or else abs R1 >= 2 ** (Int'Size - 2)
 296          then
 297             declare
 298                Bit : constant Int := Q2 rem 2;
 299
 300             begin
 301                Q2 := (Q2 - Bit) / 2;
 302                R1 := (R1 - Bit) / 2;
 303                Y  := -2;
 304             end;
 305
 306          else
 307             Y := -1;
 308          end if;
 309
 310          Scaled_Divide (Q2 - R1, Y, Z, Q2, R2, Round => True);
 311
 312          return Q1 + Q2;
 313
 314       else
 315          Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q1, R1, Round => True);
 316
 317          return Q1;
 318       end if;
 319
 320    exception
 321       when Constraint_Error => Bad_Value (Str);
 322    end Integer_To_Fixed;
 323
 324    ----------------
 325    -- Scan_Fixed --
 326    ----------------
 327
 328    function Scan_Fixed
 329      (Str : String;
 330       Ptr : not null access Integer;
 331       Max : Integer;
 332       Num : Int;
 333       Den : Int) return Int
 334    is
 335       Base  : Unsigned;
 336       Scl   : Impl.Scale_Array;
 337       Extra : Unsigned;
 338       Minus : Boolean;
 339       Val   : Impl.Value_Array;
 340
 341    begin
 342       Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus);
 343
 344       return
 345         Integer_To_Fixed (Str, Val (1), Base, Scl (1), Extra, Minus, Num, Den);
 346    end Scan_Fixed;
 347
 348    -----------------
 349    -- Value_Fixed --
 350    -----------------
 351
 352    function Value_Fixed
 353      (Str : String;
 354       Num : Int;
 355       Den : Int) return Int
 356    is
 357       Base  : Unsigned;
 358       Scl   : Impl.Scale_Array;
 359       Extra : Unsigned;
 360       Minus : Boolean;
 361       Val   : Impl.Value_Array;
 362
 363    begin
 364       Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus);
 365
 366       return
 367         Integer_To_Fixed (Str, Val (1), Base, Scl (1), Extra, Minus, Num, Den);
 368    end Value_Fixed;
 369
 370 end System.Value_F;