gcc/ada/a-textio.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 --                          A D A . T E X T _ I O                           --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2003 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Streams;          use Ada.Streams;
  35 with Interfaces.C_Streams; use Interfaces.C_Streams;
  36 with System;
  37 with System.File_IO;
  38 with Unchecked_Conversion;
  39 with Unchecked_Deallocation;
  40
  41 pragma Elaborate_All (System.File_IO);
  42 --  Needed because of calls to Chain_File in package body elaboration
  43
  44 package body Ada.Text_IO is
  45
  46    package FIO renames System.File_IO;
  47
  48    subtype AP is FCB.AFCB_Ptr;
  49
  50    function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
  51    function To_TIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode);
  52    use type FCB.File_Mode;
  53
  54    -------------------
  55    -- AFCB_Allocate --
  56    -------------------
  57
  58    function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr is
  59       pragma Unreferenced (Control_Block);
  60
  61    begin
  62       return new Text_AFCB;
  63    end AFCB_Allocate;
  64
  65    ----------------
  66    -- AFCB_Close --
  67    ----------------
  68
  69    procedure AFCB_Close (File : access Text_AFCB) is
  70    begin
  71       --  If the file being closed is one of the current files, then close
  72       --  the corresponding current file. It is not clear that this action
  73       --  is required (RM A.10.3(23)) but it seems reasonable, and besides
  74       --  ACVC test CE3208A expects this behavior.
  75
  76       if File_Type (File) = Current_In then
  77          Current_In := null;
  78       elsif File_Type (File) = Current_Out then
  79          Current_Out := null;
  80       elsif File_Type (File) = Current_Err then
  81          Current_Err := null;
  82       end if;
  83
  84       Terminate_Line (File_Type (File));
  85    end AFCB_Close;
  86
  87    ---------------
  88    -- AFCB_Free --
  89    ---------------
  90
  91    procedure AFCB_Free (File : access Text_AFCB) is
  92       type FCB_Ptr is access all Text_AFCB;
  93       FT : FCB_Ptr := FCB_Ptr (File);
  94
  95       procedure Free is new Unchecked_Deallocation (Text_AFCB, FCB_Ptr);
  96
  97    begin
  98       Free (FT);
  99    end AFCB_Free;
 100
 101    -----------
 102    -- Close --
 103    -----------
 104
 105    procedure Close (File : in out File_Type) is
 106    begin
 107       FIO.Close (AP (File));
 108    end Close;
 109
 110    ---------
 111    -- Col --
 112    ---------
 113
 114    --  Note: we assume that it is impossible in practice for the column
 115    --  to exceed the value of Count'Last, i.e. no check is required for
 116    --  overflow raising layout error.
 117
 118    function Col (File : in File_Type) return Positive_Count is
 119    begin
 120       FIO.Check_File_Open (AP (File));
 121       return File.Col;
 122    end Col;
 123
 124    function Col return Positive_Count is
 125    begin
 126       return Col (Current_Out);
 127    end Col;
 128
 129    ------------
 130    -- Create --
 131    ------------
 132
 133    procedure Create
 134      (File : in out File_Type;
 135       Mode : in File_Mode := Out_File;
 136       Name : in String := "";
 137       Form : in String := "")
 138    is
 139       Dummy_File_Control_Block : Text_AFCB;
 140       pragma Warnings (Off, Dummy_File_Control_Block);
 141       --  Yes, we know this is never assigned a value, only the tag
 142       --  is used for dispatching purposes, so that's expected.
 143
 144    begin
 145       FIO.Open (File_Ptr  => AP (File),
 146                 Dummy_FCB => Dummy_File_Control_Block,
 147                 Mode      => To_FCB (Mode),
 148                 Name      => Name,
 149                 Form      => Form,
 150                 Amethod   => 'T',
 151                 Creat     => True,
 152                 Text      => True);
 153
 154       File.Self := File;
 155    end Create;
 156
 157    -------------------
 158    -- Current_Error --
 159    -------------------
 160
 161    function Current_Error return File_Type is
 162    begin
 163       return Current_Err;
 164    end Current_Error;
 165
 166    function Current_Error return File_Access is
 167    begin
 168       return Current_Err.Self'Access;
 169    end Current_Error;
 170
 171    -------------------
 172    -- Current_Input --
 173    -------------------
 174
 175    function Current_Input return File_Type is
 176    begin
 177       return Current_In;
 178    end Current_Input;
 179
 180    function Current_Input return File_Access is
 181    begin
 182       return Current_In.Self'Access;
 183    end Current_Input;
 184
 185    --------------------
 186    -- Current_Output --
 187    --------------------
 188
 189    function Current_Output return File_Type is
 190    begin
 191       return Current_Out;
 192    end Current_Output;
 193
 194    function Current_Output return File_Access is
 195    begin
 196       return Current_Out.Self'Access;
 197    end Current_Output;
 198
 199    ------------
 200    -- Delete --
 201    ------------
 202
 203    procedure Delete (File : in out File_Type) is
 204    begin
 205       FIO.Delete (AP (File));
 206    end Delete;
 207
 208    -----------------
 209    -- End_Of_File --
 210    -----------------
 211
 212    function End_Of_File (File : in File_Type) return Boolean is
 213       ch  : int;
 214
 215    begin
 216       FIO.Check_Read_Status (AP (File));
 217
 218       if File.Before_LM then
 219
 220          if File.Before_LM_PM then
 221             return Nextc (File) = EOF;
 222          end if;
 223
 224       else
 225          ch := Getc (File);
 226
 227          if ch = EOF then
 228             return True;
 229
 230          elsif ch /= LM then
 231             Ungetc (ch, File);
 232             return False;
 233
 234          else -- ch = LM
 235             File.Before_LM := True;
 236          end if;
 237       end if;
 238
 239       --  Here we are just past the line mark with Before_LM set so that we
 240       --  do not have to try to back up past the LM, thus avoiding the need
 241       --  to back up more than one character.
 242
 243       ch := Getc (File);
 244
 245       if ch = EOF then
 246          return True;
 247
 248       elsif ch = PM and then File.Is_Regular_File then
 249          File.Before_LM_PM := True;
 250          return Nextc (File) = EOF;
 251
 252       --  Here if neither EOF nor PM followed end of line
 253
 254       else
 255          Ungetc (ch, File);
 256          return False;
 257       end if;
 258
 259    end End_Of_File;
 260
 261    function End_Of_File return Boolean is
 262    begin
 263       return End_Of_File (Current_In);
 264    end End_Of_File;
 265
 266    -----------------
 267    -- End_Of_Line --
 268    -----------------
 269
 270    function End_Of_Line (File : in File_Type) return Boolean is
 271       ch : int;
 272
 273    begin
 274       FIO.Check_Read_Status (AP (File));
 275
 276       if File.Before_LM then
 277          return True;
 278
 279       else
 280          ch := Getc (File);
 281
 282          if ch = EOF then
 283             return True;
 284
 285          else
 286             Ungetc (ch, File);
 287             return (ch = LM);
 288          end if;
 289       end if;
 290    end End_Of_Line;
 291
 292    function End_Of_Line return Boolean is
 293    begin
 294       return End_Of_Line (Current_In);
 295    end End_Of_Line;
 296
 297    -----------------
 298    -- End_Of_Page --
 299    -----------------
 300
 301    function End_Of_Page (File : in File_Type) return Boolean is
 302       ch  : int;
 303
 304    begin
 305       FIO.Check_Read_Status (AP (File));
 306
 307       if not File.Is_Regular_File then
 308          return False;
 309
 310       elsif File.Before_LM then
 311          if File.Before_LM_PM then
 312             return True;
 313          end if;
 314
 315       else
 316          ch := Getc (File);
 317
 318          if ch = EOF then
 319             return True;
 320
 321          elsif ch /= LM then
 322             Ungetc (ch, File);
 323             return False;
 324
 325          else -- ch = LM
 326             File.Before_LM := True;
 327          end if;
 328       end if;
 329
 330       --  Here we are just past the line mark with Before_LM set so that we
 331       --  do not have to try to back up past the LM, thus avoiding the need
 332       --  to back up more than one character.
 333
 334       ch := Nextc (File);
 335
 336       return ch = PM or else ch = EOF;
 337    end End_Of_Page;
 338
 339    function End_Of_Page return Boolean is
 340    begin
 341       return End_Of_Page (Current_In);
 342    end End_Of_Page;
 343
 344    --------------
 345    -- EOF_Char --
 346    --------------
 347
 348    function EOF_Char return Integer is
 349    begin
 350       return EOF;
 351    end EOF_Char;
 352
 353    -----------
 354    -- Flush --
 355    -----------
 356
 357    procedure Flush (File : in File_Type) is
 358    begin
 359       FIO.Flush (AP (File));
 360    end Flush;
 361
 362    procedure Flush is
 363    begin
 364       Flush (Current_Out);
 365    end Flush;
 366
 367    ----------
 368    -- Form --
 369    ----------
 370
 371    function Form (File : in File_Type) return String is
 372    begin
 373       return FIO.Form (AP (File));
 374    end Form;
 375
 376    ---------
 377    -- Get --
 378    ---------
 379
 380    procedure Get
 381      (File : in File_Type;
 382       Item : out Character)
 383    is
 384       ch : int;
 385
 386    begin
 387       FIO.Check_Read_Status (AP (File));
 388
 389       if File.Before_LM then
 390          File.Before_LM := False;
 391          File.Col := 1;
 392
 393          if File.Before_LM_PM then
 394             File.Line := 1;
 395             File.Page := File.Page + 1;
 396             File.Before_LM_PM := False;
 397          else
 398             File.Line := File.Line + 1;
 399          end if;
 400       end if;
 401
 402       loop
 403          ch := Getc (File);
 404
 405          if ch = EOF then
 406             raise End_Error;
 407
 408          elsif ch = LM then
 409             File.Line := File.Line + 1;
 410             File.Col := 1;
 411
 412          elsif ch = PM and then File.Is_Regular_File then
 413             File.Page := File.Page + 1;
 414             File.Line := 1;
 415
 416          else
 417             Item := Character'Val (ch);
 418             File.Col := File.Col + 1;
 419             return;
 420          end if;
 421       end loop;
 422    end Get;
 423
 424    procedure Get (Item : out Character) is
 425    begin
 426       Get (Current_In, Item);
 427    end Get;
 428
 429    procedure Get
 430      (File : in File_Type;
 431       Item : out String)
 432    is
 433       ch : int;
 434       J  : Natural;
 435
 436    begin
 437       FIO.Check_Read_Status (AP (File));
 438
 439       if File.Before_LM then
 440          File.Before_LM := False;
 441          File.Before_LM_PM := False;
 442          File.Col := 1;
 443
 444          if File.Before_LM_PM then
 445             File.Line := 1;
 446             File.Page := File.Page + 1;
 447             File.Before_LM_PM := False;
 448
 449          else
 450             File.Line := File.Line + 1;
 451          end if;
 452       end if;
 453
 454       J := Item'First;
 455       while J <= Item'Last loop
 456          ch := Getc (File);
 457
 458          if ch = EOF then
 459             raise End_Error;
 460
 461          elsif ch = LM then
 462             File.Line := File.Line + 1;
 463             File.Col := 1;
 464
 465          elsif ch = PM and then File.Is_Regular_File then
 466             File.Page := File.Page + 1;
 467             File.Line := 1;
 468
 469          else
 470             Item (J) := Character'Val (ch);
 471             J := J + 1;
 472             File.Col := File.Col + 1;
 473          end if;
 474       end loop;
 475    end Get;
 476
 477    procedure Get (Item : out String) is
 478    begin
 479       Get (Current_In, Item);
 480    end Get;
 481
 482    -------------------
 483    -- Get_Immediate --
 484    -------------------
 485
 486    --  More work required here ???
 487
 488    procedure Get_Immediate
 489      (File : in File_Type;
 490       Item : out Character)
 491    is
 492       ch          : int;
 493       end_of_file : int;
 494
 495       procedure getc_immediate
 496         (stream      : FILEs;
 497          ch          : out int;
 498          end_of_file : out int);
 499       pragma Import (C, getc_immediate, "getc_immediate");
 500
 501    begin
 502       FIO.Check_Read_Status (AP (File));
 503
 504       if File.Before_LM then
 505          File.Before_LM := False;
 506          File.Before_LM_PM := False;
 507          ch := LM;
 508
 509       else
 510          getc_immediate (File.Stream, ch, end_of_file);
 511
 512          if ferror (File.Stream) /= 0 then
 513             raise Device_Error;
 514          elsif end_of_file /= 0 then
 515             raise End_Error;
 516          end if;
 517       end if;
 518
 519       Item := Character'Val (ch);
 520    end Get_Immediate;
 521
 522    procedure Get_Immediate
 523      (Item : out Character)
 524    is
 525    begin
 526       Get_Immediate (Current_In, Item);
 527    end Get_Immediate;
 528
 529    procedure Get_Immediate
 530      (File      : in File_Type;
 531       Item      : out Character;
 532       Available : out Boolean)
 533    is
 534       ch          : int;
 535       end_of_file : int;
 536       avail       : int;
 537
 538       procedure getc_immediate_nowait
 539         (stream      : FILEs;
 540          ch          : out int;
 541          end_of_file : out int;
 542          avail       : out int);
 543       pragma Import (C, getc_immediate_nowait, "getc_immediate_nowait");
 544
 545    begin
 546       FIO.Check_Read_Status (AP (File));
 547
 548       --  If we are logically before an end of line, but physically after it,
 549       --  then we just return the end of line character, no I/O is necessary.
 550
 551       if File.Before_LM then
 552          File.Before_LM := False;
 553          File.Before_LM_PM := False;
 554
 555          Available := True;
 556          Item := Character'Val (LM);
 557
 558       --  Normal case where a read operation is required
 559
 560       else
 561          getc_immediate_nowait (File.Stream, ch, end_of_file, avail);
 562
 563          if ferror (File.Stream) /= 0 then
 564             raise Device_Error;
 565
 566          elsif end_of_file /= 0 then
 567             raise End_Error;
 568
 569          elsif avail = 0 then
 570             Available := False;
 571             Item := ASCII.NUL;
 572
 573          else
 574             Available := True;
 575             Item := Character'Val (ch);
 576          end if;
 577       end if;
 578
 579    end Get_Immediate;
 580
 581    procedure Get_Immediate
 582      (Item      : out Character;
 583       Available : out Boolean)
 584    is
 585    begin
 586       Get_Immediate (Current_In, Item, Available);
 587    end Get_Immediate;
 588
 589    --------------
 590    -- Get_Line --
 591    --------------
 592
 593    procedure Get_Line
 594      (File : in File_Type;
 595       Item : out String;
 596       Last : out Natural)
 597    is
 598       ch : int;
 599
 600    begin
 601       FIO.Check_Read_Status (AP (File));
 602       Last := Item'First - 1;
 603
 604       --  Immediate exit for null string, this is a case in which we do not
 605       --  need to test for end of file and we do not skip a line mark under
 606       --  any circumstances.
 607
 608       if Last >= Item'Last then
 609          return;
 610       end if;
 611
 612       --  Here we have at least one character, if we are immediately before
 613       --  a line mark, then we will just skip past it storing no characters.
 614
 615       if File.Before_LM then
 616          File.Before_LM := False;
 617          File.Before_LM_PM := False;
 618
 619       --  Otherwise we need to read some characters
 620
 621       else
 622          ch := Getc (File);
 623
 624          --  If we are at the end of file now, it means we are trying to
 625          --  skip a file terminator and we raise End_Error (RM A.10.7(20))
 626
 627          if ch = EOF then
 628             raise End_Error;
 629          end if;
 630
 631          --  Loop through characters. Don't bother if we hit a page mark,
 632          --  since in normal files, page marks can only follow line marks
 633          --  in any case and we only promise to treat the page nonsense
 634          --  correctly in the absense of such rogue page marks.
 635
 636          loop
 637             --  Exit the loop if read is terminated by encountering line mark
 638
 639             exit when ch = LM;
 640
 641             --  Otherwise store the character, note that we know that ch is
 642             --  something other than LM or EOF. It could possibly be a page
 643             --  mark if there is a stray page mark in the middle of a line,
 644             --  but this is not an official page mark in any case, since
 645             --  official page marks can only follow a line mark. The whole
 646             --  page business is pretty much nonsense anyway, so we do not
 647             --  want to waste time trying to make sense out of non-standard
 648             --  page marks in the file! This means that the behavior of
 649             --  Get_Line is different from repeated Get of a character, but
 650             --  that's too bad. We only promise that page numbers etc make
 651             --  sense if the file is formatted in a standard manner.
 652
 653             --  Note: we do not adjust the column number because it is quicker
 654             --  to adjust it once at the end of the operation than incrementing
 655             --  it each time around the loop.
 656
 657             Last := Last + 1;
 658             Item (Last) := Character'Val (ch);
 659
 660             --  All done if the string is full, this is the case in which
 661             --  we do not skip the following line mark. We need to adjust
 662             --  the column number in this case.
 663
 664             if Last = Item'Last then
 665                File.Col := File.Col + Count (Item'Length);
 666                return;
 667             end if;
 668
 669             --  Otherwise read next character. We also exit from the loop if
 670             --  we read an end of file. This is the case where the last line
 671             --  is not terminated with a line mark, and we consider that there
 672             --  is an implied line mark in this case (this is a non-standard
 673             --  file, but it is nice to treat it reasonably).
 674
 675             ch := Getc (File);
 676             exit when ch = EOF;
 677          end loop;
 678       end if;
 679
 680       --  We have skipped past, but not stored, a line mark. Skip following
 681       --  page mark if one follows, but do not do this for a non-regular
 682       --  file (since otherwise we get annoying wait for an extra character)
 683
 684       File.Line := File.Line + 1;
 685       File.Col := 1;
 686
 687       if File.Before_LM_PM then
 688          File.Line := 1;
 689          File.Before_LM_PM := False;
 690          File.Page := File.Page + 1;
 691
 692       elsif File.Is_Regular_File then
 693          ch := Getc (File);
 694
 695          if ch = PM and then File.Is_Regular_File then
 696             File.Line := 1;
 697             File.Page := File.Page + 1;
 698          else
 699             Ungetc (ch, File);
 700          end if;
 701       end if;
 702    end Get_Line;
 703
 704    procedure Get_Line
 705      (Item : out String;
 706       Last : out Natural)
 707    is
 708    begin
 709       Get_Line (Current_In, Item, Last);
 710    end Get_Line;
 711
 712    ----------
 713    -- Getc --
 714    ----------
 715
 716    function Getc (File : File_Type) return int is
 717       ch : int;
 718
 719    begin
 720       ch := fgetc (File.Stream);
 721
 722       if ch = EOF and then ferror (File.Stream) /= 0 then
 723          raise Device_Error;
 724       else
 725          return ch;
 726       end if;
 727    end Getc;
 728
 729    -------------
 730    -- Is_Open --
 731    -------------
 732
 733    function Is_Open (File : in File_Type) return Boolean is
 734    begin
 735       return FIO.Is_Open (AP (File));
 736    end Is_Open;
 737
 738    ----------
 739    -- Line --
 740    ----------
 741
 742    --  Note: we assume that it is impossible in practice for the line
 743    --  to exceed the value of Count'Last, i.e. no check is required for
 744    --  overflow raising layout error.
 745
 746    function Line (File : in File_Type) return Positive_Count is
 747    begin
 748       FIO.Check_File_Open (AP (File));
 749       return File.Line;
 750    end Line;
 751
 752    function Line return Positive_Count is
 753    begin
 754       return Line (Current_Out);
 755    end Line;
 756
 757    -----------------
 758    -- Line_Length --
 759    -----------------
 760
 761    function Line_Length (File : in File_Type) return Count is
 762    begin
 763       FIO.Check_Write_Status (AP (File));
 764       return File.Line_Length;
 765    end Line_Length;
 766
 767    function Line_Length return Count is
 768    begin
 769       return Line_Length (Current_Out);
 770    end Line_Length;
 771
 772    ----------------
 773    -- Look_Ahead --
 774    ----------------
 775
 776    procedure Look_Ahead
 777      (File        : in File_Type;
 778       Item        : out Character;
 779       End_Of_Line : out Boolean)
 780    is
 781       ch : int;
 782
 783    begin
 784       FIO.Check_Read_Status (AP (File));
 785
 786       if File.Before_LM then
 787          End_Of_Line := True;
 788          Item := ASCII.NUL;
 789
 790       else
 791          ch := Nextc (File);
 792
 793          if ch = LM
 794            or else ch = EOF
 795            or else (ch = PM and then File.Is_Regular_File)
 796          then
 797             End_Of_Line := True;
 798             Item := ASCII.NUL;
 799          else
 800             End_Of_Line := False;
 801             Item := Character'Val (ch);
 802          end if;
 803       end if;
 804    end Look_Ahead;
 805
 806    procedure Look_Ahead
 807      (Item        : out Character;
 808       End_Of_Line : out Boolean)
 809    is
 810    begin
 811       Look_Ahead (Current_In, Item, End_Of_Line);
 812    end Look_Ahead;
 813
 814    ----------
 815    -- Mode --
 816    ----------
 817
 818    function Mode (File : in File_Type) return File_Mode is
 819    begin
 820       return To_TIO (FIO.Mode (AP (File)));
 821    end Mode;
 822
 823    ----------
 824    -- Name --
 825    ----------
 826
 827    function Name (File : in File_Type) return String is
 828    begin
 829       return FIO.Name (AP (File));
 830    end Name;
 831
 832    --------------
 833    -- New_Line --
 834    --------------
 835
 836    procedure New_Line
 837      (File    : in File_Type;
 838       Spacing : in Positive_Count := 1)
 839    is
 840    begin
 841       --  Raise Constraint_Error if out of range value. The reason for this
 842       --  explicit test is that we don't want junk values around, even if
 843       --  checks are off in the caller.
 844
 845       if Spacing not in Positive_Count then
 846          raise Constraint_Error;
 847       end if;
 848
 849       FIO.Check_Write_Status (AP (File));
 850
 851       for K in 1 .. Spacing loop
 852          Putc (LM, File);
 853          File.Line := File.Line + 1;
 854
 855          if File.Page_Length /= 0
 856            and then File.Line > File.Page_Length
 857          then
 858             Putc (PM, File);
 859             File.Line := 1;
 860             File.Page := File.Page + 1;
 861          end if;
 862       end loop;
 863
 864       File.Col := 1;
 865    end New_Line;
 866
 867    procedure New_Line (Spacing : in Positive_Count := 1) is
 868    begin
 869       New_Line (Current_Out, Spacing);
 870    end New_Line;
 871
 872    --------------
 873    -- New_Page --
 874    --------------
 875
 876    procedure New_Page (File : in File_Type) is
 877    begin
 878       FIO.Check_Write_Status (AP (File));
 879
 880       if File.Col /= 1 or else File.Line = 1 then
 881          Putc (LM, File);
 882       end if;
 883
 884       Putc (PM, File);
 885       File.Page := File.Page + 1;
 886       File.Line := 1;
 887       File.Col := 1;
 888    end New_Page;
 889
 890    procedure New_Page is
 891    begin
 892       New_Page (Current_Out);
 893    end New_Page;
 894
 895    -----------
 896    -- Nextc --
 897    -----------
 898
 899    function Nextc (File : File_Type) return int is
 900       ch : int;
 901
 902    begin
 903       ch := fgetc (File.Stream);
 904
 905       if ch = EOF then
 906          if ferror (File.Stream) /= 0 then
 907             raise Device_Error;
 908          end if;
 909
 910       else
 911          if ungetc (ch, File.Stream) = EOF then
 912             raise Device_Error;
 913          end if;
 914       end if;
 915
 916       return ch;
 917    end Nextc;
 918
 919    ----------
 920    -- Open --
 921    ----------
 922
 923    procedure Open
 924      (File : in out File_Type;
 925       Mode : in File_Mode;
 926       Name : in String;
 927       Form : in String := "")
 928    is
 929       Dummy_File_Control_Block : Text_AFCB;
 930       pragma Warnings (Off, Dummy_File_Control_Block);
 931       --  Yes, we know this is never assigned a value, only the tag
 932       --  is used for dispatching purposes, so that's expected.
 933
 934    begin
 935       FIO.Open (File_Ptr  => AP (File),
 936                 Dummy_FCB => Dummy_File_Control_Block,
 937                 Mode      => To_FCB (Mode),
 938                 Name      => Name,
 939                 Form      => Form,
 940                 Amethod   => 'T',
 941                 Creat     => False,
 942                 Text      => True);
 943
 944       File.Self := File;
 945    end Open;
 946
 947    ----------
 948    -- Page --
 949    ----------
 950
 951    --  Note: we assume that it is impossible in practice for the page
 952    --  to exceed the value of Count'Last, i.e. no check is required for
 953    --  overflow raising layout error.
 954
 955    function Page (File : in File_Type) return Positive_Count is
 956    begin
 957       FIO.Check_File_Open (AP (File));
 958       return File.Page;
 959    end Page;
 960
 961    function Page return Positive_Count is
 962    begin
 963       return Page (Current_Out);
 964    end Page;
 965
 966    -----------------
 967    -- Page_Length --
 968    -----------------
 969
 970    function Page_Length (File : in File_Type) return Count is
 971    begin
 972       FIO.Check_Write_Status (AP (File));
 973       return File.Page_Length;
 974    end Page_Length;
 975
 976    function Page_Length return Count is
 977    begin
 978       return Page_Length (Current_Out);
 979    end Page_Length;
 980
 981    ---------
 982    -- Put --
 983    ---------
 984
 985    procedure Put
 986      (File : in File_Type;
 987       Item : in Character)
 988    is
 989    begin
 990       FIO.Check_Write_Status (AP (File));
 991
 992       if File.Line_Length /= 0 and then File.Col > File.Line_Length then
 993          New_Line (File);
 994       end if;
 995
 996       if fputc (Character'Pos (Item), File.Stream) = EOF then
 997          raise Device_Error;
 998       end if;
 999
1000       File.Col := File.Col + 1;
1001    end Put;
1002
1003    procedure Put (Item : in Character) is
1004    begin
1005       FIO.Check_Write_Status (AP (Current_Out));
1006
1007       if Current_Out.Line_Length /= 0
1008         and then Current_Out.Col > Current_Out.Line_Length
1009       then
1010          New_Line (Current_Out);
1011       end if;
1012
1013       if fputc (Character'Pos (Item), Current_Out.Stream) = EOF then
1014          raise Device_Error;
1015       end if;
1016
1017       Current_Out.Col := Current_Out.Col + 1;
1018    end Put;
1019
1020    ---------
1021    -- Put --
1022    ---------
1023
1024    procedure Put
1025      (File : in File_Type;
1026       Item : in String)
1027    is
1028    begin
1029       FIO.Check_Write_Status (AP (File));
1030
1031       if Item'Length > 0 then
1032
1033          --  If we have bounded lines, then do things character by
1034          --  character (this seems a rare case anyway!)
1035
1036          if File.Line_Length /= 0 then
1037             for J in Item'Range loop
1038                Put (File, Item (J));
1039             end loop;
1040
1041          --  Otherwise we can output the entire string at once. Note that if
1042          --  there are LF or FF characters in the string, we do not bother to
1043          --  count them as line or page terminators.
1044
1045          else
1046             FIO.Write_Buf (AP (File), Item'Address, Item'Length);
1047             File.Col := File.Col + Item'Length;
1048          end if;
1049       end if;
1050    end Put;
1051
1052    procedure Put (Item : in String) is
1053    begin
1054       Put (Current_Out, Item);
1055    end Put;
1056
1057    --------------
1058    -- Put_Line --
1059    --------------
1060
1061    procedure Put_Line
1062      (File : in File_Type;
1063       Item : in String)
1064    is
1065       Ilen   : Natural := Item'Length;
1066       Istart : Natural := Item'First;
1067
1068    begin
1069       FIO.Check_Write_Status (AP (File));
1070
1071       --  If we have bounded lines, then just do a put and a new line. In
1072       --  this case we will end up doing things character by character in
1073       --  any case, and it is a rare situation.
1074
1075       if File.Line_Length /= 0 then
1076          Put (File, Item);
1077          New_Line (File);
1078          return;
1079       end if;
1080
1081       --  We setup a single string that has the necessary terminators and
1082       --  then write it with a single call. The reason for doing this is
1083       --  that it gives better behavior for the use of Put_Line in multi-
1084       --  tasking programs, since often the OS will treat the entire put
1085       --  operation as an atomic operation.
1086
1087       --  We only do this if the message is 512 characters or less in length,
1088       --  since otherwise Put_Line would use an unbounded amount of stack
1089       --  space and could cause undetected stack overflow. If we have a
1090       --  longer string, then output the first part separately to avoid this.
1091
1092       if Ilen > 512 then
1093          FIO.Write_Buf (AP (File), Item'Address, size_t (Ilen - 512));
1094          Istart := Istart + Ilen - 512;
1095          Ilen   := 512;
1096       end if;
1097
1098       --  Now prepare the string with its terminator
1099
1100       declare
1101          Buffer : String (1 .. Ilen + 2);
1102          Plen   : size_t;
1103
1104       begin
1105          Buffer (1 .. Ilen) := Item (Istart .. Item'Last);
1106          Buffer (Ilen + 1) := Character'Val (LM);
1107
1108          if File.Page_Length /= 0
1109            and then File.Line > File.Page_Length
1110          then
1111             Buffer (Ilen + 2) := Character'Val (PM);
1112             Plen := size_t (Ilen) + 2;
1113             File.Line := 1;
1114             File.Page := File.Page + 1;
1115
1116          else
1117             Plen := size_t (Ilen) + 1;
1118             File.Line := File.Line + 1;
1119          end if;
1120
1121          FIO.Write_Buf (AP (File), Buffer'Address, Plen);
1122
1123          File.Col := 1;
1124       end;
1125    end Put_Line;
1126
1127    procedure Put_Line (Item : in String) is
1128    begin
1129       Put_Line (Current_Out, Item);
1130    end Put_Line;
1131
1132    ----------
1133    -- Putc --
1134    ----------
1135
1136    procedure Putc (ch : int; File : File_Type) is
1137    begin
1138       if fputc (ch, File.Stream) = EOF then
1139          raise Device_Error;
1140       end if;
1141    end Putc;
1142
1143    ----------
1144    -- Read --
1145    ----------
1146
1147    --  This is the primitive Stream Read routine, used when a Text_IO file
1148    --  is treated directly as a stream using Text_IO.Streams.Stream.
1149
1150    procedure Read
1151      (File : in out Text_AFCB;
1152       Item : out Stream_Element_Array;
1153       Last : out Stream_Element_Offset)
1154    is
1155       Discard_ch : int;
1156       pragma Warnings (Off, Discard_ch);
1157
1158    begin
1159       if File.Mode /= FCB.In_File then
1160          raise Mode_Error;
1161       end if;
1162
1163       --  Deal with case where our logical and physical position do not match
1164       --  because of being after an LM or LM-PM sequence when in fact we are
1165       --  logically positioned before it.
1166
1167       if File.Before_LM then
1168
1169          --  If we are before a PM, then it is possible for a stream read
1170          --  to leave us after the LM and before the PM, which is a bit
1171          --  odd. The easiest way to deal with this is to unget the PM,
1172          --  so we are indeed positioned between the characters. This way
1173          --  further stream read operations will work correctly, and the
1174          --  effect on text processing is a little weird, but what can
1175          --  be expected if stream and text input are mixed this way?
1176
1177          if File.Before_LM_PM then
1178             Discard_ch := ungetc (PM, File.Stream);
1179             File.Before_LM_PM := False;
1180          end if;
1181
1182          File.Before_LM := False;
1183
1184          Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF));
1185
1186          if Item'Length = 1 then
1187             Last := Item'Last;
1188
1189          else
1190             Last :=
1191               Item'First +
1192                 Stream_Element_Offset
1193                   (fread (buffer => Item'Address,
1194                           index  => size_t (Item'First + 1),
1195                           size   => 1,
1196                           count  => Item'Length - 1,
1197                           stream => File.Stream));
1198          end if;
1199
1200          return;
1201       end if;
1202
1203       --  Now we do the read. Since this is a text file, it is normally in
1204       --  text mode, but stream data must be read in binary mode, so we
1205       --  temporarily set binary mode for the read, resetting it after.
1206       --  These calls have no effect in a system (like Unix) where there is
1207       --  no distinction between text and binary files.
1208
1209       set_binary_mode (fileno (File.Stream));
1210
1211       Last :=
1212         Item'First +
1213           Stream_Element_Offset
1214             (fread (Item'Address, 1, Item'Length, File.Stream)) - 1;
1215
1216       if Last < Item'Last then
1217          if ferror (File.Stream) /= 0 then
1218             raise Device_Error;
1219          end if;
1220       end if;
1221
1222       set_text_mode (fileno (File.Stream));
1223    end Read;
1224
1225    -----------
1226    -- Reset --
1227    -----------
1228
1229    procedure Reset
1230      (File : in out File_Type;
1231       Mode : in File_Mode)
1232    is
1233    begin
1234       --  Don't allow change of mode for current file (RM A.10.2(5))
1235
1236       if (File = Current_In or else
1237           File = Current_Out  or else
1238           File = Current_Error)
1239         and then To_FCB (Mode) /= File.Mode
1240       then
1241          raise Mode_Error;
1242       end if;
1243
1244       Terminate_Line (File);
1245       FIO.Reset (AP (File), To_FCB (Mode));
1246       File.Page := 1;
1247       File.Line := 1;
1248       File.Col  := 1;
1249       File.Line_Length := 0;
1250       File.Page_Length := 0;
1251       File.Before_LM := False;
1252       File.Before_LM_PM := False;
1253    end Reset;
1254
1255    procedure Reset (File : in out File_Type) is
1256    begin
1257       Terminate_Line (File);
1258       FIO.Reset (AP (File));
1259       File.Page := 1;
1260       File.Line := 1;
1261       File.Col  := 1;
1262       File.Line_Length := 0;
1263       File.Page_Length := 0;
1264       File.Before_LM := False;
1265       File.Before_LM_PM := False;
1266    end Reset;
1267
1268    -------------
1269    -- Set_Col --
1270    -------------
1271
1272    procedure Set_Col
1273      (File : in File_Type;
1274       To   : in Positive_Count)
1275    is
1276       ch : int;
1277
1278    begin
1279       --  Raise Constraint_Error if out of range value. The reason for this
1280       --  explicit test is that we don't want junk values around, even if
1281       --  checks are off in the caller.
1282
1283       if To not in Positive_Count then
1284          raise Constraint_Error;
1285       end if;
1286
1287       FIO.Check_File_Open (AP (File));
1288
1289       if To = File.Col then
1290          return;
1291       end if;
1292
1293       if Mode (File) >= Out_File then
1294          if File.Line_Length /= 0 and then To > File.Line_Length then
1295             raise Layout_Error;
1296          end if;
1297
1298          if To < File.Col then
1299             New_Line (File);
1300          end if;
1301
1302          while File.Col < To loop
1303             Put (File, ' ');
1304          end loop;
1305
1306       else
1307          loop
1308             ch := Getc (File);
1309
1310             if ch = EOF then
1311                raise End_Error;
1312
1313             elsif ch = LM then
1314                File.Line := File.Line + 1;
1315                File.Col := 1;
1316
1317             elsif ch = PM and then File.Is_Regular_File then
1318                File.Page := File.Page + 1;
1319                File.Line := 1;
1320                File.Col := 1;
1321
1322             elsif To = File.Col then
1323                Ungetc (ch, File);
1324                return;
1325
1326             else
1327                File.Col := File.Col + 1;
1328             end if;
1329          end loop;
1330       end if;
1331    end Set_Col;
1332
1333    procedure Set_Col (To : in Positive_Count) is
1334    begin
1335       Set_Col (Current_Out, To);
1336    end Set_Col;
1337
1338    ---------------
1339    -- Set_Error --
1340    ---------------
1341
1342    procedure Set_Error (File : in File_Type) is
1343    begin
1344       FIO.Check_Write_Status (AP (File));
1345       Current_Err := File;
1346    end Set_Error;
1347
1348    ---------------
1349    -- Set_Input --
1350    ---------------
1351
1352    procedure Set_Input (File : in File_Type) is
1353    begin
1354       FIO.Check_Read_Status (AP (File));
1355       Current_In := File;
1356    end Set_Input;
1357
1358    --------------
1359    -- Set_Line --
1360    --------------
1361
1362    procedure Set_Line
1363      (File : in File_Type;
1364       To   : in Positive_Count)
1365    is
1366    begin
1367       --  Raise Constraint_Error if out of range value. The reason for this
1368       --  explicit test is that we don't want junk values around, even if
1369       --  checks are off in the caller.
1370
1371       if To not in Positive_Count then
1372          raise Constraint_Error;
1373       end if;
1374
1375       FIO.Check_File_Open (AP (File));
1376
1377       if To = File.Line then
1378          return;
1379       end if;
1380
1381       if Mode (File) >= Out_File then
1382          if File.Page_Length /= 0 and then To > File.Page_Length then
1383             raise Layout_Error;
1384          end if;
1385
1386          if To < File.Line then
1387             New_Page (File);
1388          end if;
1389
1390          while File.Line < To loop
1391             New_Line (File);
1392          end loop;
1393
1394       else
1395          while To /= File.Line loop
1396             Skip_Line (File);
1397          end loop;
1398       end if;
1399    end Set_Line;
1400
1401    procedure Set_Line (To : in Positive_Count) is
1402    begin
1403       Set_Line (Current_Out, To);
1404    end Set_Line;
1405
1406    ---------------------
1407    -- Set_Line_Length --
1408    ---------------------
1409
1410    procedure Set_Line_Length (File : in File_Type; To : in Count) is
1411    begin
1412       --  Raise Constraint_Error if out of range value. The reason for this
1413       --  explicit test is that we don't want junk values around, even if
1414       --  checks are off in the caller.
1415
1416       if To not in Count then
1417          raise Constraint_Error;
1418       end if;
1419
1420       FIO.Check_Write_Status (AP (File));
1421       File.Line_Length := To;
1422    end Set_Line_Length;
1423
1424    procedure Set_Line_Length (To : in Count) is
1425    begin
1426       Set_Line_Length (Current_Out, To);
1427    end Set_Line_Length;
1428
1429    ----------------
1430    -- Set_Output --
1431    ----------------
1432
1433    procedure Set_Output (File : in File_Type) is
1434    begin
1435       FIO.Check_Write_Status (AP (File));
1436       Current_Out := File;
1437    end Set_Output;
1438
1439    ---------------------
1440    -- Set_Page_Length --
1441    ---------------------
1442
1443    procedure Set_Page_Length (File : in File_Type; To : in Count) is
1444    begin
1445       --  Raise Constraint_Error if out of range value. The reason for this
1446       --  explicit test is that we don't want junk values around, even if
1447       --  checks are off in the caller.
1448
1449       if To not in Count then
1450          raise Constraint_Error;
1451       end if;
1452
1453       FIO.Check_Write_Status (AP (File));
1454       File.Page_Length := To;
1455    end Set_Page_Length;
1456
1457    procedure Set_Page_Length (To : in Count) is
1458    begin
1459       Set_Page_Length (Current_Out, To);
1460    end Set_Page_Length;
1461
1462    ---------------
1463    -- Skip_Line --
1464    ---------------
1465
1466    procedure Skip_Line
1467      (File    : in File_Type;
1468       Spacing : in Positive_Count := 1)
1469    is
1470       ch : int;
1471
1472    begin
1473       --  Raise Constraint_Error if out of range value. The reason for this
1474       --  explicit test is that we don't want junk values around, even if
1475       --  checks are off in the caller.
1476
1477       if Spacing not in Positive_Count then
1478          raise Constraint_Error;
1479       end if;
1480
1481       FIO.Check_Read_Status (AP (File));
1482
1483       for L in 1 .. Spacing loop
1484          if File.Before_LM then
1485             File.Before_LM := False;
1486             File.Before_LM_PM := False;
1487
1488          else
1489             ch := Getc (File);
1490
1491             --  If at end of file now, then immediately raise End_Error. Note
1492             --  that we can never be positioned between a line mark and a page
1493             --  mark, so if we are at the end of file, we cannot logically be
1494             --  before the implicit page mark that is at the end of the file.
1495
1496             --  For the same reason, we do not need an explicit check for a
1497             --  page mark. If there is a FF in the middle of a line, the file
1498             --  is not in canonical format and we do not care about the page
1499             --  numbers for files other than ones in canonical format.
1500
1501             if ch = EOF then
1502                raise End_Error;
1503             end if;
1504
1505             --  If not at end of file, then loop till we get to an LM or EOF.
1506             --  The latter case happens only in non-canonical files where the
1507             --  last line is not terminated by LM, but we don't want to blow
1508             --  up for such files, so we assume an implicit LM in this case.
1509
1510             loop
1511                exit when ch = LM or ch = EOF;
1512                ch := Getc (File);
1513             end loop;
1514          end if;
1515
1516          --  We have got past a line mark, now, for a regular file only,
1517          --  see if a page mark immediately follows this line mark and
1518          --  if so, skip past the page mark as well. We do not do this
1519          --  for non-regular files, since it would cause an undesirable
1520          --  wait for an additional character.
1521
1522          File.Col := 1;
1523          File.Line := File.Line + 1;
1524
1525          if File.Before_LM_PM then
1526             File.Page := File.Page + 1;
1527             File.Line := 1;
1528             File.Before_LM_PM := False;
1529
1530          elsif File.Is_Regular_File then
1531             ch := Getc (File);
1532
1533             --  Page mark can be explicit, or implied at the end of the file
1534
1535             if (ch = PM or else ch = EOF)
1536               and then File.Is_Regular_File
1537             then
1538                File.Page := File.Page + 1;
1539                File.Line := 1;
1540             else
1541                Ungetc (ch, File);
1542             end if;
1543          end if;
1544
1545       end loop;
1546    end Skip_Line;
1547
1548    procedure Skip_Line (Spacing : in Positive_Count := 1) is
1549    begin
1550       Skip_Line (Current_In, Spacing);
1551    end Skip_Line;
1552
1553    ---------------
1554    -- Skip_Page --
1555    ---------------
1556
1557    procedure Skip_Page (File : in File_Type) is
1558       ch : int;
1559
1560    begin
1561       FIO.Check_Read_Status (AP (File));
1562
1563       --  If at page mark already, just skip it
1564
1565       if File.Before_LM_PM then
1566          File.Before_LM := False;
1567          File.Before_LM_PM := False;
1568          File.Page := File.Page + 1;
1569          File.Line := 1;
1570          File.Col  := 1;
1571          return;
1572       end if;
1573
1574       --  This is a bit tricky, if we are logically before an LM then
1575       --  it is not an error if we are at an end of file now, since we
1576       --  are not really at it.
1577
1578       if File.Before_LM then
1579          File.Before_LM := False;
1580          File.Before_LM_PM := False;
1581          ch := Getc (File);
1582
1583       --  Otherwise we do raise End_Error if we are at the end of file now
1584
1585       else
1586          ch := Getc (File);
1587
1588          if ch = EOF then
1589             raise End_Error;
1590          end if;
1591       end if;
1592
1593       --  Now we can just rumble along to the next page mark, or to the
1594       --  end of file, if that comes first. The latter case happens when
1595       --  the page mark is implied at the end of file.
1596
1597       loop
1598          exit when ch = EOF
1599            or else (ch = PM and then File.Is_Regular_File);
1600          ch := Getc (File);
1601       end loop;
1602
1603       File.Page := File.Page + 1;
1604       File.Line := 1;
1605       File.Col  := 1;
1606    end Skip_Page;
1607
1608    procedure Skip_Page is
1609    begin
1610       Skip_Page (Current_In);
1611    end Skip_Page;
1612
1613    --------------------
1614    -- Standard_Error --
1615    --------------------
1616
1617    function Standard_Error return File_Type is
1618    begin
1619       return Standard_Err;
1620    end Standard_Error;
1621
1622    function Standard_Error return File_Access is
1623    begin
1624       return Standard_Err'Access;
1625    end Standard_Error;
1626
1627    --------------------
1628    -- Standard_Input --
1629    --------------------
1630
1631    function Standard_Input return File_Type is
1632    begin
1633       return Standard_In;
1634    end Standard_Input;
1635
1636    function Standard_Input return File_Access is
1637    begin
1638       return Standard_In'Access;
1639    end Standard_Input;
1640
1641    ---------------------
1642    -- Standard_Output --
1643    ---------------------
1644
1645    function Standard_Output return File_Type is
1646    begin
1647       return Standard_Out;
1648    end Standard_Output;
1649
1650    function Standard_Output return File_Access is
1651    begin
1652       return Standard_Out'Access;
1653    end Standard_Output;
1654
1655    --------------------
1656    -- Terminate_Line --
1657    --------------------
1658
1659    procedure Terminate_Line (File : File_Type) is
1660    begin
1661       FIO.Check_File_Open (AP (File));
1662
1663       --  For file other than In_File, test for needing to terminate last line
1664
1665       if Mode (File) /= In_File then
1666
1667          --  If not at start of line definition need new line
1668
1669          if File.Col /= 1 then
1670             New_Line (File);
1671
1672          --  For files other than standard error and standard output, we
1673          --  make sure that an empty file has a single line feed, so that
1674          --  it is properly formatted. We avoid this for the standard files
1675          --  because it is too much of a nuisance to have these odd line
1676          --  feeds when nothing has been written to the file.
1677
1678          elsif (File /= Standard_Err and then File /= Standard_Out)
1679            and then (File.Line = 1 and then File.Page = 1)
1680          then
1681             New_Line (File);
1682          end if;
1683       end if;
1684    end Terminate_Line;
1685
1686    ------------
1687    -- Ungetc --
1688    ------------
1689
1690    procedure Ungetc (ch : int; File : File_Type) is
1691    begin
1692       if ch /= EOF then
1693          if ungetc (ch, File.Stream) = EOF then
1694             raise Device_Error;
1695          end if;
1696       end if;
1697    end Ungetc;
1698
1699    -----------
1700    -- Write --
1701    -----------
1702
1703    --  This is the primitive Stream Write routine, used when a Text_IO file
1704    --  is treated directly as a stream using Text_IO.Streams.Stream.
1705
1706    procedure Write
1707      (File : in out Text_AFCB;
1708       Item : in Stream_Element_Array)
1709    is
1710
1711       function Has_Translated_Characters return Boolean;
1712       --  return True if Item array contains a character which will be
1713       --  translated under the text file mode. There is only one such
1714       --  character under DOS based systems which is character 10.
1715
1716       text_translation_required : Boolean;
1717       pragma Import (C, text_translation_required,
1718                      "__gnat_text_translation_required");
1719
1720       Siz : constant size_t := Item'Length;
1721
1722       function Has_Translated_Characters return Boolean is
1723       begin
1724          for K in Item'Range loop
1725             if Item (K) = 10 then
1726                return True;
1727             end if;
1728          end loop;
1729          return False;
1730       end Has_Translated_Characters;
1731
1732       Needs_Binary_Write : constant Boolean :=
1733         text_translation_required and then Has_Translated_Characters;
1734
1735    begin
1736       if File.Mode = FCB.In_File then
1737          raise Mode_Error;
1738       end if;
1739
1740       --  Now we do the write. Since this is a text file, it is normally in
1741       --  text mode, but stream data must be written in binary mode, so we
1742       --  temporarily set binary mode for the write, resetting it after. This
1743       --  is done only if needed (i.e. there is some characters in Item which
1744       --  needs to be written using the binary mode).
1745       --  These calls have no effect in a system (like Unix) where there is
1746       --  no distinction between text and binary files.
1747
1748       --  Since the character translation is done at the time the buffer is
1749       --  written (this is true under Windows) we first flush current buffer
1750       --  with text mode if needed.
1751
1752       if Needs_Binary_Write then
1753
1754          if fflush (File.Stream) = -1 then
1755             raise Device_Error;
1756          end if;
1757
1758          set_binary_mode (fileno (File.Stream));
1759       end if;
1760
1761       if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then
1762          raise Device_Error;
1763       end if;
1764
1765       --  At this point we need to flush the buffer using the binary mode then
1766       --  we reset to text mode.
1767
1768       if Needs_Binary_Write then
1769
1770          if fflush (File.Stream) = -1 then
1771             raise Device_Error;
1772          end if;
1773
1774          set_text_mode (fileno (File.Stream));
1775       end if;
1776    end Write;
1777
1778    --  Use "preallocated" strings to avoid calling "new" during the
1779    --  elaboration of the run time. This is needed in the tasking case to
1780    --  avoid calling Task_Lock too early. A filename is expected to end with a
1781    --  null character in the runtime, here the null characters are added just
1782    --  to have a correct filename length.
1783
1784    Err_Name : aliased String := "*stderr" & ASCII.Nul;
1785    In_Name  : aliased String := "*stdin" & ASCII.Nul;
1786    Out_Name : aliased String := "*stdout" & ASCII.Nul;
1787 begin
1788    -------------------------------
1789    -- Initialize Standard Files --
1790    -------------------------------
1791
1792    --  Note: the names in these files are bogus, and probably it would be
1793    --  better for these files to have no names, but the ACVC test insist!
1794    --  We use names that are bound to fail in open etc.
1795
1796    Standard_Err.Stream            := stderr;
1797    Standard_Err.Name              := Err_Name'Access;
1798    Standard_Err.Form              := Null_Str'Unrestricted_Access;
1799    Standard_Err.Mode              := FCB.Out_File;
1800    Standard_Err.Is_Regular_File   := is_regular_file (fileno (stderr)) /= 0;
1801    Standard_Err.Is_Temporary_File := False;
1802    Standard_Err.Is_System_File    := True;
1803    Standard_Err.Is_Text_File      := True;
1804    Standard_Err.Access_Method     := 'T';
1805    Standard_Err.Self              := Standard_Err;
1806
1807    Standard_In.Stream             := stdin;
1808    Standard_In.Name               := In_Name'Access;
1809    Standard_In.Form               := Null_Str'Unrestricted_Access;
1810    Standard_In.Mode               := FCB.In_File;
1811    Standard_In.Is_Regular_File    := is_regular_file (fileno (stdin)) /= 0;
1812    Standard_In.Is_Temporary_File  := False;
1813    Standard_In.Is_System_File     := True;
1814    Standard_In.Is_Text_File       := True;
1815    Standard_In.Access_Method      := 'T';
1816    Standard_In.Self               := Standard_In;
1817
1818    Standard_Out.Stream            := stdout;
1819    Standard_Out.Name              := Out_Name'Access;
1820    Standard_Out.Form              := Null_Str'Unrestricted_Access;
1821    Standard_Out.Mode              := FCB.Out_File;
1822    Standard_Out.Is_Regular_File   := is_regular_file (fileno (stdout)) /= 0;
1823    Standard_Out.Is_Temporary_File := False;
1824    Standard_Out.Is_System_File    := True;
1825    Standard_Out.Is_Text_File      := True;
1826    Standard_Out.Access_Method     := 'T';
1827    Standard_Out.Self              := Standard_Out;
1828
1829    FIO.Chain_File (AP (Standard_In));
1830    FIO.Chain_File (AP (Standard_Out));
1831    FIO.Chain_File (AP (Standard_Err));
1832
1833    FIO.Make_Unbuffered (AP (Standard_Out));
1834    FIO.Make_Unbuffered (AP (Standard_Err));
1835
1836 end Ada.Text_IO;