1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . T E X T _ I O --
9 -- Copyright (C) 1992-2016, 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
.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_Upper_Half_Char
86 File
: File_Type
) return Character;
87 -- This function is shared by Get and Get_Immediate to extract an encoded
88 -- upper half character value from the given File. The first byte has
89 -- already been read and is passed in C. The character value is returned as
90 -- the result, and the file pointer is bumped past the character.
91 -- Constraint_Error is raised if the encoded value is outside the bounds of
94 function Get_Upper_Half_Char_Immed
96 File
: File_Type
) return Character;
97 -- This routine is identical to Get_Upper_Half_Char, except that the reads
98 -- are done in Get_Immediate mode (i.e. without waiting for a line return).
100 function Getc
(File
: File_Type
) return int
;
101 -- Gets next character from file, which has already been checked for being
102 -- in read status, and returns the character read if no error occurs. The
103 -- result is EOF if the end of file was read.
105 function Getc_Immed
(File
: File_Type
) return int
;
106 -- This routine is identical to Getc, except that the read is done in
107 -- Get_Immediate mode (i.e. without waiting for a line return).
109 function Has_Upper_Half_Character
(Item
: String) return Boolean;
110 -- Returns True if any of the characters is in the range 16#80#-16#FF#
112 function Nextc
(File
: File_Type
) return int
;
113 -- Returns next character from file without skipping past it (i.e. it is a
114 -- combination of Getc followed by an Ungetc).
116 procedure Put_Encoded
(File
: File_Type
; Char
: Character);
117 -- Called to output a character Char to the given File, when the encoding
118 -- method for the file is other than brackets, and Char is upper half.
120 procedure Putc
(ch
: int
; File
: File_Type
);
121 -- Outputs the given character to the file, which has already been checked
122 -- for being in output status. Device_Error is raised if the character
123 -- cannot be written.
125 procedure Set_WCEM
(File
: in out File_Type
);
126 -- Called by Open and Create to set the wide character encoding method for
127 -- the file, processing a WCEM form parameter if one is present. File is
128 -- IN OUT because it may be closed in case of an error.
130 procedure Terminate_Line
(File
: File_Type
);
131 -- If the file is in Write_File or Append_File mode, and the current line
132 -- is not terminated, then a line terminator is written using New_Line.
133 -- Note that there is no Terminate_Page routine, because the page mark at
134 -- the end of the file is implied if necessary.
136 procedure Ungetc
(ch
: int
; File
: File_Type
);
137 -- Pushes back character into stream, using ungetc. The caller has checked
138 -- that the file is in read status. Device_Error is raised if the character
139 -- cannot be pushed back. An attempt to push back and end of file character
146 function AFCB_Allocate
(Control_Block
: Text_AFCB
) return FCB
.AFCB_Ptr
is
147 pragma Unreferenced
(Control_Block
);
149 return new Text_AFCB
;
156 procedure AFCB_Close
(File
: not null access Text_AFCB
) is
158 -- If the file being closed is one of the current files, then close
159 -- the corresponding current file. It is not clear that this action
160 -- is required (RM A.10.3(23)) but it seems reasonable, and besides
161 -- ACVC test CE3208A expects this behavior.
163 if File_Type
(File
) = Current_In
then
165 elsif File_Type
(File
) = Current_Out
then
167 elsif File_Type
(File
) = Current_Err
then
171 Terminate_Line
(File_Type
(File
));
178 procedure AFCB_Free
(File
: not null access Text_AFCB
) is
179 type FCB_Ptr
is access all Text_AFCB
;
180 FT
: FCB_Ptr
:= FCB_Ptr
(File
);
182 procedure Free
is new Ada
.Unchecked_Deallocation
(Text_AFCB
, FCB_Ptr
);
192 procedure Close
(File
: in out File_Type
) is
194 FIO
.Close
(AP
(File
)'Unrestricted_Access);
201 -- Note: we assume that it is impossible in practice for the column
202 -- to exceed the value of Count'Last, i.e. no check is required for
203 -- overflow raising layout error.
205 function Col
(File
: File_Type
) return Positive_Count
is
207 FIO
.Check_File_Open
(AP
(File
));
211 function Col
return Positive_Count
is
213 return Col
(Current_Out
);
221 (File
: in out File_Type
;
222 Mode
: File_Mode
:= Out_File
;
226 Dummy_File_Control_Block
: Text_AFCB
;
227 pragma Warnings
(Off
, Dummy_File_Control_Block
);
228 -- Yes, we know this is never assigned a value, only the tag
229 -- is used for dispatching purposes, so that's expected.
232 FIO
.Open
(File_Ptr
=> AP
(File
),
233 Dummy_FCB
=> Dummy_File_Control_Block
,
234 Mode
=> To_FCB
(Mode
),
249 function Current_Error
return File_Type
is
254 function Current_Error
return File_Access
is
256 return Current_Err
.Self
'Access;
263 function Current_Input
return File_Type
is
268 function Current_Input
return File_Access
is
270 return Current_In
.Self
'Access;
277 function Current_Output
return File_Type
is
282 function Current_Output
return File_Access
is
284 return Current_Out
.Self
'Access;
291 procedure Delete
(File
: in out File_Type
) is
293 FIO
.Delete
(AP
(File
)'Unrestricted_Access);
300 function End_Of_File
(File
: File_Type
) return Boolean is
304 FIO
.Check_Read_Status
(AP
(File
));
306 if File
.Before_Upper_Half_Character
then
309 elsif File
.Before_LM
then
310 if File
.Before_LM_PM
then
311 return Nextc
(File
) = EOF
;
325 File
.Before_LM
:= True;
329 -- Here we are just past the line mark with Before_LM set so that we
330 -- do not have to try to back up past the LM, thus avoiding the need
331 -- to back up more than one character.
338 elsif ch
= PM
and then File
.Is_Regular_File
then
339 File
.Before_LM_PM
:= True;
340 return Nextc
(File
) = EOF
;
342 -- Here if neither EOF nor PM followed end of line
351 function End_Of_File
return Boolean is
353 return End_Of_File
(Current_In
);
360 function End_Of_Line
(File
: File_Type
) return Boolean is
364 FIO
.Check_Read_Status
(AP
(File
));
366 if File
.Before_Upper_Half_Character
then
369 elsif File
.Before_LM
then
385 function End_Of_Line
return Boolean is
387 return End_Of_Line
(Current_In
);
394 function End_Of_Page
(File
: File_Type
) return Boolean is
398 FIO
.Check_Read_Status
(AP
(File
));
400 if not File
.Is_Regular_File
then
403 elsif File
.Before_Upper_Half_Character
then
406 elsif File
.Before_LM
then
407 if File
.Before_LM_PM
then
422 File
.Before_LM
:= True;
426 -- Here we are just past the line mark with Before_LM set so that we
427 -- do not have to try to back up past the LM, thus avoiding the need
428 -- to back up more than one character.
432 return ch
= PM
or else ch
= EOF
;
435 function End_Of_Page
return Boolean is
437 return End_Of_Page
(Current_In
);
444 function EOF_Char
return Integer is
453 procedure Flush
(File
: File_Type
) is
455 FIO
.Flush
(AP
(File
));
467 function Form
(File
: File_Type
) return String is
469 return FIO
.Form
(AP
(File
));
478 Item
: out Character)
483 FIO
.Check_Read_Status
(AP
(File
));
485 if File
.Before_Upper_Half_Character
then
486 File
.Before_Upper_Half_Character
:= False;
487 Item
:= File
.Saved_Upper_Half_Character
;
489 elsif File
.Before_LM
then
490 File
.Before_LM
:= False;
493 if File
.Before_LM_PM
then
495 File
.Page
:= File
.Page
+ 1;
496 File
.Before_LM_PM
:= False;
498 File
.Line
:= File
.Line
+ 1;
509 File
.Line
:= File
.Line
+ 1;
512 elsif ch
= PM
and then File
.Is_Regular_File
then
513 File
.Page
:= File
.Page
+ 1;
517 Item
:= Character'Val (ch
);
518 File
.Col
:= File
.Col
+ 1;
524 procedure Get
(Item
: out Character) is
526 Get
(Current_In
, Item
);
537 FIO
.Check_Read_Status
(AP
(File
));
539 if File
.Before_LM
then
540 File
.Before_LM
:= False;
541 File
.Before_LM_PM
:= False;
544 if File
.Before_LM_PM
then
546 File
.Page
:= File
.Page
+ 1;
547 File
.Before_LM_PM
:= False;
550 File
.Line
:= File
.Line
+ 1;
555 while J
<= Item
'Last loop
562 File
.Line
:= File
.Line
+ 1;
565 elsif ch
= PM
and then File
.Is_Regular_File
then
566 File
.Page
:= File
.Page
+ 1;
570 Item
(J
) := Character'Val (ch
);
572 File
.Col
:= File
.Col
+ 1;
577 procedure Get
(Item
: out String) is
579 Get
(Current_In
, Item
);
586 procedure Get_Immediate
588 Item
: out Character)
593 FIO
.Check_Read_Status
(AP
(File
));
595 if File
.Before_Upper_Half_Character
then
596 File
.Before_Upper_Half_Character
:= False;
597 Item
:= File
.Saved_Upper_Half_Character
;
599 elsif File
.Before_LM
then
600 File
.Before_LM
:= False;
601 File
.Before_LM_PM
:= False;
602 Item
:= Character'Val (LM
);
605 ch
:= Getc_Immed
(File
);
611 (if not Is_Start_Of_Encoding
(Character'Val (ch
), File
.WC_Method
)
612 then Character'Val (ch
)
613 else Get_Upper_Half_Char_Immed
(Character'Val (ch
), File
));
618 procedure Get_Immediate
619 (Item
: out Character)
622 Get_Immediate
(Current_In
, Item
);
625 procedure Get_Immediate
627 Item
: out Character;
628 Available
: out Boolean)
634 procedure getc_immediate_nowait
637 end_of_file
: out int
;
639 pragma Import
(C
, getc_immediate_nowait
, "getc_immediate_nowait");
642 FIO
.Check_Read_Status
(AP
(File
));
645 if File
.Before_Upper_Half_Character
then
646 File
.Before_Upper_Half_Character
:= False;
647 Item
:= File
.Saved_Upper_Half_Character
;
649 elsif File
.Before_LM
then
650 File
.Before_LM
:= False;
651 File
.Before_LM_PM
:= False;
652 Item
:= Character'Val (LM
);
655 getc_immediate_nowait
(File
.Stream
, ch
, end_of_file
, avail
);
657 if ferror
(File
.Stream
) /= 0 then
660 elsif end_of_file
/= 0 then
671 (if Is_Start_Of_Encoding
(Character'Val (ch
), File
.WC_Method
)
672 then Character'Val (ch
)
673 else Get_Upper_Half_Char_Immed
(Character'Val (ch
), File
));
679 procedure Get_Immediate
680 (Item
: out Character;
681 Available
: out Boolean)
684 Get_Immediate
(Current_In
, Item
, Available
);
694 Last
: out Natural) is separate;
695 -- The implementation of Ada.Text_IO.Get_Line is split into a subunit so
696 -- that different implementations can be used on different systems.
703 Get_Line
(Current_In
, Item
, Last
);
706 function Get_Line
(File
: File_Type
) return String is
707 function Get_Rest
(S
: String) return String;
708 -- This is a recursive function that reads the rest of the line and
709 -- returns it. S is the part read so far.
715 function Get_Rest
(S
: String) return String is
717 -- Each time we allocate a buffer the same size as what we have
718 -- read so far. This limits us to a logarithmic number of calls
719 -- to Get_Rest and also ensures only a linear use of stack space.
721 Buffer
: String (1 .. S
'Length);
725 Get_Line
(File
, Buffer
, Last
);
728 R
: constant String := S
& Buffer
(1 .. Last
);
730 if Last
< Buffer
'Last then
741 Buffer
: String (1 .. 500);
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 -- If the String has the same length as the buffer, and there is no end
754 -- of line, check whether we are at the end of file, in which case we
755 -- have the full String in the buffer.
757 elsif Last
= Buffer
'Last then
765 return Get_Rest
(Buffer
(1 .. Last
));
769 return Get_Rest
(Buffer
(1 .. Last
));
773 function Get_Line
return String is
775 return Get_Line
(Current_In
);
778 -------------------------
779 -- Get_Upper_Half_Char --
780 -------------------------
782 function Get_Upper_Half_Char
784 File
: File_Type
) return Character
786 Result
: Wide_Character;
788 function In_Char
return Character;
789 -- Function used to obtain additional characters it the wide character
790 -- sequence is more than one character long.
792 function WC_In
is new Char_Sequence_To_Wide_Char
(In_Char
);
798 function In_Char
return Character is
799 ch
: constant Integer := Getc
(File
);
804 return Character'Val (ch
);
808 -- Start of processing for Get_Upper_Half_Char
811 Result
:= WC_In
(C
, File
.WC_Method
);
813 if Wide_Character'Pos (Result
) > 16#FF#
then
814 raise Constraint_Error
with
815 "invalid wide character in Text_'I'O input";
817 return Character'Val (Wide_Character'Pos (Result
));
819 end Get_Upper_Half_Char
;
821 -------------------------------
822 -- Get_Upper_Half_Char_Immed --
823 -------------------------------
825 function Get_Upper_Half_Char_Immed
827 File
: File_Type
) return Character
829 Result
: Wide_Character;
831 function In_Char
return Character;
832 -- Function used to obtain additional characters it the wide character
833 -- sequence is more than one character long.
835 function WC_In
is new Char_Sequence_To_Wide_Char
(In_Char
);
841 function In_Char
return Character is
842 ch
: constant Integer := Getc_Immed
(File
);
847 return Character'Val (ch
);
851 -- Start of processing for Get_Upper_Half_Char_Immed
854 Result
:= WC_In
(C
, File
.WC_Method
);
856 if Wide_Character'Pos (Result
) > 16#FF#
then
857 raise Constraint_Error
with
858 "invalid wide character in Text_'I'O input";
860 return Character'Val (Wide_Character'Pos (Result
));
862 end Get_Upper_Half_Char_Immed
;
868 function Getc
(File
: File_Type
) return int
is
872 ch
:= fgetc
(File
.Stream
);
874 if ch
= EOF
and then ferror
(File
.Stream
) /= 0 then
885 function Getc_Immed
(File
: File_Type
) return int
is
889 procedure getc_immediate
890 (stream
: FILEs
; ch
: out int
; end_of_file
: out int
);
891 pragma Import
(C
, getc_immediate
, "getc_immediate");
894 FIO
.Check_Read_Status
(AP
(File
));
896 if File
.Before_LM
then
897 File
.Before_LM
:= False;
898 File
.Before_LM_PM
:= False;
902 getc_immediate
(File
.Stream
, ch
, end_of_file
);
904 if ferror
(File
.Stream
) /= 0 then
906 elsif end_of_file
/= 0 then
914 ------------------------------
915 -- Has_Upper_Half_Character --
916 ------------------------------
918 function Has_Upper_Half_Character
(Item
: String) return Boolean is
920 for J
in Item
'Range loop
921 if Character'Pos (Item
(J
)) >= 16#
80#
then
927 end Has_Upper_Half_Character
;
929 -------------------------------
930 -- Initialize_Standard_Files --
931 -------------------------------
933 procedure Initialize_Standard_Files
is
935 Standard_Err
.Stream
:= stderr
;
936 Standard_Err
.Name
:= Err_Name
'Access;
937 Standard_Err
.Form
:= Null_Str
'Unrestricted_Access;
938 Standard_Err
.Mode
:= FCB
.Out_File
;
939 Standard_Err
.Is_Regular_File
:= is_regular_file
(fileno
(stderr
)) /= 0;
940 Standard_Err
.Is_Temporary_File
:= False;
941 Standard_Err
.Is_System_File
:= True;
942 Standard_Err
.Text_Encoding
:= Default_Text
;
943 Standard_Err
.Access_Method
:= 'T';
944 Standard_Err
.Self
:= Standard_Err
;
945 Standard_Err
.WC_Method
:= Default_WCEM
;
947 Standard_In
.Stream
:= stdin
;
948 Standard_In
.Name
:= In_Name
'Access;
949 Standard_In
.Form
:= Null_Str
'Unrestricted_Access;
950 Standard_In
.Mode
:= FCB
.In_File
;
951 Standard_In
.Is_Regular_File
:= is_regular_file
(fileno
(stdin
)) /= 0;
952 Standard_In
.Is_Temporary_File
:= False;
953 Standard_In
.Is_System_File
:= True;
954 Standard_In
.Text_Encoding
:= Default_Text
;
955 Standard_In
.Access_Method
:= 'T';
956 Standard_In
.Self
:= Standard_In
;
957 Standard_In
.WC_Method
:= Default_WCEM
;
959 Standard_Out
.Stream
:= stdout
;
960 Standard_Out
.Name
:= Out_Name
'Access;
961 Standard_Out
.Form
:= Null_Str
'Unrestricted_Access;
962 Standard_Out
.Mode
:= FCB
.Out_File
;
963 Standard_Out
.Is_Regular_File
:= is_regular_file
(fileno
(stdout
)) /= 0;
964 Standard_Out
.Is_Temporary_File
:= False;
965 Standard_Out
.Is_System_File
:= True;
966 Standard_Out
.Text_Encoding
:= Default_Text
;
967 Standard_Out
.Access_Method
:= 'T';
968 Standard_Out
.Self
:= Standard_Out
;
969 Standard_Out
.WC_Method
:= Default_WCEM
;
971 FIO
.Make_Unbuffered
(AP
(Standard_Out
));
972 FIO
.Make_Unbuffered
(AP
(Standard_Err
));
973 end Initialize_Standard_Files
;
979 function Is_Open
(File
: File_Type
) return Boolean is
981 return FIO
.Is_Open
(AP
(File
));
988 -- Note: we assume that it is impossible in practice for the line
989 -- to exceed the value of Count'Last, i.e. no check is required for
990 -- overflow raising layout error.
992 function Line
(File
: File_Type
) return Positive_Count
is
994 FIO
.Check_File_Open
(AP
(File
));
998 function Line
return Positive_Count
is
1000 return Line
(Current_Out
);
1007 function Line_Length
(File
: File_Type
) return Count
is
1009 FIO
.Check_Write_Status
(AP
(File
));
1010 return File
.Line_Length
;
1013 function Line_Length
return Count
is
1015 return Line_Length
(Current_Out
);
1022 procedure Look_Ahead
1024 Item
: out Character;
1025 End_Of_Line
: out Boolean)
1030 FIO
.Check_Read_Status
(AP
(File
));
1032 -- If we are logically before a line mark, we can return immediately
1034 if File
.Before_LM
then
1035 End_Of_Line
:= True;
1038 -- If we are before an upper half character just return it (this can
1039 -- happen if there are two calls to Look_Ahead in a row).
1041 elsif File
.Before_Upper_Half_Character
then
1042 End_Of_Line
:= False;
1043 Item
:= File
.Saved_Upper_Half_Character
;
1045 -- Otherwise we must read a character from the input stream
1052 or else (ch
= PM
and then File
.Is_Regular_File
)
1054 End_Of_Line
:= True;
1058 -- Case where character obtained does not represent the start of an
1059 -- encoded sequence so it stands for itself and we can unget it with
1062 elsif not Is_Start_Of_Encoding
1063 (Character'Val (ch
), File
.WC_Method
)
1065 End_Of_Line
:= False;
1067 Item
:= Character'Val (ch
);
1069 -- For the start of an encoding, we read the character using the
1070 -- Get_Upper_Half_Char routine. It will occupy more than one byte
1071 -- so we can't put it back with ungetc. Instead we save it in the
1072 -- control block, setting a flag that everyone interested in reading
1073 -- characters must test before reading the stream.
1076 Item
:= Get_Upper_Half_Char
(Character'Val (ch
), File
);
1077 End_Of_Line
:= False;
1078 File
.Saved_Upper_Half_Character
:= Item
;
1079 File
.Before_Upper_Half_Character
:= True;
1084 procedure Look_Ahead
1085 (Item
: out Character;
1086 End_Of_Line
: out Boolean)
1089 Look_Ahead
(Current_In
, Item
, End_Of_Line
);
1096 function Mode
(File
: File_Type
) return File_Mode
is
1098 return To_TIO
(FIO
.Mode
(AP
(File
)));
1105 function Name
(File
: File_Type
) return String is
1107 return FIO
.Name
(AP
(File
));
1116 Spacing
: Positive_Count
:= 1)
1119 -- Raise Constraint_Error if out of range value. The reason for this
1120 -- explicit test is that we don't want junk values around, even if
1121 -- checks are off in the caller.
1123 if not Spacing
'Valid then
1124 raise Constraint_Error
;
1127 FIO
.Check_Write_Status
(AP
(File
));
1129 for K
in 1 .. Spacing
loop
1131 File
.Line
:= File
.Line
+ 1;
1133 if File
.Page_Length
/= 0
1134 and then File
.Line
> File
.Page_Length
1138 File
.Page
:= File
.Page
+ 1;
1145 procedure New_Line
(Spacing
: Positive_Count
:= 1) is
1147 New_Line
(Current_Out
, Spacing
);
1154 procedure New_Page
(File
: File_Type
) is
1156 FIO
.Check_Write_Status
(AP
(File
));
1158 if File
.Col
/= 1 or else File
.Line
= 1 then
1163 File
.Page
:= File
.Page
+ 1;
1168 procedure New_Page
is
1170 New_Page
(Current_Out
);
1177 function Nextc
(File
: File_Type
) return int
is
1181 ch
:= fgetc
(File
.Stream
);
1184 if ferror
(File
.Stream
) /= 0 then
1189 if ungetc
(ch
, File
.Stream
) = EOF
then
1202 (File
: in out File_Type
;
1205 Form
: String := "")
1207 Dummy_File_Control_Block
: Text_AFCB
;
1208 pragma Warnings
(Off
, Dummy_File_Control_Block
);
1209 -- Yes, we know this is never assigned a value, only the tag
1210 -- is used for dispatching purposes, so that's expected.
1213 FIO
.Open
(File_Ptr
=> AP
(File
),
1214 Dummy_FCB
=> Dummy_File_Control_Block
,
1215 Mode
=> To_FCB
(Mode
),
1230 -- Note: we assume that it is impossible in practice for the page
1231 -- to exceed the value of Count'Last, i.e. no check is required for
1232 -- overflow raising layout error.
1234 function Page
(File
: File_Type
) return Positive_Count
is
1236 FIO
.Check_File_Open
(AP
(File
));
1240 function Page
return Positive_Count
is
1242 return Page
(Current_Out
);
1249 function Page_Length
(File
: File_Type
) return Count
is
1251 FIO
.Check_Write_Status
(AP
(File
));
1252 return File
.Page_Length
;
1255 function Page_Length
return Count
is
1257 return Page_Length
(Current_Out
);
1269 FIO
.Check_Write_Status
(AP
(File
));
1271 if File
.Line_Length
/= 0 and then File
.Col
> File
.Line_Length
then
1275 -- If lower half character, or brackets encoding, output directly
1277 if Character'Pos (Item
) < 16#
80#
1278 or else File
.WC_Method
= WCEM_Brackets
1280 if fputc
(Character'Pos (Item
), File
.Stream
) = EOF
then
1284 -- Case of upper half character with non-brackets encoding
1287 Put_Encoded
(File
, Item
);
1290 File
.Col
:= File
.Col
+ 1;
1293 procedure Put
(Item
: Character) is
1295 Put
(Current_Out
, Item
);
1307 FIO
.Check_Write_Status
(AP
(File
));
1309 -- Only have something to do if string is non-null
1311 if Item
'Length > 0 then
1313 -- If we have bounded lines, or if the file encoding is other than
1314 -- Brackets and the string has at least one upper half character,
1315 -- then output the string character by character.
1317 if File
.Line_Length
/= 0
1318 or else (File
.WC_Method
/= WCEM_Brackets
1319 and then Has_Upper_Half_Character
(Item
))
1321 for J
in Item
'Range loop
1322 Put
(File
, Item
(J
));
1325 -- Otherwise we can output the entire string at once. Note that if
1326 -- there are LF or FF characters in the string, we do not bother to
1327 -- count them as line or page terminators.
1330 FIO
.Write_Buf
(AP
(File
), Item
'Address, Item
'Length);
1331 File
.Col
:= File
.Col
+ Item
'Length;
1336 procedure Put
(Item
: String) is
1338 Put
(Current_Out
, Item
);
1345 procedure Put_Encoded
(File
: File_Type
; Char
: Character) is
1346 procedure Out_Char
(C
: Character);
1347 -- Procedure to output one character of an upper half encoded sequence
1349 procedure WC_Out
is new Wide_Char_To_Char_Sequence
(Out_Char
);
1355 procedure Out_Char
(C
: Character) is
1357 Putc
(Character'Pos (C
), File
);
1360 -- Start of processing for Put_Encoded
1363 WC_Out
(Wide_Character'Val (Character'Pos (Char
)), File
.WC_Method
);
1374 Ilen
: Natural := Item
'Length;
1375 Istart
: Natural := Item
'First;
1378 FIO
.Check_Write_Status
(AP
(File
));
1380 -- If we have bounded lines, or if the file encoding is other than
1381 -- Brackets and the string has at least one upper half character, then
1382 -- output the string character by character.
1384 if File
.Line_Length
/= 0
1385 or else (File
.WC_Method
/= WCEM_Brackets
1386 and then Has_Upper_Half_Character
(Item
))
1388 for J
in Item
'Range loop
1389 Put
(File
, Item
(J
));
1396 -- Normal case where we do not need to output character by character
1398 -- We setup a single string that has the necessary terminators and
1399 -- then write it with a single call. The reason for doing this is
1400 -- that it gives better behavior for the use of Put_Line in multi-
1401 -- tasking programs, since often the OS will treat the entire put
1402 -- operation as an atomic operation.
1404 -- We only do this if the message is 512 characters or less in length,
1405 -- since otherwise Put_Line would use an unbounded amount of stack
1406 -- space and could cause undetected stack overflow. If we have a
1407 -- longer string, then output the first part separately to avoid this.
1410 FIO
.Write_Buf
(AP
(File
), Item
'Address, size_t
(Ilen
- 512));
1411 Istart
:= Istart
+ Ilen
- 512;
1415 -- Now prepare the string with its terminator
1418 Buffer
: String (1 .. Ilen
+ 2);
1422 Buffer
(1 .. Ilen
) := Item
(Istart
.. Item
'Last);
1423 Buffer
(Ilen
+ 1) := Character'Val (LM
);
1425 if File
.Page_Length
/= 0
1426 and then File
.Line
> File
.Page_Length
1428 Buffer
(Ilen
+ 2) := Character'Val (PM
);
1429 Plen
:= size_t
(Ilen
) + 2;
1431 File
.Page
:= File
.Page
+ 1;
1434 Plen
:= size_t
(Ilen
) + 1;
1435 File
.Line
:= File
.Line
+ 1;
1438 FIO
.Write_Buf
(AP
(File
), Buffer
'Address, Plen
);
1444 procedure Put_Line
(Item
: String) is
1446 Put_Line
(Current_Out
, Item
);
1453 procedure Putc
(ch
: int
; File
: File_Type
) is
1455 if fputc
(ch
, File
.Stream
) = EOF
then
1464 -- This is the primitive Stream Read routine, used when a Text_IO file
1465 -- is treated directly as a stream using Text_IO.Streams.Stream.
1468 (File
: in out Text_AFCB
;
1469 Item
: out Stream_Element_Array
;
1470 Last
: out Stream_Element_Offset
)
1473 pragma Warnings
(Off
, Discard_ch
);
1476 -- Need to deal with Before_Upper_Half_Character ???
1478 if File
.Mode
/= FCB
.In_File
then
1482 -- Deal with case where our logical and physical position do not match
1483 -- because of being after an LM or LM-PM sequence when in fact we are
1484 -- logically positioned before it.
1486 if File
.Before_LM
then
1488 -- If we are before a PM, then it is possible for a stream read
1489 -- to leave us after the LM and before the PM, which is a bit
1490 -- odd. The easiest way to deal with this is to unget the PM,
1491 -- so we are indeed positioned between the characters. This way
1492 -- further stream read operations will work correctly, and the
1493 -- effect on text processing is a little weird, but what can
1494 -- be expected if stream and text input are mixed this way?
1496 if File
.Before_LM_PM
then
1497 Discard_ch
:= ungetc
(PM
, File
.Stream
);
1498 File
.Before_LM_PM
:= False;
1501 File
.Before_LM
:= False;
1503 Item
(Item
'First) := Stream_Element
(Character'Pos (ASCII
.LF
));
1505 if Item
'Length = 1 then
1511 Stream_Element_Offset
1512 (fread
(buffer
=> Item
'Address,
1513 index
=> size_t
(Item
'First + 1),
1515 count
=> Item
'Length - 1,
1516 stream
=> File
.Stream
));
1522 -- Now we do the read. Since this is a text file, it is normally in
1523 -- text mode, but stream data must be read in binary mode, so we
1524 -- temporarily set binary mode for the read, resetting it after.
1525 -- These calls have no effect in a system (like Unix) where there is
1526 -- no distinction between text and binary files.
1528 set_binary_mode
(fileno
(File
.Stream
));
1532 Stream_Element_Offset
1533 (fread
(Item
'Address, 1, Item
'Length, File
.Stream
)) - 1;
1535 if Last
< Item
'Last then
1536 if ferror
(File
.Stream
) /= 0 then
1541 set_text_mode
(fileno
(File
.Stream
));
1549 (File
: in out File_Type
;
1553 -- Don't allow change of mode for current file (RM A.10.2(5))
1555 if (File
= Current_In
or else
1556 File
= Current_Out
or else
1557 File
= Current_Error
)
1558 and then To_FCB
(Mode
) /= File
.Mode
1563 Terminate_Line
(File
);
1564 FIO
.Reset
(AP
(File
)'Unrestricted_Access, To_FCB
(Mode
));
1568 File
.Line_Length
:= 0;
1569 File
.Page_Length
:= 0;
1570 File
.Before_LM
:= False;
1571 File
.Before_LM_PM
:= False;
1574 procedure Reset
(File
: in out File_Type
) is
1576 Terminate_Line
(File
);
1577 FIO
.Reset
(AP
(File
)'Unrestricted_Access);
1581 File
.Line_Length
:= 0;
1582 File
.Page_Length
:= 0;
1583 File
.Before_LM
:= False;
1584 File
.Before_LM_PM
:= False;
1593 To
: Positive_Count
)
1598 -- Raise Constraint_Error if out of range value. The reason for this
1599 -- explicit test is that we don't want junk values around, even if
1600 -- checks are off in the caller.
1602 if not To
'Valid then
1603 raise Constraint_Error
;
1606 FIO
.Check_File_Open
(AP
(File
));
1610 if Mode
(File
) >= Out_File
then
1612 -- Error if we attempt to set Col to a value greater than the
1613 -- maximum permissible line length.
1615 if File
.Line_Length
/= 0 and then To
> File
.Line_Length
then
1619 -- If we are behind current position, then go to start of new line
1621 if To
< File
.Col
then
1625 -- Loop to output blanks till we are at the required column
1627 while File
.Col
< To
loop
1634 -- If we are logically before a LM, but physically after it, the
1635 -- file position still reflects the position before the LM, so eat
1636 -- it now and adjust the file position appropriately.
1638 if File
.Before_LM
then
1639 File
.Before_LM
:= False;
1640 File
.Before_LM_PM
:= False;
1641 File
.Line
:= File
.Line
+ 1;
1645 -- Loop reading characters till we get one at the required Col value
1648 -- Read next character. The reason we have to read ahead is to
1649 -- skip formatting characters, the effect of Set_Col is to set
1650 -- us to a real character with the right Col value, and format
1651 -- characters don't count.
1655 -- Error if we hit an end of file
1660 -- If line mark, eat it and adjust file position
1663 File
.Line
:= File
.Line
+ 1;
1666 -- If recognized page mark, eat it, and adjust file position
1668 elsif ch
= PM
and then File
.Is_Regular_File
then
1669 File
.Page
:= File
.Page
+ 1;
1673 -- Otherwise this is the character we are looking for, so put it
1674 -- back in the input stream (we have not adjusted the file
1675 -- position yet, so everything is set right after this ungetc).
1677 elsif To
= File
.Col
then
1681 -- Keep skipping characters if we are not there yet, updating the
1682 -- file position past the skipped character.
1685 File
.Col
:= File
.Col
+ 1;
1691 procedure Set_Col
(To
: Positive_Count
) is
1693 Set_Col
(Current_Out
, To
);
1700 procedure Set_Error
(File
: File_Type
) is
1702 FIO
.Check_Write_Status
(AP
(File
));
1703 Current_Err
:= File
;
1710 procedure Set_Input
(File
: File_Type
) is
1712 FIO
.Check_Read_Status
(AP
(File
));
1722 To
: Positive_Count
)
1725 -- Raise Constraint_Error if out of range value. The reason for this
1726 -- explicit test is that we don't want junk values around, even if
1727 -- checks are off in the caller.
1729 if not To
'Valid then
1730 raise Constraint_Error
;
1733 FIO
.Check_File_Open
(AP
(File
));
1735 if To
= File
.Line
then
1739 if Mode
(File
) >= Out_File
then
1740 if File
.Page_Length
/= 0 and then To
> File
.Page_Length
then
1744 if To
< File
.Line
then
1748 while File
.Line
< To
loop
1753 while To
/= File
.Line
loop
1759 procedure Set_Line
(To
: Positive_Count
) is
1761 Set_Line
(Current_Out
, To
);
1764 ---------------------
1765 -- Set_Line_Length --
1766 ---------------------
1768 procedure Set_Line_Length
(File
: File_Type
; To
: Count
) is
1770 -- Raise Constraint_Error if out of range value. The reason for this
1771 -- explicit test is that we don't want junk values around, even if
1772 -- checks are off in the caller.
1774 if not To
'Valid then
1775 raise Constraint_Error
;
1778 FIO
.Check_Write_Status
(AP
(File
));
1779 File
.Line_Length
:= To
;
1780 end Set_Line_Length
;
1782 procedure Set_Line_Length
(To
: Count
) is
1784 Set_Line_Length
(Current_Out
, To
);
1785 end Set_Line_Length
;
1791 procedure Set_Output
(File
: File_Type
) is
1793 FIO
.Check_Write_Status
(AP
(File
));
1794 Current_Out
:= File
;
1797 ---------------------
1798 -- Set_Page_Length --
1799 ---------------------
1801 procedure Set_Page_Length
(File
: File_Type
; To
: Count
) is
1803 -- Raise Constraint_Error if out of range value. The reason for this
1804 -- explicit test is that we don't want junk values around, even if
1805 -- checks are off in the caller.
1807 if not To
'Valid then
1808 raise Constraint_Error
;
1811 FIO
.Check_Write_Status
(AP
(File
));
1812 File
.Page_Length
:= To
;
1813 end Set_Page_Length
;
1815 procedure Set_Page_Length
(To
: Count
) is
1817 Set_Page_Length
(Current_Out
, To
);
1818 end Set_Page_Length
;
1824 procedure Set_WCEM
(File
: in out File_Type
) is
1829 File
.WC_Method
:= WCEM_Brackets
;
1830 FIO
.Form_Parameter
(File
.Form
.all, "wcem", Start
, Stop
);
1833 File
.WC_Method
:= WCEM_Brackets
;
1836 if Stop
= Start
then
1837 for J
in WC_Encoding_Letters
'Range loop
1838 if File
.Form
(Start
) = WC_Encoding_Letters
(J
) then
1839 File
.WC_Method
:= J
;
1846 raise Use_Error
with "invalid WCEM form parameter";
1856 Spacing
: Positive_Count
:= 1)
1861 -- Raise Constraint_Error if out of range value. The reason for this
1862 -- explicit test is that we don't want junk values around, even if
1863 -- checks are off in the caller.
1865 if not Spacing
'Valid then
1866 raise Constraint_Error
;
1869 FIO
.Check_Read_Status
(AP
(File
));
1871 for L
in 1 .. Spacing
loop
1872 if File
.Before_LM
then
1873 File
.Before_LM
:= False;
1875 -- Note that if File.Before_LM_PM is currently set, we also have
1876 -- to reset it (because it makes sense for Before_LM_PM to be set
1877 -- only when Before_LM is also set). This is done later on in this
1878 -- subprogram, as soon as Before_LM_PM has been taken into account
1879 -- for the purpose of page and line counts.
1884 -- If at end of file now, then immediately raise End_Error. Note
1885 -- that we can never be positioned between a line mark and a page
1886 -- mark, so if we are at the end of file, we cannot logically be
1887 -- before the implicit page mark that is at the end of the file.
1889 -- For the same reason, we do not need an explicit check for a
1890 -- page mark. If there is a FF in the middle of a line, the file
1891 -- is not in canonical format and we do not care about the page
1892 -- numbers for files other than ones in canonical format.
1898 -- If not at end of file, then loop till we get to an LM or EOF.
1899 -- The latter case happens only in non-canonical files where the
1900 -- last line is not terminated by LM, but we don't want to blow
1901 -- up for such files, so we assume an implicit LM in this case.
1904 exit when ch
= LM
or else ch
= EOF
;
1909 -- We have got past a line mark, now, for a regular file only,
1910 -- see if a page mark immediately follows this line mark and
1911 -- if so, skip past the page mark as well. We do not do this
1912 -- for non-regular files, since it would cause an undesirable
1913 -- wait for an additional character.
1916 File
.Line
:= File
.Line
+ 1;
1918 if File
.Before_LM_PM
then
1919 File
.Page
:= File
.Page
+ 1;
1921 File
.Before_LM_PM
:= False;
1923 elsif File
.Is_Regular_File
then
1926 -- Page mark can be explicit, or implied at the end of the file
1928 if (ch
= PM
or else ch
= EOF
)
1929 and then File
.Is_Regular_File
1931 File
.Page
:= File
.Page
+ 1;
1939 File
.Before_Upper_Half_Character
:= False;
1942 procedure Skip_Line
(Spacing
: Positive_Count
:= 1) is
1944 Skip_Line
(Current_In
, Spacing
);
1951 procedure Skip_Page
(File
: File_Type
) is
1955 FIO
.Check_Read_Status
(AP
(File
));
1957 -- If at page mark already, just skip it
1959 if File
.Before_LM_PM
then
1960 File
.Before_LM
:= False;
1961 File
.Before_LM_PM
:= False;
1962 File
.Page
:= File
.Page
+ 1;
1968 -- This is a bit tricky, if we are logically before an LM then
1969 -- it is not an error if we are at an end of file now, since we
1970 -- are not really at it.
1972 if File
.Before_LM
then
1973 File
.Before_LM
:= False;
1974 File
.Before_LM_PM
:= False;
1977 -- Otherwise we do raise End_Error if we are at the end of file now
1987 -- Now we can just rumble along to the next page mark, or to the
1988 -- end of file, if that comes first. The latter case happens when
1989 -- the page mark is implied at the end of file.
1993 or else (ch
= PM
and then File
.Is_Regular_File
);
1997 File
.Page
:= File
.Page
+ 1;
2000 File
.Before_Upper_Half_Character
:= False;
2003 procedure Skip_Page
is
2005 Skip_Page
(Current_In
);
2008 --------------------
2009 -- Standard_Error --
2010 --------------------
2012 function Standard_Error
return File_Type
is
2014 return Standard_Err
;
2017 function Standard_Error
return File_Access
is
2019 return Standard_Err
'Access;
2022 --------------------
2023 -- Standard_Input --
2024 --------------------
2026 function Standard_Input
return File_Type
is
2031 function Standard_Input
return File_Access
is
2033 return Standard_In
'Access;
2036 ---------------------
2037 -- Standard_Output --
2038 ---------------------
2040 function Standard_Output
return File_Type
is
2042 return Standard_Out
;
2043 end Standard_Output
;
2045 function Standard_Output
return File_Access
is
2047 return Standard_Out
'Access;
2048 end Standard_Output
;
2050 --------------------
2051 -- Terminate_Line --
2052 --------------------
2054 procedure Terminate_Line
(File
: File_Type
) is
2056 FIO
.Check_File_Open
(AP
(File
));
2058 -- For file other than In_File, test for needing to terminate last line
2060 if Mode
(File
) /= In_File
then
2062 -- If not at start of line definition need new line
2064 if File
.Col
/= 1 then
2067 -- For files other than standard error and standard output, we
2068 -- make sure that an empty file has a single line feed, so that
2069 -- it is properly formatted. We avoid this for the standard files
2070 -- because it is too much of a nuisance to have these odd line
2071 -- feeds when nothing has been written to the file.
2073 -- We also avoid this for files opened in append mode, in
2074 -- accordance with (RM A.8.2(10))
2076 elsif (File
/= Standard_Err
and then File
/= Standard_Out
)
2077 and then (File
.Line
= 1 and then File
.Page
= 1)
2078 and then Mode
(File
) = Out_File
2089 procedure Ungetc
(ch
: int
; File
: File_Type
) is
2092 if ungetc
(ch
, File
.Stream
) = EOF
then
2102 -- This is the primitive Stream Write routine, used when a Text_IO file
2103 -- is treated directly as a stream using Text_IO.Streams.Stream.
2106 (File
: in out Text_AFCB
;
2107 Item
: Stream_Element_Array
)
2109 pragma Warnings
(Off
, File
);
2110 -- Because in this implementation we don't need IN OUT, we only read
2112 function Has_Translated_Characters
return Boolean;
2113 -- return True if Item array contains a character which will be
2114 -- translated under the text file mode. There is only one such
2115 -- character under DOS based systems which is character 10.
2117 text_translation_required
: Boolean;
2118 for text_translation_required
'Size use Character'Size;
2119 pragma Import
(C
, text_translation_required
,
2120 "__gnat_text_translation_required");
2122 Siz
: constant size_t
:= Item
'Length;
2124 -------------------------------
2125 -- Has_Translated_Characters --
2126 -------------------------------
2128 function Has_Translated_Characters
return Boolean is
2130 for K
in Item
'Range loop
2131 if Item
(K
) = 10 then
2136 end Has_Translated_Characters
;
2138 Needs_Binary_Write
: constant Boolean :=
2139 text_translation_required
and then Has_Translated_Characters
;
2141 -- Start of processing for Write
2144 if File
.Mode
= FCB
.In_File
then
2148 -- Now we do the write. Since this is a text file, it is normally in
2149 -- text mode, but stream data must be written in binary mode, so we
2150 -- temporarily set binary mode for the write, resetting it after. This
2151 -- is done only if needed (i.e. there is some characters in Item which
2152 -- needs to be written using the binary mode).
2153 -- These calls have no effect in a system (like Unix) where there is
2154 -- no distinction between text and binary files.
2156 -- Since the character translation is done at the time the buffer is
2157 -- written (this is true under Windows) we first flush current buffer
2158 -- with text mode if needed.
2160 if Needs_Binary_Write
then
2161 if fflush
(File
.Stream
) = -1 then
2165 set_binary_mode
(fileno
(File
.Stream
));
2168 if fwrite
(Item
'Address, 1, Siz
, File
.Stream
) /= Siz
then
2172 -- At this point we need to flush the buffer using the binary mode then
2173 -- we reset to text mode.
2175 if Needs_Binary_Write
then
2176 if fflush
(File
.Stream
) = -1 then
2180 set_text_mode
(fileno
(File
.Stream
));
2185 -- Initialize Standard Files
2187 for J
in WC_Encoding_Method
loop
2188 if WC_Encoding
= WC_Encoding_Letters
(J
) then
2193 Initialize_Standard_Files
;
2195 FIO
.Chain_File
(AP
(Standard_In
));
2196 FIO
.Chain_File
(AP
(Standard_Out
));
2197 FIO
.Chain_File
(AP
(Standard_Err
));