gcc/ada/s-fileio.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                       S Y S T E M . F I L E _ I O                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.59 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with Ada.Finalization;            use Ada.Finalization;
  37 with Ada.IO_Exceptions;           use Ada.IO_Exceptions;
  38 with Interfaces.C_Streams;        use Interfaces.C_Streams;
  39 with System.Soft_Links;
  40 with Unchecked_Deallocation;
  41
  42 package body System.File_IO is
  43
  44    use System.File_Control_Block;
  45
  46    package SSL renames System.Soft_Links;
  47
  48    ----------------------
  49    -- Global Variables --
  50    ----------------------
  51
  52    Open_Files : AFCB_Ptr;
  53    --  This points to a list of AFCB's for all open files. This is a doubly
  54    --  linked list, with the Prev pointer of the first entry, and the Next
  55    --  pointer of the last entry containing null. Note that this global
  56    --  variable must be properly protected to provide thread safety.
  57
  58    type Temp_File_Record;
  59    type Temp_File_Record_Ptr is access all Temp_File_Record;
  60
  61    type Temp_File_Record is record
  62       Name : String (1 .. L_tmpnam + 1);
  63       Next : Temp_File_Record_Ptr;
  64    end record;
  65    --  One of these is allocated for each temporary file created
  66
  67    Temp_Files : Temp_File_Record_Ptr;
  68    --  Points to list of names of temporary files. Note that this global
  69    --  variable must be properly protected to provide thread safety.
  70
  71    type File_IO_Clean_Up_Type is new Controlled with null record;
  72    --  The closing of all open files and deletion of temporary files is an
  73    --  action which takes place at the end of execution of the main program.
  74    --  This action can be implemented using a library level object which
  75    --  gets finalized at the end of the main program execution. The above is
  76    --  a controlled type introduced for this purpose.
  77
  78    procedure Finalize (V : in out File_IO_Clean_Up_Type);
  79    --  This is the finalize operation that is used to do the cleanup.
  80
  81    File_IO_Clean_Up_Object : File_IO_Clean_Up_Type;
  82    --  This is the single object of the type that triggers the finalization
  83    --  call. Since it is at the library level, this happens just before the
  84    --  environment task is finalized.
  85
  86    text_translation_required : Boolean;
  87    pragma Import
  88      (C, text_translation_required, "__gnat_text_translation_required");
  89    --  If true, add appropriate suffix to control string for Open.
  90
  91    -----------------------
  92    -- Local Subprograms --
  93    -----------------------
  94
  95    procedure Free_String is new Unchecked_Deallocation (String, Pstring);
  96
  97    subtype Fopen_String is String (1 .. 4);
  98    --  Holds open string (longest is "w+b" & nul)
  99
 100    procedure Fopen_Mode
 101      (Mode    : File_Mode;
 102       Text    : Boolean;
 103       Creat   : Boolean;
 104       Amethod : Character;
 105       Fopstr  : out Fopen_String);
 106    --  Determines proper open mode for a file to be opened in the given
 107    --  Ada mode. Text is true for a text file and false otherwise, and
 108    --  Creat is true for a create call, and False for an open call. The
 109    --  value stored in Fopstr is a nul-terminated string suitable for a
 110    --  call to fopen or freopen. Amethod is the character designating
 111    --  the access method from the Access_Method field of the FCB.
 112
 113    ----------------
 114    -- Append_Set --
 115    ----------------
 116
 117    procedure Append_Set (File : AFCB_Ptr) is
 118    begin
 119       if File.Mode = Append_File then
 120          if fseek (File.Stream, 0, SEEK_END) /= 0 then
 121             raise Device_Error;
 122          end if;
 123       end if;
 124    end Append_Set;
 125
 126    ----------------
 127    -- Chain_File --
 128    ----------------
 129
 130    procedure Chain_File (File : AFCB_Ptr) is
 131    begin
 132       --  Take a task lock, to protect the global data value Open_Files
 133       --  No exception handler needed, since we cannot get an exception.
 134
 135       SSL.Lock_Task.all;
 136       File.Next := Open_Files;
 137       File.Prev := null;
 138       Open_Files := File;
 139
 140       if File.Next /= null then
 141          File.Next.Prev := File;
 142       end if;
 143
 144       SSL.Unlock_Task.all;
 145    end Chain_File;
 146
 147    ---------------------
 148    -- Check_File_Open --
 149    ---------------------
 150
 151    procedure Check_File_Open (File : AFCB_Ptr) is
 152    begin
 153       if File = null then
 154          raise Status_Error;
 155       end if;
 156    end Check_File_Open;
 157
 158    -----------------------
 159    -- Check_Read_Status --
 160    -----------------------
 161
 162    procedure Check_Read_Status (File : AFCB_Ptr) is
 163    begin
 164       if File = null then
 165          raise Status_Error;
 166       elsif File.Mode > Inout_File then
 167          raise Mode_Error;
 168       end if;
 169    end Check_Read_Status;
 170
 171    ------------------------
 172    -- Check_Write_Status --
 173    ------------------------
 174
 175    procedure Check_Write_Status (File : AFCB_Ptr) is
 176    begin
 177       if File = null then
 178          raise Status_Error;
 179       elsif File.Mode = In_File then
 180          raise Mode_Error;
 181       end if;
 182    end Check_Write_Status;
 183
 184    -----------
 185    -- Close --
 186    -----------
 187
 188    procedure Close (File : in out AFCB_Ptr) is
 189       Close_Status : int := 0;
 190       Dup_Strm     : Boolean := False;
 191
 192    begin
 193       Check_File_Open (File);
 194       AFCB_Close (File);
 195
 196       --  Sever the association between the given file and its associated
 197       --  external file. The given file is left closed. Do not perform system
 198       --  closes on the standard input, output and error files and also do
 199       --  not attempt to close a stream that does not exist (signalled by a
 200       --  null stream value -- happens in some error situations).
 201
 202       if not File.Is_System_File
 203         and then File.Stream /= NULL_Stream
 204       then
 205          --  Do not do an fclose if this is a shared file and there is
 206          --  at least one other instance of the stream that is open.
 207
 208          if File.Shared_Status = Yes then
 209             declare
 210                P   : AFCB_Ptr;
 211
 212             begin
 213                P := Open_Files;
 214                while P /= null loop
 215                   if P /= File
 216                     and then File.Stream = P.Stream
 217                   then
 218                      Dup_Strm := True;
 219                      exit;
 220                   end if;
 221
 222                   P := P.Next;
 223                end loop;
 224             end;
 225          end if;
 226
 227          --  Do the fclose unless this was a duplicate in the shared case
 228
 229          if not Dup_Strm then
 230             Close_Status := fclose (File.Stream);
 231          end if;
 232       end if;
 233
 234       --  Dechain file from list of open files and then free the storage
 235       --  Since this is a global data structure, we have to protect against
 236       --  multiple tasks attempting to access this list.
 237
 238       --  Note that we do not use an exception handler to unlock here since
 239       --  no exception can occur inside the lock/unlock pair.
 240
 241       begin
 242          SSL.Lock_Task.all;
 243
 244          if File.Prev = null then
 245             Open_Files := File.Next;
 246          else
 247             File.Prev.Next := File.Next;
 248          end if;
 249
 250          if File.Next /= null then
 251             File.Next.Prev := File.Prev;
 252          end if;
 253
 254          SSL.Unlock_Task.all;
 255       end;
 256
 257       --  Deallocate some parts of the file structure that were kept in heap
 258       --  storage with the exception of system files (standard input, output
 259       --  and error) since they had some information allocated in the stack.
 260
 261       if not File.Is_System_File then
 262          Free_String (File.Name);
 263          Free_String (File.Form);
 264          AFCB_Free (File);
 265       end if;
 266
 267       File := null;
 268
 269       if Close_Status /= 0 then
 270          raise Device_Error;
 271       end if;
 272    end Close;
 273
 274    ------------
 275    -- Delete --
 276    ------------
 277
 278    procedure Delete (File : in out AFCB_Ptr) is
 279    begin
 280       Check_File_Open (File);
 281
 282       if not File.Is_Regular_File then
 283          raise Use_Error;
 284       end if;
 285
 286       declare
 287          Filename : aliased constant String := File.Name.all;
 288
 289       begin
 290          Close (File);
 291
 292          --  Now unlink the external file. Note that we use the full name
 293          --  in this unlink, because the working directory may have changed
 294          --  since we did the open, and we want to unlink the right file!
 295
 296          if unlink (Filename'Address) = -1 then
 297             raise Use_Error;
 298          end if;
 299       end;
 300    end Delete;
 301
 302    -----------------
 303    -- End_Of_File --
 304    -----------------
 305
 306    function End_Of_File (File : AFCB_Ptr) return Boolean is
 307    begin
 308       Check_File_Open (File);
 309
 310       if feof (File.Stream) /= 0 then
 311          return True;
 312
 313       else
 314          Check_Read_Status (File);
 315
 316          if ungetc (fgetc (File.Stream), File.Stream) = EOF then
 317             clearerr (File.Stream);
 318             return True;
 319          else
 320             return False;
 321          end if;
 322       end if;
 323    end End_Of_File;
 324
 325    --------------
 326    -- Finalize --
 327    --------------
 328
 329    --  Note: we do not need to worry about locking against multiple task
 330    --  access in this routine, since it is called only from the environment
 331    --  task just before terminating execution.
 332
 333    procedure Finalize (V : in out File_IO_Clean_Up_Type) is
 334       Discard : int;
 335       Fptr1   : AFCB_Ptr;
 336       Fptr2   : AFCB_Ptr;
 337
 338    begin
 339       --  First close all open files (the slightly complex form of this loop
 340       --  is required because Close as a side effect nulls out its argument)
 341
 342       Fptr1 := Open_Files;
 343       while Fptr1 /= null loop
 344          Fptr2 := Fptr1.Next;
 345          Close (Fptr1);
 346          Fptr1 := Fptr2;
 347       end loop;
 348
 349       --  Now unlink all temporary files. We do not bother to free the
 350       --  blocks because we are just about to terminate the program. We
 351       --  also ignore any errors while attempting these unlink operations.
 352
 353       while Temp_Files /= null loop
 354          Discard := unlink (Temp_Files.Name'Address);
 355          Temp_Files := Temp_Files.Next;
 356       end loop;
 357
 358    end Finalize;
 359
 360    -----------
 361    -- Flush --
 362    -----------
 363
 364    procedure Flush (File : AFCB_Ptr) is
 365    begin
 366       Check_Write_Status (File);
 367
 368       if fflush (File.Stream) = 0 then
 369          return;
 370       else
 371          raise Device_Error;
 372       end if;
 373    end Flush;
 374
 375    ----------------
 376    -- Fopen_Mode --
 377    ----------------
 378
 379    --  The fopen mode to be used is shown by the following table:
 380
 381    --                                     OPEN         CREATE
 382    --     Append_File                     "r+"           "w+"
 383    --     In_File                         "r"            "w+"
 384    --     Out_File (Direct_IO)            "r+"           "w"
 385    --     Out_File (all others)           "w"            "w"
 386    --     Inout_File                      "r+"           "w+"
 387
 388    --  Note: we do not use "a" or "a+" for Append_File, since this would not
 389    --  work in the case of stream files, where even if in append file mode,
 390    --  you can reset to earlier points in the file. The caller must use the
 391    --  Append_Set routine to deal with the necessary positioning.
 392
 393    --  Note: in several cases, the fopen mode used allows reading and
 394    --  writing, but the setting of the Ada mode is more restrictive. For
 395    --  instance, Create in In_File mode uses "w+" which allows writing,
 396    --  but the Ada mode In_File will cause any write operations to be
 397    --  rejected with Mode_Error in any case.
 398
 399    --  Note: for the Out_File/Open cases for other than the Direct_IO case,
 400    --  an initial call will be made by the caller to first open the file in
 401    --  "r" mode to be sure that it exists. The real open, in "w" mode, will
 402    --  then destroy this file. This is peculiar, but that's what Ada semantics
 403    --  require and the ACVT tests insist on!
 404
 405    --  If text file translation is required, then either b or t is
 406    --  added to the mode, depending on the setting of Text.
 407
 408    procedure Fopen_Mode
 409      (Mode    : File_Mode;
 410       Text    : Boolean;
 411       Creat   : Boolean;
 412       Amethod : Character;
 413       Fopstr  : out Fopen_String)
 414    is
 415       Fptr  : Positive;
 416
 417    begin
 418       case Mode is
 419          when In_File =>
 420             if Creat then
 421                Fopstr (1) := 'w';
 422                Fopstr (2) := '+';
 423                Fptr := 3;
 424             else
 425                Fopstr (1) := 'r';
 426                Fptr := 2;
 427             end if;
 428
 429          when Out_File =>
 430             if Amethod = 'D' and not Creat then
 431                Fopstr (1) := 'r';
 432                Fopstr (2) := '+';
 433                Fptr := 3;
 434             else
 435                Fopstr (1) := 'w';
 436                Fptr := 2;
 437             end if;
 438
 439          when Inout_File | Append_File =>
 440             if Creat then
 441                Fopstr (1) := 'w';
 442             else
 443                Fopstr (1) := 'r';
 444             end if;
 445
 446             Fopstr (2) := '+';
 447             Fptr := 3;
 448
 449       end case;
 450
 451       --  If text_translation_required is true then we need to append
 452       --  either a t or b to the string to get the right mode
 453
 454       if text_translation_required then
 455          if Text then
 456             Fopstr (Fptr) := 't';
 457          else
 458             Fopstr (Fptr) := 'b';
 459          end if;
 460
 461          Fptr := Fptr + 1;
 462       end if;
 463
 464       Fopstr (Fptr) := ASCII.NUL;
 465    end Fopen_Mode;
 466
 467    ----------
 468    -- Form --
 469    ----------
 470
 471    function Form (File : in AFCB_Ptr) return String is
 472    begin
 473       if File = null then
 474          raise Status_Error;
 475       else
 476          return File.Form.all (1 .. File.Form'Length - 1);
 477       end if;
 478    end Form;
 479
 480    ------------------
 481    -- Form_Boolean --
 482    ------------------
 483
 484    function Form_Boolean
 485      (Form    : String;
 486       Keyword : String;
 487       Default : Boolean)
 488       return    Boolean
 489    is
 490       V1, V2 : Natural;
 491
 492    begin
 493       Form_Parameter (Form, Keyword, V1, V2);
 494
 495       if V1 = 0 then
 496          return Default;
 497
 498       elsif Form (V1) = 'y' then
 499          return True;
 500
 501       elsif Form (V1) = 'n' then
 502          return False;
 503
 504       else
 505          raise Use_Error;
 506       end if;
 507    end Form_Boolean;
 508
 509    ------------------
 510    -- Form_Integer --
 511    ------------------
 512
 513    function Form_Integer
 514      (Form    : String;
 515       Keyword : String;
 516       Default : Integer)
 517       return    Integer
 518    is
 519       V1, V2 : Natural;
 520       V      : Integer;
 521
 522    begin
 523       Form_Parameter (Form, Keyword, V1, V2);
 524
 525       if V1 = 0 then
 526          return Default;
 527
 528       else
 529          V := 0;
 530
 531          for J in V1 .. V2 loop
 532             if Form (J) not in '0' .. '9' then
 533                raise Use_Error;
 534             else
 535                V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0');
 536             end if;
 537
 538             if V > 999_999 then
 539                raise Use_Error;
 540             end if;
 541          end loop;
 542
 543          return V;
 544       end if;
 545    end Form_Integer;
 546
 547    --------------------
 548    -- Form_Parameter --
 549    --------------------
 550
 551    procedure Form_Parameter
 552      (Form    : String;
 553       Keyword : String;
 554       Start   : out Natural;
 555       Stop    : out Natural)
 556   is
 557       Klen : constant Integer := Keyword'Length;
 558
 559    --  Start of processing for Form_Parameter
 560
 561    begin
 562       for J in Form'First + Klen .. Form'Last - 1 loop
 563          if Form (J) = '='
 564            and then Form (J - Klen .. J - 1) = Keyword
 565          then
 566             Start := J + 1;
 567             Stop := Start - 1;
 568
 569             while Form (Stop + 1) /= ASCII.NUL
 570               and then Form (Stop + 1) /= ','
 571             loop
 572                Stop := Stop + 1;
 573             end loop;
 574
 575             return;
 576          end if;
 577       end loop;
 578
 579       Start := 0;
 580       Stop  := 0;
 581    end Form_Parameter;
 582
 583    -------------
 584    -- Is_Open --
 585    -------------
 586
 587    function Is_Open (File : in AFCB_Ptr) return Boolean is
 588    begin
 589       return (File /= null);
 590    end Is_Open;
 591
 592    -------------------
 593    -- Make_Buffered --
 594    -------------------
 595
 596    procedure Make_Buffered
 597      (File     : AFCB_Ptr;
 598       Buf_Siz  : Interfaces.C_Streams.size_t) is
 599       status   : Integer;
 600
 601    begin
 602       status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz);
 603    end Make_Buffered;
 604
 605    ------------------------
 606    -- Make_Line_Buffered --
 607    ------------------------
 608
 609    procedure Make_Line_Buffered
 610      (File     : AFCB_Ptr;
 611       Line_Siz : Interfaces.C_Streams.size_t) is
 612       status   : Integer;
 613
 614    begin
 615       status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
 616    end Make_Line_Buffered;
 617
 618    ---------------------
 619    -- Make_Unbuffered --
 620    ---------------------
 621
 622    procedure Make_Unbuffered (File : AFCB_Ptr) is
 623       status : Integer;
 624
 625    begin
 626       status := setvbuf (File.Stream, Null_Address, IONBF, 0);
 627    end Make_Unbuffered;
 628
 629    ----------
 630    -- Mode --
 631    ----------
 632
 633    function Mode (File : in AFCB_Ptr) return File_Mode is
 634    begin
 635       if File = null then
 636          raise Status_Error;
 637       else
 638          return File.Mode;
 639       end if;
 640    end Mode;
 641
 642    ----------
 643    -- Name --
 644    ----------
 645
 646    function Name (File : in AFCB_Ptr) return String is
 647    begin
 648       if File = null then
 649          raise Status_Error;
 650       else
 651          return File.Name.all (1 .. File.Name'Length - 1);
 652       end if;
 653    end Name;
 654
 655    ----------
 656    -- Open --
 657    ----------
 658
 659    procedure Open
 660      (File_Ptr  : in out AFCB_Ptr;
 661       Dummy_FCB : in out AFCB'Class;
 662       Mode      : File_Mode;
 663       Name      : String;
 664       Form      : String;
 665       Amethod   : Character;
 666       Creat     : Boolean;
 667       Text      : Boolean;
 668       C_Stream  : FILEs := NULL_Stream)
 669    is
 670       procedure Tmp_Name (Buffer : Address);
 671       pragma Import (C, Tmp_Name, "__gnat_tmp_name");
 672       --  set buffer (a String address) with a temporary filename.
 673
 674       Stream : FILEs := C_Stream;
 675       --  Stream which we open in response to this request
 676
 677       Shared : Shared_Status_Type;
 678       --  Setting of Shared_Status field for file
 679
 680       Fopstr : aliased Fopen_String;
 681       --  Mode string used in fopen call
 682
 683       Formstr : aliased String (1 .. Form'Length + 1);
 684       --  Form string with ASCII.NUL appended, folded to lower case
 685
 686       Tempfile : constant Boolean := (Name'Length = 0);
 687       --  Indicates temporary file case
 688
 689       Namelen : constant Integer := max_path_len;
 690       --  Length required for file name, not including final ASCII.NUL
 691       --  Note that we used to reference L_tmpnam here, which is not
 692       --  reliable since __gnat_tmp_name does not always use tmpnam.
 693
 694       Namestr : aliased String (1 .. Namelen + 1);
 695       --  Name as given or temporary file name with ASCII.NUL appended
 696
 697       Fullname : aliased String (1 .. max_path_len + 1);
 698       --  Full name (as required for Name function, and as stored in the
 699       --  control block in the Name field) with ASCII.NUL appended.
 700
 701       Full_Name_Len : Integer;
 702       --  Length of name actually stored in Fullname
 703
 704    begin
 705       if File_Ptr /= null then
 706          raise Status_Error;
 707       end if;
 708
 709       --  Acquire form string, setting required NUL terminator
 710
 711       Formstr (1 .. Form'Length) := Form;
 712       Formstr (Formstr'Last) := ASCII.NUL;
 713
 714       --  Convert form string to lower case
 715
 716       for J in Formstr'Range loop
 717          if Formstr (J) in 'A' .. 'Z' then
 718             Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32);
 719          end if;
 720       end loop;
 721
 722       --  Acquire setting of shared parameter
 723
 724       declare
 725          V1, V2 : Natural;
 726
 727       begin
 728          Form_Parameter (Formstr, "shared", V1, V2);
 729
 730          if V1 = 0 then
 731             Shared := None;
 732
 733          elsif Formstr (V1 .. V2) = "yes" then
 734             Shared := Yes;
 735
 736          elsif Formstr (V1 .. V2) = "no" then
 737             Shared := No;
 738
 739          else
 740             raise Use_Error;
 741          end if;
 742       end;
 743
 744       --  If we were given a stream (call from xxx.C_Streams.Open), then set
 745       --  full name to null and that is all we have to do in this case so
 746       --  skip to end of processing.
 747
 748       if Stream /= NULL_Stream then
 749          Fullname (1) := ASCII.Nul;
 750          Full_Name_Len := 1;
 751
 752       --  Normal case of Open or Create
 753
 754       else
 755          --  If temporary file case, get temporary file name and add
 756          --  to the list of temporary files to be deleted on exit.
 757
 758          if Tempfile then
 759             if not Creat then
 760                raise Name_Error;
 761             end if;
 762
 763             Tmp_Name (Namestr'Address);
 764
 765             if Namestr (1) = ASCII.NUL then
 766                raise Use_Error;
 767             end if;
 768
 769             --  Chain to temp file list, ensuring thread safety with a lock
 770
 771             begin
 772                SSL.Lock_Task.all;
 773                Temp_Files :=
 774                  new Temp_File_Record'(Name => Namestr, Next => Temp_Files);
 775                SSL.Unlock_Task.all;
 776
 777             exception
 778                when others =>
 779                   SSL.Unlock_Task.all;
 780                   raise;
 781             end;
 782
 783          --  Normal case of non-null name given
 784
 785          else
 786             Namestr (1 .. Name'Length) := Name;
 787             Namestr (Name'Length + 1)  := ASCII.NUL;
 788          end if;
 789
 790          --  Get full name in accordance with the advice of RM A.8.2(22).
 791
 792          full_name (Namestr'Address, Fullname'Address);
 793
 794          if Fullname (1) = ASCII.NUL then
 795             raise Use_Error;
 796          end if;
 797
 798          for J in Fullname'Range loop
 799             if Fullname (J) = ASCII.NUL then
 800                Full_Name_Len := J;
 801                exit;
 802             end if;
 803          end loop;
 804
 805          --  If Shared=None or Shared=Yes, then check for the existence
 806          --  of another file with exactly the same full name.
 807
 808          if Shared /= No then
 809             declare
 810                P : AFCB_Ptr;
 811
 812             begin
 813                P := Open_Files;
 814                while P /= null loop
 815                   if Fullname (1 .. Full_Name_Len) = P.Name.all then
 816
 817                      --  If we get a match, and either file has Shared=None,
 818                      --  then raise Use_Error, since we don't allow two
 819                      --  files of the same name to be opened unless they
 820                      --  specify the required sharing mode.
 821
 822                      if Shared = None
 823                        or else P.Shared_Status = None
 824                      then
 825                         raise Use_Error;
 826
 827                      --  If both files have Shared=Yes, then we acquire the
 828                      --  stream from the located file to use as our stream.
 829
 830                      elsif Shared = Yes
 831                        and then P.Shared_Status = Yes
 832                      then
 833                         Stream := P.Stream;
 834                         exit;
 835
 836                      --  Otherwise one of the files has Shared=Yes and one
 837                      --  has Shared=No. If the current file has Shared=No
 838                      --  then all is well but we don't want to share any
 839                      --  other file's stream. If the current file has
 840                      --  Shared=Yes, we would like to share a stream, but
 841                      --  not from a file that has Shared=No, so in either
 842                      --  case we just keep going on the search.
 843
 844                      else
 845                         null;
 846                      end if;
 847                   end if;
 848
 849                   P := P.Next;
 850                end loop;
 851             end;
 852          end if;
 853
 854          --  Open specified file if we did not find an existing stream
 855
 856          if Stream = NULL_Stream then
 857             Fopen_Mode (Mode, Text, Creat, Amethod, Fopstr);
 858
 859             --  A special case, if we are opening (OPEN case) a file and
 860             --  the mode returned by Fopen_Mode is not "r" or "r+", then
 861             --  we first make sure that the file exists as required by
 862             --  Ada semantics.
 863
 864             if Creat = False and then Fopstr (1) /= 'r' then
 865                if file_exists (Namestr'Address) = 0 then
 866                   raise Name_Error;
 867                end if;
 868             end if;
 869
 870             --  Now open the file. Note that we use the name as given
 871             --  in the original Open call for this purpose, since that
 872             --  seems the clearest implementation of the intent. It
 873             --  would presumably work to use the full name here, but
 874             --  if there is any difference, then we should use the
 875             --  name used in the call.
 876
 877             --  Note: for a corresponding delete, we will use the
 878             --  full name, since by the time of the delete, the
 879             --  current working directory may have changed and
 880             --  we do not want to delete a different file!
 881
 882             Stream := fopen (Namestr'Address, Fopstr'Address);
 883
 884             if Stream = NULL_Stream then
 885                if file_exists (Namestr'Address) = 0 then
 886                   raise Name_Error;
 887                else
 888                   raise Use_Error;
 889                end if;
 890             end if;
 891          end if;
 892       end if;
 893
 894       --  Stream has been successfully located or opened, so now we are
 895       --  committed to completing the opening of the file. Allocate block
 896       --  on heap and fill in its fields.
 897
 898       File_Ptr := AFCB_Allocate (Dummy_FCB);
 899
 900       File_Ptr.Is_Regular_File   := (is_regular_file
 901                                       (fileno (Stream)) /= 0);
 902       File_Ptr.Is_System_File    := False;
 903       File_Ptr.Is_Text_File      := Text;
 904       File_Ptr.Shared_Status     := Shared;
 905       File_Ptr.Access_Method     := Amethod;
 906       File_Ptr.Stream            := Stream;
 907       File_Ptr.Form              := new String'(Formstr);
 908       File_Ptr.Name              := new String'(Fullname
 909                                                  (1 .. Full_Name_Len));
 910       File_Ptr.Mode              := Mode;
 911       File_Ptr.Is_Temporary_File := Tempfile;
 912
 913       Chain_File (File_Ptr);
 914       Append_Set (File_Ptr);
 915    end Open;
 916
 917    --------------
 918    -- Read_Buf --
 919    --------------
 920
 921    procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
 922       Nread : size_t;
 923
 924    begin
 925       Nread := fread (Buf, 1, Siz, File.Stream);
 926
 927       if Nread = Siz then
 928          return;
 929
 930       elsif ferror (File.Stream) /= 0 then
 931          raise Device_Error;
 932
 933       elsif Nread = 0 then
 934          raise End_Error;
 935
 936       else -- 0 < Nread < Siz
 937          raise Data_Error;
 938       end if;
 939
 940    end Read_Buf;
 941
 942    procedure Read_Buf
 943      (File  : AFCB_Ptr;
 944       Buf   : Address;
 945       Siz   : in Interfaces.C_Streams.size_t;
 946       Count : out Interfaces.C_Streams.size_t)
 947    is
 948    begin
 949       Count := fread (Buf, 1, Siz, File.Stream);
 950
 951       if Count = 0 and then ferror (File.Stream) /= 0 then
 952          raise Device_Error;
 953       end if;
 954    end Read_Buf;
 955
 956    -----------
 957    -- Reset --
 958    -----------
 959
 960    --  The reset which does not change the mode simply does a rewind.
 961
 962    procedure Reset (File : in out AFCB_Ptr) is
 963    begin
 964       Check_File_Open (File);
 965       Reset (File, File.Mode);
 966    end Reset;
 967
 968    --  The reset with a change in mode is done using freopen, and is
 969    --  not permitted except for regular files (since otherwise there
 970    --  is no name for the freopen, and in any case it seems meaningless)
 971
 972    procedure Reset (File : in out AFCB_Ptr; Mode : in File_Mode) is
 973       Fopstr : aliased Fopen_String;
 974
 975    begin
 976       Check_File_Open (File);
 977
 978       --  Change of mode not allowed for shared file or file with no name
 979       --  or file that is not a regular file, or for a system file.
 980
 981       if File.Shared_Status = Yes
 982         or else File.Name'Length <= 1
 983         or else File.Is_System_File
 984         or else (not File.Is_Regular_File)
 985       then
 986          raise Use_Error;
 987
 988       --  For In_File or Inout_File for a regular file, we can just do a
 989       --  rewind if the mode is unchanged, which is more efficient than
 990       --  doing a full reopen.
 991
 992       elsif Mode = File.Mode
 993         and then Mode <= Inout_File
 994       then
 995          rewind (File.Stream);
 996
 997       --  Here the change of mode is permitted, we do it by reopening the
 998       --  file in the new mode and replacing the stream with a new stream.
 999
1000       else
1001          Fopen_Mode
1002            (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr);
1003
1004          File.Stream :=
1005            freopen (File.Name.all'Address, Fopstr'Address, File.Stream);
1006
1007          if File.Stream = NULL_Stream then
1008             Close (File);
1009             raise Use_Error;
1010
1011          else
1012             File.Mode := Mode;
1013             Append_Set (File);
1014          end if;
1015       end if;
1016    end Reset;
1017
1018    ---------------
1019    -- Write_Buf --
1020    ---------------
1021
1022    procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1023    begin
1024       --  Note: for most purposes, the Siz and 1 parameters in the fwrite
1025       --  call could be reversed, but on VMS, this is a better choice, since
1026       --  for some file formats, reversing the parameters results in records
1027       --  of one byte each.
1028
1029       SSL.Abort_Defer.all;
1030
1031       if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
1032          if Siz /= 0 then
1033             SSL.Abort_Undefer.all;
1034             raise Device_Error;
1035          end if;
1036       end if;
1037
1038       SSL.Abort_Undefer.all;
1039    end Write_Buf;
1040
1041 end System.File_IO;