Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-ztgeau.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 . 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.Wide_Wide_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 -- Is_Blank --
90 --------------
91
92 function Is_Blank (C : Character) return Boolean is
93 begin
94 return C = ' ' or else C = ASCII.HT;
95 end Is_Blank;
96
97 ----------
98 -- Load --
99 ----------
100
101 procedure Load
102 (File : File_Type;
103 Buf : out String;
104 Ptr : in out Integer;
105 Char : Character;
106 Loaded : out Boolean)
107 is
108 ch : int;
109
110 begin
111 if File.Before_Wide_Wide_Character then
112 Loaded := False;
113 return;
114
115 else
116 ch := Getc (File);
117
118 if ch = Character'Pos (Char) then
119 Store_Char (File, ch, Buf, Ptr);
120 Loaded := True;
121 else
122 Ungetc (ch, File);
123 Loaded := False;
124 end if;
125 end if;
126 end Load;
127
128 procedure Load
129 (File : File_Type;
130 Buf : out String;
131 Ptr : in out Integer;
132 Char : Character)
133 is
134 ch : int;
135
136 begin
137 if File.Before_Wide_Wide_Character then
138 null;
139
140 else
141 ch := Getc (File);
142
143 if ch = Character'Pos (Char) then
144 Store_Char (File, ch, Buf, Ptr);
145 else
146 Ungetc (ch, File);
147 end if;
148 end if;
149 end Load;
150
151 procedure Load
152 (File : File_Type;
153 Buf : out String;
154 Ptr : in out Integer;
155 Char1 : Character;
156 Char2 : Character;
157 Loaded : out Boolean)
158 is
159 ch : int;
160
161 begin
162 if File.Before_Wide_Wide_Character then
163 Loaded := False;
164 return;
165
166 else
167 ch := Getc (File);
168
169 if ch = Character'Pos (Char1)
170 or else ch = Character'Pos (Char2)
171 then
172 Store_Char (File, ch, Buf, Ptr);
173 Loaded := True;
174 else
175 Ungetc (ch, File);
176 Loaded := False;
177 end if;
178 end if;
179 end Load;
180
181 procedure Load
182 (File : File_Type;
183 Buf : out String;
184 Ptr : in out Integer;
185 Char1 : Character;
186 Char2 : Character)
187 is
188 ch : int;
189
190 begin
191 if File.Before_Wide_Wide_Character then
192 null;
193
194 else
195 ch := Getc (File);
196
197 if ch = Character'Pos (Char1)
198 or else ch = Character'Pos (Char2)
199 then
200 Store_Char (File, ch, Buf, Ptr);
201 else
202 Ungetc (ch, File);
203 end if;
204 end if;
205 end Load;
206
207 -----------------
208 -- Load_Digits --
209 -----------------
210
211 procedure Load_Digits
212 (File : File_Type;
213 Buf : out String;
214 Ptr : in out Integer;
215 Loaded : out Boolean)
216 is
217 ch : int;
218 After_Digit : Boolean;
219
220 begin
221 if File.Before_Wide_Wide_Character then
222 Loaded := False;
223 return;
224
225 else
226 ch := Getc (File);
227
228 if ch not in Character'Pos ('0') .. Character'Pos ('9') then
229 Loaded := False;
230
231 else
232 Loaded := True;
233 After_Digit := True;
234
235 loop
236 Store_Char (File, ch, Buf, Ptr);
237 ch := Getc (File);
238
239 if ch in Character'Pos ('0') .. Character'Pos ('9') then
240 After_Digit := True;
241
242 elsif ch = Character'Pos ('_') and then After_Digit then
243 After_Digit := False;
244
245 else
246 exit;
247 end if;
248 end loop;
249 end if;
250
251 Ungetc (ch, File);
252 end if;
253 end Load_Digits;
254
255 procedure Load_Digits
256 (File : File_Type;
257 Buf : out String;
258 Ptr : in out Integer)
259 is
260 ch : int;
261 After_Digit : Boolean;
262
263 begin
264 if File.Before_Wide_Wide_Character then
265 return;
266
267 else
268 ch := Getc (File);
269
270 if ch in Character'Pos ('0') .. Character'Pos ('9') then
271 After_Digit := True;
272
273 loop
274 Store_Char (File, ch, Buf, Ptr);
275 ch := Getc (File);
276
277 if ch in Character'Pos ('0') .. Character'Pos ('9') then
278 After_Digit := True;
279
280 elsif ch = Character'Pos ('_') and then After_Digit then
281 After_Digit := False;
282
283 else
284 exit;
285 end if;
286 end loop;
287 end if;
288
289 Ungetc (ch, File);
290 end if;
291 end Load_Digits;
292
293 --------------------------
294 -- Load_Extended_Digits --
295 --------------------------
296
297 procedure Load_Extended_Digits
298 (File : File_Type;
299 Buf : out String;
300 Ptr : in out Integer;
301 Loaded : out Boolean)
302 is
303 ch : int;
304 After_Digit : Boolean := False;
305
306 begin
307 if File.Before_Wide_Wide_Character then
308 Loaded := False;
309 return;
310
311 else
312 Loaded := False;
313
314 loop
315 ch := Getc (File);
316
317 if ch in Character'Pos ('0') .. Character'Pos ('9')
318 or else
319 ch in Character'Pos ('a') .. Character'Pos ('f')
320 or else
321 ch in Character'Pos ('A') .. Character'Pos ('F')
322 then
323 After_Digit := True;
324
325 elsif ch = Character'Pos ('_') and then After_Digit then
326 After_Digit := False;
327
328 else
329 exit;
330 end if;
331
332 Store_Char (File, ch, Buf, Ptr);
333 Loaded := True;
334 end loop;
335
336 Ungetc (ch, File);
337 end if;
338 end Load_Extended_Digits;
339
340 procedure Load_Extended_Digits
341 (File : File_Type;
342 Buf : out String;
343 Ptr : in out Integer)
344 is
345 Junk : Boolean;
346 pragma Unreferenced (Junk);
347 begin
348 Load_Extended_Digits (File, Buf, Ptr, Junk);
349 end Load_Extended_Digits;
350
351 ---------------
352 -- Load_Skip --
353 ---------------
354
355 procedure Load_Skip (File : File_Type) is
356 C : Character;
357
358 begin
359 FIO.Check_Read_Status (AP (File));
360
361 -- We need to explicitly test for the case of being before a wide
362 -- character (greater than 16#7F#). Since no such character can
363 -- ever legitimately be a valid numeric character, we can
364 -- immediately signal Data_Error.
365
366 if File.Before_Wide_Wide_Character then
367 raise Data_Error;
368 end if;
369
370 -- Otherwise loop till we find a non-blank character (note that as
371 -- usual in Wide_Wide_Text_IO, blank includes horizontal tab). Note that
372 -- Get_Character deals with Before_LM/Before_LM_PM flags appropriately.
373
374 loop
375 Get_Character (File, C);
376 exit when not Is_Blank (C);
377 end loop;
378
379 Ungetc (Character'Pos (C), File);
380 File.Col := File.Col - 1;
381 end Load_Skip;
382
383 ----------------
384 -- Load_Width --
385 ----------------
386
387 procedure Load_Width
388 (File : File_Type;
389 Width : Field;
390 Buf : out String;
391 Ptr : in out Integer)
392 is
393 ch : int;
394 WC : Wide_Wide_Character;
395
396 Bad_Wide_Wide_C : Boolean := False;
397 -- Set True if one of the characters read is not in range of type
398 -- Character. This is always a Data_Error, but we do not signal it
399 -- right away, since we have to read the full number of characters.
400
401 begin
402 FIO.Check_Read_Status (AP (File));
403
404 -- If we are immediately before a line mark, then we have no characters.
405 -- This is always a data error, so we may as well raise it right away.
406
407 if File.Before_LM then
408 raise Data_Error;
409
410 else
411 for J in 1 .. Width loop
412 if File.Before_Wide_Wide_Character then
413 Bad_Wide_Wide_C := True;
414 Store_Char (File, 0, Buf, Ptr);
415 File.Before_Wide_Wide_Character := False;
416
417 else
418 ch := Getc (File);
419
420 if ch = EOF then
421 exit;
422
423 elsif ch = LM then
424 Ungetc (ch, File);
425 exit;
426
427 else
428 WC := Get_Wide_Wide_Char (Character'Val (ch), File);
429 ch := Wide_Wide_Character'Pos (WC);
430
431 if ch > 255 then
432 Bad_Wide_Wide_C := True;
433 ch := 0;
434 end if;
435
436 Store_Char (File, ch, Buf, Ptr);
437 end if;
438 end if;
439 end loop;
440
441 if Bad_Wide_Wide_C then
442 raise Data_Error;
443 end if;
444 end if;
445 end Load_Width;
446
447 --------------
448 -- Put_Item --
449 --------------
450
451 procedure Put_Item (File : File_Type; Str : String) is
452 begin
453 Check_On_One_Line (File, Str'Length);
454
455 for J in Str'Range loop
456 Put (File, Wide_Wide_Character'Val (Character'Pos (Str (J))));
457 end loop;
458 end Put_Item;
459
460 ----------------
461 -- Store_Char --
462 ----------------
463
464 procedure Store_Char
465 (File : File_Type;
466 ch : Integer;
467 Buf : out String;
468 Ptr : in out Integer)
469 is
470 begin
471 File.Col := File.Col + 1;
472
473 if Ptr = Buf'Last then
474 raise Data_Error;
475 else
476 Ptr := Ptr + 1;
477 Buf (Ptr) := Character'Val (ch);
478 end if;
479 end Store_Char;
480
481 -----------------
482 -- String_Skip --
483 -----------------
484
485 procedure String_Skip (Str : String; Ptr : out Integer) is
486 begin
487 -- Routines calling String_Skip malfunction if Str'Last = Positive'Last.
488 -- It's too much trouble to make this silly case work, so we just raise
489 -- Program_Error with an appropriate message. We raise Program_Error
490 -- rather than Constraint_Error because we don't want this case to be
491 -- converted to Data_Error.
492
493 if Str'Last = Positive'Last then
494 raise Program_Error with
495 "string upper bound is Positive'Last, not supported";
496 end if;
497
498 -- Normal case where Str'Last < Positive'Last
499
500 Ptr := Str'First;
501
502 loop
503 if Ptr > Str'Last then
504 raise End_Error;
505
506 elsif not Is_Blank (Str (Ptr)) then
507 return;
508
509 else
510 Ptr := Ptr + 1;
511 end if;
512 end loop;
513 end String_Skip;
514
515 ------------
516 -- Ungetc --
517 ------------
518
519 procedure Ungetc (ch : int; File : File_Type) is
520 begin
521 if ch /= EOF then
522 if ungetc (ch, File.Stream) = EOF then
523 raise Device_Error;
524 end if;
525 end if;
526 end Ungetc;
527
528 end Ada.Wide_Wide_Text_IO.Generic_Aux;