1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . W I D E _ W I D E _ T E X T _ I O --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada.Streams; use Ada.Streams;
33 with Interfaces.C_Streams; use Interfaces.C_Streams;
37 with System.WCh_Cnv; use System.WCh_Cnv;
38 with System.WCh_Con; use System.WCh_Con;
40 with Ada.Unchecked_Conversion;
41 with Ada.Unchecked_Deallocation;
43 pragma Elaborate_All (System.File_IO);
44 -- Needed because of calls to Chain_File in package body elaboration
46 package body Ada.Wide_Wide_Text_IO is
48 package FIO renames System.File_IO;
50 subtype AP is FCB.AFCB_Ptr;
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;
56 use type System.CRTL.size_t;
58 WC_Encoding : Character;
59 pragma Import (C, WC_Encoding, "__gl_wc_encoding");
60 -- Default wide character encoding
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
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.
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.
77 Null_Str : aliased constant String := "";
78 -- Used as form string for standard files
80 -----------------------
81 -- Local Subprograms --
82 -----------------------
84 function Get_Wide_Wide_Char_Immed
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).
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).
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
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.
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.
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
120 function AFCB_Allocate
121 (Control_Block : Wide_Wide_Text_AFCB) return FCB.AFCB_Ptr
123 pragma Unreferenced (Control_Block);
125 return new Wide_Wide_Text_AFCB;
132 procedure AFCB_Close (File : not null access Wide_Wide_Text_AFCB) is
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.
139 if File_Type (File) = Current_In then
141 elsif File_Type (File) = Current_Out then
143 elsif File_Type (File) = Current_Err then
147 Terminate_Line (File_Type (File));
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);
158 procedure Free is new
159 Ada.Unchecked_Deallocation (Wide_Wide_Text_AFCB, FCB_Ptr);
169 procedure Close (File : in out File_Type) is
171 FIO.Close (AP (File)'Unrestricted_Access);
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.
182 function Col (File : File_Type) return Positive_Count is
184 FIO.Check_File_Open (AP (File));
188 function Col return Positive_Count is
190 return Col (Current_Out);
198 (File : in out File_Type;
199 Mode : File_Mode := Out_File;
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.
209 FIO.Open (File_Ptr => AP (File),
210 Dummy_FCB => Dummy_File_Control_Block,
211 Mode => To_FCB (Mode),
226 function Current_Error return File_Type is
231 function Current_Error return File_Access is
233 return Current_Err.Self'Access;
240 function Current_Input return File_Type is
245 function Current_Input return File_Access is
247 return Current_In.Self'Access;
254 function Current_Output return File_Type is
259 function Current_Output return File_Access is
261 return Current_Out.Self'Access;
268 procedure Delete (File : in out File_Type) is
270 FIO.Delete (AP (File)'Unrestricted_Access);
277 function End_Of_File (File : File_Type) return Boolean is
281 FIO.Check_Read_Status (AP (File));
283 if File.Before_Wide_Wide_Character then
286 elsif File.Before_LM then
287 if File.Before_LM_PM then
288 return Nextc (File) = EOF;
302 File.Before_LM := True;
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.
315 elsif ch = PM and then File.Is_Regular_File then
316 File.Before_LM_PM := True;
317 return Nextc (File) = EOF;
319 -- Here if neither EOF nor PM followed end of line
328 function End_Of_File return Boolean is
330 return End_Of_File (Current_In);
337 function End_Of_Line (File : File_Type) return Boolean is
341 FIO.Check_Read_Status (AP (File));
343 if File.Before_Wide_Wide_Character then
346 elsif File.Before_LM then
362 function End_Of_Line return Boolean is
364 return End_Of_Line (Current_In);
371 function End_Of_Page (File : File_Type) return Boolean is
375 FIO.Check_Read_Status (AP (File));
377 if not File.Is_Regular_File then
380 elsif File.Before_Wide_Wide_Character then
383 elsif File.Before_LM then
384 if File.Before_LM_PM then
399 File.Before_LM := True;
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.
409 return ch = PM or else ch = EOF;
412 function End_Of_Page return Boolean is
414 return End_Of_Page (Current_In);
421 procedure Flush (File : File_Type) is
423 FIO.Flush (AP (File));
435 function Form (File : File_Type) return String is
437 return FIO.Form (AP (File));
446 Item : out Wide_Wide_Character)
451 FIO.Check_Read_Status (AP (File));
453 if File.Before_Wide_Wide_Character then
454 File.Before_Wide_Wide_Character := False;
455 Item := File.Saved_Wide_Wide_Character;
457 -- Ada.Text_IO checks Before_LM_PM here, shouldn't we do the same???
460 Get_Character (File, C);
461 Item := Get_Wide_Wide_Char (C, File);
465 procedure Get (Item : out Wide_Wide_Character) is
467 Get (Current_In, Item);
472 Item : out Wide_Wide_String)
475 for J in Item'Range loop
476 Get (File, Item (J));
480 procedure Get (Item : out Wide_Wide_String) is
482 Get (Current_In, Item);
489 procedure Get_Character
491 Item : out Character)
496 if File.Before_LM then
497 File.Before_LM := False;
498 File.Before_LM_PM := False;
501 if File.Before_LM_PM then
503 File.Page := File.Page + 1;
504 File.Before_LM_PM := False;
507 File.Line := File.Line + 1;
518 File.Line := File.Line + 1;
521 elsif ch = PM and then File.Is_Regular_File then
522 File.Page := File.Page + 1;
526 Item := Character'Val (ch);
527 File.Col := File.Col + 1;
537 procedure Get_Immediate
539 Item : out Wide_Wide_Character)
544 FIO.Check_Read_Status (AP (File));
546 if File.Before_Wide_Wide_Character then
547 File.Before_Wide_Wide_Character := False;
548 Item := File.Saved_Wide_Wide_Character;
550 elsif File.Before_LM then
551 File.Before_LM := False;
552 File.Before_LM_PM := False;
553 Item := Wide_Wide_Character'Val (LM);
556 ch := Getc_Immed (File);
561 Item := Get_Wide_Wide_Char_Immed (Character'Val (ch), File);
566 procedure Get_Immediate
567 (Item : out Wide_Wide_Character)
570 Get_Immediate (Current_In, Item);
573 procedure Get_Immediate
575 Item : out Wide_Wide_Character;
576 Available : out Boolean)
581 FIO.Check_Read_Status (AP (File));
584 if File.Before_Wide_Wide_Character then
585 File.Before_Wide_Wide_Character := False;
586 Item := File.Saved_Wide_Wide_Character;
588 elsif File.Before_LM then
589 File.Before_LM := False;
590 File.Before_LM_PM := False;
591 Item := Wide_Wide_Character'Val (LM);
594 -- Shouldn't we use getc_immediate_nowait here, like Text_IO???
596 ch := Getc_Immed (File);
601 Item := Get_Wide_Wide_Char_Immed (Character'Val (ch), File);
606 procedure Get_Immediate
607 (Item : out Wide_Wide_Character;
608 Available : out Boolean)
611 Get_Immediate (Current_In, Item, Available);
620 Item : out Wide_Wide_String;
624 FIO.Check_Read_Status (AP (File));
625 Last := Item'First - 1;
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.
631 if Last >= Item'Last then
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.
638 if File.Before_LM then
639 File.Before_LM := False;
640 File.Before_LM_PM := False;
642 -- Otherwise we need to read some characters
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))
648 if Nextc (File) = EOF then
652 -- Loop through characters in string
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.
659 if End_Of_Line (File) then
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.
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.
681 Get (File, Item (Last));
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.
687 if Last = Item'Last then
688 File.Col := File.Col + Count (Item'Length);
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.
697 exit when Nextc (File) = EOF;
703 (Item : out Wide_Wide_String;
707 Get_Line (Current_In, Item, Last);
710 function Get_Line (File : File_Type) return Wide_Wide_String is
711 Buffer : Wide_Wide_String (1 .. 500);
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.
722 function Get_Rest (S : Wide_Wide_String) return Wide_Wide_String is
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.
728 Buffer : Wide_Wide_String (1 .. S'Length);
732 Get_Line (File, Buffer, Last);
735 R : constant Wide_Wide_String := S & Buffer (1 .. Last);
737 if Last < Buffer'Last then
745 -- Start of processing for Get_Line
748 Get_Line (File, Buffer, Last);
750 if Last < Buffer'Last then
751 return Buffer (1 .. Last);
753 return Get_Rest (Buffer (1 .. Last));
757 function Get_Line return Wide_Wide_String is
759 return Get_Line (Current_In);
762 ------------------------
763 -- Get_Wide_Wide_Char --
764 ------------------------
766 function Get_Wide_Wide_Char
768 File : File_Type) return Wide_Wide_Character
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.
774 function WC_In is new Char_Sequence_To_UTF_32 (In_Char);
780 function In_Char return Character is
781 ch : constant Integer := Getc (File);
786 return Character'Val (ch);
790 -- Start of processing for Get_Wide_Wide_Char
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;
797 ------------------------------
798 -- Get_Wide_Wide_Char_Immed --
799 ------------------------------
801 function Get_Wide_Wide_Char_Immed
803 File : File_Type) return Wide_Wide_Character
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.
809 function WC_In is new Char_Sequence_To_UTF_32 (In_Char);
815 function In_Char return Character is
816 ch : constant Integer := Getc_Immed (File);
821 return Character'Val (ch);
825 -- Start of processing for Get_Wide_Wide_Char_Immed
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;
836 function Getc (File : File_Type) return int is
840 ch := fgetc (File.Stream);
842 if ch = EOF and then ferror (File.Stream) /= 0 then
853 function Getc_Immed (File : File_Type) return int is
857 procedure getc_immediate
858 (stream : FILEs; ch : out int; end_of_file : out int);
859 pragma Import (C, getc_immediate, "getc_immediate");
862 FIO.Check_Read_Status (AP (File));
864 if File.Before_LM then
865 File.Before_LM := False;
866 File.Before_LM_PM := False;
870 getc_immediate (File.Stream, ch, end_of_file);
872 if ferror (File.Stream) /= 0 then
874 elsif end_of_file /= 0 then
882 -------------------------------
883 -- Initialize_Standard_Files --
884 -------------------------------
886 procedure Initialize_Standard_Files is
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.Is_Text_File := True;
896 Standard_Err.Access_Method := 'T';
897 Standard_Err.Self := Standard_Err;
898 Standard_Err.WC_Method := Default_WCEM;
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.Is_Text_File := True;
908 Standard_In.Access_Method := 'T';
909 Standard_In.Self := Standard_In;
910 Standard_In.WC_Method := Default_WCEM;
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.Is_Text_File := True;
920 Standard_Out.Access_Method := 'T';
921 Standard_Out.Self := Standard_Out;
922 Standard_Out.WC_Method := Default_WCEM;
924 FIO.Make_Unbuffered (AP (Standard_Out));
925 FIO.Make_Unbuffered (AP (Standard_Err));
926 end Initialize_Standard_Files;
932 function Is_Open (File : File_Type) return Boolean is
934 return FIO.Is_Open (AP (File));
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.
945 function Line (File : File_Type) return Positive_Count is
947 FIO.Check_File_Open (AP (File));
951 function Line return Positive_Count is
953 return Line (Current_Out);
960 function Line_Length (File : File_Type) return Count is
962 FIO.Check_Write_Status (AP (File));
963 return File.Line_Length;
966 function Line_Length return Count is
968 return Line_Length (Current_Out);
977 Item : out Wide_Wide_Character;
978 End_Of_Line : out Boolean)
982 -- Start of processing for Look_Ahead
985 FIO.Check_Read_Status (AP (File));
987 -- If we are logically before a line mark, we can return immediately
989 if File.Before_LM then
991 Item := Wide_Wide_Character'Val (0);
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).
996 elsif File.Before_Wide_Wide_Character then
997 End_Of_Line := False;
998 Item := File.Saved_Wide_Wide_Character;
1000 -- otherwise we must read a character from the input stream
1007 or else (ch = EOF and then File.Is_Regular_File)
1009 End_Of_Line := True;
1011 Item := Wide_Wide_Character'Val (0);
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
1017 elsif not Is_Start_Of_Encoding
1018 (Character'Val (ch), File.WC_Method)
1020 End_Of_Line := False;
1022 Item := Wide_Wide_Character'Val (ch);
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.
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;
1039 procedure Look_Ahead
1040 (Item : out Wide_Wide_Character;
1041 End_Of_Line : out Boolean)
1044 Look_Ahead (Current_In, Item, End_Of_Line);
1051 function Mode (File : File_Type) return File_Mode is
1053 return To_TIO (FIO.Mode (AP (File)));
1060 function Name (File : File_Type) return String is
1062 return FIO.Name (AP (File));
1071 Spacing : Positive_Count := 1)
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.
1078 if not Spacing'Valid then
1079 raise Constraint_Error;
1082 FIO.Check_Write_Status (AP (File));
1084 for K in 1 .. Spacing loop
1086 File.Line := File.Line + 1;
1088 if File.Page_Length /= 0
1089 and then File.Line > File.Page_Length
1093 File.Page := File.Page + 1;
1100 procedure New_Line (Spacing : Positive_Count := 1) is
1102 New_Line (Current_Out, Spacing);
1109 procedure New_Page (File : File_Type) is
1111 FIO.Check_Write_Status (AP (File));
1113 if File.Col /= 1 or else File.Line = 1 then
1118 File.Page := File.Page + 1;
1123 procedure New_Page is
1125 New_Page (Current_Out);
1132 function Nextc (File : File_Type) return int is
1136 ch := fgetc (File.Stream);
1139 if ferror (File.Stream) /= 0 then
1144 if ungetc (ch, File.Stream) = EOF then
1157 (File : in out File_Type;
1160 Form : String := "")
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.
1168 FIO.Open (File_Ptr => AP (File),
1169 Dummy_FCB => Dummy_File_Control_Block,
1170 Mode => To_FCB (Mode),
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.
1189 function Page (File : File_Type) return Positive_Count is
1191 FIO.Check_File_Open (AP (File));
1195 function Page return Positive_Count is
1197 return Page (Current_Out);
1204 function Page_Length (File : File_Type) return Count is
1206 FIO.Check_Write_Status (AP (File));
1207 return File.Page_Length;
1210 function Page_Length return Count is
1212 return Page_Length (Current_Out);
1221 Item : Wide_Wide_Character)
1223 procedure Out_Char (C : Character);
1224 -- Procedure to output one character of a wide character sequence
1226 procedure WC_Out is new UTF_32_To_Char_Sequence (Out_Char);
1232 procedure Out_Char (C : Character) is
1234 Putc (Character'Pos (C), File);
1237 -- Start of processing for Put
1240 FIO.Check_Write_Status (AP (File));
1241 WC_Out (Wide_Wide_Character'Pos (Item), File.WC_Method);
1242 File.Col := File.Col + 1;
1245 procedure Put (Item : Wide_Wide_Character) is
1247 Put (Current_Out, Item);
1256 Item : Wide_Wide_String)
1259 for J in Item'Range loop
1260 Put (File, Item (J));
1264 procedure Put (Item : Wide_Wide_String) is
1266 Put (Current_Out, Item);
1275 Item : Wide_Wide_String)
1282 procedure Put_Line (Item : Wide_Wide_String) is
1284 Put (Current_Out, Item);
1285 New_Line (Current_Out);
1292 procedure Putc (ch : int; File : File_Type) is
1294 if fputc (ch, File.Stream) = EOF then
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.
1307 (File : in out Wide_Wide_Text_AFCB;
1308 Item : out Stream_Element_Array;
1309 Last : out Stream_Element_Offset)
1312 pragma Unreferenced (Discard_ch);
1315 -- Need to deal with Before_Wide_Wide_Character ???
1317 if File.Mode /= FCB.In_File then
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.
1325 if File.Before_LM then
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?
1335 if File.Before_LM_PM then
1336 Discard_ch := ungetc (PM, File.Stream);
1337 File.Before_LM_PM := False;
1340 File.Before_LM := False;
1342 Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF));
1344 if Item'Length = 1 then
1350 Stream_Element_Offset
1351 (fread (buffer => Item'Address,
1352 index => size_t (Item'First + 1),
1354 count => Item'Length - 1,
1355 stream => File.Stream));
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.
1367 set_binary_mode (fileno (File.Stream));
1371 Stream_Element_Offset
1372 (fread (Item'Address, 1, Item'Length, File.Stream)) - 1;
1374 if Last < Item'Last then
1375 if ferror (File.Stream) /= 0 then
1380 set_text_mode (fileno (File.Stream));
1388 (File : in out File_Type;
1392 -- Don't allow change of mode for current file (RM A.10.2(5))
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
1402 Terminate_Line (File);
1403 FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode));
1407 File.Line_Length := 0;
1408 File.Page_Length := 0;
1409 File.Before_LM := False;
1410 File.Before_LM_PM := False;
1413 procedure Reset (File : in out File_Type) is
1415 Terminate_Line (File);
1416 FIO.Reset (AP (File)'Unrestricted_Access);
1420 File.Line_Length := 0;
1421 File.Page_Length := 0;
1422 File.Before_LM := False;
1423 File.Before_LM_PM := False;
1432 To : Positive_Count)
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.
1441 if not To'Valid then
1442 raise Constraint_Error;
1445 FIO.Check_File_Open (AP (File));
1447 if To = File.Col then
1451 if Mode (File) >= Out_File then
1452 if File.Line_Length /= 0 and then To > File.Line_Length then
1456 if To < File.Col then
1460 while File.Col < To loop
1472 File.Line := File.Line + 1;
1475 elsif ch = PM and then File.Is_Regular_File then
1476 File.Page := File.Page + 1;
1480 elsif To = File.Col then
1485 File.Col := File.Col + 1;
1491 procedure Set_Col (To : Positive_Count) is
1493 Set_Col (Current_Out, To);
1500 procedure Set_Error (File : File_Type) is
1502 FIO.Check_Write_Status (AP (File));
1503 Current_Err := File;
1510 procedure Set_Input (File : File_Type) is
1512 FIO.Check_Read_Status (AP (File));
1522 To : Positive_Count)
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.
1529 if not To'Valid then
1530 raise Constraint_Error;
1533 FIO.Check_File_Open (AP (File));
1535 if To = File.Line then
1539 if Mode (File) >= Out_File then
1540 if File.Page_Length /= 0 and then To > File.Page_Length then
1544 if To < File.Line then
1548 while File.Line < To loop
1553 while To /= File.Line loop
1559 procedure Set_Line (To : Positive_Count) is
1561 Set_Line (Current_Out, To);
1564 ---------------------
1565 -- Set_Line_Length --
1566 ---------------------
1568 procedure Set_Line_Length (File : File_Type; To : Count) is
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.
1574 if not To'Valid then
1575 raise Constraint_Error;
1578 FIO.Check_Write_Status (AP (File));
1579 File.Line_Length := To;
1580 end Set_Line_Length;
1582 procedure Set_Line_Length (To : Count) is
1584 Set_Line_Length (Current_Out, To);
1585 end Set_Line_Length;
1591 procedure Set_Output (File : File_Type) is
1593 FIO.Check_Write_Status (AP (File));
1594 Current_Out := File;
1597 ---------------------
1598 -- Set_Page_Length --
1599 ---------------------
1601 procedure Set_Page_Length (File : File_Type; To : Count) is
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.
1607 if not To'Valid then
1608 raise Constraint_Error;
1611 FIO.Check_Write_Status (AP (File));
1612 File.Page_Length := To;
1613 end Set_Page_Length;
1615 procedure Set_Page_Length (To : Count) is
1617 Set_Page_Length (Current_Out, To);
1618 end Set_Page_Length;
1624 procedure Set_WCEM (File : in out File_Type) is
1629 File.WC_Method := WCEM_Brackets;
1630 FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop);
1633 File.WC_Method := WCEM_Brackets;
1636 if Stop = Start then
1637 for J in WC_Encoding_Letters'Range loop
1638 if File.Form (Start) = WC_Encoding_Letters (J) then
1639 File.WC_Method := J;
1646 raise Use_Error with "invalid WCEM form parameter";
1656 Spacing : Positive_Count := 1)
1661 -- Raise Constraint_Error if out of range value. The reason for this
1662 -- explicit test is that we don't want junk values around, even if
1663 -- checks are off in the caller.
1665 if not Spacing'Valid then
1666 raise Constraint_Error;
1669 FIO.Check_Read_Status (AP (File));
1671 for L in 1 .. Spacing loop
1672 if File.Before_LM then
1673 File.Before_LM := False;
1674 File.Before_LM_PM := False;
1679 -- If at end of file now, then immediately raise End_Error. Note
1680 -- that we can never be positioned between a line mark and a page
1681 -- mark, so if we are at the end of file, we cannot logically be
1682 -- before the implicit page mark that is at the end of the file.
1684 -- For the same reason, we do not need an explicit check for a
1685 -- page mark. If there is a FF in the middle of a line, the file
1686 -- is not in canonical format and we do not care about the page
1687 -- numbers for files other than ones in canonical format.
1693 -- If not at end of file, then loop till we get to an LM or EOF.
1694 -- The latter case happens only in non-canonical files where the
1695 -- last line is not terminated by LM, but we don't want to blow
1696 -- up for such files, so we assume an implicit LM in this case.
1699 exit when ch = LM or else ch = EOF;
1704 -- We have got past a line mark, now, for a regular file only,
1705 -- see if a page mark immediately follows this line mark and
1706 -- if so, skip past the page mark as well. We do not do this
1707 -- for non-regular files, since it would cause an undesirable
1708 -- wait for an additional character.
1711 File.Line := File.Line + 1;
1713 if File.Before_LM_PM then
1714 File.Page := File.Page + 1;
1716 File.Before_LM_PM := False;
1718 elsif File.Is_Regular_File then
1721 -- Page mark can be explicit, or implied at the end of the file
1723 if (ch = PM or else ch = EOF)
1724 and then File.Is_Regular_File
1726 File.Page := File.Page + 1;
1734 File.Before_Wide_Wide_Character := False;
1737 procedure Skip_Line (Spacing : Positive_Count := 1) is
1739 Skip_Line (Current_In, Spacing);
1746 procedure Skip_Page (File : File_Type) is
1750 FIO.Check_Read_Status (AP (File));
1752 -- If at page mark already, just skip it
1754 if File.Before_LM_PM then
1755 File.Before_LM := False;
1756 File.Before_LM_PM := False;
1757 File.Page := File.Page + 1;
1763 -- This is a bit tricky, if we are logically before an LM then
1764 -- it is not an error if we are at an end of file now, since we
1765 -- are not really at it.
1767 if File.Before_LM then
1768 File.Before_LM := False;
1769 File.Before_LM_PM := False;
1772 -- Otherwise we do raise End_Error if we are at the end of file now
1782 -- Now we can just rumble along to the next page mark, or to the
1783 -- end of file, if that comes first. The latter case happens when
1784 -- the page mark is implied at the end of file.
1788 or else (ch = PM and then File.Is_Regular_File);
1792 File.Page := File.Page + 1;
1795 File.Before_Wide_Wide_Character := False;
1798 procedure Skip_Page is
1800 Skip_Page (Current_In);
1803 --------------------
1804 -- Standard_Error --
1805 --------------------
1807 function Standard_Error return File_Type is
1809 return Standard_Err;
1812 function Standard_Error return File_Access is
1814 return Standard_Err'Access;
1817 --------------------
1818 -- Standard_Input --
1819 --------------------
1821 function Standard_Input return File_Type is
1826 function Standard_Input return File_Access is
1828 return Standard_In'Access;
1831 ---------------------
1832 -- Standard_Output --
1833 ---------------------
1835 function Standard_Output return File_Type is
1837 return Standard_Out;
1838 end Standard_Output;
1840 function Standard_Output return File_Access is
1842 return Standard_Out'Access;
1843 end Standard_Output;
1845 --------------------
1846 -- Terminate_Line --
1847 --------------------
1849 procedure Terminate_Line (File : File_Type) is
1851 FIO.Check_File_Open (AP (File));
1853 -- For file other than In_File, test for needing to terminate last line
1855 if Mode (File) /= In_File then
1857 -- If not at start of line definition need new line
1859 if File.Col /= 1 then
1862 -- For files other than standard error and standard output, we
1863 -- make sure that an empty file has a single line feed, so that
1864 -- it is properly formatted. We avoid this for the standard files
1865 -- because it is too much of a nuisance to have these odd line
1866 -- feeds when nothing has been written to the file.
1868 elsif (File /= Standard_Err and then File /= Standard_Out)
1869 and then (File.Line = 1 and then File.Page = 1)
1880 procedure Ungetc (ch : int; File : File_Type) is
1883 if ungetc (ch, File.Stream) = EOF then
1893 -- This is the primitive Stream Write routine, used when a Text_IO file
1894 -- is treated directly as a stream using Text_IO.Streams.Stream.
1897 (File : in out Wide_Wide_Text_AFCB;
1898 Item : Stream_Element_Array)
1900 pragma Warnings (Off, File);
1901 -- Because in this implementation we don't need IN OUT, we only read
1903 Siz : constant size_t := Item'Length;
1906 if File.Mode = FCB.In_File then
1910 -- Now we do the write. Since this is a text file, it is normally in
1911 -- text mode, but stream data must be written in binary mode, so we
1912 -- temporarily set binary mode for the write, resetting it after.
1913 -- These calls have no effect in a system (like Unix) where there is
1914 -- no distinction between text and binary files.
1916 set_binary_mode (fileno (File.Stream));
1918 if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then
1922 set_text_mode (fileno (File.Stream));
1926 -- Initialize Standard Files
1928 for J in WC_Encoding_Method loop
1929 if WC_Encoding = WC_Encoding_Letters (J) then
1934 Initialize_Standard_Files;
1936 FIO.Chain_File (AP (Standard_In));
1937 FIO.Chain_File (AP (Standard_Out));
1938 FIO.Chain_File (AP (Standard_Err));
1940 end Ada.Wide_Wide_Text_IO;