GCC v8.2
[gcc.git] / gcc / ada / libgnat / a-ztexio.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                         GNAT RUN-TIME COMPONENTS                         --
4 --                                                                          --
5 --                A D A . W I D E _ W I D E _ T E X T _ I O                 --
6 --                                                                          --
7 --                                 B o d y                                  --
8 --                                                                          --
9 --          Copyright (C) 1992-2018, Free Software Foundation, Inc.         --
10 --                                                                          --
11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
12 -- terms of the  GNU General Public License as published  by the Free Soft- --
13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17 --                                                                          --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception,   --
20 -- version 3.1, as published by the Free Software Foundation.               --
21 --                                                                          --
22 -- You should have received a copy of the GNU General Public License and    --
23 -- a copy of the GCC Runtime Library Exception along with this program;     --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25 -- <http://www.gnu.org/licenses/>.                                          --
26 --                                                                          --
27 -- GNAT was originally developed  by the GNAT team at  New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
29 --                                                                          --
30 ------------------------------------------------------------------------------
31
32 with 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_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_Wide_Char_Immed
85      (C    : Character;
86       File : File_Type) return Wide_Wide_Character;
87    --  This routine is identical to Get_Wide_Wide_Char, except that the reads
88    --  are 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_Wide_Text_AFCB) return FCB.AFCB_Ptr
122    is
123       pragma Unreferenced (Control_Block);
124    begin
125       return new Wide_Wide_Text_AFCB;
126    end AFCB_Allocate;
127
128    ----------------
129    -- AFCB_Close --
130    ----------------
131
132    procedure AFCB_Close (File : not null access Wide_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_Wide_Text_AFCB) is
155       type FCB_Ptr is access all Wide_Wide_Text_AFCB;
156       FT : FCB_Ptr := FCB_Ptr (File);
157
158       procedure Free is new
159         Ada.Unchecked_Deallocation (Wide_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_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_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_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_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_Wide_Character)
447    is
448       C  : Character;
449
450    begin
451       FIO.Check_Read_Status (AP (File));
452
453       if File.Before_Wide_Wide_Character then
454          File.Before_Wide_Wide_Character := False;
455          Item := File.Saved_Wide_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_Wide_Char (C, File);
462       end if;
463    end Get;
464
465    procedure Get (Item : out Wide_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_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_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_Wide_Character)
540    is
541       ch : int;
542
543    begin
544       FIO.Check_Read_Status (AP (File));
545
546       if File.Before_Wide_Wide_Character then
547          File.Before_Wide_Wide_Character := False;
548          Item := File.Saved_Wide_Wide_Character;
549
550       elsif File.Before_LM then
551          File.Before_LM := False;
552          File.Before_LM_PM := False;
553          Item := Wide_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_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_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_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_Wide_Character then
585          File.Before_Wide_Wide_Character := False;
586          Item := File.Saved_Wide_Wide_Character;
587
588       elsif File.Before_LM then
589          File.Before_LM := False;
590          File.Before_LM_PM := False;
591          Item := Wide_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_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_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_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,
667             --  but this is not an official page mark in any case, since
668             --  official page marks can only follow a line mark. The whole
669             --  page business is pretty much nonsense anyway, so we do not
670             --  want to waste time trying to make sense out of non-standard
671             --  page marks in the file. This means that the behavior of
672             --  Get_Line is different from repeated Get of a character, but
673             --  that's too bad. We only promise that page numbers etc make
674             --  sense if the file 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_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_Wide_String is
711       Buffer : Wide_Wide_String (1 .. 500);
712       Last   : Natural;
713
714       function Get_Rest (S : Wide_Wide_String) return Wide_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_Wide_String) return Wide_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_Wide_String (1 .. S'Length);
729          Last   : Natural;
730
731       begin
732          Get_Line (File, Buffer, Last);
733
734          declare
735             R : constant Wide_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_Wide_String is
758    begin
759       return Get_Line (Current_In);
760    end Get_Line;
761
762    ------------------------
763    -- Get_Wide_Wide_Char --
764    ------------------------
765
766    function Get_Wide_Wide_Char
767      (C    : Character;
768       File : File_Type) return Wide_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_UTF_32 (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_Wide_Char
791
792    begin
793       FIO.Check_Read_Status (AP (File));
794       return Wide_Wide_Character'Val (WC_In (C, File.WC_Method));
795    end Get_Wide_Wide_Char;
796
797    ------------------------------
798    -- Get_Wide_Wide_Char_Immed --
799    ------------------------------
800
801    function Get_Wide_Wide_Char_Immed
802      (C    : Character;
803       File : File_Type) return Wide_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_UTF_32 (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_Wide_Char_Immed
826
827    begin
828       FIO.Check_Read_Status (AP (File));
829       return Wide_Wide_Character'Val (WC_In (C, File.WC_Method));
830    end Get_Wide_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
942    --  to exceed the value of Count'Last, i.e. no check is required for
943    --  overflow raising 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_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_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_Wide_Character then
997          End_Of_Line := False;
998          Item := File.Saved_Wide_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_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_Wide_Character'Val (ch);
1023
1024          --  For the start of an encoding, we read the character using the
1025          --  Get_Wide_Wide_Char routine. It will occupy more than one byte so
1026          --  we can't put it back with ungetc. Instead we save it in the
1027          --  control block, setting a flag that everyone interested in reading
1028          --  characters must test before reading the stream.
1029
1030          else
1031             Item := Get_Wide_Wide_Char (Character'Val (ch), File);
1032             End_Of_Line := False;
1033             File.Saved_Wide_Wide_Character := Item;
1034             File.Before_Wide_Wide_Character := True;
1035          end if;
1036       end if;
1037    end Look_Ahead;
1038
1039    procedure Look_Ahead
1040      (Item        : out Wide_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          Putc (LM, File);
1086          File.Line := File.Line + 1;
1087
1088          if File.Page_Length /= 0
1089            and then File.Line > File.Page_Length
1090          then
1091             Putc (PM, File);
1092             File.Line := 1;
1093             File.Page := File.Page + 1;
1094          end if;
1095       end loop;
1096
1097       File.Col := 1;
1098    end New_Line;
1099
1100    procedure New_Line (Spacing : Positive_Count := 1) is
1101    begin
1102       New_Line (Current_Out, Spacing);
1103    end New_Line;
1104
1105    --------------
1106    -- New_Page --
1107    --------------
1108
1109    procedure New_Page (File : File_Type) is
1110    begin
1111       FIO.Check_Write_Status (AP (File));
1112
1113       if File.Col /= 1 or else File.Line = 1 then
1114          Putc (LM, File);
1115       end if;
1116
1117       Putc (PM, File);
1118       File.Page := File.Page + 1;
1119       File.Line := 1;
1120       File.Col := 1;
1121    end New_Page;
1122
1123    procedure New_Page is
1124    begin
1125       New_Page (Current_Out);
1126    end New_Page;
1127
1128    -----------
1129    -- Nextc --
1130    -----------
1131
1132    function Nextc (File : File_Type) return int is
1133       ch : int;
1134
1135    begin
1136       ch := fgetc (File.Stream);
1137
1138       if ch = EOF then
1139          if ferror (File.Stream) /= 0 then
1140             raise Device_Error;
1141          end if;
1142
1143       else
1144          if ungetc (ch, File.Stream) = EOF then
1145             raise Device_Error;
1146          end if;
1147       end if;
1148
1149       return ch;
1150    end Nextc;
1151
1152    ----------
1153    -- Open --
1154    ----------
1155
1156    procedure Open
1157      (File : in out File_Type;
1158       Mode : File_Mode;
1159       Name : String;
1160       Form : String := "")
1161    is
1162       Dummy_File_Control_Block : Wide_Wide_Text_AFCB;
1163       pragma Warnings (Off, Dummy_File_Control_Block);
1164       --  Yes, we know this is never assigned a value, only the tag
1165       --  is used for dispatching purposes, so that's expected.
1166
1167    begin
1168       FIO.Open (File_Ptr  => AP (File),
1169                 Dummy_FCB => Dummy_File_Control_Block,
1170                 Mode      => To_FCB (Mode),
1171                 Name      => Name,
1172                 Form      => Form,
1173                 Amethod   => 'W',
1174                 Creat     => False,
1175                 Text      => True);
1176
1177       File.Self := File;
1178       Set_WCEM (File);
1179    end Open;
1180
1181    ----------
1182    -- Page --
1183    ----------
1184
1185    --  Note: we assume that it is impossible in practice for the page
1186    --  to exceed the value of Count'Last, i.e. no check is required for
1187    --  overflow raising layout error.
1188
1189    function Page (File : File_Type) return Positive_Count is
1190    begin
1191       FIO.Check_File_Open (AP (File));
1192       return File.Page;
1193    end Page;
1194
1195    function Page return Positive_Count is
1196    begin
1197       return Page (Current_Out);
1198    end Page;
1199
1200    -----------------
1201    -- Page_Length --
1202    -----------------
1203
1204    function Page_Length (File : File_Type) return Count is
1205    begin
1206       FIO.Check_Write_Status (AP (File));
1207       return File.Page_Length;
1208    end Page_Length;
1209
1210    function Page_Length return Count is
1211    begin
1212       return Page_Length (Current_Out);
1213    end Page_Length;
1214
1215    ---------
1216    -- Put --
1217    ---------
1218
1219    procedure Put
1220      (File : File_Type;
1221       Item : Wide_Wide_Character)
1222    is
1223       procedure Out_Char (C : Character);
1224       --  Procedure to output one character of a wide character sequence
1225
1226       procedure WC_Out is new UTF_32_To_Char_Sequence (Out_Char);
1227
1228       --------------
1229       -- Out_Char --
1230       --------------
1231
1232       procedure Out_Char (C : Character) is
1233       begin
1234          Putc (Character'Pos (C), File);
1235       end Out_Char;
1236
1237    --  Start of processing for Put
1238
1239    begin
1240       FIO.Check_Write_Status (AP (File));
1241       WC_Out (Wide_Wide_Character'Pos (Item), File.WC_Method);
1242       File.Col := File.Col + 1;
1243    end Put;
1244
1245    procedure Put (Item : Wide_Wide_Character) is
1246    begin
1247       Put (Current_Out, Item);
1248    end Put;
1249
1250    ---------
1251    -- Put --
1252    ---------
1253
1254    procedure Put
1255      (File : File_Type;
1256       Item : Wide_Wide_String)
1257    is
1258    begin
1259       for J in Item'Range loop
1260          Put (File, Item (J));
1261       end loop;
1262    end Put;
1263
1264    procedure Put (Item : Wide_Wide_String) is
1265    begin
1266       Put (Current_Out, Item);
1267    end Put;
1268
1269    --------------
1270    -- Put_Line --
1271    --------------
1272
1273    procedure Put_Line
1274      (File : File_Type;
1275       Item : Wide_Wide_String)
1276    is
1277    begin
1278       Put (File, Item);
1279       New_Line (File);
1280    end Put_Line;
1281
1282    procedure Put_Line (Item : Wide_Wide_String) is
1283    begin
1284       Put (Current_Out, Item);
1285       New_Line (Current_Out);
1286    end Put_Line;
1287
1288    ----------
1289    -- Putc --
1290    ----------
1291
1292    procedure Putc (ch : int; File : File_Type) is
1293    begin
1294       if fputc (ch, File.Stream) = EOF then
1295          raise Device_Error;
1296       end if;
1297    end Putc;
1298
1299    ----------
1300    -- Read --
1301    ----------
1302
1303    --  This is the primitive Stream Read routine, used when a Text_IO file
1304    --  is treated directly as a stream using Text_IO.Streams.Stream.
1305
1306    procedure Read
1307      (File : in out Wide_Wide_Text_AFCB;
1308       Item : out Stream_Element_Array;
1309       Last : out Stream_Element_Offset)
1310    is
1311       Discard_ch : int;
1312       pragma Unreferenced (Discard_ch);
1313
1314    begin
1315       --  Need to deal with Before_Wide_Wide_Character ???
1316
1317       if File.Mode /= FCB.In_File then
1318          raise Mode_Error;
1319       end if;
1320
1321       --  Deal with case where our logical and physical position do not match
1322       --  because of being after an LM or LM-PM sequence when in fact we are
1323       --  logically positioned before it.
1324
1325       if File.Before_LM then
1326
1327          --  If we are before a PM, then it is possible for a stream read
1328          --  to leave us after the LM and before the PM, which is a bit
1329          --  odd. The easiest way to deal with this is to unget the PM,
1330          --  so we are indeed positioned between the characters. This way
1331          --  further stream read operations will work correctly, and the
1332          --  effect on text processing is a little weird, but what can
1333          --  be expected if stream and text input are mixed this way?
1334
1335          if File.Before_LM_PM then
1336             Discard_ch := ungetc (PM, File.Stream);
1337             File.Before_LM_PM := False;
1338          end if;
1339
1340          File.Before_LM := False;
1341
1342          Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF));
1343
1344          if Item'Length = 1 then
1345             Last := Item'Last;
1346
1347          else
1348             Last :=
1349               Item'First +
1350                 Stream_Element_Offset
1351                   (fread (buffer => Item'Address,
1352                           index  => size_t (Item'First + 1),
1353                           size   => 1,
1354                           count  => Item'Length - 1,
1355                           stream => File.Stream));
1356          end if;
1357
1358          return;
1359       end if;
1360
1361       --  Now we do the read. Since this is a text file, it is normally in
1362       --  text mode, but stream data must be read in binary mode, so we
1363       --  temporarily set binary mode for the read, resetting it after.
1364       --  These calls have no effect in a system (like Unix) where there is
1365       --  no distinction between text and binary files.
1366
1367       set_binary_mode (fileno (File.Stream));
1368
1369       Last :=
1370         Item'First +
1371           Stream_Element_Offset
1372             (fread (Item'Address, 1, Item'Length, File.Stream)) - 1;
1373
1374       if Last < Item'Last then
1375          if ferror (File.Stream) /= 0 then
1376             raise Device_Error;
1377          end if;
1378       end if;
1379
1380       set_text_mode (fileno (File.Stream));
1381    end Read;
1382
1383    -----------
1384    -- Reset --
1385    -----------
1386
1387    procedure Reset
1388      (File : in out File_Type;
1389       Mode : File_Mode)
1390    is
1391    begin
1392       --  Don't allow change of mode for current file (RM A.10.2(5))
1393
1394       if (File = Current_In or else
1395           File = Current_Out  or else
1396           File = Current_Error)
1397         and then To_FCB (Mode) /= File.Mode
1398       then
1399          raise Mode_Error;
1400       end if;
1401
1402       Terminate_Line (File);
1403       FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode));
1404       File.Page := 1;
1405       File.Line := 1;
1406       File.Col  := 1;
1407       File.Line_Length := 0;
1408       File.Page_Length := 0;
1409       File.Before_LM := False;
1410       File.Before_LM_PM := False;
1411    end Reset;
1412
1413    procedure Reset (File : in out File_Type) is
1414    begin
1415       Terminate_Line (File);
1416       FIO.Reset (AP (File)'Unrestricted_Access);
1417       File.Page := 1;
1418       File.Line := 1;
1419       File.Col  := 1;
1420       File.Line_Length := 0;
1421       File.Page_Length := 0;
1422       File.Before_LM := False;
1423       File.Before_LM_PM := False;
1424    end Reset;
1425
1426    -------------
1427    -- Set_Col --
1428    -------------
1429
1430    procedure Set_Col
1431      (File : File_Type;
1432       To   : Positive_Count)
1433    is
1434       ch : int;
1435
1436    begin
1437       --  Raise Constraint_Error if out of range value. The reason for this
1438       --  explicit test is that we don't want junk values around, even if
1439       --  checks are off in the caller.
1440
1441       if not To'Valid then
1442          raise Constraint_Error;
1443       end if;
1444
1445       FIO.Check_File_Open (AP (File));
1446
1447       if To = File.Col then
1448          return;
1449       end if;
1450
1451       if Mode (File) >= Out_File then
1452          if File.Line_Length /= 0 and then To > File.Line_Length then
1453             raise Layout_Error;
1454          end if;
1455
1456          if To < File.Col then
1457             New_Line (File);
1458          end if;
1459
1460          while File.Col < To loop
1461             Put (File, ' ');
1462          end loop;
1463
1464       else
1465          loop
1466             ch := Getc (File);
1467
1468             if ch = EOF then
1469                raise End_Error;
1470
1471             elsif ch = LM then
1472                File.Line := File.Line + 1;
1473                File.Col := 1;
1474
1475             elsif ch = PM and then File.Is_Regular_File then
1476                File.Page := File.Page + 1;
1477                File.Line := 1;
1478                File.Col := 1;
1479
1480             elsif To = File.Col then
1481                Ungetc (ch, File);
1482                return;
1483
1484             else
1485                File.Col := File.Col + 1;
1486             end if;
1487          end loop;
1488       end if;
1489    end Set_Col;
1490
1491    procedure Set_Col (To : Positive_Count) is
1492    begin
1493       Set_Col (Current_Out, To);
1494    end Set_Col;
1495
1496    ---------------
1497    -- Set_Error --
1498    ---------------
1499
1500    procedure Set_Error (File : File_Type) is
1501    begin
1502       FIO.Check_Write_Status (AP (File));
1503       Current_Err := File;
1504    end Set_Error;
1505
1506    ---------------
1507    -- Set_Input --
1508    ---------------
1509
1510    procedure Set_Input (File : File_Type) is
1511    begin
1512       FIO.Check_Read_Status (AP (File));
1513       Current_In := File;
1514    end Set_Input;
1515
1516    --------------
1517    -- Set_Line --
1518    --------------
1519
1520    procedure Set_Line
1521      (File : File_Type;
1522       To   : Positive_Count)
1523    is
1524    begin
1525       --  Raise Constraint_Error if out of range value. The reason for this
1526       --  explicit test is that we don't want junk values around, even if
1527       --  checks are off in the caller.
1528
1529       if not To'Valid then
1530          raise Constraint_Error;
1531       end if;
1532
1533       FIO.Check_File_Open (AP (File));
1534
1535       if To = File.Line then
1536          return;
1537       end if;
1538
1539       if Mode (File) >= Out_File then
1540          if File.Page_Length /= 0 and then To > File.Page_Length then
1541             raise Layout_Error;
1542          end if;
1543
1544          if To < File.Line then
1545             New_Page (File);
1546          end if;
1547
1548          while File.Line < To loop
1549             New_Line (File);
1550          end loop;
1551
1552       else
1553          while To /= File.Line loop
1554             Skip_Line (File);
1555          end loop;
1556       end if;
1557    end Set_Line;
1558
1559    procedure Set_Line (To : Positive_Count) is
1560    begin
1561       Set_Line (Current_Out, To);
1562    end Set_Line;
1563
1564    ---------------------
1565    -- Set_Line_Length --
1566    ---------------------
1567
1568    procedure Set_Line_Length (File : File_Type; To : Count) is
1569    begin
1570       --  Raise Constraint_Error if out of range value. The reason for this
1571       --  explicit test is that we don't want junk values around, even if
1572       --  checks are off in the caller.
1573
1574       if not To'Valid then
1575          raise Constraint_Error;
1576       end if;
1577
1578       FIO.Check_Write_Status (AP (File));
1579       File.Line_Length := To;
1580    end Set_Line_Length;
1581
1582    procedure Set_Line_Length (To : Count) is
1583    begin
1584       Set_Line_Length (Current_Out, To);
1585    end Set_Line_Length;
1586
1587    ----------------
1588    -- Set_Output --
1589    ----------------
1590
1591    procedure Set_Output (File : File_Type) is
1592    begin
1593       FIO.Check_Write_Status (AP (File));
1594       Current_Out := File;
1595    end Set_Output;
1596
1597    ---------------------
1598    -- Set_Page_Length --
1599    ---------------------
1600
1601    procedure Set_Page_Length (File : File_Type; To : Count) is
1602    begin
1603       --  Raise Constraint_Error if out of range value. The reason for this
1604       --  explicit test is that we don't want junk values around, even if
1605       --  checks are off in the caller.
1606
1607       if not To'Valid then
1608          raise Constraint_Error;
1609       end if;
1610
1611       FIO.Check_Write_Status (AP (File));
1612       File.Page_Length := To;
1613    end Set_Page_Length;
1614
1615    procedure Set_Page_Length (To : Count) is
1616    begin
1617       Set_Page_Length (Current_Out, To);
1618    end Set_Page_Length;
1619
1620    --------------
1621    -- Set_WCEM --
1622    --------------
1623
1624    procedure Set_WCEM (File : in out File_Type) is
1625       Start : Natural;
1626       Stop  : Natural;
1627
1628    begin
1629       FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop);
1630
1631       if Start = 0 then
1632          File.WC_Method := Default_WCEM;
1633
1634       else
1635          if Stop = Start then
1636             for J in WC_Encoding_Letters'Range loop
1637                if File.Form (Start) = WC_Encoding_Letters (J) then
1638                   File.WC_Method := J;
1639                   return;
1640                end if;
1641             end loop;
1642          end if;
1643
1644          Close (File);
1645          raise Use_Error with "invalid WCEM form parameter";
1646       end if;
1647    end Set_WCEM;
1648
1649    ---------------
1650    -- Skip_Line --
1651    ---------------
1652
1653    procedure Skip_Line
1654      (File    : File_Type;
1655       Spacing : Positive_Count := 1)
1656    is
1657       ch : int;
1658
1659    begin
1660       --  Raise Constraint_Error if out of range value. The reason for this
1661       --  explicit test is that we don't want junk values around, even if
1662       --  checks are off in the caller.
1663
1664       if not Spacing'Valid then
1665          raise Constraint_Error;
1666       end if;
1667
1668       FIO.Check_Read_Status (AP (File));
1669
1670       for L in 1 .. Spacing loop
1671          if File.Before_LM then
1672             File.Before_LM := False;
1673             File.Before_LM_PM := False;
1674
1675          else
1676             ch := Getc (File);
1677
1678             --  If at end of file now, then immediately raise End_Error. Note
1679             --  that we can never be positioned between a line mark and a page
1680             --  mark, so if we are at the end of file, we cannot logically be
1681             --  before the implicit page mark that is at the end of the file.
1682
1683             --  For the same reason, we do not need an explicit check for a
1684             --  page mark. If there is a FF in the middle of a line, the file
1685             --  is not in canonical format and we do not care about the page
1686             --  numbers for files other than ones in canonical format.
1687
1688             if ch = EOF then
1689                raise End_Error;
1690             end if;
1691
1692             --  If not at end of file, then loop till we get to an LM or EOF.
1693             --  The latter case happens only in non-canonical files where the
1694             --  last line is not terminated by LM, but we don't want to blow
1695             --  up for such files, so we assume an implicit LM in this case.
1696
1697             loop
1698                exit when ch = LM or else ch = EOF;
1699                ch := Getc (File);
1700             end loop;
1701          end if;
1702
1703          --  We have got past a line mark, now, for a regular file only,
1704          --  see if a page mark immediately follows this line mark and
1705          --  if so, skip past the page mark as well. We do not do this
1706          --  for non-regular files, since it would cause an undesirable
1707          --  wait for an additional character.
1708
1709          File.Col := 1;
1710          File.Line := File.Line + 1;
1711
1712          if File.Before_LM_PM then
1713             File.Page := File.Page + 1;
1714             File.Line := 1;
1715             File.Before_LM_PM := False;
1716
1717          elsif File.Is_Regular_File then
1718             ch := Getc (File);
1719
1720             --  Page mark can be explicit, or implied at the end of the file
1721
1722             if (ch = PM or else ch = EOF)
1723               and then File.Is_Regular_File
1724             then
1725                File.Page := File.Page + 1;
1726                File.Line := 1;
1727             else
1728                Ungetc (ch, File);
1729             end if;
1730          end if;
1731       end loop;
1732
1733       File.Before_Wide_Wide_Character := False;
1734    end Skip_Line;
1735
1736    procedure Skip_Line (Spacing : Positive_Count := 1) is
1737    begin
1738       Skip_Line (Current_In, Spacing);
1739    end Skip_Line;
1740
1741    ---------------
1742    -- Skip_Page --
1743    ---------------
1744
1745    procedure Skip_Page (File : File_Type) is
1746       ch : int;
1747
1748    begin
1749       FIO.Check_Read_Status (AP (File));
1750
1751       --  If at page mark already, just skip it
1752
1753       if File.Before_LM_PM then
1754          File.Before_LM := False;
1755          File.Before_LM_PM := False;
1756          File.Page := File.Page + 1;
1757          File.Line := 1;
1758          File.Col  := 1;
1759          return;
1760       end if;
1761
1762       --  This is a bit tricky, if we are logically before an LM then
1763       --  it is not an error if we are at an end of file now, since we
1764       --  are not really at it.
1765
1766       if File.Before_LM then
1767          File.Before_LM := False;
1768          File.Before_LM_PM := False;
1769          ch := Getc (File);
1770
1771       --  Otherwise we do raise End_Error if we are at the end of file now
1772
1773       else
1774          ch := Getc (File);
1775
1776          if ch = EOF then
1777             raise End_Error;
1778          end if;
1779       end if;
1780
1781       --  Now we can just rumble along to the next page mark, or to the
1782       --  end of file, if that comes first. The latter case happens when
1783       --  the page mark is implied at the end of file.
1784
1785       loop
1786          exit when ch = EOF
1787            or else (ch = PM and then File.Is_Regular_File);
1788          ch := Getc (File);
1789       end loop;
1790
1791       File.Page := File.Page + 1;
1792       File.Line := 1;
1793       File.Col  := 1;
1794       File.Before_Wide_Wide_Character := False;
1795    end Skip_Page;
1796
1797    procedure Skip_Page is
1798    begin
1799       Skip_Page (Current_In);
1800    end Skip_Page;
1801
1802    --------------------
1803    -- Standard_Error --
1804    --------------------
1805
1806    function Standard_Error return File_Type is
1807    begin
1808       return Standard_Err;
1809    end Standard_Error;
1810
1811    function Standard_Error return File_Access is
1812    begin
1813       return Standard_Err'Access;
1814    end Standard_Error;
1815
1816    --------------------
1817    -- Standard_Input --
1818    --------------------
1819
1820    function Standard_Input return File_Type is
1821    begin
1822       return Standard_In;
1823    end Standard_Input;
1824
1825    function Standard_Input return File_Access is
1826    begin
1827       return Standard_In'Access;
1828    end Standard_Input;
1829
1830    ---------------------
1831    -- Standard_Output --
1832    ---------------------
1833
1834    function Standard_Output return File_Type is
1835    begin
1836       return Standard_Out;
1837    end Standard_Output;
1838
1839    function Standard_Output return File_Access is
1840    begin
1841       return Standard_Out'Access;
1842    end Standard_Output;
1843
1844    --------------------
1845    -- Terminate_Line --
1846    --------------------
1847
1848    procedure Terminate_Line (File : File_Type) is
1849    begin
1850       FIO.Check_File_Open (AP (File));
1851
1852       --  For file other than In_File, test for needing to terminate last line
1853
1854       if Mode (File) /= In_File then
1855
1856          --  If not at start of line definition need new line
1857
1858          if File.Col /= 1 then
1859             New_Line (File);
1860
1861          --  For files other than standard error and standard output, we
1862          --  make sure that an empty file has a single line feed, so that
1863          --  it is properly formatted. We avoid this for the standard files
1864          --  because it is too much of a nuisance to have these odd line
1865          --  feeds when nothing has been written to the file.
1866
1867          elsif (File /= Standard_Err and then File /= Standard_Out)
1868            and then (File.Line = 1 and then File.Page = 1)
1869          then
1870             New_Line (File);
1871          end if;
1872       end if;
1873    end Terminate_Line;
1874
1875    ------------
1876    -- Ungetc --
1877    ------------
1878
1879    procedure Ungetc (ch : int; File : File_Type) is
1880    begin
1881       if ch /= EOF then
1882          if ungetc (ch, File.Stream) = EOF then
1883             raise Device_Error;
1884          end if;
1885       end if;
1886    end Ungetc;
1887
1888    -----------
1889    -- Write --
1890    -----------
1891
1892    --  This is the primitive Stream Write routine, used when a Text_IO file
1893    --  is treated directly as a stream using Text_IO.Streams.Stream.
1894
1895    procedure Write
1896      (File : in out Wide_Wide_Text_AFCB;
1897       Item : Stream_Element_Array)
1898    is
1899       pragma Warnings (Off, File);
1900       --  Because in this implementation we don't need IN OUT, we only read
1901
1902       Siz : constant size_t := Item'Length;
1903
1904    begin
1905       if File.Mode = FCB.In_File then
1906          raise Mode_Error;
1907       end if;
1908
1909       --  Now we do the write. Since this is a text file, it is normally in
1910       --  text mode, but stream data must be written in binary mode, so we
1911       --  temporarily set binary mode for the write, resetting it after.
1912       --  These calls have no effect in a system (like Unix) where there is
1913       --  no distinction between text and binary files.
1914
1915       set_binary_mode (fileno (File.Stream));
1916
1917       if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then
1918          raise Device_Error;
1919       end if;
1920
1921       set_text_mode (fileno (File.Stream));
1922    end Write;
1923
1924 begin
1925    --  Initialize Standard Files
1926
1927    for J in WC_Encoding_Method loop
1928       if WC_Encoding = WC_Encoding_Letters (J) then
1929          Default_WCEM := J;
1930       end if;
1931    end loop;
1932
1933    Initialize_Standard_Files;
1934
1935    FIO.Chain_File (AP (Standard_In));
1936    FIO.Chain_File (AP (Standard_Out));
1937    FIO.Chain_File (AP (Standard_Err));
1938
1939 end Ada.Wide_Wide_Text_IO;