1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . W I D E _ T E X T _ I O . F I X E D _ I O --
9 -- Copyright (C) 2020-2023, 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_Text_IO
.Fixed_Aux
;
34 with Ada
.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_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_Text_IO
.Fixed_Aux
(Int32
, Scan_Fixed32
, Set_Image_Fixed32
);
61 Ada
.Wide_Text_IO
.Fixed_Aux
(Int64
, Scan_Fixed64
, Set_Image_Fixed64
);
64 Ada
.Wide_Text_IO
.Fixed_Aux
(Int128
, Scan_Fixed128
, Set_Image_Fixed128
);
66 package Aux_Long_Float
is new
67 Ada
.Wide_Text_IO
.Float_Aux
68 (Long_Float, Scan_Long_Float
, Set_Image_Long_Float
);
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
77 OK_Get_32
: constant Boolean :=
78 Num
'Base'Object_Size <= 32
80 ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**31)
82 (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**31)
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
88 OK_Put_32 : constant Boolean :=
89 Num'Base'Object_Size
<= 32
91 ((Num
'Small_Numerator = 1 and then Num
'Small_Denominator <= 2**31)
93 (Num
'Small_Denominator = 1 and then Num
'Small_Numerator <= 2**31)
95 (Num
'Small_Numerator < Num
'Small_Denominator
96 and then Num
'Small_Denominator <= 2**27)
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
102 OK_Get_64
: constant Boolean :=
103 Num
'Base'Object_Size <= 64
105 ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**63)
107 (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**63)
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
113 OK_Put_64 : constant Boolean :=
114 Num'Base'Object_Size
<= 64
116 ((Num
'Small_Numerator = 1 and then Num
'Small_Denominator <= 2**63)
118 (Num
'Small_Denominator = 1 and then Num
'Small_Numerator <= 2**63)
120 (Num
'Small_Numerator < Num
'Small_Denominator
121 and then Num
'Small_Denominator <= 2**59)
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
127 OK_Get_128
: constant Boolean :=
128 Num
'Base'Object_Size <= 128
130 ((Num'Small_Numerator = 1 and then Num'Small_Denominator <= 2**127)
132 (Num'Small_Denominator = 1 and then Num'Small_Numerator <= 2**127)
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
138 OK_Put_128 : constant Boolean :=
139 Num'Base'Object_Size
<= 128
141 ((Num
'Small_Numerator = 1 and then Num
'Small_Denominator <= 2**127)
143 (Num
'Small_Denominator = 1 and then Num
'Small_Numerator <= 2**127)
145 (Num
'Small_Numerator < Num
'Small_Denominator
146 and then Num
'Small_Denominator <= 2**123)
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
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}
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.
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.
187 pragma Unsuppress
(Range_Check
);
191 Item
:= Num
'Fixed_Value
192 (Aux32
.Get
(File
, Width
,
193 -Num
'Small_Numerator,
194 -Num
'Small_Denominator));
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));
206 Aux_Long_Float
.Get
(File
, Long_Float (Item
), Width
);
210 when Constraint_Error
=> raise Data_Error
;
218 Get
(Current_In
, Item
, Width
);
226 pragma Unsuppress
(Range_Check
);
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.
236 Item
:= Num
'Fixed_Value
237 (Aux32
.Gets
(S
, Last
,
238 -Num
'Small_Numerator,
239 -Num
'Small_Denominator));
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));
251 Aux_Long_Float
.Gets
(S
, Long_Float (Item
), Last
);
255 when Constraint_Error
=> raise Data_Error
;
265 Fore
: Field
:= Default_Fore
;
266 Aft
: Field
:= Default_Aft
;
267 Exp
: Field
:= Default_Exp
)
271 Aux32
.Put
(File
, Int32
'Integer_Value (Item
), Fore
, Aft
, Exp
,
272 -Num
'Small_Numerator, -Num
'Small_Denominator,
275 Aux64
.Put
(File
, Int64
'Integer_Value (Item
), Fore
, Aft
, Exp
,
276 -Num
'Small_Numerator, -Num
'Small_Denominator,
278 elsif OK_Put_128
then
279 Aux128
.Put
(File
, Int128
'Integer_Value (Item
), Fore
, Aft
, Exp
,
280 -Num
'Small_Numerator, -Num
'Small_Denominator,
283 Aux_Long_Float
.Put
(File
, Long_Float (Item
), Fore
, Aft
, Exp
);
289 Fore
: Field
:= Default_Fore
;
290 Aft
: Field
:= Default_Aft
;
291 Exp
: Field
:= Default_Exp
)
294 Put
(Current_Out
, Item
, Fore
, Aft
, Exp
);
298 (To
: out Wide_String;
300 Aft
: Field
:= Default_Aft
;
301 Exp
: Field
:= Default_Exp
)
303 S
: String (To
'First .. To
'Last);
307 Aux32
.Puts
(S
, Int32
'Integer_Value (Item
), Aft
, Exp
,
308 -Num
'Small_Numerator, -Num
'Small_Denominator,
311 Aux64
.Puts
(S
, Int64
'Integer_Value (Item
), Aft
, Exp
,
312 -Num
'Small_Numerator, -Num
'Small_Denominator,
314 elsif OK_Put_128
then
315 Aux128
.Puts
(S
, Int128
'Integer_Value (Item
), Aft
, Exp
,
316 -Num
'Small_Numerator, -Num
'Small_Denominator,
319 Aux_Long_Float
.Puts
(S
, Long_Float (Item
), Aft
, Exp
);
322 for J
in S
'Range loop
323 To
(J
) := Wide_Character'Val (Character'Pos (S
(J
)));
327 end Ada
.Wide_Text_IO
.Fixed_IO
;