]>
Commit | Line | Data |
---|---|---|
d23b8f57 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3084fecd | 3 | -- GNAT RUN-TIME COMPONENTS -- |
d23b8f57 RK |
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 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- |
d23b8f57 RK |
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- -- | |
748086b7 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
d23b8f57 RK |
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 -- | |
748086b7 JJ |
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/>. -- | |
d23b8f57 RK |
26 | -- -- |
27 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 28 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
d23b8f57 RK |
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 | |
07fc65c4 | 47 | (Buf : String; |
d23b8f57 RK |
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; | |
67ce0d7e | 320 | pragma Unreferenced (Junk); |
d23b8f57 RK |
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; | |
b51711b5 | 427 | Buf : in out String; |
d23b8f57 RK |
428 | Ptr : in out Integer) |
429 | is | |
430 | begin | |
431 | File.Col := File.Col + 1; | |
432 | ||
fbf5a39b | 433 | if Ptr < Buf'Last then |
d23b8f57 | 434 | Ptr := Ptr + 1; |
d23b8f57 | 435 | end if; |
fbf5a39b AC |
436 | |
437 | Buf (Ptr) := Character'Val (ch); | |
d23b8f57 RK |
438 | end Store_Char; |
439 | ||
440 | ----------------- | |
441 | -- String_Skip -- | |
442 | ----------------- | |
443 | ||
444 | procedure String_Skip (Str : String; Ptr : out Integer) is | |
445 | begin | |
28fa5430 AC |
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 | ||
d23b8f57 RK |
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; |