gcc/ada/a-ztexio.adb

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