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