|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- A D A . 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 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
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_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_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_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_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_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_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_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_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_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_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_Character;
|
|
|
395
|
|
|
396 Bad_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_Character then
|
|
|
413 Bad_Wide_C := True;
|
|
|
414 Store_Char (File, 0, Buf, Ptr);
|
|
|
415 File.Before_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_Char (Character'Val (ch), File);
|
|
|
429 ch := Wide_Character'Pos (WC);
|
|
|
430
|
|
|
431 if ch > 255 then
|
|
|
432 Bad_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_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_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_Text_IO.Generic_Aux;
|
