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