]> gcc.gnu.org Git - gcc.git/blame - gcc/ada/libgnat/a-ztfiio__128.adb
[Ada] Expand integer-only implementation of ordinary fixed-point types
[gcc.git] / gcc / ada / libgnat / a-ztfiio__128.adb
CommitLineData
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
32with Interfaces;
33with Ada.Wide_Wide_Text_IO.Fixed_Aux;
34with Ada.Wide_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.Val_Fixed_32; use System.Val_Fixed_32;
39with System.Val_Fixed_64; use System.Val_Fixed_64;
40with System.Val_Fixed_128; use System.Val_Fixed_128;
41with System.WCh_Con; use System.WCh_Con;
42with System.WCh_WtS; use System.WCh_WtS;
43
44package 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
322end Ada.Wide_Wide_Text_IO.Fixed_IO;
This page took 0.075248 seconds and 5 git commands to generate.