Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-ztinau.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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 . I N T E G E R _ A U X --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2017, 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 Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
33
34 with System.Img_BIU; use System.Img_BIU;
35 with System.Img_Int; use System.Img_Int;
36 with System.Img_LLB; use System.Img_LLB;
37 with System.Img_LLI; use System.Img_LLI;
38 with System.Img_LLW; use System.Img_LLW;
39 with System.Img_WIU; use System.Img_WIU;
40 with System.Val_Int; use System.Val_Int;
41 with System.Val_LLI; use System.Val_LLI;
42
43 package body Ada.Wide_Wide_Text_IO.Integer_Aux is
44
45 -----------------------
46 -- Local Subprograms --
47 -----------------------
48
49 procedure Load_Integer
50 (File : File_Type;
51 Buf : out String;
52 Ptr : in out Natural);
53 -- This is an auxiliary routine that is used to load an possibly signed
54 -- integer literal value from the input file into Buf, starting at Ptr + 1.
55 -- On return, Ptr is set to the last character stored.
56
57 -------------
58 -- Get_Int --
59 -------------
60
61 procedure Get_Int
62 (File : File_Type;
63 Item : out Integer;
64 Width : Field)
65 is
66 Buf : String (1 .. Field'Last);
67 Ptr : aliased Integer := 1;
68 Stop : Integer := 0;
69
70 begin
71 if Width /= 0 then
72 Load_Width (File, Width, Buf, Stop);
73 String_Skip (Buf, Ptr);
74 else
75 Load_Integer (File, Buf, Stop);
76 end if;
77
78 Item := Scan_Integer (Buf, Ptr'Access, Stop);
79 Check_End_Of_Field (Buf, Stop, Ptr, Width);
80 end Get_Int;
81
82 -------------
83 -- Get_LLI --
84 -------------
85
86 procedure Get_LLI
87 (File : File_Type;
88 Item : out Long_Long_Integer;
89 Width : Field)
90 is
91 Buf : String (1 .. Field'Last);
92 Ptr : aliased Integer := 1;
93 Stop : Integer := 0;
94
95 begin
96 if Width /= 0 then
97 Load_Width (File, Width, Buf, Stop);
98 String_Skip (Buf, Ptr);
99 else
100 Load_Integer (File, Buf, Stop);
101 end if;
102
103 Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop);
104 Check_End_Of_Field (Buf, Stop, Ptr, Width);
105 end Get_LLI;
106
107 --------------
108 -- Gets_Int --
109 --------------
110
111 procedure Gets_Int
112 (From : String;
113 Item : out Integer;
114 Last : out Positive)
115 is
116 Pos : aliased Integer;
117
118 begin
119 String_Skip (From, Pos);
120 Item := Scan_Integer (From, Pos'Access, From'Last);
121 Last := Pos - 1;
122
123 exception
124 when Constraint_Error =>
125 raise Data_Error;
126 end Gets_Int;
127
128 --------------
129 -- Gets_LLI --
130 --------------
131
132 procedure Gets_LLI
133 (From : String;
134 Item : out Long_Long_Integer;
135 Last : out Positive)
136 is
137 Pos : aliased Integer;
138
139 begin
140 String_Skip (From, Pos);
141 Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last);
142 Last := Pos - 1;
143
144 exception
145 when Constraint_Error =>
146 raise Data_Error;
147 end Gets_LLI;
148
149 ------------------
150 -- Load_Integer --
151 ------------------
152
153 procedure Load_Integer
154 (File : File_Type;
155 Buf : out String;
156 Ptr : in out Natural)
157 is
158 Hash_Loc : Natural;
159 Loaded : Boolean;
160
161 begin
162 Load_Skip (File);
163 Load (File, Buf, Ptr, '+', '-');
164
165 Load_Digits (File, Buf, Ptr, Loaded);
166
167 if Loaded then
168
169 -- Deal with based case. We recognize either the standard '#' or the
170 -- allowed alternative replacement ':' (see RM J.2(3)).
171
172 Load (File, Buf, Ptr, '#', ':', Loaded);
173
174 if Loaded then
175 Hash_Loc := Ptr;
176 Load_Extended_Digits (File, Buf, Ptr);
177 Load (File, Buf, Ptr, Buf (Hash_Loc));
178 end if;
179
180 Load (File, Buf, Ptr, 'E', 'e', Loaded);
181
182 if Loaded then
183
184 -- Note: it is strange to allow a minus sign, since the syntax
185 -- does not, but that is what ACVC test CE3704F, case (6) wants.
186
187 Load (File, Buf, Ptr, '+', '-');
188 Load_Digits (File, Buf, Ptr);
189 end if;
190 end if;
191 end Load_Integer;
192
193 -------------
194 -- Put_Int --
195 -------------
196
197 procedure Put_Int
198 (File : File_Type;
199 Item : Integer;
200 Width : Field;
201 Base : Number_Base)
202 is
203 Buf : String (1 .. Field'Last);
204 Ptr : Natural := 0;
205
206 begin
207 if Base = 10 and then Width = 0 then
208 Set_Image_Integer (Item, Buf, Ptr);
209 elsif Base = 10 then
210 Set_Image_Width_Integer (Item, Width, Buf, Ptr);
211 else
212 Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr);
213 end if;
214
215 Put_Item (File, Buf (1 .. Ptr));
216 end Put_Int;
217
218 -------------
219 -- Put_LLI --
220 -------------
221
222 procedure Put_LLI
223 (File : File_Type;
224 Item : Long_Long_Integer;
225 Width : Field;
226 Base : Number_Base)
227 is
228 Buf : String (1 .. Field'Last);
229 Ptr : Natural := 0;
230
231 begin
232 if Base = 10 and then Width = 0 then
233 Set_Image_Long_Long_Integer (Item, Buf, Ptr);
234 elsif Base = 10 then
235 Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr);
236 else
237 Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr);
238 end if;
239
240 Put_Item (File, Buf (1 .. Ptr));
241 end Put_LLI;
242
243 --------------
244 -- Puts_Int --
245 --------------
246
247 procedure Puts_Int
248 (To : out String;
249 Item : Integer;
250 Base : Number_Base)
251 is
252 Buf : String (1 .. Field'Last);
253 Ptr : Natural := 0;
254
255 begin
256 if Base = 10 then
257 Set_Image_Width_Integer (Item, To'Length, Buf, Ptr);
258 else
259 Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr);
260 end if;
261
262 if Ptr > To'Length then
263 raise Layout_Error;
264 else
265 To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
266 end if;
267 end Puts_Int;
268
269 --------------
270 -- Puts_LLI --
271 --------------
272
273 procedure Puts_LLI
274 (To : out String;
275 Item : Long_Long_Integer;
276 Base : Number_Base)
277 is
278 Buf : String (1 .. Field'Last);
279 Ptr : Natural := 0;
280
281 begin
282 if Base = 10 then
283 Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr);
284 else
285 Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr);
286 end if;
287
288 if Ptr > To'Length then
289 raise Layout_Error;
290 else
291 To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
292 end if;
293 end Puts_LLI;
294
295 end Ada.Wide_Wide_Text_IO.Integer_Aux;