gcc/ada/a-textio.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                          A D A . T E X T _ I O                           --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2007, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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
  37 with System.File_IO;
  38 with System.CRTL;
  39
  40 with Ada.Unchecked_Conversion;
  41 with Ada.Unchecked_Deallocation;
  42
  43 pragma Elaborate_All (System.File_IO);
  44 --  Needed because of calls to Chain_File in package body elaboration
  45
  46 package body Ada.Text_IO is
  47
  48    package FIO renames System.File_IO;
  49
  50    subtype AP is FCB.AFCB_Ptr;
  51
  52    function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode);
  53    function To_TIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode);
  54    use type FCB.File_Mode;
  55
  56    use type System.CRTL.size_t;
  57
  58    -------------------
  59    -- AFCB_Allocate --
  60    -------------------
  61
  62    function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr is
  63       pragma Unreferenced (Control_Block);
  64    begin
  65       return new Text_AFCB;
  66    end AFCB_Allocate;
  67
  68    ----------------
  69    -- AFCB_Close --
  70    ----------------
  71
  72    procedure AFCB_Close (File : not null 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 : not null 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 Ada.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 : 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 : File_Mode := Out_File;
 139       Name : String := "";
 140       Form : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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      : 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 : 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    function Get_Line (File : File_Type) return String is
 716       Buffer : String (1 .. 500);
 717       Last   : Natural;
 718
 719       function Get_Rest (S : String) return String;
 720       --  This is a recursive function that reads the rest of the line and
 721       --  returns it. S is the part read so far.
 722
 723       --------------
 724       -- Get_Rest --
 725       --------------
 726
 727       function Get_Rest (S : String) return String is
 728
 729          --  Each time we allocate a buffer the same size as what we have
 730          --  read so far. This limits us to a logarithmic number of calls
 731          --  to Get_Rest and also ensures only a linear use of stack space.
 732
 733          Buffer : String (1 .. S'Length);
 734          Last   : Natural;
 735
 736       begin
 737          Get_Line (File, Buffer, Last);
 738
 739          declare
 740             R : constant String := S & Buffer (1 .. Last);
 741          begin
 742             if Last < Buffer'Last then
 743                return R;
 744             else
 745                return Get_Rest (R);
 746             end if;
 747          end;
 748       end Get_Rest;
 749
 750    --  Start of processing for Get_Line
 751
 752    begin
 753       Get_Line (File, Buffer, Last);
 754
 755       if Last < Buffer'Last then
 756          return Buffer (1 .. Last);
 757       else
 758          return Get_Rest (Buffer (1 .. Last));
 759       end if;
 760    end Get_Line;
 761
 762    function Get_Line return String is
 763    begin
 764       return Get_Line (Current_In);
 765    end Get_Line;
 766
 767    ----------
 768    -- Getc --
 769    ----------
 770
 771    function Getc (File : File_Type) return int is
 772       ch : int;
 773
 774    begin
 775       ch := fgetc (File.Stream);
 776
 777       if ch = EOF and then ferror (File.Stream) /= 0 then
 778          raise Device_Error;
 779       else
 780          return ch;
 781       end if;
 782    end Getc;
 783
 784    -------------
 785    -- Is_Open --
 786    -------------
 787
 788    function Is_Open (File : File_Type) return Boolean is
 789    begin
 790       return FIO.Is_Open (AP (File));
 791    end Is_Open;
 792
 793    ----------
 794    -- Line --
 795    ----------
 796
 797    --  Note: we assume that it is impossible in practice for the line
 798    --  to exceed the value of Count'Last, i.e. no check is required for
 799    --  overflow raising layout error.
 800
 801    function Line (File : File_Type) return Positive_Count is
 802    begin
 803       FIO.Check_File_Open (AP (File));
 804       return File.Line;
 805    end Line;
 806
 807    function Line return Positive_Count is
 808    begin
 809       return Line (Current_Out);
 810    end Line;
 811
 812    -----------------
 813    -- Line_Length --
 814    -----------------
 815
 816    function Line_Length (File : File_Type) return Count is
 817    begin
 818       FIO.Check_Write_Status (AP (File));
 819       return File.Line_Length;
 820    end Line_Length;
 821
 822    function Line_Length return Count is
 823    begin
 824       return Line_Length (Current_Out);
 825    end Line_Length;
 826
 827    ----------------
 828    -- Look_Ahead --
 829    ----------------
 830
 831    procedure Look_Ahead
 832      (File        : File_Type;
 833       Item        : out Character;
 834       End_Of_Line : out Boolean)
 835    is
 836       ch : int;
 837
 838    begin
 839       FIO.Check_Read_Status (AP (File));
 840
 841       if File.Before_LM then
 842          End_Of_Line := True;
 843          Item := ASCII.NUL;
 844
 845       else
 846          ch := Nextc (File);
 847
 848          if ch = LM
 849            or else ch = EOF
 850            or else (ch = PM and then File.Is_Regular_File)
 851          then
 852             End_Of_Line := True;
 853             Item := ASCII.NUL;
 854          else
 855             End_Of_Line := False;
 856             Item := Character'Val (ch);
 857          end if;
 858       end if;
 859    end Look_Ahead;
 860
 861    procedure Look_Ahead
 862      (Item        : out Character;
 863       End_Of_Line : out Boolean)
 864    is
 865    begin
 866       Look_Ahead (Current_In, Item, End_Of_Line);
 867    end Look_Ahead;
 868
 869    ----------
 870    -- Mode --
 871    ----------
 872
 873    function Mode (File : File_Type) return File_Mode is
 874    begin
 875       return To_TIO (FIO.Mode (AP (File)));
 876    end Mode;
 877
 878    ----------
 879    -- Name --
 880    ----------
 881
 882    function Name (File : File_Type) return String is
 883    begin
 884       return FIO.Name (AP (File));
 885    end Name;
 886
 887    --------------
 888    -- New_Line --
 889    --------------
 890
 891    procedure New_Line
 892      (File    : File_Type;
 893       Spacing : Positive_Count := 1)
 894    is
 895    begin
 896       --  Raise Constraint_Error if out of range value. The reason for this
 897       --  explicit test is that we don't want junk values around, even if
 898       --  checks are off in the caller.
 899
 900       if not Spacing'Valid then
 901          raise Constraint_Error;
 902       end if;
 903
 904       FIO.Check_Write_Status (AP (File));
 905
 906       for K in 1 .. Spacing loop
 907          Putc (LM, File);
 908          File.Line := File.Line + 1;
 909
 910          if File.Page_Length /= 0
 911            and then File.Line > File.Page_Length
 912          then
 913             Putc (PM, File);
 914             File.Line := 1;
 915             File.Page := File.Page + 1;
 916          end if;
 917       end loop;
 918
 919       File.Col := 1;
 920    end New_Line;
 921
 922    procedure New_Line (Spacing : Positive_Count := 1) is
 923    begin
 924       New_Line (Current_Out, Spacing);
 925    end New_Line;
 926
 927    --------------
 928    -- New_Page --
 929    --------------
 930
 931    procedure New_Page (File : File_Type) is
 932    begin
 933       FIO.Check_Write_Status (AP (File));
 934
 935       if File.Col /= 1 or else File.Line = 1 then
 936          Putc (LM, File);
 937       end if;
 938
 939       Putc (PM, File);
 940       File.Page := File.Page + 1;
 941       File.Line := 1;
 942       File.Col := 1;
 943    end New_Page;
 944
 945    procedure New_Page is
 946    begin
 947       New_Page (Current_Out);
 948    end New_Page;
 949
 950    -----------
 951    -- Nextc --
 952    -----------
 953
 954    function Nextc (File : File_Type) return int is
 955       ch : int;
 956
 957    begin
 958       ch := fgetc (File.Stream);
 959
 960       if ch = EOF then
 961          if ferror (File.Stream) /= 0 then
 962             raise Device_Error;
 963          end if;
 964
 965       else
 966          if ungetc (ch, File.Stream) = EOF then
 967             raise Device_Error;
 968          end if;
 969       end if;
 970
 971       return ch;
 972    end Nextc;
 973
 974    ----------
 975    -- Open --
 976    ----------
 977
 978    procedure Open
 979      (File : in out File_Type;
 980       Mode : File_Mode;
 981       Name : String;
 982       Form : String := "")
 983    is
 984       Dummy_File_Control_Block : Text_AFCB;
 985       pragma Warnings (Off, Dummy_File_Control_Block);
 986       --  Yes, we know this is never assigned a value, only the tag
 987       --  is used for dispatching purposes, so that's expected.
 988
 989    begin
 990       FIO.Open (File_Ptr  => AP (File),
 991                 Dummy_FCB => Dummy_File_Control_Block,
 992                 Mode      => To_FCB (Mode),
 993                 Name      => Name,
 994                 Form      => Form,
 995                 Amethod   => 'T',
 996                 Creat     => False,
 997                 Text      => True);
 998
 999       File.Self := File;
1000    end Open;
1001
1002    ----------
1003    -- Page --
1004    ----------
1005
1006    --  Note: we assume that it is impossible in practice for the page
1007    --  to exceed the value of Count'Last, i.e. no check is required for
1008    --  overflow raising layout error.
1009
1010    function Page (File : File_Type) return Positive_Count is
1011    begin
1012       FIO.Check_File_Open (AP (File));
1013       return File.Page;
1014    end Page;
1015
1016    function Page return Positive_Count is
1017    begin
1018       return Page (Current_Out);
1019    end Page;
1020
1021    -----------------
1022    -- Page_Length --
1023    -----------------
1024
1025    function Page_Length (File : File_Type) return Count is
1026    begin
1027       FIO.Check_Write_Status (AP (File));
1028       return File.Page_Length;
1029    end Page_Length;
1030
1031    function Page_Length return Count is
1032    begin
1033       return Page_Length (Current_Out);
1034    end Page_Length;
1035
1036    ---------
1037    -- Put --
1038    ---------
1039
1040    procedure Put
1041      (File : File_Type;
1042       Item : Character)
1043    is
1044    begin
1045       FIO.Check_Write_Status (AP (File));
1046
1047       if File.Line_Length /= 0 and then File.Col > File.Line_Length then
1048          New_Line (File);
1049       end if;
1050
1051       if fputc (Character'Pos (Item), File.Stream) = EOF then
1052          raise Device_Error;
1053       end if;
1054
1055       File.Col := File.Col + 1;
1056    end Put;
1057
1058    procedure Put (Item : Character) is
1059    begin
1060       FIO.Check_Write_Status (AP (Current_Out));
1061
1062       if Current_Out.Line_Length /= 0
1063         and then Current_Out.Col > Current_Out.Line_Length
1064       then
1065          New_Line (Current_Out);
1066       end if;
1067
1068       if fputc (Character'Pos (Item), Current_Out.Stream) = EOF then
1069          raise Device_Error;
1070       end if;
1071
1072       Current_Out.Col := Current_Out.Col + 1;
1073    end Put;
1074
1075    ---------
1076    -- Put --
1077    ---------
1078
1079    procedure Put
1080      (File : File_Type;
1081       Item : String)
1082    is
1083    begin
1084       FIO.Check_Write_Status (AP (File));
1085
1086       if Item'Length > 0 then
1087
1088          --  If we have bounded lines, then do things character by
1089          --  character (this seems a rare case anyway!)
1090
1091          if File.Line_Length /= 0 then
1092             for J in Item'Range loop
1093                Put (File, Item (J));
1094             end loop;
1095
1096          --  Otherwise we can output the entire string at once. Note that if
1097          --  there are LF or FF characters in the string, we do not bother to
1098          --  count them as line or page terminators.
1099
1100          else
1101             FIO.Write_Buf (AP (File), Item'Address, Item'Length);
1102             File.Col := File.Col + Item'Length;
1103          end if;
1104       end if;
1105    end Put;
1106
1107    procedure Put (Item : String) is
1108    begin
1109       Put (Current_Out, Item);
1110    end Put;
1111
1112    --------------
1113    -- Put_Line --
1114    --------------
1115
1116    procedure Put_Line
1117      (File : File_Type;
1118       Item : String)
1119    is
1120       Ilen   : Natural := Item'Length;
1121       Istart : Natural := Item'First;
1122
1123    begin
1124       FIO.Check_Write_Status (AP (File));
1125
1126       --  If we have bounded lines, then just do a put and a new line. In
1127       --  this case we will end up doing things character by character in
1128       --  any case, and it is a rare situation.
1129
1130       if File.Line_Length /= 0 then
1131          Put (File, Item);
1132          New_Line (File);
1133          return;
1134       end if;
1135
1136       --  We setup a single string that has the necessary terminators and
1137       --  then write it with a single call. The reason for doing this is
1138       --  that it gives better behavior for the use of Put_Line in multi-
1139       --  tasking programs, since often the OS will treat the entire put
1140       --  operation as an atomic operation.
1141
1142       --  We only do this if the message is 512 characters or less in length,
1143       --  since otherwise Put_Line would use an unbounded amount of stack
1144       --  space and could cause undetected stack overflow. If we have a
1145       --  longer string, then output the first part separately to avoid this.
1146
1147       if Ilen > 512 then
1148          FIO.Write_Buf (AP (File), Item'Address, size_t (Ilen - 512));
1149          Istart := Istart + Ilen - 512;
1150          Ilen   := 512;
1151       end if;
1152
1153       --  Now prepare the string with its terminator
1154
1155       declare
1156          Buffer : String (1 .. Ilen + 2);
1157          Plen   : size_t;
1158
1159       begin
1160          Buffer (1 .. Ilen) := Item (Istart .. Item'Last);
1161          Buffer (Ilen + 1) := Character'Val (LM);
1162
1163          if File.Page_Length /= 0
1164            and then File.Line > File.Page_Length
1165          then
1166             Buffer (Ilen + 2) := Character'Val (PM);
1167             Plen := size_t (Ilen) + 2;
1168             File.Line := 1;
1169             File.Page := File.Page + 1;
1170
1171          else
1172             Plen := size_t (Ilen) + 1;
1173             File.Line := File.Line + 1;
1174          end if;
1175
1176          FIO.Write_Buf (AP (File), Buffer'Address, Plen);
1177
1178          File.Col := 1;
1179       end;
1180    end Put_Line;
1181
1182    procedure Put_Line (Item : String) is
1183    begin
1184       Put_Line (Current_Out, Item);
1185    end Put_Line;
1186
1187    ----------
1188    -- Putc --
1189    ----------
1190
1191    procedure Putc (ch : int; File : File_Type) is
1192    begin
1193       if fputc (ch, File.Stream) = EOF then
1194          raise Device_Error;
1195       end if;
1196    end Putc;
1197
1198    ----------
1199    -- Read --
1200    ----------
1201
1202    --  This is the primitive Stream Read routine, used when a Text_IO file
1203    --  is treated directly as a stream using Text_IO.Streams.Stream.
1204
1205    procedure Read
1206      (File : in out Text_AFCB;
1207       Item : out Stream_Element_Array;
1208       Last : out Stream_Element_Offset)
1209    is
1210       Discard_ch : int;
1211       pragma Warnings (Off, Discard_ch);
1212
1213    begin
1214       if File.Mode /= FCB.In_File then
1215          raise Mode_Error;
1216       end if;
1217
1218       --  Deal with case where our logical and physical position do not match
1219       --  because of being after an LM or LM-PM sequence when in fact we are
1220       --  logically positioned before it.
1221
1222       if File.Before_LM then
1223
1224          --  If we are before a PM, then it is possible for a stream read
1225          --  to leave us after the LM and before the PM, which is a bit
1226          --  odd. The easiest way to deal with this is to unget the PM,
1227          --  so we are indeed positioned between the characters. This way
1228          --  further stream read operations will work correctly, and the
1229          --  effect on text processing is a little weird, but what can
1230          --  be expected if stream and text input are mixed this way?
1231
1232          if File.Before_LM_PM then
1233             Discard_ch := ungetc (PM, File.Stream);
1234             File.Before_LM_PM := False;
1235          end if;
1236
1237          File.Before_LM := False;
1238
1239          Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF));
1240
1241          if Item'Length = 1 then
1242             Last := Item'Last;
1243
1244          else
1245             Last :=
1246               Item'First +
1247                 Stream_Element_Offset
1248                   (fread (buffer => Item'Address,
1249                           index  => size_t (Item'First + 1),
1250                           size   => 1,
1251                           count  => Item'Length - 1,
1252                           stream => File.Stream));
1253          end if;
1254
1255          return;
1256       end if;
1257
1258       --  Now we do the read. Since this is a text file, it is normally in
1259       --  text mode, but stream data must be read in binary mode, so we
1260       --  temporarily set binary mode for the read, resetting it after.
1261       --  These calls have no effect in a system (like Unix) where there is
1262       --  no distinction between text and binary files.
1263
1264       set_binary_mode (fileno (File.Stream));
1265
1266       Last :=
1267         Item'First +
1268           Stream_Element_Offset
1269             (fread (Item'Address, 1, Item'Length, File.Stream)) - 1;
1270
1271       if Last < Item'Last then
1272          if ferror (File.Stream) /= 0 then
1273             raise Device_Error;
1274          end if;
1275       end if;
1276
1277       set_text_mode (fileno (File.Stream));
1278    end Read;
1279
1280    -----------
1281    -- Reset --
1282    -----------
1283
1284    procedure Reset
1285      (File : in out File_Type;
1286       Mode : File_Mode)
1287    is
1288    begin
1289       --  Don't allow change of mode for current file (RM A.10.2(5))
1290
1291       if (File = Current_In or else
1292           File = Current_Out  or else
1293           File = Current_Error)
1294         and then To_FCB (Mode) /= File.Mode
1295       then
1296          raise Mode_Error;
1297       end if;
1298
1299       Terminate_Line (File);
1300       FIO.Reset (AP (File), To_FCB (Mode));
1301       File.Page := 1;
1302       File.Line := 1;
1303       File.Col  := 1;
1304       File.Line_Length := 0;
1305       File.Page_Length := 0;
1306       File.Before_LM := False;
1307       File.Before_LM_PM := False;
1308    end Reset;
1309
1310    procedure Reset (File : in out File_Type) is
1311    begin
1312       Terminate_Line (File);
1313       FIO.Reset (AP (File));
1314       File.Page := 1;
1315       File.Line := 1;
1316       File.Col  := 1;
1317       File.Line_Length := 0;
1318       File.Page_Length := 0;
1319       File.Before_LM := False;
1320       File.Before_LM_PM := False;
1321    end Reset;
1322
1323    -------------
1324    -- Set_Col --
1325    -------------
1326
1327    procedure Set_Col
1328      (File : File_Type;
1329       To   : Positive_Count)
1330    is
1331       ch : int;
1332
1333    begin
1334       --  Raise Constraint_Error if out of range value. The reason for this
1335       --  explicit test is that we don't want junk values around, even if
1336       --  checks are off in the caller.
1337
1338       if not To'Valid then
1339          raise Constraint_Error;
1340       end if;
1341
1342       FIO.Check_File_Open (AP (File));
1343
1344       --  Output case
1345
1346       if Mode (File) >= Out_File then
1347
1348          --  Error if we attempt to set Col to a value greater than the
1349          --  maximum permissible line length.
1350
1351          if File.Line_Length /= 0 and then To > File.Line_Length then
1352             raise Layout_Error;
1353          end if;
1354
1355          --  If we are behind current position, then go to start of new line
1356
1357          if To < File.Col then
1358             New_Line (File);
1359          end if;
1360
1361          --  Loop to output blanks till we are at the required column
1362
1363          while File.Col < To loop
1364             Put (File, ' ');
1365          end loop;
1366
1367       --  Input case
1368
1369       else
1370          --  If we are logically before a LM, but physically after it, the
1371          --  file position still reflects the position before the LM, so eat
1372          --  it now and adjust the file position appropriately.
1373
1374          if File.Before_LM then
1375             File.Before_LM := False;
1376             File.Before_LM_PM := False;
1377             File.Line := File.Line + 1;
1378             File.Col := 1;
1379          end if;
1380
1381          --  Loop reading characters till we get one at the required Col value
1382
1383          loop
1384             --  Read next character. The reason we have to read ahead is to
1385             --  skip formatting characters, the effect of Set_Col is to set
1386             --  us to a real character with the right Col value, and format
1387             --  characters don't count.
1388
1389             ch := Getc (File);
1390
1391             --  Error if we hit an end of file
1392
1393             if ch = EOF then
1394                raise End_Error;
1395
1396             --  If line mark, eat it and adjust file position
1397
1398             elsif ch = LM then
1399                File.Line := File.Line + 1;
1400                File.Col := 1;
1401
1402             --  If recognized page mark, eat it, and adjust file position
1403
1404             elsif ch = PM and then File.Is_Regular_File then
1405                File.Page := File.Page + 1;
1406                File.Line := 1;
1407                File.Col := 1;
1408
1409             --  Otherwise this is the character we are looking for, so put it
1410             --  back in the input stream (we have not adjusted the file
1411             --  position yet, so everything is set right after this ungetc).
1412
1413             elsif To = File.Col then
1414                Ungetc (ch, File);
1415                return;
1416
1417             --  Keep skipping characters if we are not there yet, updating the
1418             --  file position past the skipped character.
1419
1420             else
1421                File.Col := File.Col + 1;
1422             end if;
1423          end loop;
1424       end if;
1425    end Set_Col;
1426
1427    procedure Set_Col (To : Positive_Count) is
1428    begin
1429       Set_Col (Current_Out, To);
1430    end Set_Col;
1431
1432    ---------------
1433    -- Set_Error --
1434    ---------------
1435
1436    procedure Set_Error (File : File_Type) is
1437    begin
1438       FIO.Check_Write_Status (AP (File));
1439       Current_Err := File;
1440    end Set_Error;
1441
1442    ---------------
1443    -- Set_Input --
1444    ---------------
1445
1446    procedure Set_Input (File : File_Type) is
1447    begin
1448       FIO.Check_Read_Status (AP (File));
1449       Current_In := File;
1450    end Set_Input;
1451
1452    --------------
1453    -- Set_Line --
1454    --------------
1455
1456    procedure Set_Line
1457      (File : File_Type;
1458       To   : Positive_Count)
1459    is
1460    begin
1461       --  Raise Constraint_Error if out of range value. The reason for this
1462       --  explicit test is that we don't want junk values around, even if
1463       --  checks are off in the caller.
1464
1465       if not To'Valid then
1466          raise Constraint_Error;
1467       end if;
1468
1469       FIO.Check_File_Open (AP (File));
1470
1471       if To = File.Line then
1472          return;
1473       end if;
1474
1475       if Mode (File) >= Out_File then
1476          if File.Page_Length /= 0 and then To > File.Page_Length then
1477             raise Layout_Error;
1478          end if;
1479
1480          if To < File.Line then
1481             New_Page (File);
1482          end if;
1483
1484          while File.Line < To loop
1485             New_Line (File);
1486          end loop;
1487
1488       else
1489          while To /= File.Line loop
1490             Skip_Line (File);
1491          end loop;
1492       end if;
1493    end Set_Line;
1494
1495    procedure Set_Line (To : Positive_Count) is
1496    begin
1497       Set_Line (Current_Out, To);
1498    end Set_Line;
1499
1500    ---------------------
1501    -- Set_Line_Length --
1502    ---------------------
1503
1504    procedure Set_Line_Length (File : File_Type; To : Count) is
1505    begin
1506       --  Raise Constraint_Error if out of range value. The reason for this
1507       --  explicit test is that we don't want junk values around, even if
1508       --  checks are off in the caller.
1509
1510       if not To'Valid then
1511          raise Constraint_Error;
1512       end if;
1513
1514       FIO.Check_Write_Status (AP (File));
1515       File.Line_Length := To;
1516    end Set_Line_Length;
1517
1518    procedure Set_Line_Length (To : Count) is
1519    begin
1520       Set_Line_Length (Current_Out, To);
1521    end Set_Line_Length;
1522
1523    ----------------
1524    -- Set_Output --
1525    ----------------
1526
1527    procedure Set_Output (File : File_Type) is
1528    begin
1529       FIO.Check_Write_Status (AP (File));
1530       Current_Out := File;
1531    end Set_Output;
1532
1533    ---------------------
1534    -- Set_Page_Length --
1535    ---------------------
1536
1537    procedure Set_Page_Length (File : File_Type; To : Count) is
1538    begin
1539       --  Raise Constraint_Error if out of range value. The reason for this
1540       --  explicit test is that we don't want junk values around, even if
1541       --  checks are off in the caller.
1542
1543       if not To'Valid then
1544          raise Constraint_Error;
1545       end if;
1546
1547       FIO.Check_Write_Status (AP (File));
1548       File.Page_Length := To;
1549    end Set_Page_Length;
1550
1551    procedure Set_Page_Length (To : Count) is
1552    begin
1553       Set_Page_Length (Current_Out, To);
1554    end Set_Page_Length;
1555
1556    ---------------
1557    -- Skip_Line --
1558    ---------------
1559
1560    procedure Skip_Line
1561      (File    : File_Type;
1562       Spacing : Positive_Count := 1)
1563    is
1564       ch : int;
1565
1566    begin
1567       --  Raise Constraint_Error if out of range value. The reason for this
1568       --  explicit test is that we don't want junk values around, even if
1569       --  checks are off in the caller.
1570
1571       if not Spacing'Valid then
1572          raise Constraint_Error;
1573       end if;
1574
1575       FIO.Check_Read_Status (AP (File));
1576
1577       for L in 1 .. Spacing loop
1578          if File.Before_LM then
1579             File.Before_LM := False;
1580
1581             --  Note that if File.Before_LM_PM is currently set, we also have
1582             --  to reset it (because it makes sense for Before_LM_PM to be set
1583             --  only when Before_LM is also set). This is done later on in this
1584             --  subprogram, as soon as Before_LM_PM has been taken into account
1585             --  for the purpose of page and line counts.
1586
1587          else
1588             ch := Getc (File);
1589
1590             --  If at end of file now, then immediately raise End_Error. Note
1591             --  that we can never be positioned between a line mark and a page
1592             --  mark, so if we are at the end of file, we cannot logically be
1593             --  before the implicit page mark that is at the end of the file.
1594
1595             --  For the same reason, we do not need an explicit check for a
1596             --  page mark. If there is a FF in the middle of a line, the file
1597             --  is not in canonical format and we do not care about the page
1598             --  numbers for files other than ones in canonical format.
1599
1600             if ch = EOF then
1601                raise End_Error;
1602             end if;
1603
1604             --  If not at end of file, then loop till we get to an LM or EOF.
1605             --  The latter case happens only in non-canonical files where the
1606             --  last line is not terminated by LM, but we don't want to blow
1607             --  up for such files, so we assume an implicit LM in this case.
1608
1609             loop
1610                exit when ch = LM or ch = EOF;
1611                ch := Getc (File);
1612             end loop;
1613          end if;
1614
1615          --  We have got past a line mark, now, for a regular file only,
1616          --  see if a page mark immediately follows this line mark and
1617          --  if so, skip past the page mark as well. We do not do this
1618          --  for non-regular files, since it would cause an undesirable
1619          --  wait for an additional character.
1620
1621          File.Col := 1;
1622          File.Line := File.Line + 1;
1623
1624          if File.Before_LM_PM then
1625             File.Page := File.Page + 1;
1626             File.Line := 1;
1627             File.Before_LM_PM := False;
1628
1629          elsif File.Is_Regular_File then
1630             ch := Getc (File);
1631
1632             --  Page mark can be explicit, or implied at the end of the file
1633
1634             if (ch = PM or else ch = EOF)
1635               and then File.Is_Regular_File
1636             then
1637                File.Page := File.Page + 1;
1638                File.Line := 1;
1639             else
1640                Ungetc (ch, File);
1641             end if;
1642          end if;
1643
1644       end loop;
1645    end Skip_Line;
1646
1647    procedure Skip_Line (Spacing : Positive_Count := 1) is
1648    begin
1649       Skip_Line (Current_In, Spacing);
1650    end Skip_Line;
1651
1652    ---------------
1653    -- Skip_Page --
1654    ---------------
1655
1656    procedure Skip_Page (File : File_Type) is
1657       ch : int;
1658
1659    begin
1660       FIO.Check_Read_Status (AP (File));
1661
1662       --  If at page mark already, just skip it
1663
1664       if File.Before_LM_PM then
1665          File.Before_LM := False;
1666          File.Before_LM_PM := False;
1667          File.Page := File.Page + 1;
1668          File.Line := 1;
1669          File.Col  := 1;
1670          return;
1671       end if;
1672
1673       --  This is a bit tricky, if we are logically before an LM then
1674       --  it is not an error if we are at an end of file now, since we
1675       --  are not really at it.
1676
1677       if File.Before_LM then
1678          File.Before_LM := False;
1679          File.Before_LM_PM := False;
1680          ch := Getc (File);
1681
1682       --  Otherwise we do raise End_Error if we are at the end of file now
1683
1684       else
1685          ch := Getc (File);
1686
1687          if ch = EOF then
1688             raise End_Error;
1689          end if;
1690       end if;
1691
1692       --  Now we can just rumble along to the next page mark, or to the
1693       --  end of file, if that comes first. The latter case happens when
1694       --  the page mark is implied at the end of file.
1695
1696       loop
1697          exit when ch = EOF
1698            or else (ch = PM and then File.Is_Regular_File);
1699          ch := Getc (File);
1700       end loop;
1701
1702       File.Page := File.Page + 1;
1703       File.Line := 1;
1704       File.Col  := 1;
1705    end Skip_Page;
1706
1707    procedure Skip_Page is
1708    begin
1709       Skip_Page (Current_In);
1710    end Skip_Page;
1711
1712    --------------------
1713    -- Standard_Error --
1714    --------------------
1715
1716    function Standard_Error return File_Type is
1717    begin
1718       return Standard_Err;
1719    end Standard_Error;
1720
1721    function Standard_Error return File_Access is
1722    begin
1723       return Standard_Err'Access;
1724    end Standard_Error;
1725
1726    --------------------
1727    -- Standard_Input --
1728    --------------------
1729
1730    function Standard_Input return File_Type is
1731    begin
1732       return Standard_In;
1733    end Standard_Input;
1734
1735    function Standard_Input return File_Access is
1736    begin
1737       return Standard_In'Access;
1738    end Standard_Input;
1739
1740    ---------------------
1741    -- Standard_Output --
1742    ---------------------
1743
1744    function Standard_Output return File_Type is
1745    begin
1746       return Standard_Out;
1747    end Standard_Output;
1748
1749    function Standard_Output return File_Access is
1750    begin
1751       return Standard_Out'Access;
1752    end Standard_Output;
1753
1754    --------------------
1755    -- Terminate_Line --
1756    --------------------
1757
1758    procedure Terminate_Line (File : File_Type) is
1759    begin
1760       FIO.Check_File_Open (AP (File));
1761
1762       --  For file other than In_File, test for needing to terminate last line
1763
1764       if Mode (File) /= In_File then
1765
1766          --  If not at start of line definition need new line
1767
1768          if File.Col /= 1 then
1769             New_Line (File);
1770
1771          --  For files other than standard error and standard output, we
1772          --  make sure that an empty file has a single line feed, so that
1773          --  it is properly formatted. We avoid this for the standard files
1774          --  because it is too much of a nuisance to have these odd line
1775          --  feeds when nothing has been written to the file.
1776
1777          --  We also avoid this for files opened in append mode, in
1778          --  accordance with (RM A.8.2(10))
1779
1780          elsif (File /= Standard_Err and then File /= Standard_Out)
1781            and then (File.Line = 1 and then File.Page = 1)
1782            and then Mode (File) = Out_File
1783          then
1784             New_Line (File);
1785          end if;
1786       end if;
1787    end Terminate_Line;
1788
1789    ------------
1790    -- Ungetc --
1791    ------------
1792
1793    procedure Ungetc (ch : int; File : File_Type) is
1794    begin
1795       if ch /= EOF then
1796          if ungetc (ch, File.Stream) = EOF then
1797             raise Device_Error;
1798          end if;
1799       end if;
1800    end Ungetc;
1801
1802    -----------
1803    -- Write --
1804    -----------
1805
1806    --  This is the primitive Stream Write routine, used when a Text_IO file
1807    --  is treated directly as a stream using Text_IO.Streams.Stream.
1808
1809    procedure Write
1810      (File : in out Text_AFCB;
1811       Item : Stream_Element_Array)
1812    is
1813       function Has_Translated_Characters return Boolean;
1814       --  return True if Item array contains a character which will be
1815       --  translated under the text file mode. There is only one such
1816       --  character under DOS based systems which is character 10.
1817
1818       text_translation_required : Boolean;
1819       for text_translation_required'Size use Character'Size;
1820       pragma Import (C, text_translation_required,
1821                      "__gnat_text_translation_required");
1822
1823       Siz : constant size_t := Item'Length;
1824
1825       function Has_Translated_Characters return Boolean is
1826       begin
1827          for K in Item'Range loop
1828             if Item (K) = 10 then
1829                return True;
1830             end if;
1831          end loop;
1832          return False;
1833       end Has_Translated_Characters;
1834
1835       Needs_Binary_Write : constant Boolean :=
1836         text_translation_required and then Has_Translated_Characters;
1837
1838    begin
1839       if File.Mode = FCB.In_File then
1840          raise Mode_Error;
1841       end if;
1842
1843       --  Now we do the write. Since this is a text file, it is normally in
1844       --  text mode, but stream data must be written in binary mode, so we
1845       --  temporarily set binary mode for the write, resetting it after. This
1846       --  is done only if needed (i.e. there is some characters in Item which
1847       --  needs to be written using the binary mode).
1848       --  These calls have no effect in a system (like Unix) where there is
1849       --  no distinction between text and binary files.
1850
1851       --  Since the character translation is done at the time the buffer is
1852       --  written (this is true under Windows) we first flush current buffer
1853       --  with text mode if needed.
1854
1855       if Needs_Binary_Write then
1856
1857          if fflush (File.Stream) = -1 then
1858             raise Device_Error;
1859          end if;
1860
1861          set_binary_mode (fileno (File.Stream));
1862       end if;
1863
1864       if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then
1865          raise Device_Error;
1866       end if;
1867
1868       --  At this point we need to flush the buffer using the binary mode then
1869       --  we reset to text mode.
1870
1871       if Needs_Binary_Write then
1872
1873          if fflush (File.Stream) = -1 then
1874             raise Device_Error;
1875          end if;
1876
1877          set_text_mode (fileno (File.Stream));
1878       end if;
1879    end Write;
1880
1881    --  Use "preallocated" strings to avoid calling "new" during the
1882    --  elaboration of the run time. This is needed in the tasking case to
1883    --  avoid calling Task_Lock too early. A filename is expected to end with a
1884    --  null character in the runtime, here the null characters are added just
1885    --  to have a correct filename length.
1886
1887    Err_Name : aliased String := "*stderr" & ASCII.Nul;
1888    In_Name  : aliased String := "*stdin" & ASCII.Nul;
1889    Out_Name : aliased String := "*stdout" & ASCII.Nul;
1890 begin
1891    -------------------------------
1892    -- Initialize Standard Files --
1893    -------------------------------
1894
1895    --  Note: the names in these files are bogus, and probably it would be
1896    --  better for these files to have no names, but the ACVC test insist!
1897    --  We use names that are bound to fail in open etc.
1898
1899    Standard_Err.Stream            := stderr;
1900    Standard_Err.Name              := Err_Name'Access;
1901    Standard_Err.Form              := Null_Str'Unrestricted_Access;
1902    Standard_Err.Mode              := FCB.Out_File;
1903    Standard_Err.Is_Regular_File   := is_regular_file (fileno (stderr)) /= 0;
1904    Standard_Err.Is_Temporary_File := False;
1905    Standard_Err.Is_System_File    := True;
1906    Standard_Err.Is_Text_File      := True;
1907    Standard_Err.Access_Method     := 'T';
1908    Standard_Err.Self              := Standard_Err;
1909
1910    Standard_In.Stream             := stdin;
1911    Standard_In.Name               := In_Name'Access;
1912    Standard_In.Form               := Null_Str'Unrestricted_Access;
1913    Standard_In.Mode               := FCB.In_File;
1914    Standard_In.Is_Regular_File    := is_regular_file (fileno (stdin)) /= 0;
1915    Standard_In.Is_Temporary_File  := False;
1916    Standard_In.Is_System_File     := True;
1917    Standard_In.Is_Text_File       := True;
1918    Standard_In.Access_Method      := 'T';
1919    Standard_In.Self               := Standard_In;
1920
1921    Standard_Out.Stream            := stdout;
1922    Standard_Out.Name              := Out_Name'Access;
1923    Standard_Out.Form              := Null_Str'Unrestricted_Access;
1924    Standard_Out.Mode              := FCB.Out_File;
1925    Standard_Out.Is_Regular_File   := is_regular_file (fileno (stdout)) /= 0;
1926    Standard_Out.Is_Temporary_File := False;
1927    Standard_Out.Is_System_File    := True;
1928    Standard_Out.Is_Text_File      := True;
1929    Standard_Out.Access_Method     := 'T';
1930    Standard_Out.Self              := Standard_Out;
1931
1932    FIO.Chain_File (AP (Standard_In));
1933    FIO.Chain_File (AP (Standard_Out));
1934    FIO.Chain_File (AP (Standard_Err));
1935
1936    FIO.Make_Unbuffered (AP (Standard_Out));
1937    FIO.Make_Unbuffered (AP (Standard_Err));
1938
1939 end Ada.Text_IO;