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