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