1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . 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
.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");
61 -----------------------
62 -- Local Subprograms --
63 -----------------------
65 function Getc_Immed
(File
: File_Type
) return int
;
66 -- This routine is identical to Getc, except that the read is done in
67 -- Get_Immediate mode (i.e. without waiting for a line return).
69 function Get_Upper_Half_Char
71 File
: File_Type
) return Character;
72 -- This function is shared by Get and Get_Immediate to extract an encoded
73 -- upper half character value from the given File. The first byte has
74 -- already been read and is passed in C. The character value is returned as
75 -- the result, and the file pointer is bumped past the character.
76 -- Constraint_Error is raised if the encoded value is outside the bounds of
79 function Get_Upper_Half_Char_Immed
81 File
: File_Type
) return Character;
82 -- This routine is identical to Get_Upper_Half_Char, except that the reads
83 -- are done in Get_Immediate mode (i.e. without waiting for a line return).
85 function Has_Upper_Half_Character
(Item
: String) return Boolean;
86 -- Returns True if any of the characters is in the range 16#80#-16#FF#
88 procedure Put_Encoded
(File
: File_Type
; Char
: Character);
89 -- Called to output a character Char to the given File, when the encoding
90 -- method for the file is other than brackets, and Char is upper half.
92 procedure Set_WCEM
(File
: in out File_Type
);
93 -- Called by Open and Create to set the wide character encoding method for
94 -- the file, processing a WCEM form parameter if one is present. File is
95 -- IN OUT because it may be closed in case of an error.
101 function AFCB_Allocate
(Control_Block
: Text_AFCB
) return FCB
.AFCB_Ptr
is
102 pragma Unreferenced
(Control_Block
);
104 return new Text_AFCB
;
111 procedure AFCB_Close
(File
: not null access Text_AFCB
) is
113 -- If the file being closed is one of the current files, then close
114 -- the corresponding current file. It is not clear that this action
115 -- is required (RM A.10.3(23)) but it seems reasonable, and besides
116 -- ACVC test CE3208A expects this behavior.
118 if File_Type
(File
) = Current_In
then
120 elsif File_Type
(File
) = Current_Out
then
122 elsif File_Type
(File
) = Current_Err
then
126 Terminate_Line
(File_Type
(File
));
133 procedure AFCB_Free
(File
: not null access Text_AFCB
) is
134 type FCB_Ptr
is access all Text_AFCB
;
135 FT
: FCB_Ptr
:= FCB_Ptr
(File
);
137 procedure Free
is new Ada
.Unchecked_Deallocation
(Text_AFCB
, FCB_Ptr
);
147 procedure Close
(File
: in out File_Type
) is
149 FIO
.Close
(AP
(File
)'Unrestricted_Access);
156 -- Note: we assume that it is impossible in practice for the column
157 -- to exceed the value of Count'Last, i.e. no check is required for
158 -- overflow raising layout error.
160 function Col
(File
: File_Type
) return Positive_Count
is
162 FIO
.Check_File_Open
(AP
(File
));
166 function Col
return Positive_Count
is
168 return Col
(Current_Out
);
176 (File
: in out File_Type
;
177 Mode
: File_Mode
:= Out_File
;
181 Dummy_File_Control_Block
: Text_AFCB
;
182 pragma Warnings
(Off
, Dummy_File_Control_Block
);
183 -- Yes, we know this is never assigned a value, only the tag
184 -- is used for dispatching purposes, so that's expected.
187 FIO
.Open
(File_Ptr
=> AP
(File
),
188 Dummy_FCB
=> Dummy_File_Control_Block
,
189 Mode
=> To_FCB
(Mode
),
204 function Current_Error
return File_Type
is
209 function Current_Error
return File_Access
is
211 return Current_Err
.Self
'Access;
218 function Current_Input
return File_Type
is
223 function Current_Input
return File_Access
is
225 return Current_In
.Self
'Access;
232 function Current_Output
return File_Type
is
237 function Current_Output
return File_Access
is
239 return Current_Out
.Self
'Access;
246 procedure Delete
(File
: in out File_Type
) is
248 FIO
.Delete
(AP
(File
)'Unrestricted_Access);
255 function End_Of_File
(File
: File_Type
) return Boolean is
259 FIO
.Check_Read_Status
(AP
(File
));
261 if File
.Before_Upper_Half_Character
then
264 elsif File
.Before_LM
then
265 if File
.Before_LM_PM
then
266 return Nextc
(File
) = EOF
;
280 File
.Before_LM
:= True;
284 -- Here we are just past the line mark with Before_LM set so that we
285 -- do not have to try to back up past the LM, thus avoiding the need
286 -- to back up more than one character.
293 elsif ch
= PM
and then File
.Is_Regular_File
then
294 File
.Before_LM_PM
:= True;
295 return Nextc
(File
) = EOF
;
297 -- Here if neither EOF nor PM followed end of line
306 function End_Of_File
return Boolean is
308 return End_Of_File
(Current_In
);
315 function End_Of_Line
(File
: File_Type
) return Boolean is
319 FIO
.Check_Read_Status
(AP
(File
));
321 if File
.Before_Upper_Half_Character
then
324 elsif File
.Before_LM
then
340 function End_Of_Line
return Boolean is
342 return End_Of_Line
(Current_In
);
349 function End_Of_Page
(File
: File_Type
) return Boolean is
353 FIO
.Check_Read_Status
(AP
(File
));
355 if not File
.Is_Regular_File
then
358 elsif File
.Before_Upper_Half_Character
then
361 elsif File
.Before_LM
then
362 if File
.Before_LM_PM
then
377 File
.Before_LM
:= True;
381 -- Here we are just past the line mark with Before_LM set so that we
382 -- do not have to try to back up past the LM, thus avoiding the need
383 -- to back up more than one character.
387 return ch
= PM
or else ch
= EOF
;
390 function End_Of_Page
return Boolean is
392 return End_Of_Page
(Current_In
);
399 function EOF_Char
return Integer is
408 procedure Flush
(File
: File_Type
) is
410 FIO
.Flush
(AP
(File
));
422 function Form
(File
: File_Type
) return String is
424 return FIO
.Form
(AP
(File
));
433 Item
: out Character)
438 FIO
.Check_Read_Status
(AP
(File
));
440 if File
.Before_Upper_Half_Character
then
441 File
.Before_Upper_Half_Character
:= False;
442 Item
:= File
.Saved_Upper_Half_Character
;
444 elsif File
.Before_LM
then
445 File
.Before_LM
:= False;
448 if File
.Before_LM_PM
then
450 File
.Page
:= File
.Page
+ 1;
451 File
.Before_LM_PM
:= False;
453 File
.Line
:= File
.Line
+ 1;
464 File
.Line
:= File
.Line
+ 1;
467 elsif ch
= PM
and then File
.Is_Regular_File
then
468 File
.Page
:= File
.Page
+ 1;
472 Item
:= Character'Val (ch
);
473 File
.Col
:= File
.Col
+ 1;
479 procedure Get
(Item
: out Character) is
481 Get
(Current_In
, Item
);
492 FIO
.Check_Read_Status
(AP
(File
));
494 if File
.Before_LM
then
495 File
.Before_LM
:= False;
496 File
.Before_LM_PM
:= False;
499 if File
.Before_LM_PM
then
501 File
.Page
:= File
.Page
+ 1;
502 File
.Before_LM_PM
:= False;
505 File
.Line
:= File
.Line
+ 1;
510 while J
<= Item
'Last loop
517 File
.Line
:= File
.Line
+ 1;
520 elsif ch
= PM
and then File
.Is_Regular_File
then
521 File
.Page
:= File
.Page
+ 1;
525 Item
(J
) := Character'Val (ch
);
527 File
.Col
:= File
.Col
+ 1;
532 procedure Get
(Item
: out String) is
534 Get
(Current_In
, Item
);
541 procedure Get_Immediate
543 Item
: out Character)
548 FIO
.Check_Read_Status
(AP
(File
));
550 if File
.Before_Upper_Half_Character
then
551 File
.Before_Upper_Half_Character
:= False;
552 Item
:= File
.Saved_Upper_Half_Character
;
554 elsif File
.Before_LM
then
555 File
.Before_LM
:= False;
556 File
.Before_LM_PM
:= False;
557 Item
:= Character'Val (LM
);
560 ch
:= Getc_Immed
(File
);
566 (if not Is_Start_Of_Encoding
(Character'Val (ch
), File
.WC_Method
)
567 then Character'Val (ch
)
568 else Get_Upper_Half_Char_Immed
(Character'Val (ch
), File
));
573 procedure Get_Immediate
574 (Item
: out Character)
577 Get_Immediate
(Current_In
, Item
);
580 procedure Get_Immediate
582 Item
: out Character;
583 Available
: out Boolean)
589 procedure getc_immediate_nowait
592 end_of_file
: out int
;
594 pragma Import
(C
, getc_immediate_nowait
, "getc_immediate_nowait");
597 FIO
.Check_Read_Status
(AP
(File
));
600 if File
.Before_Upper_Half_Character
then
601 File
.Before_Upper_Half_Character
:= False;
602 Item
:= File
.Saved_Upper_Half_Character
;
604 elsif File
.Before_LM
then
605 File
.Before_LM
:= False;
606 File
.Before_LM_PM
:= False;
607 Item
:= Character'Val (LM
);
610 getc_immediate_nowait
(File
.Stream
, ch
, end_of_file
, avail
);
612 if ferror
(File
.Stream
) /= 0 then
615 elsif end_of_file
/= 0 then
626 (if Is_Start_Of_Encoding
(Character'Val (ch
), File
.WC_Method
)
627 then Character'Val (ch
)
628 else Get_Upper_Half_Char_Immed
(Character'Val (ch
), File
));
634 procedure Get_Immediate
635 (Item
: out Character;
636 Available
: out Boolean)
639 Get_Immediate
(Current_In
, Item
, Available
);
654 FIO
.Check_Read_Status
(AP
(File
));
655 Last
:= Item
'First - 1;
657 -- Immediate exit for null string, this is a case in which we do not
658 -- need to test for end of file and we do not skip a line mark under
659 -- any circumstances.
661 if Last
>= Item
'Last then
665 -- Here we have at least one character, if we are immediately before
666 -- a line mark, then we will just skip past it storing no characters.
668 if File
.Before_LM
then
669 File
.Before_LM
:= False;
670 File
.Before_LM_PM
:= False;
672 -- Otherwise we need to read some characters
677 -- If we are at the end of file now, it means we are trying to
678 -- skip a file terminator and we raise End_Error (RM A.10.7(20))
684 -- Loop through characters. Don't bother if we hit a page mark,
685 -- since in normal files, page marks can only follow line marks
686 -- in any case and we only promise to treat the page nonsense
687 -- correctly in the absense of such rogue page marks.
690 -- Exit the loop if read is terminated by encountering line mark
694 -- Otherwise store the character, note that we know that ch is
695 -- something other than LM or EOF. It could possibly be a page
696 -- mark if there is a stray page mark in the middle of a line,
697 -- but this is not an official page mark in any case, since
698 -- official page marks can only follow a line mark. The whole
699 -- page business is pretty much nonsense anyway, so we do not
700 -- want to waste time trying to make sense out of non-standard
701 -- page marks in the file! This means that the behavior of
702 -- Get_Line is different from repeated Get of a character, but
703 -- that's too bad. We only promise that page numbers etc make
704 -- sense if the file is formatted in a standard manner.
706 -- Note: we do not adjust the column number because it is quicker
707 -- to adjust it once at the end of the operation than incrementing
708 -- it each time around the loop.
711 Item
(Last
) := Character'Val (ch
);
713 -- All done if the string is full, this is the case in which
714 -- we do not skip the following line mark. We need to adjust
715 -- the column number in this case.
717 if Last
= Item
'Last then
718 File
.Col
:= File
.Col
+ Count
(Item
'Length);
722 -- Otherwise read next character. We also exit from the loop if
723 -- we read an end of file. This is the case where the last line
724 -- is not terminated with a line mark, and we consider that there
725 -- is an implied line mark in this case (this is a non-standard
726 -- file, but it is nice to treat it reasonably).
733 -- We have skipped past, but not stored, a line mark. Skip following
734 -- page mark if one follows, but do not do this for a non-regular
735 -- file (since otherwise we get annoying wait for an extra character)
737 File
.Line
:= File
.Line
+ 1;
740 if File
.Before_LM_PM
then
742 File
.Before_LM_PM
:= False;
743 File
.Page
:= File
.Page
+ 1;
745 elsif File
.Is_Regular_File
then
748 if ch
= PM
and then File
.Is_Regular_File
then
750 File
.Page
:= File
.Page
+ 1;
762 Get_Line
(Current_In
, Item
, Last
);
765 function Get_Line
(File
: File_Type
) return String is
766 Buffer
: String (1 .. 500);
769 function Get_Rest
(S
: String) return String;
770 -- This is a recursive function that reads the rest of the line and
771 -- returns it. S is the part read so far.
777 function Get_Rest
(S
: String) return String is
779 -- Each time we allocate a buffer the same size as what we have
780 -- read so far. This limits us to a logarithmic number of calls
781 -- to Get_Rest and also ensures only a linear use of stack space.
783 Buffer
: String (1 .. S
'Length);
787 Get_Line
(File
, Buffer
, Last
);
790 R
: constant String := S
& Buffer
(1 .. Last
);
792 if Last
< Buffer
'Last then
800 -- Start of processing for Get_Line
803 Get_Line
(File
, Buffer
, Last
);
805 if Last
< Buffer
'Last then
806 return Buffer
(1 .. Last
);
808 return Get_Rest
(Buffer
(1 .. Last
));
812 function Get_Line
return String is
814 return Get_Line
(Current_In
);
817 -------------------------
818 -- Get_Upper_Half_Char --
819 -------------------------
821 function Get_Upper_Half_Char
823 File
: File_Type
) return Character
825 Result
: Wide_Character;
827 function In_Char
return Character;
828 -- Function used to obtain additional characters it the wide character
829 -- sequence is more than one character long.
831 function WC_In
is new Char_Sequence_To_Wide_Char
(In_Char
);
837 function In_Char
return Character is
838 ch
: constant Integer := Getc
(File
);
843 return Character'Val (ch
);
847 -- Start of processing for Get_Upper_Half_Char
850 Result
:= WC_In
(C
, File
.WC_Method
);
852 if Wide_Character'Pos (Result
) > 16#FF#
then
853 raise Constraint_Error
with
854 "invalid wide character in Text_'I'O input";
856 return Character'Val (Wide_Character'Pos (Result
));
858 end Get_Upper_Half_Char
;
860 -------------------------------
861 -- Get_Upper_Half_Char_Immed --
862 -------------------------------
864 function Get_Upper_Half_Char_Immed
866 File
: File_Type
) return Character
868 Result
: Wide_Character;
870 function In_Char
return Character;
871 -- Function used to obtain additional characters it the wide character
872 -- sequence is more than one character long.
874 function WC_In
is new Char_Sequence_To_Wide_Char
(In_Char
);
880 function In_Char
return Character is
881 ch
: constant Integer := Getc_Immed
(File
);
886 return Character'Val (ch
);
890 -- Start of processing for Get_Upper_Half_Char_Immed
893 Result
:= WC_In
(C
, File
.WC_Method
);
895 if Wide_Character'Pos (Result
) > 16#FF#
then
896 raise Constraint_Error
with
897 "invalid wide character in Text_'I'O input";
899 return Character'Val (Wide_Character'Pos (Result
));
901 end Get_Upper_Half_Char_Immed
;
907 function Getc
(File
: File_Type
) return int
is
911 ch
:= fgetc
(File
.Stream
);
913 if ch
= EOF
and then ferror
(File
.Stream
) /= 0 then
924 function Getc_Immed
(File
: File_Type
) return int
is
928 procedure getc_immediate
929 (stream
: FILEs
; ch
: out int
; end_of_file
: out int
);
930 pragma Import
(C
, getc_immediate
, "getc_immediate");
933 FIO
.Check_Read_Status
(AP
(File
));
935 if File
.Before_LM
then
936 File
.Before_LM
:= False;
937 File
.Before_LM_PM
:= False;
941 getc_immediate
(File
.Stream
, ch
, end_of_file
);
943 if ferror
(File
.Stream
) /= 0 then
945 elsif end_of_file
/= 0 then
953 ------------------------------
954 -- Has_Upper_Half_Character --
955 ------------------------------
957 function Has_Upper_Half_Character
(Item
: String) return Boolean is
959 for J
in Item
'Range loop
960 if Character'Pos (Item
(J
)) >= 16#
80#
then
966 end Has_Upper_Half_Character
;
972 function Is_Open
(File
: File_Type
) return Boolean is
974 return FIO
.Is_Open
(AP
(File
));
981 -- Note: we assume that it is impossible in practice for the line
982 -- to exceed the value of Count'Last, i.e. no check is required for
983 -- overflow raising layout error.
985 function Line
(File
: File_Type
) return Positive_Count
is
987 FIO
.Check_File_Open
(AP
(File
));
991 function Line
return Positive_Count
is
993 return Line
(Current_Out
);
1000 function Line_Length
(File
: File_Type
) return Count
is
1002 FIO
.Check_Write_Status
(AP
(File
));
1003 return File
.Line_Length
;
1006 function Line_Length
return Count
is
1008 return Line_Length
(Current_Out
);
1015 procedure Look_Ahead
1017 Item
: out Character;
1018 End_Of_Line
: out Boolean)
1023 FIO
.Check_Read_Status
(AP
(File
));
1025 -- If we are logically before a line mark, we can return immediately
1027 if File
.Before_LM
then
1028 End_Of_Line
:= True;
1031 -- If we are before an upper half character just return it (this can
1032 -- happen if there are two calls to Look_Ahead in a row).
1034 elsif File
.Before_Upper_Half_Character
then
1035 End_Of_Line
:= False;
1036 Item
:= File
.Saved_Upper_Half_Character
;
1038 -- Otherwise we must read a character from the input stream
1045 or else (ch
= PM
and then File
.Is_Regular_File
)
1047 End_Of_Line
:= True;
1051 -- Case where character obtained does not represent the start of an
1052 -- encoded sequence so it stands for itself and we can unget it with
1055 elsif not Is_Start_Of_Encoding
1056 (Character'Val (ch
), File
.WC_Method
)
1058 End_Of_Line
:= False;
1060 Item
:= Character'Val (ch
);
1062 -- For the start of an encoding, we read the character using the
1063 -- Get_Upper_Half_Char routine. It will occupy more than one byte
1064 -- so we can't put it back with ungetc. Instead we save it in the
1065 -- control block, setting a flag that everyone interested in reading
1066 -- characters must test before reading the stream.
1069 Item
:= Get_Upper_Half_Char
(Character'Val (ch
), File
);
1070 End_Of_Line
:= False;
1071 File
.Saved_Upper_Half_Character
:= Item
;
1072 File
.Before_Upper_Half_Character
:= True;
1077 procedure Look_Ahead
1078 (Item
: out Character;
1079 End_Of_Line
: out Boolean)
1082 Look_Ahead
(Current_In
, Item
, End_Of_Line
);
1089 function Mode
(File
: File_Type
) return File_Mode
is
1091 return To_TIO
(FIO
.Mode
(AP
(File
)));
1098 function Name
(File
: File_Type
) return String is
1100 return FIO
.Name
(AP
(File
));
1109 Spacing
: Positive_Count
:= 1)
1112 -- Raise Constraint_Error if out of range value. The reason for this
1113 -- explicit test is that we don't want junk values around, even if
1114 -- checks are off in the caller.
1116 if not Spacing
'Valid then
1117 raise Constraint_Error
;
1120 FIO
.Check_Write_Status
(AP
(File
));
1122 for K
in 1 .. Spacing
loop
1124 File
.Line
:= File
.Line
+ 1;
1126 if File
.Page_Length
/= 0
1127 and then File
.Line
> File
.Page_Length
1131 File
.Page
:= File
.Page
+ 1;
1138 procedure New_Line
(Spacing
: Positive_Count
:= 1) is
1140 New_Line
(Current_Out
, Spacing
);
1147 procedure New_Page
(File
: File_Type
) is
1149 FIO
.Check_Write_Status
(AP
(File
));
1151 if File
.Col
/= 1 or else File
.Line
= 1 then
1156 File
.Page
:= File
.Page
+ 1;
1161 procedure New_Page
is
1163 New_Page
(Current_Out
);
1170 function Nextc
(File
: File_Type
) return int
is
1174 ch
:= fgetc
(File
.Stream
);
1177 if ferror
(File
.Stream
) /= 0 then
1182 if ungetc
(ch
, File
.Stream
) = EOF
then
1195 (File
: in out File_Type
;
1198 Form
: String := "")
1200 Dummy_File_Control_Block
: Text_AFCB
;
1201 pragma Warnings
(Off
, Dummy_File_Control_Block
);
1202 -- Yes, we know this is never assigned a value, only the tag
1203 -- is used for dispatching purposes, so that's expected.
1206 FIO
.Open
(File_Ptr
=> AP
(File
),
1207 Dummy_FCB
=> Dummy_File_Control_Block
,
1208 Mode
=> To_FCB
(Mode
),
1223 -- Note: we assume that it is impossible in practice for the page
1224 -- to exceed the value of Count'Last, i.e. no check is required for
1225 -- overflow raising layout error.
1227 function Page
(File
: File_Type
) return Positive_Count
is
1229 FIO
.Check_File_Open
(AP
(File
));
1233 function Page
return Positive_Count
is
1235 return Page
(Current_Out
);
1242 function Page_Length
(File
: File_Type
) return Count
is
1244 FIO
.Check_Write_Status
(AP
(File
));
1245 return File
.Page_Length
;
1248 function Page_Length
return Count
is
1250 return Page_Length
(Current_Out
);
1262 FIO
.Check_Write_Status
(AP
(File
));
1264 if File
.Line_Length
/= 0 and then File
.Col
> File
.Line_Length
then
1268 -- If lower half character, or brackets encoding, output directly
1270 if Character'Pos (Item
) < 16#
80#
1271 or else File
.WC_Method
= WCEM_Brackets
1273 if fputc
(Character'Pos (Item
), File
.Stream
) = EOF
then
1277 -- Case of upper half character with non-brackets encoding
1280 Put_Encoded
(File
, Item
);
1283 File
.Col
:= File
.Col
+ 1;
1286 procedure Put
(Item
: Character) is
1288 FIO
.Check_Write_Status
(AP
(Current_Out
));
1290 if Current_Out
.Line_Length
/= 0
1291 and then Current_Out
.Col
> Current_Out
.Line_Length
1293 New_Line
(Current_Out
);
1296 -- If lower half character, or brackets encoding, output directly
1298 if Character'Pos (Item
) < 16#
80#
1299 or else Default_WCEM
= WCEM_Brackets
1301 if fputc
(Character'Pos (Item
), Current_Out
.Stream
) = EOF
then
1305 -- Case of upper half character with non-brackets encoding
1308 Put_Encoded
(Current_Out
, Item
);
1311 Current_Out
.Col
:= Current_Out
.Col
+ 1;
1323 FIO
.Check_Write_Status
(AP
(File
));
1325 -- Only have something to do if string is non-null
1327 if Item
'Length > 0 then
1329 -- If we have bounded lines, or if the file encoding is other than
1330 -- Brackets and the string has at least one upper half character,
1331 -- then output the string character by character.
1333 if File
.Line_Length
/= 0
1334 or else (File
.WC_Method
/= WCEM_Brackets
1335 and then Has_Upper_Half_Character
(Item
))
1337 for J
in Item
'Range loop
1338 Put
(File
, Item
(J
));
1341 -- Otherwise we can output the entire string at once. Note that if
1342 -- there are LF or FF characters in the string, we do not bother to
1343 -- count them as line or page terminators.
1346 FIO
.Write_Buf
(AP
(File
), Item
'Address, Item
'Length);
1347 File
.Col
:= File
.Col
+ Item
'Length;
1352 procedure Put
(Item
: String) is
1354 Put
(Current_Out
, Item
);
1361 procedure Put_Encoded
(File
: File_Type
; Char
: Character) is
1362 procedure Out_Char
(C
: Character);
1363 -- Procedure to output one character of an upper half encoded sequence
1365 procedure WC_Out
is new Wide_Char_To_Char_Sequence
(Out_Char
);
1371 procedure Out_Char
(C
: Character) is
1373 Putc
(Character'Pos (C
), File
);
1376 -- Start of processing for Put_Encoded
1379 WC_Out
(Wide_Character'Val (Character'Pos (Char
)), File
.WC_Method
);
1390 Ilen
: Natural := Item
'Length;
1391 Istart
: Natural := Item
'First;
1394 FIO
.Check_Write_Status
(AP
(File
));
1396 -- If we have bounded lines, or if the file encoding is other than
1397 -- Brackets and the string has at least one upper half character, then
1398 -- output the string character by character.
1400 if File
.Line_Length
/= 0
1401 or else (File
.WC_Method
/= WCEM_Brackets
1402 and then Has_Upper_Half_Character
(Item
))
1404 for J
in Item
'Range loop
1405 Put
(File
, Item
(J
));
1412 -- Normal case where we do not need to output character by character
1414 -- We setup a single string that has the necessary terminators and
1415 -- then write it with a single call. The reason for doing this is
1416 -- that it gives better behavior for the use of Put_Line in multi-
1417 -- tasking programs, since often the OS will treat the entire put
1418 -- operation as an atomic operation.
1420 -- We only do this if the message is 512 characters or less in length,
1421 -- since otherwise Put_Line would use an unbounded amount of stack
1422 -- space and could cause undetected stack overflow. If we have a
1423 -- longer string, then output the first part separately to avoid this.
1426 FIO
.Write_Buf
(AP
(File
), Item
'Address, size_t
(Ilen
- 512));
1427 Istart
:= Istart
+ Ilen
- 512;
1431 -- Now prepare the string with its terminator
1434 Buffer
: String (1 .. Ilen
+ 2);
1438 Buffer
(1 .. Ilen
) := Item
(Istart
.. Item
'Last);
1439 Buffer
(Ilen
+ 1) := Character'Val (LM
);
1441 if File
.Page_Length
/= 0
1442 and then File
.Line
> File
.Page_Length
1444 Buffer
(Ilen
+ 2) := Character'Val (PM
);
1445 Plen
:= size_t
(Ilen
) + 2;
1447 File
.Page
:= File
.Page
+ 1;
1450 Plen
:= size_t
(Ilen
) + 1;
1451 File
.Line
:= File
.Line
+ 1;
1454 FIO
.Write_Buf
(AP
(File
), Buffer
'Address, Plen
);
1460 procedure Put_Line
(Item
: String) is
1462 Put_Line
(Current_Out
, Item
);
1469 procedure Putc
(ch
: int
; File
: File_Type
) is
1471 if fputc
(ch
, File
.Stream
) = EOF
then
1480 -- This is the primitive Stream Read routine, used when a Text_IO file
1481 -- is treated directly as a stream using Text_IO.Streams.Stream.
1484 (File
: in out Text_AFCB
;
1485 Item
: out Stream_Element_Array
;
1486 Last
: out Stream_Element_Offset
)
1489 pragma Warnings
(Off
, Discard_ch
);
1492 -- Need to deal with Before_Upper_Half_Character ???
1494 if File
.Mode
/= FCB
.In_File
then
1498 -- Deal with case where our logical and physical position do not match
1499 -- because of being after an LM or LM-PM sequence when in fact we are
1500 -- logically positioned before it.
1502 if File
.Before_LM
then
1504 -- If we are before a PM, then it is possible for a stream read
1505 -- to leave us after the LM and before the PM, which is a bit
1506 -- odd. The easiest way to deal with this is to unget the PM,
1507 -- so we are indeed positioned between the characters. This way
1508 -- further stream read operations will work correctly, and the
1509 -- effect on text processing is a little weird, but what can
1510 -- be expected if stream and text input are mixed this way?
1512 if File
.Before_LM_PM
then
1513 Discard_ch
:= ungetc
(PM
, File
.Stream
);
1514 File
.Before_LM_PM
:= False;
1517 File
.Before_LM
:= False;
1519 Item
(Item
'First) := Stream_Element
(Character'Pos (ASCII
.LF
));
1521 if Item
'Length = 1 then
1527 Stream_Element_Offset
1528 (fread
(buffer
=> Item
'Address,
1529 index
=> size_t
(Item
'First + 1),
1531 count
=> Item
'Length - 1,
1532 stream
=> File
.Stream
));
1538 -- Now we do the read. Since this is a text file, it is normally in
1539 -- text mode, but stream data must be read in binary mode, so we
1540 -- temporarily set binary mode for the read, resetting it after.
1541 -- These calls have no effect in a system (like Unix) where there is
1542 -- no distinction between text and binary files.
1544 set_binary_mode
(fileno
(File
.Stream
));
1548 Stream_Element_Offset
1549 (fread
(Item
'Address, 1, Item
'Length, File
.Stream
)) - 1;
1551 if Last
< Item
'Last then
1552 if ferror
(File
.Stream
) /= 0 then
1557 set_text_mode
(fileno
(File
.Stream
));
1565 (File
: in out File_Type
;
1569 -- Don't allow change of mode for current file (RM A.10.2(5))
1571 if (File
= Current_In
or else
1572 File
= Current_Out
or else
1573 File
= Current_Error
)
1574 and then To_FCB
(Mode
) /= File
.Mode
1579 Terminate_Line
(File
);
1580 FIO
.Reset
(AP
(File
)'Unrestricted_Access, To_FCB
(Mode
));
1584 File
.Line_Length
:= 0;
1585 File
.Page_Length
:= 0;
1586 File
.Before_LM
:= False;
1587 File
.Before_LM_PM
:= False;
1590 procedure Reset
(File
: in out File_Type
) is
1592 Terminate_Line
(File
);
1593 FIO
.Reset
(AP
(File
)'Unrestricted_Access);
1597 File
.Line_Length
:= 0;
1598 File
.Page_Length
:= 0;
1599 File
.Before_LM
:= False;
1600 File
.Before_LM_PM
:= False;
1609 To
: Positive_Count
)
1614 -- Raise Constraint_Error if out of range value. The reason for this
1615 -- explicit test is that we don't want junk values around, even if
1616 -- checks are off in the caller.
1618 if not To
'Valid then
1619 raise Constraint_Error
;
1622 FIO
.Check_File_Open
(AP
(File
));
1626 if Mode
(File
) >= Out_File
then
1628 -- Error if we attempt to set Col to a value greater than the
1629 -- maximum permissible line length.
1631 if File
.Line_Length
/= 0 and then To
> File
.Line_Length
then
1635 -- If we are behind current position, then go to start of new line
1637 if To
< File
.Col
then
1641 -- Loop to output blanks till we are at the required column
1643 while File
.Col
< To
loop
1650 -- If we are logically before a LM, but physically after it, the
1651 -- file position still reflects the position before the LM, so eat
1652 -- it now and adjust the file position appropriately.
1654 if File
.Before_LM
then
1655 File
.Before_LM
:= False;
1656 File
.Before_LM_PM
:= False;
1657 File
.Line
:= File
.Line
+ 1;
1661 -- Loop reading characters till we get one at the required Col value
1664 -- Read next character. The reason we have to read ahead is to
1665 -- skip formatting characters, the effect of Set_Col is to set
1666 -- us to a real character with the right Col value, and format
1667 -- characters don't count.
1671 -- Error if we hit an end of file
1676 -- If line mark, eat it and adjust file position
1679 File
.Line
:= File
.Line
+ 1;
1682 -- If recognized page mark, eat it, and adjust file position
1684 elsif ch
= PM
and then File
.Is_Regular_File
then
1685 File
.Page
:= File
.Page
+ 1;
1689 -- Otherwise this is the character we are looking for, so put it
1690 -- back in the input stream (we have not adjusted the file
1691 -- position yet, so everything is set right after this ungetc).
1693 elsif To
= File
.Col
then
1697 -- Keep skipping characters if we are not there yet, updating the
1698 -- file position past the skipped character.
1701 File
.Col
:= File
.Col
+ 1;
1707 procedure Set_Col
(To
: Positive_Count
) is
1709 Set_Col
(Current_Out
, To
);
1716 procedure Set_Error
(File
: File_Type
) is
1718 FIO
.Check_Write_Status
(AP
(File
));
1719 Current_Err
:= File
;
1726 procedure Set_Input
(File
: File_Type
) is
1728 FIO
.Check_Read_Status
(AP
(File
));
1738 To
: Positive_Count
)
1741 -- Raise Constraint_Error if out of range value. The reason for this
1742 -- explicit test is that we don't want junk values around, even if
1743 -- checks are off in the caller.
1745 if not To
'Valid then
1746 raise Constraint_Error
;
1749 FIO
.Check_File_Open
(AP
(File
));
1751 if To
= File
.Line
then
1755 if Mode
(File
) >= Out_File
then
1756 if File
.Page_Length
/= 0 and then To
> File
.Page_Length
then
1760 if To
< File
.Line
then
1764 while File
.Line
< To
loop
1769 while To
/= File
.Line
loop
1775 procedure Set_Line
(To
: Positive_Count
) is
1777 Set_Line
(Current_Out
, To
);
1780 ---------------------
1781 -- Set_Line_Length --
1782 ---------------------
1784 procedure Set_Line_Length
(File
: File_Type
; To
: Count
) is
1786 -- Raise Constraint_Error if out of range value. The reason for this
1787 -- explicit test is that we don't want junk values around, even if
1788 -- checks are off in the caller.
1790 if not To
'Valid then
1791 raise Constraint_Error
;
1794 FIO
.Check_Write_Status
(AP
(File
));
1795 File
.Line_Length
:= To
;
1796 end Set_Line_Length
;
1798 procedure Set_Line_Length
(To
: Count
) is
1800 Set_Line_Length
(Current_Out
, To
);
1801 end Set_Line_Length
;
1807 procedure Set_Output
(File
: File_Type
) is
1809 FIO
.Check_Write_Status
(AP
(File
));
1810 Current_Out
:= File
;
1813 ---------------------
1814 -- Set_Page_Length --
1815 ---------------------
1817 procedure Set_Page_Length
(File
: File_Type
; To
: Count
) is
1819 -- Raise Constraint_Error if out of range value. The reason for this
1820 -- explicit test is that we don't want junk values around, even if
1821 -- checks are off in the caller.
1823 if not To
'Valid then
1824 raise Constraint_Error
;
1827 FIO
.Check_Write_Status
(AP
(File
));
1828 File
.Page_Length
:= To
;
1829 end Set_Page_Length
;
1831 procedure Set_Page_Length
(To
: Count
) is
1833 Set_Page_Length
(Current_Out
, To
);
1834 end Set_Page_Length
;
1840 procedure Set_WCEM
(File
: in out File_Type
) is
1845 File
.WC_Method
:= WCEM_Brackets
;
1846 FIO
.Form_Parameter
(File
.Form
.all, "wcem", Start
, Stop
);
1849 File
.WC_Method
:= WCEM_Brackets
;
1852 if Stop
= Start
then
1853 for J
in WC_Encoding_Letters
'Range loop
1854 if File
.Form
(Start
) = WC_Encoding_Letters
(J
) then
1855 File
.WC_Method
:= J
;
1862 raise Use_Error
with "invalid WCEM form parameter";
1872 Spacing
: Positive_Count
:= 1)
1877 -- Raise Constraint_Error if out of range value. The reason for this
1878 -- explicit test is that we don't want junk values around, even if
1879 -- checks are off in the caller.
1881 if not Spacing
'Valid then
1882 raise Constraint_Error
;
1885 FIO
.Check_Read_Status
(AP
(File
));
1887 for L
in 1 .. Spacing
loop
1888 if File
.Before_LM
then
1889 File
.Before_LM
:= False;
1891 -- Note that if File.Before_LM_PM is currently set, we also have
1892 -- to reset it (because it makes sense for Before_LM_PM to be set
1893 -- only when Before_LM is also set). This is done later on in this
1894 -- subprogram, as soon as Before_LM_PM has been taken into account
1895 -- for the purpose of page and line counts.
1900 -- If at end of file now, then immediately raise End_Error. Note
1901 -- that we can never be positioned between a line mark and a page
1902 -- mark, so if we are at the end of file, we cannot logically be
1903 -- before the implicit page mark that is at the end of the file.
1905 -- For the same reason, we do not need an explicit check for a
1906 -- page mark. If there is a FF in the middle of a line, the file
1907 -- is not in canonical format and we do not care about the page
1908 -- numbers for files other than ones in canonical format.
1914 -- If not at end of file, then loop till we get to an LM or EOF.
1915 -- The latter case happens only in non-canonical files where the
1916 -- last line is not terminated by LM, but we don't want to blow
1917 -- up for such files, so we assume an implicit LM in this case.
1920 exit when ch
= LM
or ch
= EOF
;
1925 -- We have got past a line mark, now, for a regular file only,
1926 -- see if a page mark immediately follows this line mark and
1927 -- if so, skip past the page mark as well. We do not do this
1928 -- for non-regular files, since it would cause an undesirable
1929 -- wait for an additional character.
1932 File
.Line
:= File
.Line
+ 1;
1934 if File
.Before_LM_PM
then
1935 File
.Page
:= File
.Page
+ 1;
1937 File
.Before_LM_PM
:= False;
1939 elsif File
.Is_Regular_File
then
1942 -- Page mark can be explicit, or implied at the end of the file
1944 if (ch
= PM
or else ch
= EOF
)
1945 and then File
.Is_Regular_File
1947 File
.Page
:= File
.Page
+ 1;
1955 File
.Before_Upper_Half_Character
:= False;
1958 procedure Skip_Line
(Spacing
: Positive_Count
:= 1) is
1960 Skip_Line
(Current_In
, Spacing
);
1967 procedure Skip_Page
(File
: File_Type
) is
1971 FIO
.Check_Read_Status
(AP
(File
));
1973 -- If at page mark already, just skip it
1975 if File
.Before_LM_PM
then
1976 File
.Before_LM
:= False;
1977 File
.Before_LM_PM
:= False;
1978 File
.Page
:= File
.Page
+ 1;
1984 -- This is a bit tricky, if we are logically before an LM then
1985 -- it is not an error if we are at an end of file now, since we
1986 -- are not really at it.
1988 if File
.Before_LM
then
1989 File
.Before_LM
:= False;
1990 File
.Before_LM_PM
:= False;
1993 -- Otherwise we do raise End_Error if we are at the end of file now
2003 -- Now we can just rumble along to the next page mark, or to the
2004 -- end of file, if that comes first. The latter case happens when
2005 -- the page mark is implied at the end of file.
2009 or else (ch
= PM
and then File
.Is_Regular_File
);
2013 File
.Page
:= File
.Page
+ 1;
2016 File
.Before_Upper_Half_Character
:= False;
2019 procedure Skip_Page
is
2021 Skip_Page
(Current_In
);
2024 --------------------
2025 -- Standard_Error --
2026 --------------------
2028 function Standard_Error
return File_Type
is
2030 return Standard_Err
;
2033 function Standard_Error
return File_Access
is
2035 return Standard_Err
'Access;
2038 --------------------
2039 -- Standard_Input --
2040 --------------------
2042 function Standard_Input
return File_Type
is
2047 function Standard_Input
return File_Access
is
2049 return Standard_In
'Access;
2052 ---------------------
2053 -- Standard_Output --
2054 ---------------------
2056 function Standard_Output
return File_Type
is
2058 return Standard_Out
;
2059 end Standard_Output
;
2061 function Standard_Output
return File_Access
is
2063 return Standard_Out
'Access;
2064 end Standard_Output
;
2066 --------------------
2067 -- Terminate_Line --
2068 --------------------
2070 procedure Terminate_Line
(File
: File_Type
) is
2072 FIO
.Check_File_Open
(AP
(File
));
2074 -- For file other than In_File, test for needing to terminate last line
2076 if Mode
(File
) /= In_File
then
2078 -- If not at start of line definition need new line
2080 if File
.Col
/= 1 then
2083 -- For files other than standard error and standard output, we
2084 -- make sure that an empty file has a single line feed, so that
2085 -- it is properly formatted. We avoid this for the standard files
2086 -- because it is too much of a nuisance to have these odd line
2087 -- feeds when nothing has been written to the file.
2089 -- We also avoid this for files opened in append mode, in
2090 -- accordance with (RM A.8.2(10))
2092 elsif (File
/= Standard_Err
and then File
/= Standard_Out
)
2093 and then (File
.Line
= 1 and then File
.Page
= 1)
2094 and then Mode
(File
) = Out_File
2105 procedure Ungetc
(ch
: int
; File
: File_Type
) is
2108 if ungetc
(ch
, File
.Stream
) = EOF
then
2118 -- This is the primitive Stream Write routine, used when a Text_IO file
2119 -- is treated directly as a stream using Text_IO.Streams.Stream.
2122 (File
: in out Text_AFCB
;
2123 Item
: Stream_Element_Array
)
2125 pragma Warnings
(Off
, File
);
2126 -- Because in this implementation we don't need IN OUT, we only read
2128 function Has_Translated_Characters
return Boolean;
2129 -- return True if Item array contains a character which will be
2130 -- translated under the text file mode. There is only one such
2131 -- character under DOS based systems which is character 10.
2133 text_translation_required
: Boolean;
2134 for text_translation_required
'Size use Character'Size;
2135 pragma Import
(C
, text_translation_required
,
2136 "__gnat_text_translation_required");
2138 Siz
: constant size_t
:= Item
'Length;
2140 -------------------------------
2141 -- Has_Translated_Characters --
2142 -------------------------------
2144 function Has_Translated_Characters
return Boolean is
2146 for K
in Item
'Range loop
2147 if Item
(K
) = 10 then
2152 end Has_Translated_Characters
;
2154 Needs_Binary_Write
: constant Boolean :=
2155 text_translation_required
2156 and then Has_Translated_Characters
;
2158 -- Start of processing for Write
2161 if File
.Mode
= FCB
.In_File
then
2165 -- Now we do the write. Since this is a text file, it is normally in
2166 -- text mode, but stream data must be written in binary mode, so we
2167 -- temporarily set binary mode for the write, resetting it after. This
2168 -- is done only if needed (i.e. there is some characters in Item which
2169 -- needs to be written using the binary mode).
2170 -- These calls have no effect in a system (like Unix) where there is
2171 -- no distinction between text and binary files.
2173 -- Since the character translation is done at the time the buffer is
2174 -- written (this is true under Windows) we first flush current buffer
2175 -- with text mode if needed.
2177 if Needs_Binary_Write
then
2178 if fflush
(File
.Stream
) = -1 then
2182 set_binary_mode
(fileno
(File
.Stream
));
2185 if fwrite
(Item
'Address, 1, Siz
, File
.Stream
) /= Siz
then
2189 -- At this point we need to flush the buffer using the binary mode then
2190 -- we reset to text mode.
2192 if Needs_Binary_Write
then
2193 if fflush
(File
.Stream
) = -1 then
2197 set_text_mode
(fileno
(File
.Stream
));
2201 -- Use "preallocated" strings to avoid calling "new" during the
2202 -- elaboration of the run time. This is needed in the tasking case to
2203 -- avoid calling Task_Lock too early. A filename is expected to end with a
2204 -- null character in the runtime, here the null characters are added just
2205 -- to have a correct filename length.
2207 Err_Name
: aliased String := "*stderr" & ASCII
.NUL
;
2208 In_Name
: aliased String := "*stdin" & ASCII
.NUL
;
2209 Out_Name
: aliased String := "*stdout" & ASCII
.NUL
;
2212 -------------------------------
2213 -- Initialize Standard Files --
2214 -------------------------------
2216 for J
in WC_Encoding_Method
loop
2217 if WC_Encoding
= WC_Encoding_Letters
(J
) then
2222 -- Note: the names in these files are bogus, and probably it would be
2223 -- better for these files to have no names, but the ACVC test insist!
2224 -- We use names that are bound to fail in open etc.
2226 Standard_Err
.Stream
:= stderr
;
2227 Standard_Err
.Name
:= Err_Name
'Access;
2228 Standard_Err
.Form
:= Null_Str
'Unrestricted_Access;
2229 Standard_Err
.Mode
:= FCB
.Out_File
;
2230 Standard_Err
.Is_Regular_File
:= is_regular_file
(fileno
(stderr
)) /= 0;
2231 Standard_Err
.Is_Temporary_File
:= False;
2232 Standard_Err
.Is_System_File
:= True;
2233 Standard_Err
.Is_Text_File
:= True;
2234 Standard_Err
.Access_Method
:= 'T';
2235 Standard_Err
.Self
:= Standard_Err
;
2236 Standard_Err
.WC_Method
:= Default_WCEM
;
2238 Standard_In
.Stream
:= stdin
;
2239 Standard_In
.Name
:= In_Name
'Access;
2240 Standard_In
.Form
:= Null_Str
'Unrestricted_Access;
2241 Standard_In
.Mode
:= FCB
.In_File
;
2242 Standard_In
.Is_Regular_File
:= is_regular_file
(fileno
(stdin
)) /= 0;
2243 Standard_In
.Is_Temporary_File
:= False;
2244 Standard_In
.Is_System_File
:= True;
2245 Standard_In
.Is_Text_File
:= True;
2246 Standard_In
.Access_Method
:= 'T';
2247 Standard_In
.Self
:= Standard_In
;
2248 Standard_In
.WC_Method
:= Default_WCEM
;
2250 Standard_Out
.Stream
:= stdout
;
2251 Standard_Out
.Name
:= Out_Name
'Access;
2252 Standard_Out
.Form
:= Null_Str
'Unrestricted_Access;
2253 Standard_Out
.Mode
:= FCB
.Out_File
;
2254 Standard_Out
.Is_Regular_File
:= is_regular_file
(fileno
(stdout
)) /= 0;
2255 Standard_Out
.Is_Temporary_File
:= False;
2256 Standard_Out
.Is_System_File
:= True;
2257 Standard_Out
.Is_Text_File
:= True;
2258 Standard_Out
.Access_Method
:= 'T';
2259 Standard_Out
.Self
:= Standard_Out
;
2260 Standard_Out
.WC_Method
:= Default_WCEM
;
2262 FIO
.Chain_File
(AP
(Standard_In
));
2263 FIO
.Chain_File
(AP
(Standard_Out
));
2264 FIO
.Chain_File
(AP
(Standard_Err
));
2266 FIO
.Make_Unbuffered
(AP
(Standard_Out
));
2267 FIO
.Make_Unbuffered
(AP
(Standard_Err
));