2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
[official-gcc.git] / gcc / ada / a-textio.adb
blob61d6accc078aec4dfd3902ea2f28e934709df482
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- A D A . T E X T _ I O --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
32 with Ada.Streams; use Ada.Streams;
33 with Interfaces.C_Streams; use Interfaces.C_Streams;
35 with System.File_IO;
36 with System.CRTL;
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
85 (C : Character;
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
92 -- type Character.
94 function Get_Upper_Half_Char_Immed
95 (C : Character;
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
140 -- (EOF) is ignored.
142 -------------------
143 -- AFCB_Allocate --
144 -------------------
146 function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr is
147 pragma Unreferenced (Control_Block);
148 begin
149 return new Text_AFCB;
150 end AFCB_Allocate;
152 ----------------
153 -- AFCB_Close --
154 ----------------
156 procedure AFCB_Close (File : not null access Text_AFCB) is
157 begin
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
164 Current_In := null;
165 elsif File_Type (File) = Current_Out then
166 Current_Out := null;
167 elsif File_Type (File) = Current_Err then
168 Current_Err := null;
169 end if;
171 Terminate_Line (File_Type (File));
172 end AFCB_Close;
174 ---------------
175 -- AFCB_Free --
176 ---------------
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);
184 begin
185 Free (FT);
186 end AFCB_Free;
188 -----------
189 -- Close --
190 -----------
192 procedure Close (File : in out File_Type) is
193 begin
194 FIO.Close (AP (File)'Unrestricted_Access);
195 end Close;
197 ---------
198 -- Col --
199 ---------
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
206 begin
207 FIO.Check_File_Open (AP (File));
208 return File.Col;
209 end Col;
211 function Col return Positive_Count is
212 begin
213 return Col (Current_Out);
214 end Col;
216 ------------
217 -- Create --
218 ------------
220 procedure Create
221 (File : in out File_Type;
222 Mode : File_Mode := Out_File;
223 Name : String := "";
224 Form : String := "")
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.
231 begin
232 FIO.Open (File_Ptr => AP (File),
233 Dummy_FCB => Dummy_File_Control_Block,
234 Mode => To_FCB (Mode),
235 Name => Name,
236 Form => Form,
237 Amethod => 'T',
238 Creat => True,
239 Text => True);
241 File.Self := File;
242 Set_WCEM (File);
243 end Create;
245 -------------------
246 -- Current_Error --
247 -------------------
249 function Current_Error return File_Type is
250 begin
251 return Current_Err;
252 end Current_Error;
254 function Current_Error return File_Access is
255 begin
256 return Current_Err.Self'Access;
257 end Current_Error;
259 -------------------
260 -- Current_Input --
261 -------------------
263 function Current_Input return File_Type is
264 begin
265 return Current_In;
266 end Current_Input;
268 function Current_Input return File_Access is
269 begin
270 return Current_In.Self'Access;
271 end Current_Input;
273 --------------------
274 -- Current_Output --
275 --------------------
277 function Current_Output return File_Type is
278 begin
279 return Current_Out;
280 end Current_Output;
282 function Current_Output return File_Access is
283 begin
284 return Current_Out.Self'Access;
285 end Current_Output;
287 ------------
288 -- Delete --
289 ------------
291 procedure Delete (File : in out File_Type) is
292 begin
293 FIO.Delete (AP (File)'Unrestricted_Access);
294 end Delete;
296 -----------------
297 -- End_Of_File --
298 -----------------
300 function End_Of_File (File : File_Type) return Boolean is
301 ch : int;
303 begin
304 FIO.Check_Read_Status (AP (File));
306 if File.Before_Upper_Half_Character then
307 return False;
309 elsif File.Before_LM then
310 if File.Before_LM_PM then
311 return Nextc (File) = EOF;
312 end if;
314 else
315 ch := Getc (File);
317 if ch = EOF then
318 return True;
320 elsif ch /= LM then
321 Ungetc (ch, File);
322 return False;
324 else -- ch = LM
325 File.Before_LM := True;
326 end if;
327 end if;
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.
333 ch := Getc (File);
335 if ch = EOF then
336 return True;
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
344 else
345 Ungetc (ch, File);
346 return False;
347 end if;
349 end End_Of_File;
351 function End_Of_File return Boolean is
352 begin
353 return End_Of_File (Current_In);
354 end End_Of_File;
356 -----------------
357 -- End_Of_Line --
358 -----------------
360 function End_Of_Line (File : File_Type) return Boolean is
361 ch : int;
363 begin
364 FIO.Check_Read_Status (AP (File));
366 if File.Before_Upper_Half_Character then
367 return False;
369 elsif File.Before_LM then
370 return True;
372 else
373 ch := Getc (File);
375 if ch = EOF then
376 return True;
378 else
379 Ungetc (ch, File);
380 return (ch = LM);
381 end if;
382 end if;
383 end End_Of_Line;
385 function End_Of_Line return Boolean is
386 begin
387 return End_Of_Line (Current_In);
388 end End_Of_Line;
390 -----------------
391 -- End_Of_Page --
392 -----------------
394 function End_Of_Page (File : File_Type) return Boolean is
395 ch : int;
397 begin
398 FIO.Check_Read_Status (AP (File));
400 if not File.Is_Regular_File then
401 return False;
403 elsif File.Before_Upper_Half_Character then
404 return False;
406 elsif File.Before_LM then
407 if File.Before_LM_PM then
408 return True;
409 end if;
411 else
412 ch := Getc (File);
414 if ch = EOF then
415 return True;
417 elsif ch /= LM then
418 Ungetc (ch, File);
419 return False;
421 else -- ch = LM
422 File.Before_LM := True;
423 end if;
424 end if;
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.
430 ch := Nextc (File);
432 return ch = PM or else ch = EOF;
433 end End_Of_Page;
435 function End_Of_Page return Boolean is
436 begin
437 return End_Of_Page (Current_In);
438 end End_Of_Page;
440 --------------
441 -- EOF_Char --
442 --------------
444 function EOF_Char return Integer is
445 begin
446 return EOF;
447 end EOF_Char;
449 -----------
450 -- Flush --
451 -----------
453 procedure Flush (File : File_Type) is
454 begin
455 FIO.Flush (AP (File));
456 end Flush;
458 procedure Flush is
459 begin
460 Flush (Current_Out);
461 end Flush;
463 ----------
464 -- Form --
465 ----------
467 function Form (File : File_Type) return String is
468 begin
469 return FIO.Form (AP (File));
470 end Form;
472 ---------
473 -- Get --
474 ---------
476 procedure Get
477 (File : File_Type;
478 Item : out Character)
480 ch : int;
482 begin
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;
491 File.Col := 1;
493 if File.Before_LM_PM then
494 File.Line := 1;
495 File.Page := File.Page + 1;
496 File.Before_LM_PM := False;
497 else
498 File.Line := File.Line + 1;
499 end if;
500 end if;
502 loop
503 ch := Getc (File);
505 if ch = EOF then
506 raise End_Error;
508 elsif ch = LM then
509 File.Line := File.Line + 1;
510 File.Col := 1;
512 elsif ch = PM and then File.Is_Regular_File then
513 File.Page := File.Page + 1;
514 File.Line := 1;
516 else
517 Item := Character'Val (ch);
518 File.Col := File.Col + 1;
519 return;
520 end if;
521 end loop;
522 end Get;
524 procedure Get (Item : out Character) is
525 begin
526 Get (Current_In, Item);
527 end Get;
529 procedure Get
530 (File : File_Type;
531 Item : out String)
533 ch : int;
534 J : Natural;
536 begin
537 FIO.Check_Read_Status (AP (File));
539 if File.Before_LM then
540 File.Before_LM := False;
541 File.Before_LM_PM := False;
542 File.Col := 1;
544 if File.Before_LM_PM then
545 File.Line := 1;
546 File.Page := File.Page + 1;
547 File.Before_LM_PM := False;
549 else
550 File.Line := File.Line + 1;
551 end if;
552 end if;
554 J := Item'First;
555 while J <= Item'Last loop
556 ch := Getc (File);
558 if ch = EOF then
559 raise End_Error;
561 elsif ch = LM then
562 File.Line := File.Line + 1;
563 File.Col := 1;
565 elsif ch = PM and then File.Is_Regular_File then
566 File.Page := File.Page + 1;
567 File.Line := 1;
569 else
570 Item (J) := Character'Val (ch);
571 J := J + 1;
572 File.Col := File.Col + 1;
573 end if;
574 end loop;
575 end Get;
577 procedure Get (Item : out String) is
578 begin
579 Get (Current_In, Item);
580 end Get;
582 -------------------
583 -- Get_Immediate --
584 -------------------
586 procedure Get_Immediate
587 (File : File_Type;
588 Item : out Character)
590 ch : int;
592 begin
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);
604 else
605 ch := Getc_Immed (File);
607 if ch = EOF then
608 raise End_Error;
609 else
610 Item :=
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));
614 end if;
615 end if;
616 end Get_Immediate;
618 procedure Get_Immediate
619 (Item : out Character)
621 begin
622 Get_Immediate (Current_In, Item);
623 end Get_Immediate;
625 procedure Get_Immediate
626 (File : File_Type;
627 Item : out Character;
628 Available : out Boolean)
630 ch : int;
631 end_of_file : int;
632 avail : int;
634 procedure getc_immediate_nowait
635 (stream : FILEs;
636 ch : out int;
637 end_of_file : out int;
638 avail : out int);
639 pragma Import (C, getc_immediate_nowait, "getc_immediate_nowait");
641 begin
642 FIO.Check_Read_Status (AP (File));
643 Available := True;
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);
654 else
655 getc_immediate_nowait (File.Stream, ch, end_of_file, avail);
657 if ferror (File.Stream) /= 0 then
658 raise Device_Error;
660 elsif end_of_file /= 0 then
661 raise End_Error;
663 elsif avail = 0 then
664 Available := False;
665 Item := ASCII.NUL;
667 else
668 Available := True;
670 Item :=
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));
674 end if;
675 end if;
677 end Get_Immediate;
679 procedure Get_Immediate
680 (Item : out Character;
681 Available : out Boolean)
683 begin
684 Get_Immediate (Current_In, Item, Available);
685 end Get_Immediate;
687 --------------
688 -- Get_Line --
689 --------------
691 procedure Get_Line
692 (File : File_Type;
693 Item : out String;
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.
698 procedure Get_Line
699 (Item : out String;
700 Last : out Natural)
702 begin
703 Get_Line (Current_In, Item, Last);
704 end Get_Line;
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.
711 --------------
712 -- Get_Rest --
713 --------------
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);
722 Last : Natural;
724 begin
725 Get_Line (File, Buffer, Last);
727 declare
728 R : constant String := S & Buffer (1 .. Last);
729 begin
730 if Last < Buffer'Last then
731 return R;
733 else
734 return Get_Rest (R);
735 end if;
736 end;
737 end Get_Rest;
739 -- Local variables
741 Buffer : String (1 .. 500);
742 ch : int;
743 Last : Natural;
745 -- Start of processing for Get_Line
747 begin
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
758 ch := Getc (File);
760 if ch = EOF then
761 return Buffer;
763 else
764 Ungetc (ch, File);
765 return Get_Rest (Buffer (1 .. Last));
766 end if;
768 else
769 return Get_Rest (Buffer (1 .. Last));
770 end if;
771 end Get_Line;
773 function Get_Line return String is
774 begin
775 return Get_Line (Current_In);
776 end Get_Line;
778 -------------------------
779 -- Get_Upper_Half_Char --
780 -------------------------
782 function Get_Upper_Half_Char
783 (C : Character;
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);
794 -------------
795 -- In_Char --
796 -------------
798 function In_Char return Character is
799 ch : constant Integer := Getc (File);
800 begin
801 if ch = EOF then
802 raise End_Error;
803 else
804 return Character'Val (ch);
805 end if;
806 end In_Char;
808 -- Start of processing for Get_Upper_Half_Char
810 begin
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";
816 else
817 return Character'Val (Wide_Character'Pos (Result));
818 end if;
819 end Get_Upper_Half_Char;
821 -------------------------------
822 -- Get_Upper_Half_Char_Immed --
823 -------------------------------
825 function Get_Upper_Half_Char_Immed
826 (C : Character;
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);
837 -------------
838 -- In_Char --
839 -------------
841 function In_Char return Character is
842 ch : constant Integer := Getc_Immed (File);
843 begin
844 if ch = EOF then
845 raise End_Error;
846 else
847 return Character'Val (ch);
848 end if;
849 end In_Char;
851 -- Start of processing for Get_Upper_Half_Char_Immed
853 begin
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";
859 else
860 return Character'Val (Wide_Character'Pos (Result));
861 end if;
862 end Get_Upper_Half_Char_Immed;
864 ----------
865 -- Getc --
866 ----------
868 function Getc (File : File_Type) return int is
869 ch : int;
871 begin
872 ch := fgetc (File.Stream);
874 if ch = EOF and then ferror (File.Stream) /= 0 then
875 raise Device_Error;
876 else
877 return ch;
878 end if;
879 end Getc;
881 ----------------
882 -- Getc_Immed --
883 ----------------
885 function Getc_Immed (File : File_Type) return int is
886 ch : int;
887 end_of_file : int;
889 procedure getc_immediate
890 (stream : FILEs; ch : out int; end_of_file : out int);
891 pragma Import (C, getc_immediate, "getc_immediate");
893 begin
894 FIO.Check_Read_Status (AP (File));
896 if File.Before_LM then
897 File.Before_LM := False;
898 File.Before_LM_PM := False;
899 ch := LM;
901 else
902 getc_immediate (File.Stream, ch, end_of_file);
904 if ferror (File.Stream) /= 0 then
905 raise Device_Error;
906 elsif end_of_file /= 0 then
907 return EOF;
908 end if;
909 end if;
911 return ch;
912 end Getc_Immed;
914 ------------------------------
915 -- Has_Upper_Half_Character --
916 ------------------------------
918 function Has_Upper_Half_Character (Item : String) return Boolean is
919 begin
920 for J in Item'Range loop
921 if Character'Pos (Item (J)) >= 16#80# then
922 return True;
923 end if;
924 end loop;
926 return False;
927 end Has_Upper_Half_Character;
929 -------------------------------
930 -- Initialize_Standard_Files --
931 -------------------------------
933 procedure Initialize_Standard_Files is
934 begin
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;
975 -------------
976 -- Is_Open --
977 -------------
979 function Is_Open (File : File_Type) return Boolean is
980 begin
981 return FIO.Is_Open (AP (File));
982 end Is_Open;
984 ----------
985 -- Line --
986 ----------
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
993 begin
994 FIO.Check_File_Open (AP (File));
995 return File.Line;
996 end Line;
998 function Line return Positive_Count is
999 begin
1000 return Line (Current_Out);
1001 end Line;
1003 -----------------
1004 -- Line_Length --
1005 -----------------
1007 function Line_Length (File : File_Type) return Count is
1008 begin
1009 FIO.Check_Write_Status (AP (File));
1010 return File.Line_Length;
1011 end Line_Length;
1013 function Line_Length return Count is
1014 begin
1015 return Line_Length (Current_Out);
1016 end Line_Length;
1018 ----------------
1019 -- Look_Ahead --
1020 ----------------
1022 procedure Look_Ahead
1023 (File : File_Type;
1024 Item : out Character;
1025 End_Of_Line : out Boolean)
1027 ch : int;
1029 begin
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;
1036 Item := ASCII.NUL;
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
1047 else
1048 ch := Getc (File);
1050 if ch = LM
1051 or else ch = EOF
1052 or else (ch = PM and then File.Is_Regular_File)
1053 then
1054 End_Of_Line := True;
1055 Ungetc (ch, File);
1056 Item := ASCII.NUL;
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
1060 -- no difficulty.
1062 elsif not Is_Start_Of_Encoding
1063 (Character'Val (ch), File.WC_Method)
1064 then
1065 End_Of_Line := False;
1066 Ungetc (ch, File);
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.
1075 else
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;
1080 end if;
1081 end if;
1082 end Look_Ahead;
1084 procedure Look_Ahead
1085 (Item : out Character;
1086 End_Of_Line : out Boolean)
1088 begin
1089 Look_Ahead (Current_In, Item, End_Of_Line);
1090 end Look_Ahead;
1092 ----------
1093 -- Mode --
1094 ----------
1096 function Mode (File : File_Type) return File_Mode is
1097 begin
1098 return To_TIO (FIO.Mode (AP (File)));
1099 end Mode;
1101 ----------
1102 -- Name --
1103 ----------
1105 function Name (File : File_Type) return String is
1106 begin
1107 return FIO.Name (AP (File));
1108 end Name;
1110 --------------
1111 -- New_Line --
1112 --------------
1114 procedure New_Line
1115 (File : File_Type;
1116 Spacing : Positive_Count := 1)
1118 begin
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;
1125 end if;
1127 FIO.Check_Write_Status (AP (File));
1129 for K in 1 .. Spacing loop
1130 Putc (LM, File);
1131 File.Line := File.Line + 1;
1133 if File.Page_Length /= 0
1134 and then File.Line > File.Page_Length
1135 then
1136 Putc (PM, File);
1137 File.Line := 1;
1138 File.Page := File.Page + 1;
1139 end if;
1140 end loop;
1142 File.Col := 1;
1143 end New_Line;
1145 procedure New_Line (Spacing : Positive_Count := 1) is
1146 begin
1147 New_Line (Current_Out, Spacing);
1148 end New_Line;
1150 --------------
1151 -- New_Page --
1152 --------------
1154 procedure New_Page (File : File_Type) is
1155 begin
1156 FIO.Check_Write_Status (AP (File));
1158 if File.Col /= 1 or else File.Line = 1 then
1159 Putc (LM, File);
1160 end if;
1162 Putc (PM, File);
1163 File.Page := File.Page + 1;
1164 File.Line := 1;
1165 File.Col := 1;
1166 end New_Page;
1168 procedure New_Page is
1169 begin
1170 New_Page (Current_Out);
1171 end New_Page;
1173 -----------
1174 -- Nextc --
1175 -----------
1177 function Nextc (File : File_Type) return int is
1178 ch : int;
1180 begin
1181 ch := fgetc (File.Stream);
1183 if ch = EOF then
1184 if ferror (File.Stream) /= 0 then
1185 raise Device_Error;
1186 end if;
1188 else
1189 if ungetc (ch, File.Stream) = EOF then
1190 raise Device_Error;
1191 end if;
1192 end if;
1194 return ch;
1195 end Nextc;
1197 ----------
1198 -- Open --
1199 ----------
1201 procedure Open
1202 (File : in out File_Type;
1203 Mode : File_Mode;
1204 Name : String;
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.
1212 begin
1213 FIO.Open (File_Ptr => AP (File),
1214 Dummy_FCB => Dummy_File_Control_Block,
1215 Mode => To_FCB (Mode),
1216 Name => Name,
1217 Form => Form,
1218 Amethod => 'T',
1219 Creat => False,
1220 Text => True);
1222 File.Self := File;
1223 Set_WCEM (File);
1224 end Open;
1226 ----------
1227 -- Page --
1228 ----------
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
1235 begin
1236 FIO.Check_File_Open (AP (File));
1237 return File.Page;
1238 end Page;
1240 function Page return Positive_Count is
1241 begin
1242 return Page (Current_Out);
1243 end Page;
1245 -----------------
1246 -- Page_Length --
1247 -----------------
1249 function Page_Length (File : File_Type) return Count is
1250 begin
1251 FIO.Check_Write_Status (AP (File));
1252 return File.Page_Length;
1253 end Page_Length;
1255 function Page_Length return Count is
1256 begin
1257 return Page_Length (Current_Out);
1258 end Page_Length;
1260 ---------
1261 -- Put --
1262 ---------
1264 procedure Put
1265 (File : File_Type;
1266 Item : Character)
1268 begin
1269 FIO.Check_Write_Status (AP (File));
1271 if File.Line_Length /= 0 and then File.Col > File.Line_Length then
1272 New_Line (File);
1273 end if;
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
1279 then
1280 if fputc (Character'Pos (Item), File.Stream) = EOF then
1281 raise Device_Error;
1282 end if;
1284 -- Case of upper half character with non-brackets encoding
1286 else
1287 Put_Encoded (File, Item);
1288 end if;
1290 File.Col := File.Col + 1;
1291 end Put;
1293 procedure Put (Item : Character) is
1294 begin
1295 Put (Current_Out, Item);
1296 end Put;
1298 ---------
1299 -- Put --
1300 ---------
1302 procedure Put
1303 (File : File_Type;
1304 Item : String)
1306 begin
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))
1320 then
1321 for J in Item'Range loop
1322 Put (File, Item (J));
1323 end loop;
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.
1329 else
1330 FIO.Write_Buf (AP (File), Item'Address, Item'Length);
1331 File.Col := File.Col + Item'Length;
1332 end if;
1333 end if;
1334 end Put;
1336 procedure Put (Item : String) is
1337 begin
1338 Put (Current_Out, Item);
1339 end Put;
1341 -----------------
1342 -- Put_Encoded --
1343 -----------------
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);
1351 --------------
1352 -- Out_Char --
1353 --------------
1355 procedure Out_Char (C : Character) is
1356 begin
1357 Putc (Character'Pos (C), File);
1358 end Out_Char;
1360 -- Start of processing for Put_Encoded
1362 begin
1363 WC_Out (Wide_Character'Val (Character'Pos (Char)), File.WC_Method);
1364 end Put_Encoded;
1366 --------------
1367 -- Put_Line --
1368 --------------
1370 procedure Put_Line
1371 (File : File_Type;
1372 Item : String)
1374 Ilen : Natural := Item'Length;
1375 Istart : Natural := Item'First;
1377 begin
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))
1387 then
1388 for J in Item'Range loop
1389 Put (File, Item (J));
1390 end loop;
1392 New_Line (File);
1393 return;
1394 end if;
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.
1409 if Ilen > 512 then
1410 FIO.Write_Buf (AP (File), Item'Address, size_t (Ilen - 512));
1411 Istart := Istart + Ilen - 512;
1412 Ilen := 512;
1413 end if;
1415 -- Now prepare the string with its terminator
1417 declare
1418 Buffer : String (1 .. Ilen + 2);
1419 Plen : size_t;
1421 begin
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
1427 then
1428 Buffer (Ilen + 2) := Character'Val (PM);
1429 Plen := size_t (Ilen) + 2;
1430 File.Line := 1;
1431 File.Page := File.Page + 1;
1433 else
1434 Plen := size_t (Ilen) + 1;
1435 File.Line := File.Line + 1;
1436 end if;
1438 FIO.Write_Buf (AP (File), Buffer'Address, Plen);
1440 File.Col := 1;
1441 end;
1442 end Put_Line;
1444 procedure Put_Line (Item : String) is
1445 begin
1446 Put_Line (Current_Out, Item);
1447 end Put_Line;
1449 ----------
1450 -- Putc --
1451 ----------
1453 procedure Putc (ch : int; File : File_Type) is
1454 begin
1455 if fputc (ch, File.Stream) = EOF then
1456 raise Device_Error;
1457 end if;
1458 end Putc;
1460 ----------
1461 -- Read --
1462 ----------
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.
1467 procedure Read
1468 (File : in out Text_AFCB;
1469 Item : out Stream_Element_Array;
1470 Last : out Stream_Element_Offset)
1472 Discard_ch : int;
1473 pragma Warnings (Off, Discard_ch);
1475 begin
1476 -- Need to deal with Before_Upper_Half_Character ???
1478 if File.Mode /= FCB.In_File then
1479 raise Mode_Error;
1480 end if;
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;
1499 end if;
1501 File.Before_LM := False;
1503 Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF));
1505 if Item'Length = 1 then
1506 Last := Item'Last;
1508 else
1509 Last :=
1510 Item'First +
1511 Stream_Element_Offset
1512 (fread (buffer => Item'Address,
1513 index => size_t (Item'First + 1),
1514 size => 1,
1515 count => Item'Length - 1,
1516 stream => File.Stream));
1517 end if;
1519 return;
1520 end if;
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));
1530 Last :=
1531 Item'First +
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
1537 raise Device_Error;
1538 end if;
1539 end if;
1541 set_text_mode (fileno (File.Stream));
1542 end Read;
1544 -----------
1545 -- Reset --
1546 -----------
1548 procedure Reset
1549 (File : in out File_Type;
1550 Mode : File_Mode)
1552 begin
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
1559 then
1560 raise Mode_Error;
1561 end if;
1563 Terminate_Line (File);
1564 FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode));
1565 File.Page := 1;
1566 File.Line := 1;
1567 File.Col := 1;
1568 File.Line_Length := 0;
1569 File.Page_Length := 0;
1570 File.Before_LM := False;
1571 File.Before_LM_PM := False;
1572 end Reset;
1574 procedure Reset (File : in out File_Type) is
1575 begin
1576 Terminate_Line (File);
1577 FIO.Reset (AP (File)'Unrestricted_Access);
1578 File.Page := 1;
1579 File.Line := 1;
1580 File.Col := 1;
1581 File.Line_Length := 0;
1582 File.Page_Length := 0;
1583 File.Before_LM := False;
1584 File.Before_LM_PM := False;
1585 end Reset;
1587 -------------
1588 -- Set_Col --
1589 -------------
1591 procedure Set_Col
1592 (File : File_Type;
1593 To : Positive_Count)
1595 ch : int;
1597 begin
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;
1604 end if;
1606 FIO.Check_File_Open (AP (File));
1608 -- Output case
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
1616 raise Layout_Error;
1617 end if;
1619 -- If we are behind current position, then go to start of new line
1621 if To < File.Col then
1622 New_Line (File);
1623 end if;
1625 -- Loop to output blanks till we are at the required column
1627 while File.Col < To loop
1628 Put (File, ' ');
1629 end loop;
1631 -- Input case
1633 else
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;
1642 File.Col := 1;
1643 end if;
1645 -- Loop reading characters till we get one at the required Col value
1647 loop
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.
1653 ch := Getc (File);
1655 -- Error if we hit an end of file
1657 if ch = EOF then
1658 raise End_Error;
1660 -- If line mark, eat it and adjust file position
1662 elsif ch = LM then
1663 File.Line := File.Line + 1;
1664 File.Col := 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;
1670 File.Line := 1;
1671 File.Col := 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
1678 Ungetc (ch, File);
1679 return;
1681 -- Keep skipping characters if we are not there yet, updating the
1682 -- file position past the skipped character.
1684 else
1685 File.Col := File.Col + 1;
1686 end if;
1687 end loop;
1688 end if;
1689 end Set_Col;
1691 procedure Set_Col (To : Positive_Count) is
1692 begin
1693 Set_Col (Current_Out, To);
1694 end Set_Col;
1696 ---------------
1697 -- Set_Error --
1698 ---------------
1700 procedure Set_Error (File : File_Type) is
1701 begin
1702 FIO.Check_Write_Status (AP (File));
1703 Current_Err := File;
1704 end Set_Error;
1706 ---------------
1707 -- Set_Input --
1708 ---------------
1710 procedure Set_Input (File : File_Type) is
1711 begin
1712 FIO.Check_Read_Status (AP (File));
1713 Current_In := File;
1714 end Set_Input;
1716 --------------
1717 -- Set_Line --
1718 --------------
1720 procedure Set_Line
1721 (File : File_Type;
1722 To : Positive_Count)
1724 begin
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;
1731 end if;
1733 FIO.Check_File_Open (AP (File));
1735 if To = File.Line then
1736 return;
1737 end if;
1739 if Mode (File) >= Out_File then
1740 if File.Page_Length /= 0 and then To > File.Page_Length then
1741 raise Layout_Error;
1742 end if;
1744 if To < File.Line then
1745 New_Page (File);
1746 end if;
1748 while File.Line < To loop
1749 New_Line (File);
1750 end loop;
1752 else
1753 while To /= File.Line loop
1754 Skip_Line (File);
1755 end loop;
1756 end if;
1757 end Set_Line;
1759 procedure Set_Line (To : Positive_Count) is
1760 begin
1761 Set_Line (Current_Out, To);
1762 end Set_Line;
1764 ---------------------
1765 -- Set_Line_Length --
1766 ---------------------
1768 procedure Set_Line_Length (File : File_Type; To : Count) is
1769 begin
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;
1776 end if;
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
1783 begin
1784 Set_Line_Length (Current_Out, To);
1785 end Set_Line_Length;
1787 ----------------
1788 -- Set_Output --
1789 ----------------
1791 procedure Set_Output (File : File_Type) is
1792 begin
1793 FIO.Check_Write_Status (AP (File));
1794 Current_Out := File;
1795 end Set_Output;
1797 ---------------------
1798 -- Set_Page_Length --
1799 ---------------------
1801 procedure Set_Page_Length (File : File_Type; To : Count) is
1802 begin
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;
1809 end if;
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
1816 begin
1817 Set_Page_Length (Current_Out, To);
1818 end Set_Page_Length;
1820 --------------
1821 -- Set_WCEM --
1822 --------------
1824 procedure Set_WCEM (File : in out File_Type) is
1825 Start : Natural;
1826 Stop : Natural;
1828 begin
1829 File.WC_Method := WCEM_Brackets;
1830 FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop);
1832 if Start = 0 then
1833 File.WC_Method := WCEM_Brackets;
1835 else
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;
1840 return;
1841 end if;
1842 end loop;
1843 end if;
1845 Close (File);
1846 raise Use_Error with "invalid WCEM form parameter";
1847 end if;
1848 end Set_WCEM;
1850 ---------------
1851 -- Skip_Line --
1852 ---------------
1854 procedure Skip_Line
1855 (File : File_Type;
1856 Spacing : Positive_Count := 1)
1858 ch : int;
1860 begin
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;
1867 end if;
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.
1881 else
1882 ch := Getc (File);
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.
1894 if ch = EOF then
1895 raise End_Error;
1896 end if;
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.
1903 loop
1904 exit when ch = LM or else ch = EOF;
1905 ch := Getc (File);
1906 end loop;
1907 end if;
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.
1915 File.Col := 1;
1916 File.Line := File.Line + 1;
1918 if File.Before_LM_PM then
1919 File.Page := File.Page + 1;
1920 File.Line := 1;
1921 File.Before_LM_PM := False;
1923 elsif File.Is_Regular_File then
1924 ch := Getc (File);
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
1930 then
1931 File.Page := File.Page + 1;
1932 File.Line := 1;
1933 else
1934 Ungetc (ch, File);
1935 end if;
1936 end if;
1937 end loop;
1939 File.Before_Upper_Half_Character := False;
1940 end Skip_Line;
1942 procedure Skip_Line (Spacing : Positive_Count := 1) is
1943 begin
1944 Skip_Line (Current_In, Spacing);
1945 end Skip_Line;
1947 ---------------
1948 -- Skip_Page --
1949 ---------------
1951 procedure Skip_Page (File : File_Type) is
1952 ch : int;
1954 begin
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;
1963 File.Line := 1;
1964 File.Col := 1;
1965 return;
1966 end if;
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;
1975 ch := Getc (File);
1977 -- Otherwise we do raise End_Error if we are at the end of file now
1979 else
1980 ch := Getc (File);
1982 if ch = EOF then
1983 raise End_Error;
1984 end if;
1985 end if;
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.
1991 loop
1992 exit when ch = EOF
1993 or else (ch = PM and then File.Is_Regular_File);
1994 ch := Getc (File);
1995 end loop;
1997 File.Page := File.Page + 1;
1998 File.Line := 1;
1999 File.Col := 1;
2000 File.Before_Upper_Half_Character := False;
2001 end Skip_Page;
2003 procedure Skip_Page is
2004 begin
2005 Skip_Page (Current_In);
2006 end Skip_Page;
2008 --------------------
2009 -- Standard_Error --
2010 --------------------
2012 function Standard_Error return File_Type is
2013 begin
2014 return Standard_Err;
2015 end Standard_Error;
2017 function Standard_Error return File_Access is
2018 begin
2019 return Standard_Err'Access;
2020 end Standard_Error;
2022 --------------------
2023 -- Standard_Input --
2024 --------------------
2026 function Standard_Input return File_Type is
2027 begin
2028 return Standard_In;
2029 end Standard_Input;
2031 function Standard_Input return File_Access is
2032 begin
2033 return Standard_In'Access;
2034 end Standard_Input;
2036 ---------------------
2037 -- Standard_Output --
2038 ---------------------
2040 function Standard_Output return File_Type is
2041 begin
2042 return Standard_Out;
2043 end Standard_Output;
2045 function Standard_Output return File_Access is
2046 begin
2047 return Standard_Out'Access;
2048 end Standard_Output;
2050 --------------------
2051 -- Terminate_Line --
2052 --------------------
2054 procedure Terminate_Line (File : File_Type) is
2055 begin
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
2065 New_Line (File);
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
2079 then
2080 New_Line (File);
2081 end if;
2082 end if;
2083 end Terminate_Line;
2085 ------------
2086 -- Ungetc --
2087 ------------
2089 procedure Ungetc (ch : int; File : File_Type) is
2090 begin
2091 if ch /= EOF then
2092 if ungetc (ch, File.Stream) = EOF then
2093 raise Device_Error;
2094 end if;
2095 end if;
2096 end Ungetc;
2098 -----------
2099 -- Write --
2100 -----------
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.
2105 procedure Write
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
2129 begin
2130 for K in Item'Range loop
2131 if Item (K) = 10 then
2132 return True;
2133 end if;
2134 end loop;
2135 return False;
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
2143 begin
2144 if File.Mode = FCB.In_File then
2145 raise Mode_Error;
2146 end if;
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
2162 raise Device_Error;
2163 end if;
2165 set_binary_mode (fileno (File.Stream));
2166 end if;
2168 if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then
2169 raise Device_Error;
2170 end if;
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
2177 raise Device_Error;
2178 end if;
2180 set_text_mode (fileno (File.Stream));
2181 end if;
2182 end Write;
2184 begin
2185 -- Initialize Standard Files
2187 for J in WC_Encoding_Method loop
2188 if WC_Encoding = WC_Encoding_Letters (J) then
2189 Default_WCEM := J;
2190 end if;
2191 end loop;
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));
2199 end Ada.Text_IO;