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