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