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