]>
Commit | Line | Data |
---|---|---|
d23b8f57 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3084fecd | 3 | -- GNAT RUN-TIME COMPONENTS -- |
d23b8f57 RK |
4 | -- -- |
5 | -- A D A . W I D E _ T E X T _ I O -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
748086b7 | 9 | -- Copyright (C) 1992-2009, 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 | ||
d23b8f57 RK |
32 | with Ada.Streams; use Ada.Streams; |
33 | with Interfaces.C_Streams; use Interfaces.C_Streams; | |
34 | ||
209db2bf | 35 | with System.CRTL; |
d23b8f57 RK |
36 | with System.File_IO; |
37 | with System.WCh_Cnv; use System.WCh_Cnv; | |
38 | with System.WCh_Con; use System.WCh_Con; | |
4e45e7a9 | 39 | |
cecaf88a RD |
40 | with Ada.Unchecked_Conversion; |
41 | with Ada.Unchecked_Deallocation; | |
d23b8f57 RK |
42 | |
43 | pragma Elaborate_All (System.File_IO); | |
44 | -- Needed because of calls to Chain_File in package body elaboration | |
45 | ||
46 | package body Ada.Wide_Text_IO is | |
47 | ||
48 | package FIO renames System.File_IO; | |
49 | ||
50 | subtype AP is FCB.AFCB_Ptr; | |
51 | ||
cecaf88a RD |
52 | function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); |
53 | function To_TIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); | |
d23b8f57 RK |
54 | use type FCB.File_Mode; |
55 | ||
209db2bf AC |
56 | use type System.CRTL.size_t; |
57 | ||
d23b8f57 RK |
58 | WC_Encoding : Character; |
59 | pragma Import (C, WC_Encoding, "__gl_wc_encoding"); | |
60 | ||
61 | ----------------------- | |
62 | -- Local Subprograms -- | |
63 | ----------------------- | |
64 | ||
4e45e7a9 | 65 | function Getc_Immed (File : File_Type) return int; |
d23b8f57 RK |
66 | -- This routine is identical to Getc, except that the read is done in |
67 | -- Get_Immediate mode (i.e. without waiting for a line return). | |
68 | ||
69 | function Get_Wide_Char_Immed | |
70 | (C : Character; | |
4e45e7a9 | 71 | File : File_Type) return Wide_Character; |
d23b8f57 RK |
72 | -- This routine is identical to Get_Wide_Char, except that the reads are |
73 | -- done in Get_Immediate mode (i.e. without waiting for a line return). | |
74 | ||
75 | procedure Set_WCEM (File : in out File_Type); | |
b917101e RD |
76 | -- Called by Open and Create to set the wide character encoding method for |
77 | -- the file, processing a WCEM form parameter if one is present. File is | |
78 | -- IN OUT because it may be closed in case of an error. | |
d23b8f57 RK |
79 | |
80 | ------------------- | |
81 | -- AFCB_Allocate -- | |
82 | ------------------- | |
83 | ||
84 | function AFCB_Allocate | |
4e45e7a9 | 85 | (Control_Block : Wide_Text_AFCB) return FCB.AFCB_Ptr |
d23b8f57 | 86 | is |
fbf5a39b | 87 | pragma Unreferenced (Control_Block); |
d23b8f57 RK |
88 | begin |
89 | return new Wide_Text_AFCB; | |
90 | end AFCB_Allocate; | |
91 | ||
92 | ---------------- | |
93 | -- AFCB_Close -- | |
94 | ---------------- | |
95 | ||
d90e94c7 | 96 | procedure AFCB_Close (File : not null access Wide_Text_AFCB) is |
d23b8f57 RK |
97 | begin |
98 | -- If the file being closed is one of the current files, then close | |
99 | -- the corresponding current file. It is not clear that this action | |
100 | -- is required (RM A.10.3(23)) but it seems reasonable, and besides | |
101 | -- ACVC test CE3208A expects this behavior. | |
102 | ||
103 | if File_Type (File) = Current_In then | |
104 | Current_In := null; | |
105 | elsif File_Type (File) = Current_Out then | |
106 | Current_Out := null; | |
107 | elsif File_Type (File) = Current_Err then | |
108 | Current_Err := null; | |
109 | end if; | |
110 | ||
111 | Terminate_Line (File_Type (File)); | |
112 | end AFCB_Close; | |
113 | ||
114 | --------------- | |
115 | -- AFCB_Free -- | |
116 | --------------- | |
117 | ||
d90e94c7 | 118 | procedure AFCB_Free (File : not null access Wide_Text_AFCB) is |
d23b8f57 RK |
119 | type FCB_Ptr is access all Wide_Text_AFCB; |
120 | FT : FCB_Ptr := FCB_Ptr (File); | |
121 | ||
cecaf88a RD |
122 | procedure Free is |
123 | new Ada.Unchecked_Deallocation (Wide_Text_AFCB, FCB_Ptr); | |
d23b8f57 RK |
124 | |
125 | begin | |
126 | Free (FT); | |
127 | end AFCB_Free; | |
128 | ||
129 | ----------- | |
130 | -- Close -- | |
131 | ----------- | |
132 | ||
133 | procedure Close (File : in out File_Type) is | |
134 | begin | |
100a5d66 | 135 | FIO.Close (AP (File)'Unrestricted_Access); |
d23b8f57 RK |
136 | end Close; |
137 | ||
138 | --------- | |
139 | -- Col -- | |
140 | --------- | |
141 | ||
142 | -- Note: we assume that it is impossible in practice for the column | |
143 | -- to exceed the value of Count'Last, i.e. no check is required for | |
144 | -- overflow raising layout error. | |
145 | ||
4e45e7a9 | 146 | function Col (File : File_Type) return Positive_Count is |
d23b8f57 RK |
147 | begin |
148 | FIO.Check_File_Open (AP (File)); | |
149 | return File.Col; | |
150 | end Col; | |
151 | ||
152 | function Col return Positive_Count is | |
153 | begin | |
154 | return Col (Current_Out); | |
155 | end Col; | |
156 | ||
157 | ------------ | |
158 | -- Create -- | |
159 | ------------ | |
160 | ||
161 | procedure Create | |
162 | (File : in out File_Type; | |
4e45e7a9 RD |
163 | Mode : File_Mode := Out_File; |
164 | Name : String := ""; | |
165 | Form : String := "") | |
d23b8f57 | 166 | is |
fbf5a39b AC |
167 | Dummy_File_Control_Block : Wide_Text_AFCB; |
168 | pragma Warnings (Off, Dummy_File_Control_Block); | |
169 | -- Yes, we know this is never assigned a value, only the tag | |
170 | -- is used for dispatching purposes, so that's expected. | |
d23b8f57 RK |
171 | |
172 | begin | |
173 | FIO.Open (File_Ptr => AP (File), | |
fbf5a39b | 174 | Dummy_FCB => Dummy_File_Control_Block, |
d23b8f57 RK |
175 | Mode => To_FCB (Mode), |
176 | Name => Name, | |
177 | Form => Form, | |
178 | Amethod => 'W', | |
179 | Creat => True, | |
180 | Text => True); | |
afc5f979 AC |
181 | |
182 | File.Self := File; | |
d23b8f57 RK |
183 | Set_WCEM (File); |
184 | end Create; | |
185 | ||
186 | ------------------- | |
187 | -- Current_Error -- | |
188 | ------------------- | |
189 | ||
190 | function Current_Error return File_Type is | |
191 | begin | |
192 | return Current_Err; | |
193 | end Current_Error; | |
194 | ||
195 | function Current_Error return File_Access is | |
196 | begin | |
afc5f979 | 197 | return Current_Err.Self'Access; |
d23b8f57 RK |
198 | end Current_Error; |
199 | ||
200 | ------------------- | |
201 | -- Current_Input -- | |
202 | ------------------- | |
203 | ||
204 | function Current_Input return File_Type is | |
205 | begin | |
206 | return Current_In; | |
207 | end Current_Input; | |
208 | ||
209 | function Current_Input return File_Access is | |
210 | begin | |
afc5f979 | 211 | return Current_In.Self'Access; |
d23b8f57 RK |
212 | end Current_Input; |
213 | ||
214 | -------------------- | |
215 | -- Current_Output -- | |
216 | -------------------- | |
217 | ||
218 | function Current_Output return File_Type is | |
219 | begin | |
220 | return Current_Out; | |
221 | end Current_Output; | |
222 | ||
223 | function Current_Output return File_Access is | |
224 | begin | |
afc5f979 | 225 | return Current_Out.Self'Access; |
d23b8f57 RK |
226 | end Current_Output; |
227 | ||
228 | ------------ | |
229 | -- Delete -- | |
230 | ------------ | |
231 | ||
232 | procedure Delete (File : in out File_Type) is | |
233 | begin | |
100a5d66 | 234 | FIO.Delete (AP (File)'Unrestricted_Access); |
d23b8f57 RK |
235 | end Delete; |
236 | ||
237 | ----------------- | |
238 | -- End_Of_File -- | |
239 | ----------------- | |
240 | ||
4e45e7a9 | 241 | function End_Of_File (File : File_Type) return Boolean is |
d23b8f57 RK |
242 | ch : int; |
243 | ||
244 | begin | |
245 | FIO.Check_Read_Status (AP (File)); | |
246 | ||
247 | if File.Before_Wide_Character then | |
248 | return False; | |
249 | ||
250 | elsif File.Before_LM then | |
d23b8f57 RK |
251 | if File.Before_LM_PM then |
252 | return Nextc (File) = EOF; | |
253 | end if; | |
254 | ||
255 | else | |
256 | ch := Getc (File); | |
257 | ||
258 | if ch = EOF then | |
259 | return True; | |
260 | ||
261 | elsif ch /= LM then | |
262 | Ungetc (ch, File); | |
263 | return False; | |
264 | ||
265 | else -- ch = LM | |
266 | File.Before_LM := True; | |
267 | end if; | |
268 | end if; | |
269 | ||
270 | -- Here we are just past the line mark with Before_LM set so that we | |
271 | -- do not have to try to back up past the LM, thus avoiding the need | |
272 | -- to back up more than one character. | |
273 | ||
274 | ch := Getc (File); | |
275 | ||
276 | if ch = EOF then | |
277 | return True; | |
278 | ||
279 | elsif ch = PM and then File.Is_Regular_File then | |
280 | File.Before_LM_PM := True; | |
281 | return Nextc (File) = EOF; | |
282 | ||
283 | -- Here if neither EOF nor PM followed end of line | |
284 | ||
285 | else | |
286 | Ungetc (ch, File); | |
287 | return False; | |
288 | end if; | |
289 | ||
290 | end End_Of_File; | |
291 | ||
292 | function End_Of_File return Boolean is | |
293 | begin | |
294 | return End_Of_File (Current_In); | |
295 | end End_Of_File; | |
296 | ||
297 | ----------------- | |
298 | -- End_Of_Line -- | |
299 | ----------------- | |
300 | ||
4e45e7a9 | 301 | function End_Of_Line (File : File_Type) return Boolean is |
d23b8f57 RK |
302 | ch : int; |
303 | ||
304 | begin | |
305 | FIO.Check_Read_Status (AP (File)); | |
306 | ||
307 | if File.Before_Wide_Character then | |
308 | return False; | |
309 | ||
310 | elsif File.Before_LM then | |
311 | return True; | |
312 | ||
313 | else | |
314 | ch := Getc (File); | |
315 | ||
316 | if ch = EOF then | |
317 | return True; | |
318 | ||
319 | else | |
320 | Ungetc (ch, File); | |
321 | return (ch = LM); | |
322 | end if; | |
323 | end if; | |
324 | end End_Of_Line; | |
325 | ||
326 | function End_Of_Line return Boolean is | |
327 | begin | |
328 | return End_Of_Line (Current_In); | |
329 | end End_Of_Line; | |
330 | ||
331 | ----------------- | |
332 | -- End_Of_Page -- | |
333 | ----------------- | |
334 | ||
4e45e7a9 | 335 | function End_Of_Page (File : File_Type) return Boolean is |
d23b8f57 RK |
336 | ch : int; |
337 | ||
338 | begin | |
339 | FIO.Check_Read_Status (AP (File)); | |
340 | ||
341 | if not File.Is_Regular_File then | |
342 | return False; | |
343 | ||
344 | elsif File.Before_Wide_Character then | |
345 | return False; | |
346 | ||
347 | elsif File.Before_LM then | |
348 | if File.Before_LM_PM then | |
349 | return True; | |
350 | end if; | |
351 | ||
352 | else | |
353 | ch := Getc (File); | |
354 | ||
355 | if ch = EOF then | |
356 | return True; | |
357 | ||
358 | elsif ch /= LM then | |
359 | Ungetc (ch, File); | |
360 | return False; | |
361 | ||
362 | else -- ch = LM | |
363 | File.Before_LM := True; | |
364 | end if; | |
365 | end if; | |
366 | ||
367 | -- Here we are just past the line mark with Before_LM set so that we | |
368 | -- do not have to try to back up past the LM, thus avoiding the need | |
369 | -- to back up more than one character. | |
370 | ||
371 | ch := Nextc (File); | |
372 | ||
373 | return ch = PM or else ch = EOF; | |
374 | end End_Of_Page; | |
375 | ||
376 | function End_Of_Page return Boolean is | |
377 | begin | |
378 | return End_Of_Page (Current_In); | |
379 | end End_Of_Page; | |
380 | ||
381 | ----------- | |
382 | -- Flush -- | |
383 | ----------- | |
384 | ||
4e45e7a9 | 385 | procedure Flush (File : File_Type) is |
d23b8f57 RK |
386 | begin |
387 | FIO.Flush (AP (File)); | |
388 | end Flush; | |
389 | ||
390 | procedure Flush is | |
391 | begin | |
392 | Flush (Current_Out); | |
393 | end Flush; | |
394 | ||
395 | ---------- | |
396 | -- Form -- | |
397 | ---------- | |
398 | ||
4e45e7a9 | 399 | function Form (File : File_Type) return String is |
d23b8f57 RK |
400 | begin |
401 | return FIO.Form (AP (File)); | |
402 | end Form; | |
403 | ||
404 | --------- | |
405 | -- Get -- | |
406 | --------- | |
407 | ||
408 | procedure Get | |
4e45e7a9 | 409 | (File : File_Type; |
d23b8f57 RK |
410 | Item : out Wide_Character) |
411 | is | |
412 | C : Character; | |
413 | ||
414 | begin | |
415 | FIO.Check_Read_Status (AP (File)); | |
416 | ||
417 | if File.Before_Wide_Character then | |
418 | File.Before_Wide_Character := False; | |
419 | Item := File.Saved_Wide_Character; | |
420 | ||
b917101e RD |
421 | -- Ada.Text_IO checks Before_LM_PM here, shouldn't we do the same??? |
422 | ||
d23b8f57 RK |
423 | else |
424 | Get_Character (File, C); | |
425 | Item := Get_Wide_Char (C, File); | |
426 | end if; | |
427 | end Get; | |
428 | ||
429 | procedure Get (Item : out Wide_Character) is | |
430 | begin | |
431 | Get (Current_In, Item); | |
432 | end Get; | |
433 | ||
434 | procedure Get | |
4e45e7a9 | 435 | (File : File_Type; |
d23b8f57 RK |
436 | Item : out Wide_String) |
437 | is | |
438 | begin | |
439 | for J in Item'Range loop | |
440 | Get (File, Item (J)); | |
441 | end loop; | |
442 | end Get; | |
443 | ||
444 | procedure Get (Item : out Wide_String) is | |
445 | begin | |
446 | Get (Current_In, Item); | |
447 | end Get; | |
448 | ||
449 | ------------------- | |
450 | -- Get_Character -- | |
451 | ------------------- | |
452 | ||
453 | procedure Get_Character | |
4e45e7a9 | 454 | (File : File_Type; |
d23b8f57 RK |
455 | Item : out Character) |
456 | is | |
457 | ch : int; | |
458 | ||
459 | begin | |
460 | if File.Before_LM then | |
461 | File.Before_LM := False; | |
462 | File.Before_LM_PM := False; | |
463 | File.Col := 1; | |
464 | ||
465 | if File.Before_LM_PM then | |
466 | File.Line := 1; | |
467 | File.Page := File.Page + 1; | |
468 | File.Before_LM_PM := False; | |
469 | ||
470 | else | |
471 | File.Line := File.Line + 1; | |
472 | end if; | |
473 | end if; | |
474 | ||
475 | loop | |
476 | ch := Getc (File); | |
477 | ||
478 | if ch = EOF then | |
479 | raise End_Error; | |
480 | ||
481 | elsif ch = LM then | |
482 | File.Line := File.Line + 1; | |
483 | File.Col := 1; | |
484 | ||
485 | elsif ch = PM and then File.Is_Regular_File then | |
486 | File.Page := File.Page + 1; | |
487 | File.Line := 1; | |
488 | ||
489 | else | |
490 | Item := Character'Val (ch); | |
491 | File.Col := File.Col + 1; | |
492 | return; | |
493 | end if; | |
494 | end loop; | |
495 | end Get_Character; | |
496 | ||
497 | ------------------- | |
498 | -- Get_Immediate -- | |
499 | ------------------- | |
500 | ||
501 | procedure Get_Immediate | |
4e45e7a9 | 502 | (File : File_Type; |
d23b8f57 RK |
503 | Item : out Wide_Character) |
504 | is | |
505 | ch : int; | |
506 | ||
507 | begin | |
508 | FIO.Check_Read_Status (AP (File)); | |
509 | ||
510 | if File.Before_Wide_Character then | |
511 | File.Before_Wide_Character := False; | |
512 | Item := File.Saved_Wide_Character; | |
513 | ||
514 | elsif File.Before_LM then | |
515 | File.Before_LM := False; | |
516 | File.Before_LM_PM := False; | |
517 | Item := Wide_Character'Val (LM); | |
518 | ||
519 | else | |
520 | ch := Getc_Immed (File); | |
521 | ||
522 | if ch = EOF then | |
523 | raise End_Error; | |
524 | else | |
525 | Item := Get_Wide_Char_Immed (Character'Val (ch), File); | |
526 | end if; | |
527 | end if; | |
528 | end Get_Immediate; | |
529 | ||
530 | procedure Get_Immediate | |
531 | (Item : out Wide_Character) | |
532 | is | |
533 | begin | |
534 | Get_Immediate (Current_In, Item); | |
535 | end Get_Immediate; | |
536 | ||
537 | procedure Get_Immediate | |
4e45e7a9 | 538 | (File : File_Type; |
d23b8f57 RK |
539 | Item : out Wide_Character; |
540 | Available : out Boolean) | |
541 | is | |
542 | ch : int; | |
543 | ||
544 | begin | |
545 | FIO.Check_Read_Status (AP (File)); | |
546 | Available := True; | |
547 | ||
548 | if File.Before_Wide_Character then | |
549 | File.Before_Wide_Character := False; | |
550 | Item := File.Saved_Wide_Character; | |
551 | ||
552 | elsif File.Before_LM then | |
553 | File.Before_LM := False; | |
554 | File.Before_LM_PM := False; | |
555 | Item := Wide_Character'Val (LM); | |
556 | ||
557 | else | |
b917101e RD |
558 | -- Shouldn't we use getc_immediate_nowait here, like Text_IO??? |
559 | ||
d23b8f57 RK |
560 | ch := Getc_Immed (File); |
561 | ||
562 | if ch = EOF then | |
563 | raise End_Error; | |
564 | else | |
565 | Item := Get_Wide_Char_Immed (Character'Val (ch), File); | |
566 | end if; | |
567 | end if; | |
568 | end Get_Immediate; | |
569 | ||
570 | procedure Get_Immediate | |
571 | (Item : out Wide_Character; | |
572 | Available : out Boolean) | |
573 | is | |
574 | begin | |
575 | Get_Immediate (Current_In, Item, Available); | |
576 | end Get_Immediate; | |
577 | ||
578 | -------------- | |
579 | -- Get_Line -- | |
580 | -------------- | |
581 | ||
582 | procedure Get_Line | |
4e45e7a9 | 583 | (File : File_Type; |
d23b8f57 RK |
584 | Item : out Wide_String; |
585 | Last : out Natural) | |
586 | is | |
587 | begin | |
588 | FIO.Check_Read_Status (AP (File)); | |
589 | Last := Item'First - 1; | |
590 | ||
591 | -- Immediate exit for null string, this is a case in which we do not | |
592 | -- need to test for end of file and we do not skip a line mark under | |
593 | -- any circumstances. | |
594 | ||
595 | if Last >= Item'Last then | |
596 | return; | |
597 | end if; | |
598 | ||
599 | -- Here we have at least one character, if we are immediately before | |
600 | -- a line mark, then we will just skip past it storing no characters. | |
601 | ||
602 | if File.Before_LM then | |
603 | File.Before_LM := False; | |
604 | File.Before_LM_PM := False; | |
605 | ||
606 | -- Otherwise we need to read some characters | |
607 | ||
608 | else | |
609 | -- If we are at the end of file now, it means we are trying to | |
610 | -- skip a file terminator and we raise End_Error (RM A.10.7(20)) | |
611 | ||
612 | if Nextc (File) = EOF then | |
613 | raise End_Error; | |
614 | end if; | |
615 | ||
616 | -- Loop through characters in string | |
617 | ||
618 | loop | |
619 | -- Exit the loop if read is terminated by encountering line mark | |
620 | -- Note that the use of Skip_Line here ensures we properly deal | |
621 | -- with setting the page and line numbers. | |
622 | ||
623 | if End_Of_Line (File) then | |
624 | Skip_Line (File); | |
625 | return; | |
626 | end if; | |
627 | ||
628 | -- Otherwise store the character, note that we know that ch is | |
629 | -- something other than LM or EOF. It could possibly be a page | |
630 | -- mark if there is a stray page mark in the middle of a line, | |
631 | -- but this is not an official page mark in any case, since | |
632 | -- official page marks can only follow a line mark. The whole | |
633 | -- page business is pretty much nonsense anyway, so we do not | |
634 | -- want to waste time trying to make sense out of non-standard | |
635 | -- page marks in the file! This means that the behavior of | |
636 | -- Get_Line is different from repeated Get of a character, but | |
637 | -- that's too bad. We only promise that page numbers etc make | |
638 | -- sense if the file is formatted in a standard manner. | |
639 | ||
640 | -- Note: we do not adjust the column number because it is quicker | |
641 | -- to adjust it once at the end of the operation than incrementing | |
642 | -- it each time around the loop. | |
643 | ||
644 | Last := Last + 1; | |
645 | Get (File, Item (Last)); | |
646 | ||
647 | -- All done if the string is full, this is the case in which | |
648 | -- we do not skip the following line mark. We need to adjust | |
649 | -- the column number in this case. | |
650 | ||
651 | if Last = Item'Last then | |
652 | File.Col := File.Col + Count (Item'Length); | |
653 | return; | |
654 | end if; | |
655 | ||
656 | -- Exit from the loop if we are at the end of file. This happens | |
657 | -- if we have a last line that is not terminated with a line mark. | |
658 | -- In this case we consider that there is an implied line mark; | |
659 | -- this is a non-standard file, but we will treat it nicely. | |
660 | ||
661 | exit when Nextc (File) = EOF; | |
662 | end loop; | |
663 | end if; | |
664 | end Get_Line; | |
665 | ||
666 | procedure Get_Line | |
667 | (Item : out Wide_String; | |
668 | Last : out Natural) | |
669 | is | |
670 | begin | |
671 | Get_Line (Current_In, Item, Last); | |
672 | end Get_Line; | |
673 | ||
4e45e7a9 RD |
674 | function Get_Line (File : File_Type) return Wide_String is |
675 | Buffer : Wide_String (1 .. 500); | |
676 | Last : Natural; | |
677 | ||
678 | function Get_Rest (S : Wide_String) return Wide_String; | |
679 | -- This is a recursive function that reads the rest of the line and | |
680 | -- returns it. S is the part read so far. | |
681 | ||
682 | -------------- | |
683 | -- Get_Rest -- | |
684 | -------------- | |
685 | ||
686 | function Get_Rest (S : Wide_String) return Wide_String is | |
687 | ||
688 | -- Each time we allocate a buffer the same size as what we have | |
689 | -- read so far. This limits us to a logarithmic number of calls | |
690 | -- to Get_Rest and also ensures only a linear use of stack space. | |
691 | ||
692 | Buffer : Wide_String (1 .. S'Length); | |
693 | Last : Natural; | |
694 | ||
695 | begin | |
696 | Get_Line (File, Buffer, Last); | |
697 | ||
698 | declare | |
699 | R : constant Wide_String := S & Buffer (1 .. Last); | |
700 | begin | |
701 | if Last < Buffer'Last then | |
702 | return R; | |
703 | else | |
704 | return Get_Rest (R); | |
705 | end if; | |
706 | end; | |
707 | end Get_Rest; | |
708 | ||
709 | -- Start of processing for Get_Line | |
710 | ||
711 | begin | |
712 | Get_Line (File, Buffer, Last); | |
713 | ||
714 | if Last < Buffer'Last then | |
715 | return Buffer (1 .. Last); | |
716 | else | |
717 | return Get_Rest (Buffer (1 .. Last)); | |
718 | end if; | |
719 | end Get_Line; | |
720 | ||
721 | function Get_Line return Wide_String is | |
722 | begin | |
723 | return Get_Line (Current_In); | |
724 | end Get_Line; | |
725 | ||
d23b8f57 RK |
726 | ------------------- |
727 | -- Get_Wide_Char -- | |
728 | ------------------- | |
729 | ||
730 | function Get_Wide_Char | |
731 | (C : Character; | |
4e45e7a9 | 732 | File : File_Type) return Wide_Character |
d23b8f57 RK |
733 | is |
734 | function In_Char return Character; | |
735 | -- Function used to obtain additional characters it the wide character | |
736 | -- sequence is more than one character long. | |
737 | ||
4e45e7a9 RD |
738 | function WC_In is new Char_Sequence_To_Wide_Char (In_Char); |
739 | ||
740 | ------------- | |
741 | -- In_Char -- | |
742 | ------------- | |
743 | ||
d23b8f57 RK |
744 | function In_Char return Character is |
745 | ch : constant Integer := Getc (File); | |
d23b8f57 RK |
746 | begin |
747 | if ch = EOF then | |
748 | raise End_Error; | |
749 | else | |
750 | return Character'Val (ch); | |
751 | end if; | |
752 | end In_Char; | |
753 | ||
b917101e | 754 | -- Start of processing for Get_Wide_Char |
d23b8f57 RK |
755 | |
756 | begin | |
afc5f979 | 757 | FIO.Check_Read_Status (AP (File)); |
d23b8f57 RK |
758 | return WC_In (C, File.WC_Method); |
759 | end Get_Wide_Char; | |
760 | ||
761 | ------------------------- | |
762 | -- Get_Wide_Char_Immed -- | |
763 | ------------------------- | |
764 | ||
765 | function Get_Wide_Char_Immed | |
766 | (C : Character; | |
4e45e7a9 | 767 | File : File_Type) return Wide_Character |
d23b8f57 RK |
768 | is |
769 | function In_Char return Character; | |
770 | -- Function used to obtain additional characters it the wide character | |
771 | -- sequence is more than one character long. | |
772 | ||
4e45e7a9 RD |
773 | function WC_In is new Char_Sequence_To_Wide_Char (In_Char); |
774 | ||
775 | ------------- | |
776 | -- In_Char -- | |
777 | ------------- | |
778 | ||
d23b8f57 RK |
779 | function In_Char return Character is |
780 | ch : constant Integer := Getc_Immed (File); | |
d23b8f57 RK |
781 | begin |
782 | if ch = EOF then | |
783 | raise End_Error; | |
784 | else | |
785 | return Character'Val (ch); | |
786 | end if; | |
787 | end In_Char; | |
788 | ||
4e45e7a9 | 789 | -- Start of processing for Get_Wide_Char_Immed |
d23b8f57 RK |
790 | |
791 | begin | |
afc5f979 | 792 | FIO.Check_Read_Status (AP (File)); |
d23b8f57 RK |
793 | return WC_In (C, File.WC_Method); |
794 | end Get_Wide_Char_Immed; | |
795 | ||
796 | ---------- | |
797 | -- Getc -- | |
798 | ---------- | |
799 | ||
800 | function Getc (File : File_Type) return int is | |
801 | ch : int; | |
802 | ||
803 | begin | |
804 | ch := fgetc (File.Stream); | |
805 | ||
806 | if ch = EOF and then ferror (File.Stream) /= 0 then | |
807 | raise Device_Error; | |
808 | else | |
809 | return ch; | |
810 | end if; | |
811 | end Getc; | |
812 | ||
813 | ---------------- | |
814 | -- Getc_Immed -- | |
815 | ---------------- | |
816 | ||
4e45e7a9 | 817 | function Getc_Immed (File : File_Type) return int is |
d23b8f57 RK |
818 | ch : int; |
819 | end_of_file : int; | |
820 | ||
821 | procedure getc_immediate | |
822 | (stream : FILEs; ch : out int; end_of_file : out int); | |
823 | pragma Import (C, getc_immediate, "getc_immediate"); | |
824 | ||
825 | begin | |
826 | FIO.Check_Read_Status (AP (File)); | |
827 | ||
828 | if File.Before_LM then | |
829 | File.Before_LM := False; | |
830 | File.Before_LM_PM := False; | |
831 | ch := LM; | |
832 | ||
833 | else | |
834 | getc_immediate (File.Stream, ch, end_of_file); | |
835 | ||
836 | if ferror (File.Stream) /= 0 then | |
837 | raise Device_Error; | |
838 | elsif end_of_file /= 0 then | |
839 | return EOF; | |
840 | end if; | |
841 | end if; | |
842 | ||
843 | return ch; | |
844 | end Getc_Immed; | |
845 | ||
846 | ------------- | |
847 | -- Is_Open -- | |
848 | ------------- | |
849 | ||
4e45e7a9 | 850 | function Is_Open (File : File_Type) return Boolean is |
d23b8f57 RK |
851 | begin |
852 | return FIO.Is_Open (AP (File)); | |
853 | end Is_Open; | |
854 | ||
855 | ---------- | |
856 | -- Line -- | |
857 | ---------- | |
858 | ||
859 | -- Note: we assume that it is impossible in practice for the line | |
860 | -- to exceed the value of Count'Last, i.e. no check is required for | |
861 | -- overflow raising layout error. | |
862 | ||
4e45e7a9 | 863 | function Line (File : File_Type) return Positive_Count is |
d23b8f57 RK |
864 | begin |
865 | FIO.Check_File_Open (AP (File)); | |
866 | return File.Line; | |
867 | end Line; | |
868 | ||
869 | function Line return Positive_Count is | |
870 | begin | |
871 | return Line (Current_Out); | |
872 | end Line; | |
873 | ||
874 | ----------------- | |
875 | -- Line_Length -- | |
876 | ----------------- | |
877 | ||
4e45e7a9 | 878 | function Line_Length (File : File_Type) return Count is |
d23b8f57 RK |
879 | begin |
880 | FIO.Check_Write_Status (AP (File)); | |
881 | return File.Line_Length; | |
882 | end Line_Length; | |
883 | ||
884 | function Line_Length return Count is | |
885 | begin | |
886 | return Line_Length (Current_Out); | |
887 | end Line_Length; | |
888 | ||
889 | ---------------- | |
890 | -- Look_Ahead -- | |
891 | ---------------- | |
892 | ||
893 | procedure Look_Ahead | |
4e45e7a9 | 894 | (File : File_Type; |
d23b8f57 RK |
895 | Item : out Wide_Character; |
896 | End_Of_Line : out Boolean) | |
897 | is | |
898 | ch : int; | |
899 | ||
900 | -- Start of processing for Look_Ahead | |
901 | ||
902 | begin | |
903 | FIO.Check_Read_Status (AP (File)); | |
904 | ||
905 | -- If we are logically before a line mark, we can return immediately | |
906 | ||
907 | if File.Before_LM then | |
908 | End_Of_Line := True; | |
909 | Item := Wide_Character'Val (0); | |
910 | ||
b917101e | 911 | -- If we are before a wide character, just return it (this can happen |
d23b8f57 RK |
912 | -- if there are two calls to Look_Ahead in a row). |
913 | ||
914 | elsif File.Before_Wide_Character then | |
915 | End_Of_Line := False; | |
916 | Item := File.Saved_Wide_Character; | |
917 | ||
918 | -- otherwise we must read a character from the input stream | |
919 | ||
920 | else | |
921 | ch := Getc (File); | |
922 | ||
923 | if ch = LM | |
924 | or else ch = EOF | |
925 | or else (ch = EOF and then File.Is_Regular_File) | |
926 | then | |
927 | End_Of_Line := True; | |
928 | Ungetc (ch, File); | |
929 | Item := Wide_Character'Val (0); | |
930 | ||
b917101e RD |
931 | -- Case where character obtained does not represent the start of an |
932 | -- encoded sequence so it stands for itself and we can unget it with | |
d23b8f57 RK |
933 | -- no difficulty. |
934 | ||
b917101e RD |
935 | elsif not Is_Start_Of_Encoding |
936 | (Character'Val (ch), File.WC_Method) | |
937 | then | |
d23b8f57 RK |
938 | End_Of_Line := False; |
939 | Ungetc (ch, File); | |
940 | Item := Wide_Character'Val (ch); | |
941 | ||
b917101e RD |
942 | -- For the start of an encoding, we read the character using the |
943 | -- Get_Wide_Char routine. It will occupy more than one byte so we | |
944 | -- can't put it back with ungetc. Instead we save it in the control | |
945 | -- block, setting a flag that everyone interested in reading | |
d23b8f57 RK |
946 | -- characters must test before reading the stream. |
947 | ||
948 | else | |
949 | Item := Get_Wide_Char (Character'Val (ch), File); | |
950 | End_Of_Line := False; | |
951 | File.Saved_Wide_Character := Item; | |
952 | File.Before_Wide_Character := True; | |
953 | end if; | |
954 | end if; | |
955 | end Look_Ahead; | |
956 | ||
957 | procedure Look_Ahead | |
958 | (Item : out Wide_Character; | |
959 | End_Of_Line : out Boolean) | |
960 | is | |
961 | begin | |
962 | Look_Ahead (Current_In, Item, End_Of_Line); | |
963 | end Look_Ahead; | |
964 | ||
965 | ---------- | |
966 | -- Mode -- | |
967 | ---------- | |
968 | ||
4e45e7a9 | 969 | function Mode (File : File_Type) return File_Mode is |
d23b8f57 RK |
970 | begin |
971 | return To_TIO (FIO.Mode (AP (File))); | |
972 | end Mode; | |
973 | ||
974 | ---------- | |
975 | -- Name -- | |
976 | ---------- | |
977 | ||
4e45e7a9 | 978 | function Name (File : File_Type) return String is |
d23b8f57 RK |
979 | begin |
980 | return FIO.Name (AP (File)); | |
981 | end Name; | |
982 | ||
983 | -------------- | |
984 | -- New_Line -- | |
985 | -------------- | |
986 | ||
987 | procedure New_Line | |
4e45e7a9 RD |
988 | (File : File_Type; |
989 | Spacing : Positive_Count := 1) | |
d23b8f57 RK |
990 | is |
991 | begin | |
992 | -- Raise Constraint_Error if out of range value. The reason for this | |
993 | -- explicit test is that we don't want junk values around, even if | |
994 | -- checks are off in the caller. | |
995 | ||
405e57ad | 996 | if not Spacing'Valid then |
d23b8f57 RK |
997 | raise Constraint_Error; |
998 | end if; | |
999 | ||
1000 | FIO.Check_Write_Status (AP (File)); | |
1001 | ||
1002 | for K in 1 .. Spacing loop | |
1003 | Putc (LM, File); | |
1004 | File.Line := File.Line + 1; | |
1005 | ||
1006 | if File.Page_Length /= 0 | |
1007 | and then File.Line > File.Page_Length | |
1008 | then | |
1009 | Putc (PM, File); | |
1010 | File.Line := 1; | |
1011 | File.Page := File.Page + 1; | |
1012 | end if; | |
1013 | end loop; | |
1014 | ||
1015 | File.Col := 1; | |
1016 | end New_Line; | |
1017 | ||
4e45e7a9 | 1018 | procedure New_Line (Spacing : Positive_Count := 1) is |
d23b8f57 RK |
1019 | begin |
1020 | New_Line (Current_Out, Spacing); | |
1021 | end New_Line; | |
1022 | ||
1023 | -------------- | |
1024 | -- New_Page -- | |
1025 | -------------- | |
1026 | ||
4e45e7a9 | 1027 | procedure New_Page (File : File_Type) is |
d23b8f57 RK |
1028 | begin |
1029 | FIO.Check_Write_Status (AP (File)); | |
1030 | ||
1031 | if File.Col /= 1 or else File.Line = 1 then | |
1032 | Putc (LM, File); | |
1033 | end if; | |
1034 | ||
1035 | Putc (PM, File); | |
1036 | File.Page := File.Page + 1; | |
1037 | File.Line := 1; | |
1038 | File.Col := 1; | |
1039 | end New_Page; | |
1040 | ||
1041 | procedure New_Page is | |
1042 | begin | |
1043 | New_Page (Current_Out); | |
1044 | end New_Page; | |
1045 | ||
1046 | ----------- | |
1047 | -- Nextc -- | |
1048 | ----------- | |
1049 | ||
1050 | function Nextc (File : File_Type) return int is | |
1051 | ch : int; | |
1052 | ||
1053 | begin | |
1054 | ch := fgetc (File.Stream); | |
1055 | ||
1056 | if ch = EOF then | |
1057 | if ferror (File.Stream) /= 0 then | |
1058 | raise Device_Error; | |
1059 | end if; | |
1060 | ||
1061 | else | |
1062 | if ungetc (ch, File.Stream) = EOF then | |
1063 | raise Device_Error; | |
1064 | end if; | |
1065 | end if; | |
1066 | ||
1067 | return ch; | |
1068 | end Nextc; | |
1069 | ||
1070 | ---------- | |
1071 | -- Open -- | |
1072 | ---------- | |
1073 | ||
1074 | procedure Open | |
1075 | (File : in out File_Type; | |
4e45e7a9 RD |
1076 | Mode : File_Mode; |
1077 | Name : String; | |
1078 | Form : String := "") | |
d23b8f57 | 1079 | is |
fbf5a39b AC |
1080 | Dummy_File_Control_Block : Wide_Text_AFCB; |
1081 | pragma Warnings (Off, Dummy_File_Control_Block); | |
1082 | -- Yes, we know this is never assigned a value, only the tag | |
1083 | -- is used for dispatching purposes, so that's expected. | |
d23b8f57 RK |
1084 | |
1085 | begin | |
1086 | FIO.Open (File_Ptr => AP (File), | |
fbf5a39b | 1087 | Dummy_FCB => Dummy_File_Control_Block, |
d23b8f57 RK |
1088 | Mode => To_FCB (Mode), |
1089 | Name => Name, | |
1090 | Form => Form, | |
1091 | Amethod => 'W', | |
1092 | Creat => False, | |
1093 | Text => True); | |
afc5f979 AC |
1094 | |
1095 | File.Self := File; | |
d23b8f57 RK |
1096 | Set_WCEM (File); |
1097 | end Open; | |
1098 | ||
1099 | ---------- | |
1100 | -- Page -- | |
1101 | ---------- | |
1102 | ||
1103 | -- Note: we assume that it is impossible in practice for the page | |
1104 | -- to exceed the value of Count'Last, i.e. no check is required for | |
1105 | -- overflow raising layout error. | |
1106 | ||
4e45e7a9 | 1107 | function Page (File : File_Type) return Positive_Count is |
d23b8f57 RK |
1108 | begin |
1109 | FIO.Check_File_Open (AP (File)); | |
1110 | return File.Page; | |
1111 | end Page; | |
1112 | ||
1113 | function Page return Positive_Count is | |
1114 | begin | |
1115 | return Page (Current_Out); | |
1116 | end Page; | |
1117 | ||
1118 | ----------------- | |
1119 | -- Page_Length -- | |
1120 | ----------------- | |
1121 | ||
4e45e7a9 | 1122 | function Page_Length (File : File_Type) return Count is |
d23b8f57 RK |
1123 | begin |
1124 | FIO.Check_Write_Status (AP (File)); | |
1125 | return File.Page_Length; | |
1126 | end Page_Length; | |
1127 | ||
1128 | function Page_Length return Count is | |
1129 | begin | |
1130 | return Page_Length (Current_Out); | |
1131 | end Page_Length; | |
1132 | ||
1133 | --------- | |
1134 | -- Put -- | |
1135 | --------- | |
1136 | ||
1137 | procedure Put | |
4e45e7a9 RD |
1138 | (File : File_Type; |
1139 | Item : Wide_Character) | |
d23b8f57 RK |
1140 | is |
1141 | procedure Out_Char (C : Character); | |
1142 | -- Procedure to output one character of a wide character sequence | |
1143 | ||
4e45e7a9 | 1144 | procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char); |
d031ecc4 | 1145 | |
4e45e7a9 RD |
1146 | -------------- |
1147 | -- Out_Char -- | |
1148 | -------------- | |
1149 | ||
d23b8f57 RK |
1150 | procedure Out_Char (C : Character) is |
1151 | begin | |
1152 | Putc (Character'Pos (C), File); | |
1153 | end Out_Char; | |
1154 | ||
4e45e7a9 | 1155 | -- Start of processing for Put |
d23b8f57 RK |
1156 | |
1157 | begin | |
afc5f979 | 1158 | FIO.Check_Write_Status (AP (File)); |
d23b8f57 RK |
1159 | WC_Out (Item, File.WC_Method); |
1160 | File.Col := File.Col + 1; | |
1161 | end Put; | |
1162 | ||
4e45e7a9 | 1163 | procedure Put (Item : Wide_Character) is |
d23b8f57 RK |
1164 | begin |
1165 | Put (Current_Out, Item); | |
1166 | end Put; | |
1167 | ||
1168 | --------- | |
1169 | -- Put -- | |
1170 | --------- | |
1171 | ||
1172 | procedure Put | |
4e45e7a9 RD |
1173 | (File : File_Type; |
1174 | Item : Wide_String) | |
d23b8f57 RK |
1175 | is |
1176 | begin | |
1177 | for J in Item'Range loop | |
1178 | Put (File, Item (J)); | |
1179 | end loop; | |
1180 | end Put; | |
1181 | ||
4e45e7a9 | 1182 | procedure Put (Item : Wide_String) is |
d23b8f57 RK |
1183 | begin |
1184 | Put (Current_Out, Item); | |
1185 | end Put; | |
1186 | ||
1187 | -------------- | |
1188 | -- Put_Line -- | |
1189 | -------------- | |
1190 | ||
1191 | procedure Put_Line | |
4e45e7a9 RD |
1192 | (File : File_Type; |
1193 | Item : Wide_String) | |
d23b8f57 RK |
1194 | is |
1195 | begin | |
1196 | Put (File, Item); | |
1197 | New_Line (File); | |
1198 | end Put_Line; | |
1199 | ||
4e45e7a9 | 1200 | procedure Put_Line (Item : Wide_String) is |
d23b8f57 RK |
1201 | begin |
1202 | Put (Current_Out, Item); | |
1203 | New_Line (Current_Out); | |
1204 | end Put_Line; | |
1205 | ||
1206 | ---------- | |
1207 | -- Putc -- | |
1208 | ---------- | |
1209 | ||
1210 | procedure Putc (ch : int; File : File_Type) is | |
1211 | begin | |
1212 | if fputc (ch, File.Stream) = EOF then | |
1213 | raise Device_Error; | |
1214 | end if; | |
1215 | end Putc; | |
1216 | ||
1217 | ---------- | |
1218 | -- Read -- | |
1219 | ---------- | |
1220 | ||
1221 | -- This is the primitive Stream Read routine, used when a Text_IO file | |
1222 | -- is treated directly as a stream using Text_IO.Streams.Stream. | |
1223 | ||
1224 | procedure Read | |
1225 | (File : in out Wide_Text_AFCB; | |
1226 | Item : out Stream_Element_Array; | |
1227 | Last : out Stream_Element_Offset) | |
1228 | is | |
fbf5a39b AC |
1229 | Discard_ch : int; |
1230 | pragma Unreferenced (Discard_ch); | |
d23b8f57 RK |
1231 | |
1232 | begin | |
1233 | -- Need to deal with Before_Wide_Character ??? | |
1234 | ||
1235 | if File.Mode /= FCB.In_File then | |
1236 | raise Mode_Error; | |
1237 | end if; | |
1238 | ||
1239 | -- Deal with case where our logical and physical position do not match | |
1240 | -- because of being after an LM or LM-PM sequence when in fact we are | |
1241 | -- logically positioned before it. | |
1242 | ||
1243 | if File.Before_LM then | |
1244 | ||
1245 | -- If we are before a PM, then it is possible for a stream read | |
1246 | -- to leave us after the LM and before the PM, which is a bit | |
1247 | -- odd. The easiest way to deal with this is to unget the PM, | |
1248 | -- so we are indeed positioned between the characters. This way | |
1249 | -- further stream read operations will work correctly, and the | |
1250 | -- effect on text processing is a little weird, but what can | |
1251 | -- be expected if stream and text input are mixed this way? | |
1252 | ||
1253 | if File.Before_LM_PM then | |
fbf5a39b | 1254 | Discard_ch := ungetc (PM, File.Stream); |
d23b8f57 RK |
1255 | File.Before_LM_PM := False; |
1256 | end if; | |
1257 | ||
1258 | File.Before_LM := False; | |
1259 | ||
1260 | Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF)); | |
1261 | ||
1262 | if Item'Length = 1 then | |
1263 | Last := Item'Last; | |
1264 | ||
1265 | else | |
1266 | Last := | |
1267 | Item'First + | |
1268 | Stream_Element_Offset | |
1269 | (fread (buffer => Item'Address, | |
1270 | index => size_t (Item'First + 1), | |
1271 | size => 1, | |
1272 | count => Item'Length - 1, | |
1273 | stream => File.Stream)); | |
1274 | end if; | |
1275 | ||
1276 | return; | |
1277 | end if; | |
1278 | ||
1279 | -- Now we do the read. Since this is a text file, it is normally in | |
1280 | -- text mode, but stream data must be read in binary mode, so we | |
1281 | -- temporarily set binary mode for the read, resetting it after. | |
1282 | -- These calls have no effect in a system (like Unix) where there is | |
1283 | -- no distinction between text and binary files. | |
1284 | ||
1285 | set_binary_mode (fileno (File.Stream)); | |
1286 | ||
1287 | Last := | |
1288 | Item'First + | |
1289 | Stream_Element_Offset | |
1290 | (fread (Item'Address, 1, Item'Length, File.Stream)) - 1; | |
1291 | ||
1292 | if Last < Item'Last then | |
1293 | if ferror (File.Stream) /= 0 then | |
1294 | raise Device_Error; | |
1295 | end if; | |
1296 | end if; | |
1297 | ||
1298 | set_text_mode (fileno (File.Stream)); | |
1299 | end Read; | |
1300 | ||
1301 | ----------- | |
1302 | -- Reset -- | |
1303 | ----------- | |
1304 | ||
1305 | procedure Reset | |
1306 | (File : in out File_Type; | |
4e45e7a9 | 1307 | Mode : File_Mode) |
d23b8f57 RK |
1308 | is |
1309 | begin | |
1310 | -- Don't allow change of mode for current file (RM A.10.2(5)) | |
1311 | ||
1312 | if (File = Current_In or else | |
1313 | File = Current_Out or else | |
1314 | File = Current_Error) | |
1315 | and then To_FCB (Mode) /= File.Mode | |
1316 | then | |
1317 | raise Mode_Error; | |
1318 | end if; | |
1319 | ||
1320 | Terminate_Line (File); | |
100a5d66 | 1321 | FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); |
d23b8f57 RK |
1322 | File.Page := 1; |
1323 | File.Line := 1; | |
1324 | File.Col := 1; | |
1325 | File.Line_Length := 0; | |
1326 | File.Page_Length := 0; | |
1327 | File.Before_LM := False; | |
1328 | File.Before_LM_PM := False; | |
1329 | end Reset; | |
1330 | ||
1331 | procedure Reset (File : in out File_Type) is | |
1332 | begin | |
1333 | Terminate_Line (File); | |
100a5d66 | 1334 | FIO.Reset (AP (File)'Unrestricted_Access); |
d23b8f57 RK |
1335 | File.Page := 1; |
1336 | File.Line := 1; | |
1337 | File.Col := 1; | |
1338 | File.Line_Length := 0; | |
1339 | File.Page_Length := 0; | |
1340 | File.Before_LM := False; | |
1341 | File.Before_LM_PM := False; | |
1342 | end Reset; | |
1343 | ||
1344 | ------------- | |
1345 | -- Set_Col -- | |
1346 | ------------- | |
1347 | ||
1348 | procedure Set_Col | |
4e45e7a9 RD |
1349 | (File : File_Type; |
1350 | To : Positive_Count) | |
d23b8f57 RK |
1351 | is |
1352 | ch : int; | |
1353 | ||
1354 | begin | |
1355 | -- Raise Constraint_Error if out of range value. The reason for this | |
1356 | -- explicit test is that we don't want junk values around, even if | |
1357 | -- checks are off in the caller. | |
1358 | ||
405e57ad | 1359 | if not To'Valid then |
d23b8f57 RK |
1360 | raise Constraint_Error; |
1361 | end if; | |
1362 | ||
1363 | FIO.Check_File_Open (AP (File)); | |
1364 | ||
1365 | if To = File.Col then | |
1366 | return; | |
1367 | end if; | |
1368 | ||
1369 | if Mode (File) >= Out_File then | |
1370 | if File.Line_Length /= 0 and then To > File.Line_Length then | |
1371 | raise Layout_Error; | |
1372 | end if; | |
1373 | ||
1374 | if To < File.Col then | |
1375 | New_Line (File); | |
1376 | end if; | |
1377 | ||
1378 | while File.Col < To loop | |
1379 | Put (File, ' '); | |
1380 | end loop; | |
1381 | ||
1382 | else | |
1383 | loop | |
1384 | ch := Getc (File); | |
1385 | ||
1386 | if ch = EOF then | |
1387 | raise End_Error; | |
1388 | ||
1389 | elsif ch = LM then | |
1390 | File.Line := File.Line + 1; | |
1391 | File.Col := 1; | |
1392 | ||
1393 | elsif ch = PM and then File.Is_Regular_File then | |
1394 | File.Page := File.Page + 1; | |
1395 | File.Line := 1; | |
1396 | File.Col := 1; | |
1397 | ||
1398 | elsif To = File.Col then | |
1399 | Ungetc (ch, File); | |
1400 | return; | |
1401 | ||
1402 | else | |
1403 | File.Col := File.Col + 1; | |
1404 | end if; | |
1405 | end loop; | |
1406 | end if; | |
1407 | end Set_Col; | |
1408 | ||
4e45e7a9 | 1409 | procedure Set_Col (To : Positive_Count) is |
d23b8f57 RK |
1410 | begin |
1411 | Set_Col (Current_Out, To); | |
1412 | end Set_Col; | |
1413 | ||
1414 | --------------- | |
1415 | -- Set_Error -- | |
1416 | --------------- | |
1417 | ||
4e45e7a9 | 1418 | procedure Set_Error (File : File_Type) is |
d23b8f57 RK |
1419 | begin |
1420 | FIO.Check_Write_Status (AP (File)); | |
1421 | Current_Err := File; | |
1422 | end Set_Error; | |
1423 | ||
1424 | --------------- | |
1425 | -- Set_Input -- | |
1426 | --------------- | |
1427 | ||
4e45e7a9 | 1428 | procedure Set_Input (File : File_Type) is |
d23b8f57 RK |
1429 | begin |
1430 | FIO.Check_Read_Status (AP (File)); | |
1431 | Current_In := File; | |
1432 | end Set_Input; | |
1433 | ||
1434 | -------------- | |
1435 | -- Set_Line -- | |
1436 | -------------- | |
1437 | ||
1438 | procedure Set_Line | |
4e45e7a9 RD |
1439 | (File : File_Type; |
1440 | To : Positive_Count) | |
d23b8f57 RK |
1441 | is |
1442 | begin | |
1443 | -- Raise Constraint_Error if out of range value. The reason for this | |
1444 | -- explicit test is that we don't want junk values around, even if | |
1445 | -- checks are off in the caller. | |
1446 | ||
405e57ad | 1447 | if not To'Valid then |
d23b8f57 RK |
1448 | raise Constraint_Error; |
1449 | end if; | |
1450 | ||
1451 | FIO.Check_File_Open (AP (File)); | |
1452 | ||
1453 | if To = File.Line then | |
1454 | return; | |
1455 | end if; | |
1456 | ||
1457 | if Mode (File) >= Out_File then | |
1458 | if File.Page_Length /= 0 and then To > File.Page_Length then | |
1459 | raise Layout_Error; | |
1460 | end if; | |
1461 | ||
1462 | if To < File.Line then | |
1463 | New_Page (File); | |
1464 | end if; | |
1465 | ||
1466 | while File.Line < To loop | |
1467 | New_Line (File); | |
1468 | end loop; | |
1469 | ||
1470 | else | |
1471 | while To /= File.Line loop | |
1472 | Skip_Line (File); | |
1473 | end loop; | |
1474 | end if; | |
1475 | end Set_Line; | |
1476 | ||
4e45e7a9 | 1477 | procedure Set_Line (To : Positive_Count) is |
d23b8f57 RK |
1478 | begin |
1479 | Set_Line (Current_Out, To); | |
1480 | end Set_Line; | |
1481 | ||
1482 | --------------------- | |
1483 | -- Set_Line_Length -- | |
1484 | --------------------- | |
1485 | ||
4e45e7a9 | 1486 | procedure Set_Line_Length (File : File_Type; To : Count) is |
d23b8f57 RK |
1487 | begin |
1488 | -- Raise Constraint_Error if out of range value. The reason for this | |
1489 | -- explicit test is that we don't want junk values around, even if | |
1490 | -- checks are off in the caller. | |
1491 | ||
405e57ad | 1492 | if not To'Valid then |
d23b8f57 RK |
1493 | raise Constraint_Error; |
1494 | end if; | |
1495 | ||
1496 | FIO.Check_Write_Status (AP (File)); | |
1497 | File.Line_Length := To; | |
1498 | end Set_Line_Length; | |
1499 | ||
4e45e7a9 | 1500 | procedure Set_Line_Length (To : Count) is |
d23b8f57 RK |
1501 | begin |
1502 | Set_Line_Length (Current_Out, To); | |
1503 | end Set_Line_Length; | |
1504 | ||
1505 | ---------------- | |
1506 | -- Set_Output -- | |
1507 | ---------------- | |
1508 | ||
4e45e7a9 | 1509 | procedure Set_Output (File : File_Type) is |
d23b8f57 RK |
1510 | begin |
1511 | FIO.Check_Write_Status (AP (File)); | |
1512 | Current_Out := File; | |
1513 | end Set_Output; | |
1514 | ||
1515 | --------------------- | |
1516 | -- Set_Page_Length -- | |
1517 | --------------------- | |
1518 | ||
4e45e7a9 | 1519 | procedure Set_Page_Length (File : File_Type; To : Count) is |
d23b8f57 RK |
1520 | begin |
1521 | -- Raise Constraint_Error if out of range value. The reason for this | |
1522 | -- explicit test is that we don't want junk values around, even if | |
1523 | -- checks are off in the caller. | |
1524 | ||
405e57ad | 1525 | if not To'Valid then |
d23b8f57 RK |
1526 | raise Constraint_Error; |
1527 | end if; | |
1528 | ||
1529 | FIO.Check_Write_Status (AP (File)); | |
1530 | File.Page_Length := To; | |
1531 | end Set_Page_Length; | |
1532 | ||
4e45e7a9 | 1533 | procedure Set_Page_Length (To : Count) is |
d23b8f57 RK |
1534 | begin |
1535 | Set_Page_Length (Current_Out, To); | |
1536 | end Set_Page_Length; | |
1537 | ||
1538 | -------------- | |
1539 | -- Set_WCEM -- | |
1540 | -------------- | |
1541 | ||
1542 | procedure Set_WCEM (File : in out File_Type) is | |
1543 | Start : Natural; | |
1544 | Stop : Natural; | |
1545 | ||
1546 | begin | |
1547 | File.WC_Method := WCEM_Brackets; | |
1548 | FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop); | |
1549 | ||
1550 | if Start = 0 then | |
1551 | File.WC_Method := WCEM_Brackets; | |
1552 | ||
830f9af8 | 1553 | else |
d23b8f57 RK |
1554 | if Stop = Start then |
1555 | for J in WC_Encoding_Letters'Range loop | |
1556 | if File.Form (Start) = WC_Encoding_Letters (J) then | |
1557 | File.WC_Method := J; | |
1558 | return; | |
1559 | end if; | |
1560 | end loop; | |
1561 | end if; | |
1562 | ||
1563 | Close (File); | |
b917101e | 1564 | raise Use_Error with "invalid WCEM form parameter"; |
d23b8f57 RK |
1565 | end if; |
1566 | end Set_WCEM; | |
1567 | ||
1568 | --------------- | |
1569 | -- Skip_Line -- | |
1570 | --------------- | |
1571 | ||
1572 | procedure Skip_Line | |
4e45e7a9 RD |
1573 | (File : File_Type; |
1574 | Spacing : Positive_Count := 1) | |
d23b8f57 RK |
1575 | is |
1576 | ch : int; | |
1577 | ||
1578 | begin | |
1579 | -- Raise Constraint_Error if out of range value. The reason for this | |
1580 | -- explicit test is that we don't want junk values around, even if | |
1581 | -- checks are off in the caller. | |
1582 | ||
405e57ad | 1583 | if not Spacing'Valid then |
d23b8f57 RK |
1584 | raise Constraint_Error; |
1585 | end if; | |
1586 | ||
1587 | FIO.Check_Read_Status (AP (File)); | |
1588 | ||
1589 | for L in 1 .. Spacing loop | |
1590 | if File.Before_LM then | |
1591 | File.Before_LM := False; | |
1592 | File.Before_LM_PM := False; | |
1593 | ||
1594 | else | |
1595 | ch := Getc (File); | |
1596 | ||
1597 | -- If at end of file now, then immediately raise End_Error. Note | |
1598 | -- that we can never be positioned between a line mark and a page | |
1599 | -- mark, so if we are at the end of file, we cannot logically be | |
1600 | -- before the implicit page mark that is at the end of the file. | |
1601 | ||
1602 | -- For the same reason, we do not need an explicit check for a | |
1603 | -- page mark. If there is a FF in the middle of a line, the file | |
1604 | -- is not in canonical format and we do not care about the page | |
1605 | -- numbers for files other than ones in canonical format. | |
1606 | ||
1607 | if ch = EOF then | |
1608 | raise End_Error; | |
1609 | end if; | |
1610 | ||
1611 | -- If not at end of file, then loop till we get to an LM or EOF. | |
1612 | -- The latter case happens only in non-canonical files where the | |
1613 | -- last line is not terminated by LM, but we don't want to blow | |
1614 | -- up for such files, so we assume an implicit LM in this case. | |
1615 | ||
1616 | loop | |
1617 | exit when ch = LM or ch = EOF; | |
1618 | ch := Getc (File); | |
1619 | end loop; | |
1620 | end if; | |
1621 | ||
1622 | -- We have got past a line mark, now, for a regular file only, | |
1623 | -- see if a page mark immediately follows this line mark and | |
1624 | -- if so, skip past the page mark as well. We do not do this | |
1625 | -- for non-regular files, since it would cause an undesirable | |
1626 | -- wait for an additional character. | |
1627 | ||
1628 | File.Col := 1; | |
1629 | File.Line := File.Line + 1; | |
1630 | ||
1631 | if File.Before_LM_PM then | |
1632 | File.Page := File.Page + 1; | |
1633 | File.Line := 1; | |
1634 | File.Before_LM_PM := False; | |
1635 | ||
1636 | elsif File.Is_Regular_File then | |
1637 | ch := Getc (File); | |
1638 | ||
1639 | -- Page mark can be explicit, or implied at the end of the file | |
1640 | ||
1641 | if (ch = PM or else ch = EOF) | |
1642 | and then File.Is_Regular_File | |
1643 | then | |
1644 | File.Page := File.Page + 1; | |
1645 | File.Line := 1; | |
1646 | else | |
1647 | Ungetc (ch, File); | |
1648 | end if; | |
1649 | end if; | |
d23b8f57 RK |
1650 | end loop; |
1651 | ||
1652 | File.Before_Wide_Character := False; | |
1653 | end Skip_Line; | |
1654 | ||
4e45e7a9 | 1655 | procedure Skip_Line (Spacing : Positive_Count := 1) is |
d23b8f57 RK |
1656 | begin |
1657 | Skip_Line (Current_In, Spacing); | |
1658 | end Skip_Line; | |
1659 | ||
1660 | --------------- | |
1661 | -- Skip_Page -- | |
1662 | --------------- | |
1663 | ||
4e45e7a9 | 1664 | procedure Skip_Page (File : File_Type) is |
d23b8f57 RK |
1665 | ch : int; |
1666 | ||
1667 | begin | |
1668 | FIO.Check_Read_Status (AP (File)); | |
1669 | ||
1670 | -- If at page mark already, just skip it | |
1671 | ||
1672 | if File.Before_LM_PM then | |
1673 | File.Before_LM := False; | |
1674 | File.Before_LM_PM := False; | |
1675 | File.Page := File.Page + 1; | |
1676 | File.Line := 1; | |
1677 | File.Col := 1; | |
1678 | return; | |
1679 | end if; | |
1680 | ||
1681 | -- This is a bit tricky, if we are logically before an LM then | |
1682 | -- it is not an error if we are at an end of file now, since we | |
1683 | -- are not really at it. | |
1684 | ||
1685 | if File.Before_LM then | |
1686 | File.Before_LM := False; | |
1687 | File.Before_LM_PM := False; | |
1688 | ch := Getc (File); | |
1689 | ||
1690 | -- Otherwise we do raise End_Error if we are at the end of file now | |
1691 | ||
1692 | else | |
1693 | ch := Getc (File); | |
1694 | ||
1695 | if ch = EOF then | |
1696 | raise End_Error; | |
1697 | end if; | |
1698 | end if; | |
1699 | ||
1700 | -- Now we can just rumble along to the next page mark, or to the | |
1701 | -- end of file, if that comes first. The latter case happens when | |
1702 | -- the page mark is implied at the end of file. | |
1703 | ||
1704 | loop | |
1705 | exit when ch = EOF | |
1706 | or else (ch = PM and then File.Is_Regular_File); | |
1707 | ch := Getc (File); | |
1708 | end loop; | |
1709 | ||
1710 | File.Page := File.Page + 1; | |
1711 | File.Line := 1; | |
1712 | File.Col := 1; | |
1713 | File.Before_Wide_Character := False; | |
1714 | end Skip_Page; | |
1715 | ||
1716 | procedure Skip_Page is | |
1717 | begin | |
1718 | Skip_Page (Current_In); | |
1719 | end Skip_Page; | |
1720 | ||
1721 | -------------------- | |
1722 | -- Standard_Error -- | |
1723 | -------------------- | |
1724 | ||
1725 | function Standard_Error return File_Type is | |
1726 | begin | |
1727 | return Standard_Err; | |
1728 | end Standard_Error; | |
1729 | ||
1730 | function Standard_Error return File_Access is | |
1731 | begin | |
1732 | return Standard_Err'Access; | |
1733 | end Standard_Error; | |
1734 | ||
1735 | -------------------- | |
1736 | -- Standard_Input -- | |
1737 | -------------------- | |
1738 | ||
1739 | function Standard_Input return File_Type is | |
1740 | begin | |
1741 | return Standard_In; | |
1742 | end Standard_Input; | |
1743 | ||
1744 | function Standard_Input return File_Access is | |
1745 | begin | |
1746 | return Standard_In'Access; | |
1747 | end Standard_Input; | |
1748 | ||
1749 | --------------------- | |
1750 | -- Standard_Output -- | |
1751 | --------------------- | |
1752 | ||
1753 | function Standard_Output return File_Type is | |
1754 | begin | |
1755 | return Standard_Out; | |
1756 | end Standard_Output; | |
1757 | ||
1758 | function Standard_Output return File_Access is | |
1759 | begin | |
1760 | return Standard_Out'Access; | |
1761 | end Standard_Output; | |
1762 | ||
1763 | -------------------- | |
1764 | -- Terminate_Line -- | |
1765 | -------------------- | |
1766 | ||
1767 | procedure Terminate_Line (File : File_Type) is | |
1768 | begin | |
1769 | FIO.Check_File_Open (AP (File)); | |
1770 | ||
1771 | -- For file other than In_File, test for needing to terminate last line | |
1772 | ||
1773 | if Mode (File) /= In_File then | |
1774 | ||
1775 | -- If not at start of line definition need new line | |
1776 | ||
1777 | if File.Col /= 1 then | |
1778 | New_Line (File); | |
1779 | ||
1780 | -- For files other than standard error and standard output, we | |
1781 | -- make sure that an empty file has a single line feed, so that | |
1782 | -- it is properly formatted. We avoid this for the standard files | |
1783 | -- because it is too much of a nuisance to have these odd line | |
1784 | -- feeds when nothing has been written to the file. | |
1785 | ||
1786 | elsif (File /= Standard_Err and then File /= Standard_Out) | |
1787 | and then (File.Line = 1 and then File.Page = 1) | |
1788 | then | |
1789 | New_Line (File); | |
1790 | end if; | |
1791 | end if; | |
1792 | end Terminate_Line; | |
1793 | ||
1794 | ------------ | |
1795 | -- Ungetc -- | |
1796 | ------------ | |
1797 | ||
1798 | procedure Ungetc (ch : int; File : File_Type) is | |
1799 | begin | |
1800 | if ch /= EOF then | |
1801 | if ungetc (ch, File.Stream) = EOF then | |
1802 | raise Device_Error; | |
1803 | end if; | |
1804 | end if; | |
1805 | end Ungetc; | |
1806 | ||
1807 | ----------- | |
1808 | -- Write -- | |
1809 | ----------- | |
1810 | ||
1811 | -- This is the primitive Stream Write routine, used when a Text_IO file | |
1812 | -- is treated directly as a stream using Text_IO.Streams.Stream. | |
1813 | ||
1814 | procedure Write | |
1815 | (File : in out Wide_Text_AFCB; | |
4e45e7a9 | 1816 | Item : Stream_Element_Array) |
d23b8f57 | 1817 | is |
b11e8d6f RD |
1818 | pragma Warnings (Off, File); |
1819 | -- Because in this implementation we don't need IN OUT, we only read | |
1820 | ||
d23b8f57 RK |
1821 | Siz : constant size_t := Item'Length; |
1822 | ||
1823 | begin | |
1824 | if File.Mode = FCB.In_File then | |
1825 | raise Mode_Error; | |
1826 | end if; | |
1827 | ||
1828 | -- Now we do the write. Since this is a text file, it is normally in | |
1829 | -- text mode, but stream data must be written in binary mode, so we | |
1830 | -- temporarily set binary mode for the write, resetting it after. | |
1831 | -- These calls have no effect in a system (like Unix) where there is | |
1832 | -- no distinction between text and binary files. | |
1833 | ||
1834 | set_binary_mode (fileno (File.Stream)); | |
1835 | ||
1836 | if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then | |
1837 | raise Device_Error; | |
1838 | end if; | |
1839 | ||
1840 | set_text_mode (fileno (File.Stream)); | |
1841 | end Write; | |
1842 | ||
1843 | -- Use "preallocated" strings to avoid calling "new" during the | |
1844 | -- elaboration of the run time. This is needed in the tasking case to | |
1845 | -- avoid calling Task_Lock too early. A filename is expected to end with | |
1846 | -- a null character in the runtime, here the null characters are added | |
1847 | -- just to have a correct filename length. | |
1848 | ||
43c6e0cb TQ |
1849 | Err_Name : aliased String := "*stderr" & ASCII.NUL; |
1850 | In_Name : aliased String := "*stdin" & ASCII.NUL; | |
1851 | Out_Name : aliased String := "*stdout" & ASCII.NUL; | |
d23b8f57 RK |
1852 | |
1853 | begin | |
1854 | ------------------------------- | |
1855 | -- Initialize Standard Files -- | |
1856 | ------------------------------- | |
1857 | ||
1858 | for J in WC_Encoding_Method loop | |
1859 | if WC_Encoding = WC_Encoding_Letters (J) then | |
1860 | Default_WCEM := J; | |
1861 | end if; | |
1862 | end loop; | |
1863 | ||
1864 | -- Note: the names in these files are bogus, and probably it would be | |
1865 | -- better for these files to have no names, but the ACVC test insist! | |
1866 | -- We use names that are bound to fail in open etc. | |
1867 | ||
1868 | Standard_Err.Stream := stderr; | |
1869 | Standard_Err.Name := Err_Name'Access; | |
1870 | Standard_Err.Form := Null_Str'Unrestricted_Access; | |
1871 | Standard_Err.Mode := FCB.Out_File; | |
1872 | Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; | |
1873 | Standard_Err.Is_Temporary_File := False; | |
1874 | Standard_Err.Is_System_File := True; | |
1875 | Standard_Err.Is_Text_File := True; | |
1876 | Standard_Err.Access_Method := 'T'; | |
afc5f979 | 1877 | Standard_Err.Self := Standard_Err; |
d23b8f57 RK |
1878 | Standard_Err.WC_Method := Default_WCEM; |
1879 | ||
afc5f979 AC |
1880 | Standard_In.Stream := stdin; |
1881 | Standard_In.Name := In_Name'Access; | |
1882 | Standard_In.Form := Null_Str'Unrestricted_Access; | |
1883 | Standard_In.Mode := FCB.In_File; | |
1884 | Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; | |
1885 | Standard_In.Is_Temporary_File := False; | |
1886 | Standard_In.Is_System_File := True; | |
1887 | Standard_In.Is_Text_File := True; | |
1888 | Standard_In.Access_Method := 'T'; | |
1889 | Standard_In.Self := Standard_In; | |
1890 | Standard_In.WC_Method := Default_WCEM; | |
d23b8f57 RK |
1891 | |
1892 | Standard_Out.Stream := stdout; | |
1893 | Standard_Out.Name := Out_Name'Access; | |
1894 | Standard_Out.Form := Null_Str'Unrestricted_Access; | |
1895 | Standard_Out.Mode := FCB.Out_File; | |
1896 | Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; | |
1897 | Standard_Out.Is_Temporary_File := False; | |
1898 | Standard_Out.Is_System_File := True; | |
1899 | Standard_Out.Is_Text_File := True; | |
1900 | Standard_Out.Access_Method := 'T'; | |
afc5f979 | 1901 | Standard_Out.Self := Standard_Out; |
d23b8f57 RK |
1902 | Standard_Out.WC_Method := Default_WCEM; |
1903 | ||
1904 | FIO.Chain_File (AP (Standard_In)); | |
1905 | FIO.Chain_File (AP (Standard_Out)); | |
1906 | FIO.Chain_File (AP (Standard_Err)); | |
1907 | ||
1908 | FIO.Make_Unbuffered (AP (Standard_Out)); | |
1909 | FIO.Make_Unbuffered (AP (Standard_Err)); | |
1910 | ||
1911 | end Ada.Wide_Text_IO; |