Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-tigeau.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 . T E X T _ I O . G E N E R I C _ 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 Interfaces.C_Streams; use Interfaces.C_Streams;
33 with System.File_IO;
34 with System.File_Control_Block;
35
36 package body Ada.Text_IO.Generic_Aux is
37
38 package FIO renames System.File_IO;
39 package FCB renames System.File_Control_Block;
40 subtype AP is FCB.AFCB_Ptr;
41
42 ------------------------
43 -- Check_End_Of_Field --
44 ------------------------
45
46 procedure Check_End_Of_Field
47 (Buf : String;
48 Stop : Integer;
49 Ptr : Integer;
50 Width : Field)
51 is
52 begin
53 if Ptr > Stop then
54 return;
55
56 elsif Width = 0 then
57 raise Data_Error;
58
59 else
60 for J in Ptr .. Stop loop
61 if not Is_Blank (Buf (J)) then
62 raise Data_Error;
63 end if;
64 end loop;
65 end if;
66 end Check_End_Of_Field;
67
68 -----------------------
69 -- Check_On_One_Line --
70 -----------------------
71
72 procedure Check_On_One_Line
73 (File : File_Type;
74 Length : Integer)
75 is
76 begin
77 FIO.Check_Write_Status (AP (File));
78
79 if File.Line_Length /= 0 then
80 if Count (Length) > File.Line_Length then
81 raise Layout_Error;
82 elsif File.Col + Count (Length) > File.Line_Length + 1 then
83 New_Line (File);
84 end if;
85 end if;
86 end Check_On_One_Line;
87
88 ----------
89 -- Getc --
90 ----------
91
92 function Getc (File : File_Type) return int is
93 ch : int;
94
95 begin
96 ch := fgetc (File.Stream);
97
98 if ch = EOF and then ferror (File.Stream) /= 0 then
99 raise Device_Error;
100 else
101 return ch;
102 end if;
103 end Getc;
104
105 --------------
106 -- Is_Blank --
107 --------------
108
109 function Is_Blank (C : Character) return Boolean is
110 begin
111 return C = ' ' or else C = ASCII.HT;
112 end Is_Blank;
113
114 ----------
115 -- Load --
116 ----------
117
118 procedure Load
119 (File : File_Type;
120 Buf : out String;
121 Ptr : in out Integer;
122 Char : Character;
123 Loaded : out Boolean)
124 is
125 ch : int;
126
127 begin
128 ch := Getc (File);
129
130 if ch = Character'Pos (Char) then
131 Store_Char (File, ch, Buf, Ptr);
132 Loaded := True;
133 else
134 Ungetc (ch, File);
135 Loaded := False;
136 end if;
137 end Load;
138
139 procedure Load
140 (File : File_Type;
141 Buf : out String;
142 Ptr : in out Integer;
143 Char : Character)
144 is
145 ch : int;
146
147 begin
148 ch := Getc (File);
149
150 if ch = Character'Pos (Char) then
151 Store_Char (File, ch, Buf, Ptr);
152 else
153 Ungetc (ch, File);
154 end if;
155 end Load;
156
157 procedure Load
158 (File : File_Type;
159 Buf : out String;
160 Ptr : in out Integer;
161 Char1 : Character;
162 Char2 : Character;
163 Loaded : out Boolean)
164 is
165 ch : int;
166
167 begin
168 ch := Getc (File);
169
170 if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then
171 Store_Char (File, ch, Buf, Ptr);
172 Loaded := True;
173 else
174 Ungetc (ch, File);
175 Loaded := False;
176 end if;
177 end Load;
178
179 procedure Load
180 (File : File_Type;
181 Buf : out String;
182 Ptr : in out Integer;
183 Char1 : Character;
184 Char2 : Character)
185 is
186 ch : int;
187
188 begin
189 ch := Getc (File);
190
191 if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then
192 Store_Char (File, ch, Buf, Ptr);
193 else
194 Ungetc (ch, File);
195 end if;
196 end Load;
197
198 -----------------
199 -- Load_Digits --
200 -----------------
201
202 procedure Load_Digits
203 (File : File_Type;
204 Buf : out String;
205 Ptr : in out Integer;
206 Loaded : out Boolean)
207 is
208 ch : int;
209 After_Digit : Boolean;
210
211 begin
212 ch := Getc (File);
213
214 if ch not in Character'Pos ('0') .. Character'Pos ('9') then
215 Loaded := False;
216
217 else
218 Loaded := True;
219 After_Digit := True;
220
221 loop
222 Store_Char (File, ch, Buf, Ptr);
223 ch := Getc (File);
224
225 if ch in Character'Pos ('0') .. Character'Pos ('9') then
226 After_Digit := True;
227
228 elsif ch = Character'Pos ('_') and then After_Digit then
229 After_Digit := False;
230
231 else
232 exit;
233 end if;
234 end loop;
235 end if;
236
237 Ungetc (ch, File);
238 end Load_Digits;
239
240 procedure Load_Digits
241 (File : File_Type;
242 Buf : out String;
243 Ptr : in out Integer)
244 is
245 ch : int;
246 After_Digit : Boolean;
247
248 begin
249 ch := Getc (File);
250
251 if ch in Character'Pos ('0') .. Character'Pos ('9') then
252 After_Digit := True;
253
254 loop
255 Store_Char (File, ch, Buf, Ptr);
256 ch := Getc (File);
257
258 if ch in Character'Pos ('0') .. Character'Pos ('9') then
259 After_Digit := True;
260
261 elsif ch = Character'Pos ('_') and then After_Digit then
262 After_Digit := False;
263
264 else
265 exit;
266 end if;
267 end loop;
268 end if;
269
270 Ungetc (ch, File);
271 end Load_Digits;
272
273 --------------------------
274 -- Load_Extended_Digits --
275 --------------------------
276
277 procedure Load_Extended_Digits
278 (File : File_Type;
279 Buf : out String;
280 Ptr : in out Integer;
281 Loaded : out Boolean)
282 is
283 ch : int;
284 After_Digit : Boolean := False;
285
286 begin
287 Loaded := False;
288
289 loop
290 ch := Getc (File);
291
292 if ch in Character'Pos ('0') .. Character'Pos ('9')
293 or else
294 ch in Character'Pos ('a') .. Character'Pos ('f')
295 or else
296 ch in Character'Pos ('A') .. Character'Pos ('F')
297 then
298 After_Digit := True;
299
300 elsif ch = Character'Pos ('_') and then After_Digit then
301 After_Digit := False;
302
303 else
304 exit;
305 end if;
306
307 Store_Char (File, ch, Buf, Ptr);
308 Loaded := True;
309 end loop;
310
311 Ungetc (ch, File);
312 end Load_Extended_Digits;
313
314 procedure Load_Extended_Digits
315 (File : File_Type;
316 Buf : out String;
317 Ptr : in out Integer)
318 is
319 Junk : Boolean;
320 pragma Unreferenced (Junk);
321 begin
322 Load_Extended_Digits (File, Buf, Ptr, Junk);
323 end Load_Extended_Digits;
324
325 ---------------
326 -- Load_Skip --
327 ---------------
328
329 procedure Load_Skip (File : File_Type) is
330 C : Character;
331
332 begin
333 FIO.Check_Read_Status (AP (File));
334
335 -- Loop till we find a non-blank character (note that as usual in
336 -- Text_IO, blank includes horizontal tab). Note that Get deals with
337 -- the Before_LM and Before_LM_PM flags appropriately.
338
339 loop
340 Get (File, C);
341 exit when not Is_Blank (C);
342 end loop;
343
344 Ungetc (Character'Pos (C), File);
345 File.Col := File.Col - 1;
346 end Load_Skip;
347
348 ----------------
349 -- Load_Width --
350 ----------------
351
352 procedure Load_Width
353 (File : File_Type;
354 Width : Field;
355 Buf : out String;
356 Ptr : in out Integer)
357 is
358 ch : int;
359
360 begin
361 FIO.Check_Read_Status (AP (File));
362
363 -- If we are immediately before a line mark, then we have no characters.
364 -- This is always a data error, so we may as well raise it right away.
365
366 if File.Before_LM then
367 raise Data_Error;
368
369 else
370 for J in 1 .. Width loop
371 ch := Getc (File);
372
373 if ch = EOF then
374 return;
375
376 elsif ch = LM then
377 Ungetc (ch, File);
378 return;
379
380 else
381 Store_Char (File, ch, Buf, Ptr);
382 end if;
383 end loop;
384 end if;
385 end Load_Width;
386
387 -----------
388 -- Nextc --
389 -----------
390
391 function Nextc (File : File_Type) return int is
392 ch : int;
393
394 begin
395 ch := fgetc (File.Stream);
396
397 if ch = EOF then
398 if ferror (File.Stream) /= 0 then
399 raise Device_Error;
400 else
401 return EOF;
402 end if;
403
404 else
405 Ungetc (ch, File);
406 return ch;
407 end if;
408 end Nextc;
409
410 --------------
411 -- Put_Item --
412 --------------
413
414 procedure Put_Item (File : File_Type; Str : String) is
415 begin
416 Check_On_One_Line (File, Str'Length);
417 Put (File, Str);
418 end Put_Item;
419
420 ----------------
421 -- Store_Char --
422 ----------------
423
424 procedure Store_Char
425 (File : File_Type;
426 ch : int;
427 Buf : in out String;
428 Ptr : in out Integer)
429 is
430 begin
431 File.Col := File.Col + 1;
432
433 if Ptr < Buf'Last then
434 Ptr := Ptr + 1;
435 end if;
436
437 Buf (Ptr) := Character'Val (ch);
438 end Store_Char;
439
440 -----------------
441 -- String_Skip --
442 -----------------
443
444 procedure String_Skip (Str : String; Ptr : out Integer) is
445 begin
446 -- Routines calling String_Skip malfunction if Str'Last = Positive'Last.
447 -- It's too much trouble to make this silly case work, so we just raise
448 -- Program_Error with an appropriate message. We raise Program_Error
449 -- rather than Constraint_Error because we don't want this case to be
450 -- converted to Data_Error.
451
452 if Str'Last = Positive'Last then
453 raise Program_Error with
454 "string upper bound is Positive'Last, not supported";
455 end if;
456
457 -- Normal case where Str'Last < Positive'Last
458
459 Ptr := Str'First;
460
461 loop
462 if Ptr > Str'Last then
463 raise End_Error;
464
465 elsif not Is_Blank (Str (Ptr)) then
466 return;
467
468 else
469 Ptr := Ptr + 1;
470 end if;
471 end loop;
472 end String_Skip;
473
474 ------------
475 -- Ungetc --
476 ------------
477
478 procedure Ungetc (ch : int; File : File_Type) is
479 begin
480 if ch /= EOF then
481 if ungetc (ch, File.Stream) = EOF then
482 raise Device_Error;
483 end if;
484 end if;
485 end Ungetc;
486
487 end Ada.Text_IO.Generic_Aux;