gcc/ada/a-witeio.adb

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