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