gcc/ada/libgnat/s-valued.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                       S Y S T E M . V A L U E _ D                        --
   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_D is
  37
  38    pragma Assert (Int'Size <= Uns'Size);
  39    --  We need an unsigned type large enough to represent the mantissa
  40
  41    package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1), Round => False);
  42    --  We do not use the Extra digit for decimal fixed-point types
  43
  44    function Integer_to_Decimal
  45      (Str    : String;
  46       Val    : Uns;
  47       Base   : Unsigned;
  48       ScaleB : Integer;
  49       Minus  : Boolean;
  50       Scale  : Integer) return Int;
  51    --  Convert the real value from integer to decimal representation
  52
  53    ------------------------
  54    -- Integer_to_Decimal --
  55    ------------------------
  56
  57    function Integer_to_Decimal
  58      (Str    : String;
  59       Val    : Uns;
  60       Base   : Unsigned;
  61       ScaleB : Integer;
  62       Minus  : Boolean;
  63       Scale  : Integer) return Int
  64    is
  65       function Safe_Expont
  66         (Base   : Int;
  67          Exp    : in out Natural;
  68          Factor : Int) return Int;
  69       --  Return (Base ** Exp) * Factor if the computation does not overflow,
  70       --  or else the number of the form (Base ** K) * Factor with the largest
  71       --  magnitude if the former computation overflows. In both cases, Exp is
  72       --  updated to contain the remaining power in the computation. Note that
  73       --  Factor is expected to be positive in this context.
  74
  75       function Unsigned_To_Signed (Val : Uns) return Int;
  76       --  Convert an integer value from unsigned to signed representation
  77
  78       -----------------
  79       -- Safe_Expont --
  80       -----------------
  81
  82       function Safe_Expont
  83         (Base   : Int;
  84          Exp    : in out Natural;
  85          Factor : Int) return Int
  86       is
  87          pragma Assert (Base /= 0 and then Factor > 0);
  88
  89          Max : constant Int := Int'Last / Base;
  90
  91          Result : Int := Factor;
  92
  93       begin
  94          while Exp > 0 and then Result <= Max loop
  95             Result := Result * Base;
  96             Exp    := Exp - 1;
  97          end loop;
  98
  99          return Result;
 100       end Safe_Expont;
 101
 102       ------------------------
 103       -- Unsigned_To_Signed --
 104       ------------------------
 105
 106       function Unsigned_To_Signed (Val : Uns) return Int is
 107       begin
 108          --  Deal with overflow cases, and also with largest negative number
 109
 110          if Val > Uns (Int'Last) then
 111             if Minus and then Val = Uns (-(Int'First)) then
 112                return Int'First;
 113             else
 114                Bad_Value (Str);
 115             end if;
 116
 117          --  Negative values
 118
 119          elsif Minus then
 120             return -(Int (Val));
 121
 122          --  Positive values
 123
 124          else
 125             return Int (Val);
 126          end if;
 127       end Unsigned_To_Signed;
 128
 129    begin
 130       --  If the base of the value is 10 or its scaling factor is zero, then
 131       --  add the scales (they are defined in the opposite sense) and apply
 132       --  the result to the value, checking for overflow in the process.
 133
 134       if Base = 10 or else ScaleB = 0 then
 135          declare
 136             S : Integer := ScaleB + Scale;
 137             V : Uns     := Val;
 138
 139          begin
 140             while S < 0 loop
 141                V := V / 10;
 142                S := S + 1;
 143             end loop;
 144
 145             while S > 0 loop
 146                if V <= Uns'Last / 10 then
 147                   V := V * 10;
 148                   S := S - 1;
 149                else
 150                   Bad_Value (Str);
 151                end if;
 152             end loop;
 153
 154             return Unsigned_To_Signed (V);
 155          end;
 156
 157       --  If the base of the value is not 10, use a scaled divide operation
 158       --  to compute Val * (Base ** ScaleB) * (10 ** Scale).
 159
 160       else
 161          declare
 162             B : constant Int     := Int (Base);
 163             S : constant Integer := ScaleB;
 164
 165             V : Uns := Val;
 166
 167             Y, Z, Q, R : Int;
 168
 169          begin
 170             --  If S is too negative, then drop trailing digits
 171
 172             if S < 0 then
 173                declare
 174                   LS : Integer := -S;
 175
 176                begin
 177                   Y := 10 ** Integer'Max (0, Scale);
 178                   Z := Safe_Expont (B, LS, 10 ** Integer'Max (0, -Scale));
 179
 180                   for J in 1 .. LS loop
 181                      V := V / Uns (B);
 182                   end loop;
 183                end;
 184
 185             --  If S is too positive, then scale V up, which may then overflow
 186
 187             elsif S > 0 then
 188                declare
 189                   LS : Integer := S;
 190
 191                begin
 192                   Y := Safe_Expont (B, LS, 10 ** Integer'Max (0, Scale));
 193                   Z := 10 ** Integer'Max (0, -Scale);
 194
 195                   for J in 1 .. LS loop
 196                      if V <= Uns'Last / Uns (B) then
 197                         V := V * Uns (B);
 198                      else
 199                         Bad_Value (Str);
 200                      end if;
 201                   end loop;
 202                end;
 203
 204             --  The case S equal to zero should have been handled earlier
 205
 206             else
 207                raise Program_Error;
 208             end if;
 209
 210             --  Perform a scale divide operation with rounding to match 'Image
 211
 212             Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q, R, Round => True);
 213
 214             return Q;
 215          end;
 216       end if;
 217
 218    exception
 219       when Constraint_Error => Bad_Value (Str);
 220    end Integer_to_Decimal;
 221
 222    ------------------
 223    -- Scan_Decimal --
 224    ------------------
 225
 226    function Scan_Decimal
 227      (Str   : String;
 228       Ptr   : not null access Integer;
 229       Max   : Integer;
 230       Scale : Integer) return Int
 231    is
 232       Base  : Unsigned;
 233       Scl   : Impl.Scale_Array;
 234       Extra : Unsigned;
 235       Minus : Boolean;
 236       Val   : Impl.Value_Array;
 237
 238    begin
 239       Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus);
 240
 241       return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale);
 242    end Scan_Decimal;
 243
 244    -------------------
 245    -- Value_Decimal --
 246    -------------------
 247
 248    function Value_Decimal (Str : String; Scale : Integer) return Int is
 249       Base  : Unsigned;
 250       Scl   : Impl.Scale_Array;
 251       Extra : Unsigned;
 252       Minus : Boolean;
 253       Val   : Impl.Value_Array;
 254
 255    begin
 256       Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus);
 257
 258       return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale);
 259    end Value_Decimal;
 260
 261 end System.Value_D;