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