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, 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 32with System.Unsigned_Types; use System.Unsigned_Types; 33with System.Val_Util; use System.Val_Util; 34with System.Value_R; 35 36package 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, 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 ScaleB : Integer; 234 Extra : Unsigned; 235 pragma Unreferenced (Extra); 236 Minus : Boolean; 237 Val : Uns; 238 239 begin 240 Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus); 241 242 return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale); 243 end Scan_Decimal; 244 245 ------------------- 246 -- Value_Decimal -- 247 ------------------- 248 249 function Value_Decimal (Str : String; Scale : Integer) return Int is 250 Base : Unsigned; 251 ScaleB : Integer; 252 Extra : Unsigned; 253 pragma Unreferenced (Extra); 254 Minus : Boolean; 255 Val : Uns; 256 257 begin 258 Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus); 259 260 return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale); 261 end Value_Decimal; 262 263end System.Value_D; 264