annotate gcc/ada/libgnat/a-tideau.adb @ 131:84e7813d76e9

gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents 04ced10e8804
children 1830386684a0
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
111
kono
parents:
diff changeset
1 ------------------------------------------------------------------------------
kono
parents:
diff changeset
2 -- --
kono
parents:
diff changeset
3 -- GNAT RUN-TIME COMPONENTS --
kono
parents:
diff changeset
4 -- --
kono
parents:
diff changeset
5 -- A D A . T E X T _ I O . D E C I M A L _ A U X --
kono
parents:
diff changeset
6 -- --
kono
parents:
diff changeset
7 -- B o d y --
kono
parents:
diff changeset
8 -- --
131
84e7813d76e9 gcc-8.2
mir3636
parents: 111
diff changeset
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
111
kono
parents:
diff changeset
10 -- --
kono
parents:
diff changeset
11 -- GNAT is free software; you can redistribute it and/or modify it under --
kono
parents:
diff changeset
12 -- terms of the GNU General Public License as published by the Free Soft- --
kono
parents:
diff changeset
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
kono
parents:
diff changeset
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
kono
parents:
diff changeset
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
kono
parents:
diff changeset
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
kono
parents:
diff changeset
17 -- --
kono
parents:
diff changeset
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
kono
parents:
diff changeset
19 -- additional permissions described in the GCC Runtime Library Exception, --
kono
parents:
diff changeset
20 -- version 3.1, as published by the Free Software Foundation. --
kono
parents:
diff changeset
21 -- --
kono
parents:
diff changeset
22 -- You should have received a copy of the GNU General Public License and --
kono
parents:
diff changeset
23 -- a copy of the GCC Runtime Library Exception along with this program; --
kono
parents:
diff changeset
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
kono
parents:
diff changeset
25 -- <http://www.gnu.org/licenses/>. --
kono
parents:
diff changeset
26 -- --
kono
parents:
diff changeset
27 -- GNAT was originally developed by the GNAT team at New York University. --
kono
parents:
diff changeset
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
kono
parents:
diff changeset
29 -- --
kono
parents:
diff changeset
30 ------------------------------------------------------------------------------
kono
parents:
diff changeset
31
kono
parents:
diff changeset
32 with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
kono
parents:
diff changeset
33 with Ada.Text_IO.Float_Aux; use Ada.Text_IO.Float_Aux;
kono
parents:
diff changeset
34
kono
parents:
diff changeset
35 with System.Img_Dec; use System.Img_Dec;
kono
parents:
diff changeset
36 with System.Img_LLD; use System.Img_LLD;
kono
parents:
diff changeset
37 with System.Val_Dec; use System.Val_Dec;
kono
parents:
diff changeset
38 with System.Val_LLD; use System.Val_LLD;
kono
parents:
diff changeset
39
kono
parents:
diff changeset
40 package body Ada.Text_IO.Decimal_Aux is
kono
parents:
diff changeset
41
kono
parents:
diff changeset
42 -------------
kono
parents:
diff changeset
43 -- Get_Dec --
kono
parents:
diff changeset
44 -------------
kono
parents:
diff changeset
45
kono
parents:
diff changeset
46 function Get_Dec
kono
parents:
diff changeset
47 (File : File_Type;
kono
parents:
diff changeset
48 Width : Field;
kono
parents:
diff changeset
49 Scale : Integer) return Integer
kono
parents:
diff changeset
50 is
kono
parents:
diff changeset
51 Buf : String (1 .. Field'Last);
kono
parents:
diff changeset
52 Ptr : aliased Integer;
kono
parents:
diff changeset
53 Stop : Integer := 0;
kono
parents:
diff changeset
54 Item : Integer;
kono
parents:
diff changeset
55
kono
parents:
diff changeset
56 begin
kono
parents:
diff changeset
57 if Width /= 0 then
kono
parents:
diff changeset
58 Load_Width (File, Width, Buf, Stop);
kono
parents:
diff changeset
59 String_Skip (Buf, Ptr);
kono
parents:
diff changeset
60 else
kono
parents:
diff changeset
61 Load_Real (File, Buf, Stop);
kono
parents:
diff changeset
62 Ptr := 1;
kono
parents:
diff changeset
63 end if;
kono
parents:
diff changeset
64
kono
parents:
diff changeset
65 Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale);
kono
parents:
diff changeset
66 Check_End_Of_Field (Buf, Stop, Ptr, Width);
kono
parents:
diff changeset
67 return Item;
kono
parents:
diff changeset
68 end Get_Dec;
kono
parents:
diff changeset
69
kono
parents:
diff changeset
70 -------------
kono
parents:
diff changeset
71 -- Get_LLD --
kono
parents:
diff changeset
72 -------------
kono
parents:
diff changeset
73
kono
parents:
diff changeset
74 function Get_LLD
kono
parents:
diff changeset
75 (File : File_Type;
kono
parents:
diff changeset
76 Width : Field;
kono
parents:
diff changeset
77 Scale : Integer) return Long_Long_Integer
kono
parents:
diff changeset
78 is
kono
parents:
diff changeset
79 Buf : String (1 .. Field'Last);
kono
parents:
diff changeset
80 Ptr : aliased Integer;
kono
parents:
diff changeset
81 Stop : Integer := 0;
kono
parents:
diff changeset
82 Item : Long_Long_Integer;
kono
parents:
diff changeset
83
kono
parents:
diff changeset
84 begin
kono
parents:
diff changeset
85 if Width /= 0 then
kono
parents:
diff changeset
86 Load_Width (File, Width, Buf, Stop);
kono
parents:
diff changeset
87 String_Skip (Buf, Ptr);
kono
parents:
diff changeset
88 else
kono
parents:
diff changeset
89 Load_Real (File, Buf, Stop);
kono
parents:
diff changeset
90 Ptr := 1;
kono
parents:
diff changeset
91 end if;
kono
parents:
diff changeset
92
kono
parents:
diff changeset
93 Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale);
kono
parents:
diff changeset
94 Check_End_Of_Field (Buf, Stop, Ptr, Width);
kono
parents:
diff changeset
95 return Item;
kono
parents:
diff changeset
96 end Get_LLD;
kono
parents:
diff changeset
97
kono
parents:
diff changeset
98 --------------
kono
parents:
diff changeset
99 -- Gets_Dec --
kono
parents:
diff changeset
100 --------------
kono
parents:
diff changeset
101
kono
parents:
diff changeset
102 function Gets_Dec
kono
parents:
diff changeset
103 (From : String;
kono
parents:
diff changeset
104 Last : not null access Positive;
kono
parents:
diff changeset
105 Scale : Integer) return Integer
kono
parents:
diff changeset
106 is
kono
parents:
diff changeset
107 Pos : aliased Integer;
kono
parents:
diff changeset
108 Item : Integer;
kono
parents:
diff changeset
109
kono
parents:
diff changeset
110 begin
kono
parents:
diff changeset
111 String_Skip (From, Pos);
kono
parents:
diff changeset
112 Item := Scan_Decimal (From, Pos'Access, From'Last, Scale);
kono
parents:
diff changeset
113 Last.all := Pos - 1;
kono
parents:
diff changeset
114 return Item;
kono
parents:
diff changeset
115
kono
parents:
diff changeset
116 exception
kono
parents:
diff changeset
117 when Constraint_Error =>
kono
parents:
diff changeset
118 Last.all := Pos - 1;
kono
parents:
diff changeset
119 raise Data_Error;
kono
parents:
diff changeset
120 end Gets_Dec;
kono
parents:
diff changeset
121
kono
parents:
diff changeset
122 --------------
kono
parents:
diff changeset
123 -- Gets_LLD --
kono
parents:
diff changeset
124 --------------
kono
parents:
diff changeset
125
kono
parents:
diff changeset
126 function Gets_LLD
kono
parents:
diff changeset
127 (From : String;
kono
parents:
diff changeset
128 Last : not null access Positive;
kono
parents:
diff changeset
129 Scale : Integer) return Long_Long_Integer
kono
parents:
diff changeset
130 is
kono
parents:
diff changeset
131 Pos : aliased Integer;
kono
parents:
diff changeset
132 Item : Long_Long_Integer;
kono
parents:
diff changeset
133
kono
parents:
diff changeset
134 begin
kono
parents:
diff changeset
135 String_Skip (From, Pos);
kono
parents:
diff changeset
136 Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale);
kono
parents:
diff changeset
137 Last.all := Pos - 1;
kono
parents:
diff changeset
138 return Item;
kono
parents:
diff changeset
139
kono
parents:
diff changeset
140 exception
kono
parents:
diff changeset
141 when Constraint_Error =>
kono
parents:
diff changeset
142 Last.all := Pos - 1;
kono
parents:
diff changeset
143 raise Data_Error;
kono
parents:
diff changeset
144 end Gets_LLD;
kono
parents:
diff changeset
145
kono
parents:
diff changeset
146 -------------
kono
parents:
diff changeset
147 -- Put_Dec --
kono
parents:
diff changeset
148 -------------
kono
parents:
diff changeset
149
kono
parents:
diff changeset
150 procedure Put_Dec
kono
parents:
diff changeset
151 (File : File_Type;
kono
parents:
diff changeset
152 Item : Integer;
kono
parents:
diff changeset
153 Fore : Field;
kono
parents:
diff changeset
154 Aft : Field;
kono
parents:
diff changeset
155 Exp : Field;
kono
parents:
diff changeset
156 Scale : Integer)
kono
parents:
diff changeset
157 is
kono
parents:
diff changeset
158 Buf : String (1 .. Field'Last);
kono
parents:
diff changeset
159 Ptr : Natural := 0;
kono
parents:
diff changeset
160
kono
parents:
diff changeset
161 begin
kono
parents:
diff changeset
162 Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
kono
parents:
diff changeset
163 Put_Item (File, Buf (1 .. Ptr));
kono
parents:
diff changeset
164 end Put_Dec;
kono
parents:
diff changeset
165
kono
parents:
diff changeset
166 -------------
kono
parents:
diff changeset
167 -- Put_LLD --
kono
parents:
diff changeset
168 -------------
kono
parents:
diff changeset
169
kono
parents:
diff changeset
170 procedure Put_LLD
kono
parents:
diff changeset
171 (File : File_Type;
kono
parents:
diff changeset
172 Item : Long_Long_Integer;
kono
parents:
diff changeset
173 Fore : Field;
kono
parents:
diff changeset
174 Aft : Field;
kono
parents:
diff changeset
175 Exp : Field;
kono
parents:
diff changeset
176 Scale : Integer)
kono
parents:
diff changeset
177 is
kono
parents:
diff changeset
178 Buf : String (1 .. Field'Last);
kono
parents:
diff changeset
179 Ptr : Natural := 0;
kono
parents:
diff changeset
180
kono
parents:
diff changeset
181 begin
kono
parents:
diff changeset
182 Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
kono
parents:
diff changeset
183 Put_Item (File, Buf (1 .. Ptr));
kono
parents:
diff changeset
184 end Put_LLD;
kono
parents:
diff changeset
185
kono
parents:
diff changeset
186 --------------
kono
parents:
diff changeset
187 -- Puts_Dec --
kono
parents:
diff changeset
188 --------------
kono
parents:
diff changeset
189
kono
parents:
diff changeset
190 procedure Puts_Dec
kono
parents:
diff changeset
191 (To : out String;
kono
parents:
diff changeset
192 Item : Integer;
kono
parents:
diff changeset
193 Aft : Field;
kono
parents:
diff changeset
194 Exp : Field;
kono
parents:
diff changeset
195 Scale : Integer)
kono
parents:
diff changeset
196 is
kono
parents:
diff changeset
197 Buf : String (1 .. Field'Last);
kono
parents:
diff changeset
198 Fore : Integer;
kono
parents:
diff changeset
199 Ptr : Natural := 0;
kono
parents:
diff changeset
200
kono
parents:
diff changeset
201 begin
kono
parents:
diff changeset
202 -- Compute Fore, allowing for Aft digits and the decimal dot
kono
parents:
diff changeset
203
kono
parents:
diff changeset
204 Fore := To'Length - Field'Max (1, Aft) - 1;
kono
parents:
diff changeset
205
kono
parents:
diff changeset
206 -- Allow for Exp and two more for E+ or E- if exponent present
kono
parents:
diff changeset
207
kono
parents:
diff changeset
208 if Exp /= 0 then
kono
parents:
diff changeset
209 Fore := Fore - 2 - Exp;
kono
parents:
diff changeset
210 end if;
kono
parents:
diff changeset
211
kono
parents:
diff changeset
212 -- Make sure we have enough room
kono
parents:
diff changeset
213
kono
parents:
diff changeset
214 if Fore < 1 then
kono
parents:
diff changeset
215 raise Layout_Error;
kono
parents:
diff changeset
216 end if;
kono
parents:
diff changeset
217
kono
parents:
diff changeset
218 -- Do the conversion and check length of result
kono
parents:
diff changeset
219
kono
parents:
diff changeset
220 Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
kono
parents:
diff changeset
221
kono
parents:
diff changeset
222 if Ptr > To'Length then
kono
parents:
diff changeset
223 raise Layout_Error;
kono
parents:
diff changeset
224 else
kono
parents:
diff changeset
225 To := Buf (1 .. Ptr);
kono
parents:
diff changeset
226 end if;
kono
parents:
diff changeset
227 end Puts_Dec;
kono
parents:
diff changeset
228
kono
parents:
diff changeset
229 --------------
131
84e7813d76e9 gcc-8.2
mir3636
parents: 111
diff changeset
230 -- Puts_LLD --
111
kono
parents:
diff changeset
231 --------------
kono
parents:
diff changeset
232
kono
parents:
diff changeset
233 procedure Puts_LLD
kono
parents:
diff changeset
234 (To : out String;
kono
parents:
diff changeset
235 Item : Long_Long_Integer;
kono
parents:
diff changeset
236 Aft : Field;
kono
parents:
diff changeset
237 Exp : Field;
kono
parents:
diff changeset
238 Scale : Integer)
kono
parents:
diff changeset
239 is
kono
parents:
diff changeset
240 Buf : String (1 .. Field'Last);
kono
parents:
diff changeset
241 Fore : Integer;
kono
parents:
diff changeset
242 Ptr : Natural := 0;
kono
parents:
diff changeset
243
kono
parents:
diff changeset
244 begin
kono
parents:
diff changeset
245 Fore :=
kono
parents:
diff changeset
246 (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp);
kono
parents:
diff changeset
247
kono
parents:
diff changeset
248 if Fore < 1 then
kono
parents:
diff changeset
249 raise Layout_Error;
kono
parents:
diff changeset
250 end if;
kono
parents:
diff changeset
251
kono
parents:
diff changeset
252 Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp);
kono
parents:
diff changeset
253
kono
parents:
diff changeset
254 if Ptr > To'Length then
kono
parents:
diff changeset
255 raise Layout_Error;
kono
parents:
diff changeset
256 else
kono
parents:
diff changeset
257 To := Buf (1 .. Ptr);
kono
parents:
diff changeset
258 end if;
kono
parents:
diff changeset
259 end Puts_LLD;
kono
parents:
diff changeset
260
kono
parents:
diff changeset
261 end Ada.Text_IO.Decimal_Aux;