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 --                                                                          --
  10 --          Copyright (C) 1992-2002 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with Ada.Finalization;            use Ada.Finalization;
  36 with Ada.IO_Exceptions;           use Ada.IO_Exceptions;
  37 with Interfaces.C_Streams;        use Interfaces.C_Streams;
  38 with System.Soft_Links;
  39 with Unchecked_Deallocation;
  40
  41 package body System.File_IO is
  42
  43    use System.File_Control_Block;
  44
  45    package SSL renames System.Soft_Links;
  46
  47    ----------------------
  48    -- Global Variables --
  49    ----------------------
  50
  51    Open_Files : AFCB_Ptr;
  52    --  This points to a list of AFCB's for all open files. This is a doubly
  53    --  linked list, with the Prev pointer of the first entry, and the Next
  54    --  pointer of the last entry containing null. Note that this global
  55    --  variable must be properly protected to provide thread safety.
  56
  57    type Temp_File_Record;
  58    type Temp_File_Record_Ptr is access all Temp_File_Record;
  59
  60    type Temp_File_Record is record
  61       Name : String (1 .. L_tmpnam + 1);
  62       Next : Temp_File_Record_Ptr;
  63    end record;
  64    --  One of these is allocated for each temporary file created
  65
  66    Temp_Files : Temp_File_Record_Ptr;
  67    --  Points to list of names of temporary files. Note that this global
  68    --  variable must be properly protected to provide thread safety.
  69
  70    type File_IO_Clean_Up_Type is new Controlled with null record;
  71    --  The closing of all open files and deletion of temporary files is an
  72    --  action which takes place at the end of execution of the main program.
  73    --  This action can be implemented using a library level object which
  74    --  gets finalized at the end of the main program execution. The above is
  75    --  a controlled type introduced for this purpose.
  76
  77    procedure Finalize (V : in out File_IO_Clean_Up_Type);
  78    --  This is the finalize operation that is used to do the cleanup.
  79
  80    File_IO_Clean_Up_Object : File_IO_Clean_Up_Type;
  81    pragma Warnings (Off, File_IO_Clean_Up_Object);
  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       pragma Warnings (Off, V);
 335
 336       Discard : int;
 337       Fptr1   : AFCB_Ptr;
 338       Fptr2   : AFCB_Ptr;
 339
 340    begin
 341       --  First close all open files (the slightly complex form of this loop
 342       --  is required because Close as a side effect nulls out its argument)
 343
 344       Fptr1 := Open_Files;
 345       while Fptr1 /= null loop
 346          Fptr2 := Fptr1.Next;
 347          Close (Fptr1);
 348          Fptr1 := Fptr2;
 349       end loop;
 350
 351       --  Now unlink all temporary files. We do not bother to free the
 352       --  blocks because we are just about to terminate the program. We
 353       --  also ignore any errors while attempting these unlink operations.
 354
 355       while Temp_Files /= null loop
 356          Discard := unlink (Temp_Files.Name'Address);
 357          Temp_Files := Temp_Files.Next;
 358       end loop;
 359
 360    end Finalize;
 361
 362    -----------
 363    -- Flush --
 364    -----------
 365
 366    procedure Flush (File : AFCB_Ptr) is
 367    begin
 368       Check_Write_Status (File);
 369
 370       if fflush (File.Stream) = 0 then
 371          return;
 372       else
 373          raise Device_Error;
 374       end if;
 375    end Flush;
 376
 377    ----------------
 378    -- Fopen_Mode --
 379    ----------------
 380
 381    --  The fopen mode to be used is shown by the following table:
 382
 383    --                                     OPEN         CREATE
 384    --     Append_File                     "r+"           "w+"
 385    --     In_File                         "r"            "w+"
 386    --     Out_File (Direct_IO)            "r+"           "w"
 387    --     Out_File (all others)           "w"            "w"
 388    --     Inout_File                      "r+"           "w+"
 389
 390    --  Note: we do not use "a" or "a+" for Append_File, since this would not
 391    --  work in the case of stream files, where even if in append file mode,
 392    --  you can reset to earlier points in the file. The caller must use the
 393    --  Append_Set routine to deal with the necessary positioning.
 394
 395    --  Note: in several cases, the fopen mode used allows reading and
 396    --  writing, but the setting of the Ada mode is more restrictive. For
 397    --  instance, Create in In_File mode uses "w+" which allows writing,
 398    --  but the Ada mode In_File will cause any write operations to be
 399    --  rejected with Mode_Error in any case.
 400
 401    --  Note: for the Out_File/Open cases for other than the Direct_IO case,
 402    --  an initial call will be made by the caller to first open the file in
 403    --  "r" mode to be sure that it exists. The real open, in "w" mode, will
 404    --  then destroy this file. This is peculiar, but that's what Ada semantics
 405    --  require and the ACVT tests insist on!
 406
 407    --  If text file translation is required, then either b or t is
 408    --  added to the mode, depending on the setting of Text.
 409
 410    procedure Fopen_Mode
 411      (Mode    : File_Mode;
 412       Text    : Boolean;
 413       Creat   : Boolean;
 414       Amethod : Character;
 415       Fopstr  : out Fopen_String)
 416    is
 417       Fptr  : Positive;
 418
 419    begin
 420       case Mode is
 421          when In_File =>
 422             if Creat then
 423                Fopstr (1) := 'w';
 424                Fopstr (2) := '+';
 425                Fptr := 3;
 426             else
 427                Fopstr (1) := 'r';
 428                Fptr := 2;
 429             end if;
 430
 431          when Out_File =>
 432             if Amethod = 'D' and not Creat then
 433                Fopstr (1) := 'r';
 434                Fopstr (2) := '+';
 435                Fptr := 3;
 436             else
 437                Fopstr (1) := 'w';
 438                Fptr := 2;
 439             end if;
 440
 441          when Inout_File | Append_File =>
 442             if Creat then
 443                Fopstr (1) := 'w';
 444             else
 445                Fopstr (1) := 'r';
 446             end if;
 447
 448             Fopstr (2) := '+';
 449             Fptr := 3;
 450
 451       end case;
 452
 453       --  If text_translation_required is true then we need to append
 454       --  either a t or b to the string to get the right mode
 455
 456       if text_translation_required then
 457          if Text then
 458             Fopstr (Fptr) := 't';
 459          else
 460             Fopstr (Fptr) := 'b';
 461          end if;
 462
 463          Fptr := Fptr + 1;
 464       end if;
 465
 466       Fopstr (Fptr) := ASCII.NUL;
 467    end Fopen_Mode;
 468
 469    ----------
 470    -- Form --
 471    ----------
 472
 473    function Form (File : in AFCB_Ptr) return String is
 474    begin
 475       if File = null then
 476          raise Status_Error;
 477       else
 478          return File.Form.all (1 .. File.Form'Length - 1);
 479       end if;
 480    end Form;
 481
 482    ------------------
 483    -- Form_Boolean --
 484    ------------------
 485
 486    function Form_Boolean
 487      (Form    : String;
 488       Keyword : String;
 489       Default : Boolean)
 490       return    Boolean
 491    is
 492       V1, V2 : Natural;
 493
 494    begin
 495       Form_Parameter (Form, Keyword, V1, V2);
 496
 497       if V1 = 0 then
 498          return Default;
 499
 500       elsif Form (V1) = 'y' then
 501          return True;
 502
 503       elsif Form (V1) = 'n' then
 504          return False;
 505
 506       else
 507          raise Use_Error;
 508       end if;
 509    end Form_Boolean;
 510
 511    ------------------
 512    -- Form_Integer --
 513    ------------------
 514
 515    function Form_Integer
 516      (Form    : String;
 517       Keyword : String;
 518       Default : Integer)
 519       return    Integer
 520    is
 521       V1, V2 : Natural;
 522       V      : Integer;
 523
 524    begin
 525       Form_Parameter (Form, Keyword, V1, V2);
 526
 527       if V1 = 0 then
 528          return Default;
 529
 530       else
 531          V := 0;
 532
 533          for J in V1 .. V2 loop
 534             if Form (J) not in '0' .. '9' then
 535                raise Use_Error;
 536             else
 537                V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0');
 538             end if;
 539
 540             if V > 999_999 then
 541                raise Use_Error;
 542             end if;
 543          end loop;
 544
 545          return V;
 546       end if;
 547    end Form_Integer;
 548
 549    --------------------
 550    -- Form_Parameter --
 551    --------------------
 552
 553    procedure Form_Parameter
 554      (Form    : String;
 555       Keyword : String;
 556       Start   : out Natural;
 557       Stop    : out Natural)
 558   is
 559       Klen : constant Integer := Keyword'Length;
 560
 561    --  Start of processing for Form_Parameter
 562
 563    begin
 564       for J in Form'First + Klen .. Form'Last - 1 loop
 565          if Form (J) = '='
 566            and then Form (J - Klen .. J - 1) = Keyword
 567          then
 568             Start := J + 1;
 569             Stop := Start - 1;
 570
 571             while Form (Stop + 1) /= ASCII.NUL
 572               and then Form (Stop + 1) /= ','
 573             loop
 574                Stop := Stop + 1;
 575             end loop;
 576
 577             return;
 578          end if;
 579       end loop;
 580
 581       Start := 0;
 582       Stop  := 0;
 583    end Form_Parameter;
 584
 585    -------------
 586    -- Is_Open --
 587    -------------
 588
 589    function Is_Open (File : in AFCB_Ptr) return Boolean is
 590    begin
 591       return (File /= null);
 592    end Is_Open;
 593
 594    -------------------
 595    -- Make_Buffered --
 596    -------------------
 597
 598    procedure Make_Buffered
 599      (File     : AFCB_Ptr;
 600       Buf_Siz  : Interfaces.C_Streams.size_t) is
 601       status   : Integer;
 602
 603    begin
 604       status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz);
 605    end Make_Buffered;
 606
 607    ------------------------
 608    -- Make_Line_Buffered --
 609    ------------------------
 610
 611    procedure Make_Line_Buffered
 612      (File     : AFCB_Ptr;
 613       Line_Siz : Interfaces.C_Streams.size_t) is
 614       status   : Integer;
 615
 616    begin
 617       status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
 618    end Make_Line_Buffered;
 619
 620    ---------------------
 621    -- Make_Unbuffered --
 622    ---------------------
 623
 624    procedure Make_Unbuffered (File : AFCB_Ptr) is
 625       status : Integer;
 626
 627    begin
 628       status := setvbuf (File.Stream, Null_Address, IONBF, 0);
 629    end Make_Unbuffered;
 630
 631    ----------
 632    -- Mode --
 633    ----------
 634
 635    function Mode (File : in AFCB_Ptr) return File_Mode is
 636    begin
 637       if File = null then
 638          raise Status_Error;
 639       else
 640          return File.Mode;
 641       end if;
 642    end Mode;
 643
 644    ----------
 645    -- Name --
 646    ----------
 647
 648    function Name (File : in AFCB_Ptr) return String is
 649    begin
 650       if File = null then
 651          raise Status_Error;
 652       else
 653          return File.Name.all (1 .. File.Name'Length - 1);
 654       end if;
 655    end Name;
 656
 657    ----------
 658    -- Open --
 659    ----------
 660
 661    procedure Open
 662      (File_Ptr  : in out AFCB_Ptr;
 663       Dummy_FCB : in out AFCB'Class;
 664       Mode      : File_Mode;
 665       Name      : String;
 666       Form      : String;
 667       Amethod   : Character;
 668       Creat     : Boolean;
 669       Text      : Boolean;
 670       C_Stream  : FILEs := NULL_Stream)
 671    is
 672       procedure Tmp_Name (Buffer : Address);
 673       pragma Import (C, Tmp_Name, "__gnat_tmp_name");
 674       --  set buffer (a String address) with a temporary filename.
 675
 676       Stream : FILEs := C_Stream;
 677       --  Stream which we open in response to this request
 678
 679       Shared : Shared_Status_Type;
 680       --  Setting of Shared_Status field for file
 681
 682       Fopstr : aliased Fopen_String;
 683       --  Mode string used in fopen call
 684
 685       Formstr : aliased String (1 .. Form'Length + 1);
 686       --  Form string with ASCII.NUL appended, folded to lower case
 687
 688       Tempfile : constant Boolean := (Name'Length = 0);
 689       --  Indicates temporary file case
 690
 691       Namelen : constant Integer := max_path_len;
 692       --  Length required for file name, not including final ASCII.NUL
 693       --  Note that we used to reference L_tmpnam here, which is not
 694       --  reliable since __gnat_tmp_name does not always use tmpnam.
 695
 696       Namestr : aliased String (1 .. Namelen + 1);
 697       --  Name as given or temporary file name with ASCII.NUL appended
 698
 699       Fullname : aliased String (1 .. max_path_len + 1);
 700       --  Full name (as required for Name function, and as stored in the
 701       --  control block in the Name field) with ASCII.NUL appended.
 702
 703       Full_Name_Len : Integer;
 704       --  Length of name actually stored in Fullname
 705
 706    begin
 707       if File_Ptr /= null then
 708          raise Status_Error;
 709       end if;
 710
 711       --  Acquire form string, setting required NUL terminator
 712
 713       Formstr (1 .. Form'Length) := Form;
 714       Formstr (Formstr'Last) := ASCII.NUL;
 715
 716       --  Convert form string to lower case
 717
 718       for J in Formstr'Range loop
 719          if Formstr (J) in 'A' .. 'Z' then
 720             Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32);
 721          end if;
 722       end loop;
 723
 724       --  Acquire setting of shared parameter
 725
 726       declare
 727          V1, V2 : Natural;
 728
 729       begin
 730          Form_Parameter (Formstr, "shared", V1, V2);
 731
 732          if V1 = 0 then
 733             Shared := None;
 734
 735          elsif Formstr (V1 .. V2) = "yes" then
 736             Shared := Yes;
 737
 738          elsif Formstr (V1 .. V2) = "no" then
 739             Shared := No;
 740
 741          else
 742             raise Use_Error;
 743          end if;
 744       end;
 745
 746       --  If we were given a stream (call from xxx.C_Streams.Open), then set
 747       --  full name to null and that is all we have to do in this case so
 748       --  skip to end of processing.
 749
 750       if Stream /= NULL_Stream then
 751          Fullname (1) := ASCII.Nul;
 752          Full_Name_Len := 1;
 753
 754       --  Normal case of Open or Create
 755
 756       else
 757          --  If temporary file case, get temporary file name and add
 758          --  to the list of temporary files to be deleted on exit.
 759
 760          if Tempfile then
 761             if not Creat then
 762                raise Name_Error;
 763             end if;
 764
 765             Tmp_Name (Namestr'Address);
 766
 767             if Namestr (1) = ASCII.NUL then
 768                raise Use_Error;
 769             end if;
 770
 771             --  Chain to temp file list, ensuring thread safety with a lock
 772
 773             begin
 774                SSL.Lock_Task.all;
 775                Temp_Files :=
 776                  new Temp_File_Record'(Name => Namestr, Next => Temp_Files);
 777                SSL.Unlock_Task.all;
 778
 779             exception
 780                when others =>
 781                   SSL.Unlock_Task.all;
 782                   raise;
 783             end;
 784
 785          --  Normal case of non-null name given
 786
 787          else
 788             Namestr (1 .. Name'Length) := Name;
 789             Namestr (Name'Length + 1)  := ASCII.NUL;
 790          end if;
 791
 792          --  Get full name in accordance with the advice of RM A.8.2(22).
 793
 794          full_name (Namestr'Address, Fullname'Address);
 795
 796          if Fullname (1) = ASCII.NUL then
 797             raise Use_Error;
 798          end if;
 799
 800          Full_Name_Len := 1;
 801          while Full_Name_Len < Fullname'Last
 802            and then Fullname (Full_Name_Len) /= ASCII.NUL
 803          loop
 804             Full_Name_Len := Full_Name_Len + 1;
 805          end loop;
 806
 807          --  If Shared=None or Shared=Yes, then check for the existence
 808          --  of another file with exactly the same full name.
 809
 810          if Shared /= No then
 811             declare
 812                P : AFCB_Ptr;
 813
 814             begin
 815                P := Open_Files;
 816                while P /= null loop
 817                   if Fullname (1 .. Full_Name_Len) = P.Name.all then
 818
 819                      --  If we get a match, and either file has Shared=None,
 820                      --  then raise Use_Error, since we don't allow two
 821                      --  files of the same name to be opened unless they
 822                      --  specify the required sharing mode.
 823
 824                      if Shared = None
 825                        or else P.Shared_Status = None
 826                      then
 827                         raise Use_Error;
 828
 829                      --  If both files have Shared=Yes, then we acquire the
 830                      --  stream from the located file to use as our stream.
 831
 832                      elsif Shared = Yes
 833                        and then P.Shared_Status = Yes
 834                      then
 835                         Stream := P.Stream;
 836                         exit;
 837
 838                      --  Otherwise one of the files has Shared=Yes and one
 839                      --  has Shared=No. If the current file has Shared=No
 840                      --  then all is well but we don't want to share any
 841                      --  other file's stream. If the current file has
 842                      --  Shared=Yes, we would like to share a stream, but
 843                      --  not from a file that has Shared=No, so in either
 844                      --  case we just keep going on the search.
 845
 846                      else
 847                         null;
 848                      end if;
 849                   end if;
 850
 851                   P := P.Next;
 852                end loop;
 853             end;
 854          end if;
 855
 856          --  Open specified file if we did not find an existing stream
 857
 858          if Stream = NULL_Stream then
 859             Fopen_Mode (Mode, Text, Creat, Amethod, Fopstr);
 860
 861             --  A special case, if we are opening (OPEN case) a file and
 862             --  the mode returned by Fopen_Mode is not "r" or "r+", then
 863             --  we first make sure that the file exists as required by
 864             --  Ada semantics.
 865
 866             if Creat = False and then Fopstr (1) /= 'r' then
 867                if file_exists (Namestr'Address) = 0 then
 868                   raise Name_Error;
 869                end if;
 870             end if;
 871
 872             --  Now open the file. Note that we use the name as given
 873             --  in the original Open call for this purpose, since that
 874             --  seems the clearest implementation of the intent. It
 875             --  would presumably work to use the full name here, but
 876             --  if there is any difference, then we should use the
 877             --  name used in the call.
 878
 879             --  Note: for a corresponding delete, we will use the
 880             --  full name, since by the time of the delete, the
 881             --  current working directory may have changed and
 882             --  we do not want to delete a different file!
 883
 884             Stream := fopen (Namestr'Address, Fopstr'Address);
 885
 886             if Stream = NULL_Stream then
 887                if file_exists (Namestr'Address) = 0 then
 888                   raise Name_Error;
 889                else
 890                   raise Use_Error;
 891                end if;
 892             end if;
 893          end if;
 894       end if;
 895
 896       --  Stream has been successfully located or opened, so now we are
 897       --  committed to completing the opening of the file. Allocate block
 898       --  on heap and fill in its fields.
 899
 900       File_Ptr := AFCB_Allocate (Dummy_FCB);
 901
 902       File_Ptr.Is_Regular_File   := (is_regular_file
 903                                       (fileno (Stream)) /= 0);
 904       File_Ptr.Is_System_File    := False;
 905       File_Ptr.Is_Text_File      := Text;
 906       File_Ptr.Shared_Status     := Shared;
 907       File_Ptr.Access_Method     := Amethod;
 908       File_Ptr.Stream            := Stream;
 909       File_Ptr.Form              := new String'(Formstr);
 910       File_Ptr.Name              := new String'(Fullname
 911                                                  (1 .. Full_Name_Len));
 912       File_Ptr.Mode              := Mode;
 913       File_Ptr.Is_Temporary_File := Tempfile;
 914
 915       Chain_File (File_Ptr);
 916       Append_Set (File_Ptr);
 917    end Open;
 918
 919    --------------
 920    -- Read_Buf --
 921    --------------
 922
 923    procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
 924       Nread : size_t;
 925
 926    begin
 927       Nread := fread (Buf, 1, Siz, File.Stream);
 928
 929       if Nread = Siz then
 930          return;
 931
 932       elsif ferror (File.Stream) /= 0 then
 933          raise Device_Error;
 934
 935       elsif Nread = 0 then
 936          raise End_Error;
 937
 938       else -- 0 < Nread < Siz
 939          raise Data_Error;
 940       end if;
 941
 942    end Read_Buf;
 943
 944    procedure Read_Buf
 945      (File  : AFCB_Ptr;
 946       Buf   : Address;
 947       Siz   : in Interfaces.C_Streams.size_t;
 948       Count : out Interfaces.C_Streams.size_t)
 949    is
 950    begin
 951       Count := fread (Buf, 1, Siz, File.Stream);
 952
 953       if Count = 0 and then ferror (File.Stream) /= 0 then
 954          raise Device_Error;
 955       end if;
 956    end Read_Buf;
 957
 958    -----------
 959    -- Reset --
 960    -----------
 961
 962    --  The reset which does not change the mode simply does a rewind.
 963
 964    procedure Reset (File : in out AFCB_Ptr) is
 965    begin
 966       Check_File_Open (File);
 967       Reset (File, File.Mode);
 968    end Reset;
 969
 970    --  The reset with a change in mode is done using freopen, and is
 971    --  not permitted except for regular files (since otherwise there
 972    --  is no name for the freopen, and in any case it seems meaningless)
 973
 974    procedure Reset (File : in out AFCB_Ptr; Mode : in File_Mode) is
 975       Fopstr : aliased Fopen_String;
 976
 977    begin
 978       Check_File_Open (File);
 979
 980       --  Change of mode not allowed for shared file or file with no name
 981       --  or file that is not a regular file, or for a system file.
 982
 983       if File.Shared_Status = Yes
 984         or else File.Name'Length <= 1
 985         or else File.Is_System_File
 986         or else (not File.Is_Regular_File)
 987       then
 988          raise Use_Error;
 989
 990       --  For In_File or Inout_File for a regular file, we can just do a
 991       --  rewind if the mode is unchanged, which is more efficient than
 992       --  doing a full reopen.
 993
 994       elsif Mode = File.Mode
 995         and then Mode <= Inout_File
 996       then
 997          rewind (File.Stream);
 998
 999       --  Here the change of mode is permitted, we do it by reopening the
1000       --  file in the new mode and replacing the stream with a new stream.
1001
1002       else
1003          Fopen_Mode
1004            (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr);
1005
1006          File.Stream :=
1007            freopen (File.Name.all'Address, Fopstr'Address, File.Stream);
1008
1009          if File.Stream = NULL_Stream then
1010             Close (File);
1011             raise Use_Error;
1012
1013          else
1014             File.Mode := Mode;
1015             Append_Set (File);
1016          end if;
1017       end if;
1018    end Reset;
1019
1020    ---------------
1021    -- Write_Buf --
1022    ---------------
1023
1024    procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1025    begin
1026       --  Note: for most purposes, the Siz and 1 parameters in the fwrite
1027       --  call could be reversed, but on VMS, this is a better choice, since
1028       --  for some file formats, reversing the parameters results in records
1029       --  of one byte each.
1030
1031       SSL.Abort_Defer.all;
1032
1033       if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
1034          if Siz /= 0 then
1035             SSL.Abort_Undefer.all;
1036             raise Device_Error;
1037          end if;
1038       end if;
1039
1040       SSL.Abort_Undefer.all;
1041    end Write_Buf;
1042
1043 end System.File_IO;