1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
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 --
9 -- Copyright (C) 2020-2024, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
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
.Img_LFlt
; use System
.Img_LFlt
;
39 with System
.Val_Fixed_32
; use System
.Val_Fixed_32
;
40 with System
.Val_Fixed_64
; use System
.Val_Fixed_64
;
41 with System
.Val_Fixed_128
; use System
.Val_Fixed_128
;
42 with System
.Val_LFlt
; use System
.Val_LFlt
;
43 with System
.WCh_Con
; use System
.WCh_Con
;
44 with System
.WCh_WtS
; use System
.WCh_WtS
;
46 package body Ada
.Wide_Wide_Text_IO
.Fixed_IO
is
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.
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
;
58 Ada
.Wide_Wide_Text_IO
.Fixed_Aux
(Int32
, Scan_Fixed32
, Set_Image_Fixed32
);
61 Ada
.Wide_Wide_Text_IO
.Fixed_Aux
(Int64
, Scan_Fixed64
, Set_Image_Fixed64
);
64 Ada
.Wide_Wide_Text_IO
.Fixed_Aux
65 (Int128
, Scan_Fixed128
, Set_Image_Fixed128
);
67 package Aux_Long_Float
is new
68 Ada
.Wide_Wide_Text_IO
.Float_Aux
69 (Long_Float, Scan_Long_Float
, Set_Image_Long_Float
);
71 -- Throughout this generic body, we distinguish between the case where type
72 -- Int32 is OK, where type Int64 is OK and where type Int128 is OK. These
73 -- boolean constants are used to test for this, such that only code for the
74 -- relevant case is included in the instance; that's why the computation of
75 -- their value must be fully static (although it is not a static expression
78 OK_Get_32
: constant Boolean :=
79 Num
'Base'Object_Size <= 32
81 ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
83 (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
85 (Num'Small_Numerator <= 2**27
86 and then Num'Small_Denominator <= 2**27));
87 -- These conditions are derived from the prerequisites of System.Value_F
89 OK_Put_32 : constant Boolean :=
90 Num'Base'Object_Size
<= 32
92 ((Num
'Small_Numerator = 1 and then Num
'Small_Denominator <= 2**31)
94 (Num
'Small_Denominator = 1 and then Num
'Small_Numerator <= 2**31)
96 (Num
'Small_Numerator < Num
'Small_Denominator
97 and then Num
'Small_Denominator <= 2**27)
99 (Num
'Small_Denominator < Num
'Small_Numerator
100 and then Num
'Small_Numerator <= 2**25));
101 -- These conditions are derived from the prerequisites of System.Image_F
103 OK_Get_64
: constant Boolean :=
104 Num
'Base'Object_Size <= 64
106 ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
108 (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
110 (Num'Small_Numerator <= 2**59
111 and then Num'Small_Denominator <= 2**59));
112 -- These conditions are derived from the prerequisites of System.Value_F
114 OK_Put_64 : constant Boolean :=
115 Num'Base'Object_Size
<= 64
117 ((Num
'Small_Numerator = 1 and then Num
'Small_Denominator <= 2**63)
119 (Num
'Small_Denominator = 1 and then Num
'Small_Numerator <= 2**63)
121 (Num
'Small_Numerator < Num
'Small_Denominator
122 and then Num
'Small_Denominator <= 2**59)
124 (Num
'Small_Denominator < Num
'Small_Numerator
125 and then Num
'Small_Numerator <= 2**53));
126 -- These conditions are derived from the prerequisites of System.Image_F
128 OK_Get_128
: constant Boolean :=
129 Num
'Base'Object_Size <= 128
131 ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**127)
133 (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**127)
135 (Num'Small_Numerator <= 2**123
136 and then Num'Small_Denominator <= 2**123));
137 -- These conditions are derived from the prerequisites of System.Value_F
139 OK_Put_128 : constant Boolean :=
140 Num'Base'Object_Size
<= 128
142 ((Num
'Small_Numerator = 1 and then Num
'Small_Denominator <= 2**127)
144 (Num
'Small_Denominator = 1 and then Num
'Small_Numerator <= 2**127)
146 (Num
'Small_Numerator < Num
'Small_Denominator
147 and then Num
'Small_Denominator <= 2**123)
149 (Num
'Small_Denominator < Num
'Small_Numerator
150 and then Num
'Small_Numerator <= 2**122));
151 -- These conditions are derived from the prerequisites of System.Image_F
153 E
: constant Natural :=
154 127 - 64 * Boolean'Pos (OK_Put_64
) - 32 * Boolean'Pos (OK_Put_32
);
155 -- T'Size - 1 for the selected Int{32,64,128}
157 F0
: constant Natural := 0;
158 F1
: constant Natural :=
159 F0
+ 38 * Boolean'Pos (2.0**E
* Num
'Small * 10.0**(-F0
) >= 1.0E+38);
160 F2
: constant Natural :=
161 F1
+ 19 * Boolean'Pos (2.0**E
* Num
'Small * 10.0**(-F1
) >= 1.0E+19);
162 F3
: constant Natural :=
163 F2
+ 9 * Boolean'Pos (2.0**E
* Num
'Small * 10.0**(-F2
) >= 1.0E+9);
164 F4
: constant Natural :=
165 F3
+ 5 * Boolean'Pos (2.0**E
* Num
'Small * 10.0**(-F3
) >= 1.0E+5);
166 F5
: constant Natural :=
167 F4
+ 3 * Boolean'Pos (2.0**E
* Num
'Small * 10.0**(-F4
) >= 1.0E+3);
168 F6
: constant Natural :=
169 F5
+ 2 * Boolean'Pos (2.0**E
* Num
'Small * 10.0**(-F5
) >= 1.0E+2);
170 F7
: constant Natural :=
171 F6
+ 1 * Boolean'Pos (2.0**E
* Num
'Small * 10.0**(-F6
) >= 1.0E+1);
172 -- Binary search for the number of digits - 1 before the decimal point of
173 -- the product 2.0**E * Num'Small.
175 For0
: constant Natural := 2 + F7
;
176 -- Fore value for the fixed point type whose mantissa is Int{32,64,128} and
177 -- whose small is Num'Small.
188 pragma Unsuppress
(Range_Check
);
192 Item
:= Num
'Fixed_Value
193 (Aux32
.Get
(File
, Width
,
194 -Num
'Small_Numerator,
195 -Num
'Small_Denominator));
197 Item
:= Num
'Fixed_Value
198 (Aux64
.Get
(File
, Width
,
199 -Num
'Small_Numerator,
200 -Num
'Small_Denominator));
201 elsif OK_Get_128
then
202 Item
:= Num
'Fixed_Value
203 (Aux128
.Get
(File
, Width
,
204 -Num
'Small_Numerator,
205 -Num
'Small_Denominator));
207 Aux_Long_Float
.Get
(File
, Long_Float (Item
), Width
);
211 when Constraint_Error
=> raise Data_Error
;
219 Get
(Current_In
, Item
, Width
);
223 (From
: Wide_Wide_String
;
227 pragma Unsuppress
(Range_Check
);
229 S
: constant String := Wide_Wide_String_To_String
(From
, WCEM_Upper
);
230 -- String on which we do the actual conversion. Note that the method
231 -- used for wide character encoding is irrelevant, since if there is
232 -- a character outside the Standard.Character range then the call to
233 -- Aux.Gets will raise Data_Error in any case.
237 Item
:= Num
'Fixed_Value
238 (Aux32
.Gets
(S
, Last
,
239 -Num
'Small_Numerator,
240 -Num
'Small_Denominator));
242 Item
:= Num
'Fixed_Value
243 (Aux64
.Gets
(S
, Last
,
244 -Num
'Small_Numerator,
245 -Num
'Small_Denominator));
246 elsif OK_Get_128
then
247 Item
:= Num
'Fixed_Value
248 (Aux128
.Gets
(S
, Last
,
249 -Num
'Small_Numerator,
250 -Num
'Small_Denominator));
252 Aux_Long_Float
.Gets
(S
, Long_Float (Item
), Last
);
256 when Constraint_Error
=> raise Data_Error
;
266 Fore
: Field
:= Default_Fore
;
267 Aft
: Field
:= Default_Aft
;
268 Exp
: Field
:= Default_Exp
)
272 Aux32
.Put
(File
, Int32
'Integer_Value (Item
), Fore
, Aft
, Exp
,
273 -Num
'Small_Numerator, -Num
'Small_Denominator,
276 Aux64
.Put
(File
, Int64
'Integer_Value (Item
), Fore
, Aft
, Exp
,
277 -Num
'Small_Numerator, -Num
'Small_Denominator,
279 elsif OK_Put_128
then
280 Aux128
.Put
(File
, Int128
'Integer_Value (Item
), Fore
, Aft
, Exp
,
281 -Num
'Small_Numerator, -Num
'Small_Denominator,
284 Aux_Long_Float
.Put
(File
, Long_Float (Item
), Fore
, Aft
, Exp
);
290 Fore
: Field
:= Default_Fore
;
291 Aft
: Field
:= Default_Aft
;
292 Exp
: Field
:= Default_Exp
)
295 Put
(Current_Out
, Item
, Fore
, Aft
, Exp
);
299 (To
: out Wide_Wide_String
;
301 Aft
: Field
:= Default_Aft
;
302 Exp
: Field
:= Default_Exp
)
304 S
: String (To
'First .. To
'Last);
308 Aux32
.Puts
(S
, Int32
'Integer_Value (Item
), Aft
, Exp
,
309 -Num
'Small_Numerator, -Num
'Small_Denominator,
312 Aux64
.Puts
(S
, Int64
'Integer_Value (Item
), Aft
, Exp
,
313 -Num
'Small_Numerator, -Num
'Small_Denominator,
315 elsif OK_Put_128
then
316 Aux128
.Puts
(S
, Int128
'Integer_Value (Item
), Aft
, Exp
,
317 -Num
'Small_Numerator, -Num
'Small_Denominator,
320 Aux_Long_Float
.Puts
(S
, Long_Float (Item
), Aft
, Exp
);
323 for J
in S
'Range loop
324 To
(J
) := Wide_Wide_Character
'Val (Character'Pos (S
(J
)));
328 end Ada
.Wide_Wide_Text_IO
.Fixed_IO
;