1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2020-2021, 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 Interfaces; 33with Ada.Wide_Text_IO.Fixed_Aux; 34with Ada.Wide_Text_IO.Float_Aux; 35with System.Img_Fixed_32; use System.Img_Fixed_32; 36with System.Img_Fixed_64; use System.Img_Fixed_64; 37with System.Img_Fixed_128; use System.Img_Fixed_128; 38with System.Img_LFlt; use System.Img_LFlt; 39with System.Val_Fixed_32; use System.Val_Fixed_32; 40with System.Val_Fixed_64; use System.Val_Fixed_64; 41with System.Val_Fixed_128; use System.Val_Fixed_128; 42with System.Val_LFlt; use System.Val_LFlt; 43with System.WCh_Con; use System.WCh_Con; 44with System.WCh_WtS; use System.WCh_WtS; 45 46package body Ada.Wide_Text_IO.Fixed_IO is 47 48 -- Note: we still use the floating-point I/O routines for types whose small 49 -- is not the ratio of two sufficiently small integers. This will result in 50 -- inaccuracies for fixed point types that require more precision than is 51 -- available in Long_Float. 52 53 subtype Int32 is Interfaces.Integer_32; use type Int32; 54 subtype Int64 is Interfaces.Integer_64; use type Int64; 55 subtype Int128 is Interfaces.Integer_128; use type Int128; 56 57 package Aux32 is new 58 Ada.Wide_Text_IO.Fixed_Aux (Int32, Scan_Fixed32, Set_Image_Fixed32); 59 60 package Aux64 is new 61 Ada.Wide_Text_IO.Fixed_Aux (Int64, Scan_Fixed64, Set_Image_Fixed64); 62 63 package Aux128 is new 64 Ada.Wide_Text_IO.Fixed_Aux (Int128, Scan_Fixed128, Set_Image_Fixed128); 65 66 package Aux_Long_Float is new 67 Ada.Wide_Text_IO.Float_Aux 68 (Long_Float, Scan_Long_Float, Set_Image_Long_Float); 69 70 -- Throughout this generic body, we distinguish between the case where type 71 -- Int32 is OK, where type Int64 is OK and where type Int128 is OK. These 72 -- boolean constants are used to test for this, such that only code for the 73 -- relevant case is included in the instance; that's why the computation of 74 -- their value must be fully static (although it is not a static expression 75 -- in the RM sense). 76 77 OK_Get_32 : constant Boolean := 78 Num'Base'Object_Size <= 32 79 and then 80 ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31) 81 or else 82 (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31) 83 or else 84 (Num'Small_Numerator <= 2**27 85 and then Num'Small_Denominator <= 2**27)); 86 -- These conditions are derived from the prerequisites of System.Value_F 87 88 OK_Put_32 : constant Boolean := 89 Num'Base'Object_Size <= 32 90 and then 91 ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31) 92 or else 93 (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31) 94 or else 95 (Num'Small_Numerator < Num'Small_Denominator 96 and then Num'Small_Denominator <= 2**27) 97 or else 98 (Num'Small_Denominator < Num'Small_Numerator 99 and then Num'Small_Numerator <= 2**25)); 100 -- These conditions are derived from the prerequisites of System.Image_F 101 102 OK_Get_64 : constant Boolean := 103 Num'Base'Object_Size <= 64 104 and then 105 ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63) 106 or else 107 (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63) 108 or else 109 (Num'Small_Numerator <= 2**59 110 and then Num'Small_Denominator <= 2**59)); 111 -- These conditions are derived from the prerequisites of System.Value_F 112 113 OK_Put_64 : constant Boolean := 114 Num'Base'Object_Size <= 64 115 and then 116 ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63) 117 or else 118 (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63) 119 or else 120 (Num'Small_Numerator < Num'Small_Denominator 121 and then Num'Small_Denominator <= 2**59) 122 or else 123 (Num'Small_Denominator < Num'Small_Numerator 124 and then Num'Small_Numerator <= 2**53)); 125 -- These conditions are derived from the prerequisites of System.Image_F 126 127 OK_Get_128 : constant Boolean := 128 Num'Base'Object_Size <= 128 129 and then 130 ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**127) 131 or else 132 (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**127) 133 or else 134 (Num'Small_Numerator <= 2**123 135 and then Num'Small_Denominator <= 2**123)); 136 -- These conditions are derived from the prerequisites of System.Value_F 137 138 OK_Put_128 : constant Boolean := 139 Num'Base'Object_Size <= 128 140 and then 141 ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**127) 142 or else 143 (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**127) 144 or else 145 (Num'Small_Numerator < Num'Small_Denominator 146 and then Num'Small_Denominator <= 2**123) 147 or else 148 (Num'Small_Denominator < Num'Small_Numerator 149 and then Num'Small_Numerator <= 2**122)); 150 -- These conditions are derived from the prerequisites of System.Image_F 151 152 E : constant Natural := 153 127 - 64 * Boolean'Pos (OK_Put_64) - 32 * Boolean'Pos (OK_Put_32); 154 -- T'Size - 1 for the selected Int{32,64,128} 155 156 F0 : constant Natural := 0; 157 F1 : constant Natural := 158 F0 + 38 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F0) >= 1.0E+38); 159 F2 : constant Natural := 160 F1 + 19 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F1) >= 1.0E+19); 161 F3 : constant Natural := 162 F2 + 9 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F2) >= 1.0E+9); 163 F4 : constant Natural := 164 F3 + 5 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F3) >= 1.0E+5); 165 F5 : constant Natural := 166 F4 + 3 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F4) >= 1.0E+3); 167 F6 : constant Natural := 168 F5 + 2 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F5) >= 1.0E+2); 169 F7 : constant Natural := 170 F6 + 1 * Boolean'Pos (2.0**E * Num'Small * 10.0**(-F6) >= 1.0E+1); 171 -- Binary search for the number of digits - 1 before the decimal point of 172 -- the product 2.0**E * Num'Small. 173 174 For0 : constant Natural := 2 + F7; 175 -- Fore value for the fixed point type whose mantissa is Int{32,64,128} and 176 -- whose small is Num'Small. 177 178 --------- 179 -- Get -- 180 --------- 181 182 procedure Get 183 (File : File_Type; 184 Item : out Num; 185 Width : Field := 0) 186 is 187 pragma Unsuppress (Range_Check); 188 189 begin 190 if OK_Get_32 then 191 Item := Num'Fixed_Value 192 (Aux32.Get (File, Width, 193 -Num'Small_Numerator, 194 -Num'Small_Denominator)); 195 elsif OK_Get_64 then 196 Item := Num'Fixed_Value 197 (Aux64.Get (File, Width, 198 -Num'Small_Numerator, 199 -Num'Small_Denominator)); 200 elsif OK_Get_128 then 201 Item := Num'Fixed_Value 202 (Aux128.Get (File, Width, 203 -Num'Small_Numerator, 204 -Num'Small_Denominator)); 205 else 206 Aux_Long_Float.Get (File, Long_Float (Item), Width); 207 end if; 208 209 exception 210 when Constraint_Error => raise Data_Error; 211 end Get; 212 213 procedure Get 214 (Item : out Num; 215 Width : Field := 0) 216 is 217 begin 218 Get (Current_In, Item, Width); 219 end Get; 220 221 procedure Get 222 (From : Wide_String; 223 Item : out Num; 224 Last : out Positive) 225 is 226 pragma Unsuppress (Range_Check); 227 228 S : constant String := Wide_String_To_String (From, WCEM_Upper); 229 -- String on which we do the actual conversion. Note that the method 230 -- used for wide character encoding is irrelevant, since if there is 231 -- a character outside the Standard.Character range then the call to 232 -- Aux.Gets will raise Data_Error in any case. 233 234 begin 235 if OK_Get_32 then 236 Item := Num'Fixed_Value 237 (Aux32.Gets (S, Last, 238 -Num'Small_Numerator, 239 -Num'Small_Denominator)); 240 elsif OK_Get_64 then 241 Item := Num'Fixed_Value 242 (Aux64.Gets (S, Last, 243 -Num'Small_Numerator, 244 -Num'Small_Denominator)); 245 elsif OK_Get_128 then 246 Item := Num'Fixed_Value 247 (Aux128.Gets (S, Last, 248 -Num'Small_Numerator, 249 -Num'Small_Denominator)); 250 else 251 Aux_Long_Float.Gets (S, Long_Float (Item), Last); 252 end if; 253 254 exception 255 when Constraint_Error => raise Data_Error; 256 end Get; 257 258 --------- 259 -- Put -- 260 --------- 261 262 procedure Put 263 (File : File_Type; 264 Item : Num; 265 Fore : Field := Default_Fore; 266 Aft : Field := Default_Aft; 267 Exp : Field := Default_Exp) 268 is 269 begin 270 if OK_Put_32 then 271 Aux32.Put (File, Int32'Integer_Value (Item), Fore, Aft, Exp, 272 -Num'Small_Numerator, -Num'Small_Denominator, 273 For0, Num'Aft); 274 elsif OK_Put_64 then 275 Aux64.Put (File, Int64'Integer_Value (Item), Fore, Aft, Exp, 276 -Num'Small_Numerator, -Num'Small_Denominator, 277 For0, Num'Aft); 278 elsif OK_Put_128 then 279 Aux128.Put (File, Int128'Integer_Value (Item), Fore, Aft, Exp, 280 -Num'Small_Numerator, -Num'Small_Denominator, 281 For0, Num'Aft); 282 else 283 Aux_Long_Float.Put (File, Long_Float (Item), Fore, Aft, Exp); 284 end if; 285 end Put; 286 287 procedure Put 288 (Item : Num; 289 Fore : Field := Default_Fore; 290 Aft : Field := Default_Aft; 291 Exp : Field := Default_Exp) 292 is 293 begin 294 Put (Current_Out, Item, Fore, Aft, Exp); 295 end Put; 296 297 procedure Put 298 (To : out Wide_String; 299 Item : Num; 300 Aft : Field := Default_Aft; 301 Exp : Field := Default_Exp) 302 is 303 S : String (To'First .. To'Last); 304 305 begin 306 if OK_Put_32 then 307 Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, 308 -Num'Small_Numerator, -Num'Small_Denominator, 309 For0, Num'Aft); 310 elsif OK_Put_64 then 311 Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, 312 -Num'Small_Numerator, -Num'Small_Denominator, 313 For0, Num'Aft); 314 elsif OK_Put_128 then 315 Aux128.Puts (S, Int128'Integer_Value (Item), Aft, Exp, 316 -Num'Small_Numerator, -Num'Small_Denominator, 317 For0, Num'Aft); 318 else 319 Aux_Long_Float.Puts (S, Long_Float (Item), Aft, Exp); 320 end if; 321 322 for J in S'Range loop 323 To (J) := Wide_Character'Val (Character'Pos (S (J))); 324 end loop; 325 end Put; 326 327end Ada.Wide_Text_IO.Fixed_IO; 328