2014-03-25 Richard Biener <rguenther@suse.de>

[official-gcc.git] / gcc / ada / s-fileio.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                       S Y S T E M . F I L E _ I O                        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Finalization;  use Ada.Finalization;
with Ada.IO_Exceptions; use Ada.IO_Exceptions;

with Interfaces.C;
with Interfaces.C_Streams; use Interfaces.C_Streams;

with System.CRTL;
with System.Case_Util;    use System.Case_Util;
with System.OS_Lib;
with System.Soft_Links;

with Ada.Unchecked_Deallocation;

package body System.File_IO is

   use System.File_Control_Block;

   package SSL renames System.Soft_Links;

   use type Interfaces.C.int;
   use type CRTL.size_t;

   subtype String_Access is System.OS_Lib.String_Access;
   procedure Free (X : in out String_Access) renames System.OS_Lib.Free;

   function "=" (X, Y : String_Access) return Boolean
     renames System.OS_Lib."=";

   ----------------------
   -- Global Variables --
   ----------------------

   Open_Files : AFCB_Ptr;
   --  This points to a list of AFCB's for all open files. This is a doubly
   --  linked list, with the Prev pointer of the first entry, and the Next
   --  pointer of the last entry containing null. Note that this global
   --  variable must be properly protected to provide thread safety.

   type Temp_File_Record;
   type Temp_File_Record_Ptr is access all Temp_File_Record;

   type Temp_File_Record is record
      Name : String (1 .. max_path_len + 1);
      Next : Temp_File_Record_Ptr;
   end record;
   --  One of these is allocated for each temporary file created

   Temp_Files : Temp_File_Record_Ptr;
   --  Points to list of names of temporary files. Note that this global
   --  variable must be properly protected to provide thread safety.

   type File_IO_Clean_Up_Type is new Limited_Controlled with null record;
   --  The closing of all open files and deletion of temporary files is an
   --  action that takes place at the end of execution of the main program.
   --  This action is implemented using a library level object which gets
   --  finalized at the end of program execution. Note that the type is
   --  limited, in order to stop the compiler optimizing away the declaration
   --  which would be allowed in the non-limited case.

   procedure Finalize (V : in out File_IO_Clean_Up_Type);
   --  This is the finalize operation that is used to do the cleanup

   File_IO_Clean_Up_Object : File_IO_Clean_Up_Type;
   pragma Warnings (Off, File_IO_Clean_Up_Object);
   --  This is the single object of the type that triggers the finalization
   --  call. Since it is at the library level, this happens just before the
   --  environment task is finalized.

   text_translation_required : Boolean;
   for text_translation_required'Size use Character'Size;
   pragma Import
     (C, text_translation_required, "__gnat_text_translation_required");
   --  If true, add appropriate suffix to control string for Open

   VMS_Formstr : String_Access := null;
   --  For special VMS RMS keywords and values

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Free_String is new Ada.Unchecked_Deallocation (String, Pstring);

   subtype Fopen_String is String (1 .. 4);
   --  Holds open string (longest is "w+b" & nul)

   procedure Fopen_Mode
     (Mode    : File_Mode;
      Text    : Boolean;
      Creat   : Boolean;
      Amethod : Character;
      Fopstr  : out Fopen_String);
   --  Determines proper open mode for a file to be opened in the given
   --  Ada mode. Text is true for a text file and false otherwise, and
   --  Creat is true for a create call, and False for an open call. The
   --  value stored in Fopstr is a nul-terminated string suitable for a
   --  call to fopen or freopen. Amethod is the character designating
   --  the access method from the Access_Method field of the FCB.

   function Errno_Message
     (Name  : String;
      Errno : Integer := OS_Lib.Errno) return String;
   --  Return Errno_Message for Errno, with file name prepended

   procedure Raise_Device_Error
     (File  : AFCB_Ptr;
      Errno : Integer := OS_Lib.Errno);
   pragma No_Return (Raise_Device_Error);
   --  Clear error indication on File and raise Device_Error with an exception
   --  message providing errno information.

   procedure Form_VMS_RMS_Keys (Form : String; VMS_Form : out String_Access);
   --  Parse the RMS Keys

   function Form_RMS_Context_Key
     (Form     : String;
      VMS_Form : String_Access) return Natural;
   --  Parse the RMS Context Key

   ----------------
   -- Append_Set --
   ----------------

   procedure Append_Set (File : AFCB_Ptr) is
   begin
      if File.Mode = Append_File then
         if fseek (File.Stream, 0, SEEK_END) /= 0 then
            Raise_Device_Error (File);
         end if;
      end if;
   end Append_Set;

   ----------------
   -- Chain_File --
   ----------------

   procedure Chain_File (File : AFCB_Ptr) is
   begin
      --  Take a task lock, to protect the global data value Open_Files

      SSL.Lock_Task.all;

      --  Do the chaining operation locked

      File.Next := Open_Files;
      File.Prev := null;
      Open_Files := File;

      if File.Next /= null then
         File.Next.Prev := File;
      end if;

      SSL.Unlock_Task.all;

   exception
      when others =>
         SSL.Unlock_Task.all;
         raise;
   end Chain_File;

   ---------------------
   -- Check_File_Open --
   ---------------------

   procedure Check_File_Open (File : AFCB_Ptr) is
   begin
      if File = null then
         raise Status_Error with "file not open";
      end if;
   end Check_File_Open;

   -----------------------
   -- Check_Read_Status --
   -----------------------

   procedure Check_Read_Status (File : AFCB_Ptr) is
   begin
      if File = null then
         raise Status_Error with "file not open";
      elsif File.Mode not in Read_File_Mode then
         raise Mode_Error with "file not readable";
      end if;
   end Check_Read_Status;

   ------------------------
   -- Check_Write_Status --
   ------------------------

   procedure Check_Write_Status (File : AFCB_Ptr) is
   begin
      if File = null then
         raise Status_Error with "file not open";
      elsif File.Mode = In_File then
         raise Mode_Error with "file not writable";
      end if;
   end Check_Write_Status;

   -----------
   -- Close --
   -----------

   procedure Close (File_Ptr : access AFCB_Ptr) is
      Close_Status : int := 0;
      Dup_Strm     : Boolean := False;
      File         : AFCB_Ptr renames File_Ptr.all;
      Errno        : Integer := 0;

   begin
      --  Take a task lock, to protect the global data value Open_Files

      SSL.Lock_Task.all;

      Check_File_Open (File);
      AFCB_Close (File);

      --  Sever the association between the given file and its associated
      --  external file. The given file is left closed. Do not perform system
      --  closes on the standard input, output and error files and also do not
      --  attempt to close a stream that does not exist (signalled by a null
      --  stream value -- happens in some error situations).

      if not File.Is_System_File and then File.Stream /= NULL_Stream then

         --  Do not do an fclose if this is a shared file and there is at least
         --  one other instance of the stream that is open.

         if File.Shared_Status = Yes then
            declare
               P   : AFCB_Ptr;

            begin
               P := Open_Files;
               while P /= null loop
                  if P /= File and then File.Stream = P.Stream then
                     Dup_Strm := True;
                     exit;
                  end if;

                  P := P.Next;
               end loop;
            end;
         end if;

         --  Do the fclose unless this was a duplicate in the shared case

         if not Dup_Strm then
            Close_Status := fclose (File.Stream);

            if Close_Status /= 0 then
               Errno := OS_Lib.Errno;
            end if;
         end if;
      end if;

      --  Dechain file from list of open files and then free the storage

      if File.Prev = null then
         Open_Files := File.Next;
      else
         File.Prev.Next := File.Next;
      end if;

      if File.Next /= null then
         File.Next.Prev := File.Prev;
      end if;

      --  Deallocate some parts of the file structure that were kept in heap
      --  storage with the exception of system files (standard input, output
      --  and error) since they had some information allocated in the stack.

      if not File.Is_System_File then
         Free_String (File.Name);
         Free_String (File.Form);
         AFCB_Free (File);
      end if;

      File := null;

      if Close_Status /= 0 then
         Raise_Device_Error (null, Errno);
      end if;

      SSL.Unlock_Task.all;

   exception
      when others =>
         SSL.Unlock_Task.all;
         raise;
   end Close;

   ------------
   -- Delete --
   ------------

   procedure Delete (File_Ptr : access AFCB_Ptr) is
      File : AFCB_Ptr renames File_Ptr.all;

   begin
      Check_File_Open (File);

      if not File.Is_Regular_File then
         raise Use_Error with "cannot delete non-regular file";
      end if;

      declare
         Filename : aliased constant String := File.Name.all;

      begin
         Close (File_Ptr);

         --  Now unlink the external file. Note that we use the full name in
         --  this unlink, because the working directory may have changed since
         --  we did the open, and we want to unlink the right file.

         if unlink (Filename'Address) = -1 then
            raise Use_Error with OS_Lib.Errno_Message;
         end if;
      end;
   end Delete;

   -----------------
   -- End_Of_File --
   -----------------

   function End_Of_File (File : AFCB_Ptr) return Boolean is
   begin
      Check_File_Open (File);

      if feof (File.Stream) /= 0 then
         return True;

      else
         Check_Read_Status (File);

         if ungetc (fgetc (File.Stream), File.Stream) = EOF then
            clearerr (File.Stream);
            return True;
         else
            return False;
         end if;
      end if;
   end End_Of_File;

   -------------------
   -- Errno_Message --
   -------------------

   function Errno_Message
     (Name  : String;
      Errno : Integer := OS_Lib.Errno) return String
   is
   begin
      return Name & ": " & OS_Lib.Errno_Message (Err => Errno);
   end Errno_Message;

   --------------
   -- Finalize --
   --------------

   --  Note: we do not need to worry about locking against multiple task access
   --  in this routine, since it is called only from the environment task just
   --  before terminating execution.

   procedure Finalize (V : in out File_IO_Clean_Up_Type) is
      pragma Warnings (Off, V);

      Fptr1   : aliased AFCB_Ptr;
      Fptr2   : AFCB_Ptr;

      Discard : int;
      pragma Unreferenced (Discard);

   begin
      --  Take a lock to protect global Open_Files data structure

      SSL.Lock_Task.all;

      --  First close all open files (the slightly complex form of this loop is
      --  required because Close as a side effect nulls out its argument).

      Fptr1 := Open_Files;
      while Fptr1 /= null loop
         Fptr2 := Fptr1.Next;
         Close (Fptr1'Access);
         Fptr1 := Fptr2;
      end loop;

      --  Now unlink all temporary files. We do not bother to free the blocks
      --  because we are just about to terminate the program. We also ignore
      --  any errors while attempting these unlink operations.

      while Temp_Files /= null loop
         Discard := unlink (Temp_Files.Name'Address);
         Temp_Files := Temp_Files.Next;
      end loop;

      SSL.Unlock_Task.all;

   exception
      when others =>
         SSL.Unlock_Task.all;
         raise;
   end Finalize;

   -----------
   -- Flush --
   -----------

   procedure Flush (File : AFCB_Ptr) is
   begin
      Check_Write_Status (File);

      if fflush (File.Stream) /= 0 then
         Raise_Device_Error (File);
      end if;
   end Flush;

   ----------------
   -- Fopen_Mode --
   ----------------

   --  The fopen mode to be used is shown by the following table:

   --                                     OPEN         CREATE
   --     Append_File                     "r+"           "w+"
   --     In_File                         "r"            "w+"
   --     Out_File (Direct_IO)            "r+"           "w"
   --     Out_File (all others)           "w"            "w"
   --     Inout_File                      "r+"           "w+"

   --  Note: we do not use "a" or "a+" for Append_File, since this would not
   --  work in the case of stream files, where even if in append file mode,
   --  you can reset to earlier points in the file. The caller must use the
   --  Append_Set routine to deal with the necessary positioning.

   --  Note: in several cases, the fopen mode used allows reading and writing,
   --  but the setting of the Ada mode is more restrictive. For instance,
   --  Create in In_File mode uses "w+" which allows writing, but the Ada mode
   --  In_File will cause any write operations to be rejected with Mode_Error
   --  in any case.

   --  Note: for the Out_File/Open cases for other than the Direct_IO case, an
   --  initial call will be made by the caller to first open the file in "r"
   --  mode to be sure that it exists. The real open, in "w" mode, will then
   --  destroy this file. This is peculiar, but that's what Ada semantics
   --  require and the ACATS tests insist on.

   --  If text file translation is required, then either "b" or "t" is appended
   --  to the mode, depending on the setting of Text.

   procedure Fopen_Mode
     (Mode    : File_Mode;
      Text    : Boolean;
      Creat   : Boolean;
      Amethod : Character;
      Fopstr  : out Fopen_String)
   is
      Fptr : Positive;

   begin
      case Mode is
         when In_File =>
            if Creat then
               Fopstr (1) := 'w';
               Fopstr (2) := '+';
               Fptr := 3;
            else
               Fopstr (1) := 'r';
               Fptr := 2;
            end if;

         when Out_File =>
            if Amethod = 'D' and then not Creat then
               Fopstr (1) := 'r';
               Fopstr (2) := '+';
               Fptr := 3;
            else
               Fopstr (1) := 'w';
               Fptr := 2;
            end if;

         when Inout_File | Append_File =>
            Fopstr (1) := (if Creat then 'w' else 'r');
            Fopstr (2) := '+';
            Fptr := 3;
      end case;

      --  If text_translation_required is true then we need to append either a
      --  "t" or "b" to the string to get the right mode.

      if text_translation_required then
         Fopstr (Fptr) := (if Text then 't' else 'b');
         Fptr := Fptr + 1;
      end if;

      Fopstr (Fptr) := ASCII.NUL;
   end Fopen_Mode;

   ----------
   -- Form --
   ----------

   function Form (File : AFCB_Ptr) return String is
   begin
      if File = null then
         raise Status_Error with "Form: file not open";
      else
         return File.Form.all (1 .. File.Form'Length - 1);
      end if;
   end Form;

   ------------------
   -- Form_Boolean --
   ------------------

   function Form_Boolean
     (Form    : String;
      Keyword : String;
      Default : Boolean) return Boolean
   is
      V1, V2 : Natural;
      pragma Unreferenced (V2);

   begin
      Form_Parameter (Form, Keyword, V1, V2);

      if V1 = 0 then
         return Default;
      elsif Form (V1) = 'y' then
         return True;
      elsif Form (V1) = 'n' then
         return False;
      else
         raise Use_Error with "invalid Form";
      end if;
   end Form_Boolean;

   ------------------
   -- Form_Integer --
   ------------------

   function Form_Integer
     (Form    : String;
      Keyword : String;
      Default : Integer) return Integer
   is
      V1, V2 : Natural;
      V      : Integer;

   begin
      Form_Parameter (Form, Keyword, V1, V2);

      if V1 = 0 then
         return Default;

      else
         V := 0;

         for J in V1 .. V2 loop
            if Form (J) not in '0' .. '9' then
               raise Use_Error with "invalid Form";
            else
               V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0');
            end if;

            if V > 999_999 then
               raise Use_Error with "invalid Form";
            end if;
         end loop;

         return V;
      end if;
   end Form_Integer;

   --------------------
   -- Form_Parameter --
   --------------------

   procedure Form_Parameter
     (Form    : String;
      Keyword : String;
      Start   : out Natural;
      Stop    : out Natural)
   is
      Klen : constant Integer := Keyword'Length;

   begin
      for J in Form'First + Klen .. Form'Last - 1 loop
         if Form (J) = '='
           and then Form (J - Klen .. J - 1) = Keyword
         then
            Start := J + 1;
            Stop := Start - 1;
            while Form (Stop + 1) /= ASCII.NUL
              and then Form (Stop + 1) /= ','
            loop
               Stop := Stop + 1;
            end loop;

            return;
         end if;
      end loop;

      Start := 0;
      Stop  := 0;
   end Form_Parameter;

   --------------------------
   -- Form_RMS_Context_Key --
   --------------------------

   function Form_RMS_Context_Key
     (Form     : String;
      VMS_Form : String_Access) return Natural
   is
      type Context_Parms is
        (Binary_Data, Convert_Fortran_Carriage_Control, Force_Record_Mode,
         Force_Stream_Mode, Explicit_Write);
      --  Ada-fied list of all possible Context keyword values

      Pos   : Natural := 0;
      Klen  : Natural := 0;
      Index : Natural;

   begin
      --  Find the end of the occupation

      for J in VMS_Form'First .. VMS_Form'Last loop
         if VMS_Form (J) = ASCII.NUL then
            Pos := J;
            exit;
         end if;
      end loop;

      Index := Form'First;
      while Index < Form'Last loop
         if Form (Index) = '=' then
            Index := Index + 1;

            --  Loop through the context values and look for a match

            for Parm in Context_Parms loop
               declare
                  KImage : String := Context_Parms'Image (Parm);

               begin
                  Klen := KImage'Length;
                  To_Lower (KImage);

                  if Index + Klen - 1 <= Form'Last
                    and then Form (Index .. Index + Klen - 1) = KImage
                  then
                     case Parm is
                        when Force_Record_Mode =>
                           VMS_Form (Pos) := '"';
                           Pos := Pos + 1;
                           VMS_Form (Pos .. Pos + 6) := "ctx=rec";
                           Pos := Pos + 7;
                           VMS_Form (Pos) := '"';
                           Pos := Pos + 1;
                           VMS_Form (Pos) := ',';
                           return Index + Klen;

                        when Force_Stream_Mode =>
                           VMS_Form (Pos) := '"';
                           Pos := Pos + 1;
                           VMS_Form (Pos .. Pos + 6) := "ctx=stm";
                           Pos := Pos + 7;
                           VMS_Form (Pos) := '"';
                           Pos := Pos + 1;
                           VMS_Form (Pos) := ',';
                           return Index + Klen;

                        when others =>
                           raise Use_Error
                             with "unimplemented RMS Context Value";
                     end case;
                  end if;
               end;
            end loop;

            raise Use_Error with "unrecognized RMS Context Value";
         end if;
      end loop;

      raise Use_Error with "malformed RMS Context Value";
   end Form_RMS_Context_Key;

   -----------------------
   -- Form_VMS_RMS_Keys --
   -----------------------

   procedure Form_VMS_RMS_Keys (Form : String; VMS_Form : out String_Access)
   is
      VMS_RMS_Keys_Token : constant String := "vms_rms_keys";
      Klen : Natural := VMS_RMS_Keys_Token'Length;
      Index : Natural;

      --  Ada-fied list of all RMS keywords, translated from the HP C Run-Time
      --  Library Reference Manual, Table REF-3: RMS Valid Keywords and Values.

      type RMS_Keys is
       (Access_Callback, Allocation_Quantity, Block_Size, Context,
        Default_Extension_Quantity, Default_File_Name_String, Error_Callback,
        File_Processing_Options, Fixed_Header_Size, Global_Buffer_Count,
        Multiblock_Count, Multibuffer_Count, Maximum_Record_Size,
        Terminal_Input_Prompt, Record_Attributes, Record_Format,
        Record_Processing_Options, Retrieval_Pointer_Count, Sharing_Options,
        Timeout_IO_Value);

   begin
      Index := Form'First + Klen - 1;
      while Index < Form'Last loop
         Index := Index + 1;

         --  Scan for the token signalling VMS RMS Keys ahead.  Should
         --  whitespace be eaten???

         if Form (Index - Klen .. Index - 1) = VMS_RMS_Keys_Token then

            --  Allocate the VMS form string that will contain the cryptic
            --  CRTL RMS strings and initialize it to all nulls.  Since the
            --  CRTL strings are always shorter than the Ada-fied strings,
            --  it follows that an allocation of the original size will be
            --  more than adequate.
            VMS_Form := new String'(Form (Form'First .. Form'Last));
            VMS_Form.all := (others => ASCII.NUL);

            if Form (Index) = '=' then
               Index := Index + 1;
               if Form (Index) = '(' then
                  while Index < Form'Last loop
                     Index := Index + 1;

                     --  Loop through the RMS Keys and dispatch.

                     for Key in RMS_Keys loop
                        declare
                           KImage : String := RMS_Keys'Image (Key);

                        begin
                           Klen := KImage'Length;
                           To_Lower (KImage);

                           if Form (Index .. Index + Klen - 1) = KImage then
                              case Key is
                                 when Context =>
                                    Index := Form_RMS_Context_Key
                                     (Form (Index + Klen .. Form'Last),
                                      VMS_Form);
                                    exit;

                                 when others =>
                                    raise Use_Error
                                     with "unimplemented VMS RMS Form Key";
                              end case;
                           end if;
                        end;
                     end loop;

                     if Form (Index) = ')' then

                        --  Done, erase the unneeded trailing comma and return

                        for J in reverse VMS_Form'First .. VMS_Form'Last loop
                           if VMS_Form (J) = ',' then
                              VMS_Form (J) := ASCII.NUL;
                              return;
                           end if;
                        end loop;

                        --  Shouldn't be possible to get here

                        raise Use_Error;

                     elsif Form (Index) = ',' then

                        --  Another key ahead, exit inner loop

                        null;

                     else

                        --  Keyword value not terminated correctly

                        raise Use_Error with "malformed VMS RMS Form";
                     end if;
                  end loop;
               end if;
            end if;

            --  Found the keyword, but not followed by correct syntax

            raise Use_Error with "malformed VMS RMS Form";
         end if;
      end loop;
   end Form_VMS_RMS_Keys;

   -------------
   -- Is_Open --
   -------------

   function Is_Open (File : AFCB_Ptr) return Boolean is
   begin
      --  We return True if the file is open, and the underlying file stream is
      --  usable. In particular on Windows an application linked with -mwindows
      --  option set does not have a console attached. In this case standard
      --  files (Current_Output, Current_Error, Current_Input) are not created.
      --  We want Is_Open (Current_Output) to return False in this case.

      return File /= null and then fileno (File.Stream) /= -1;
   end Is_Open;

   -------------------
   -- Make_Buffered --
   -------------------

   procedure Make_Buffered
     (File    : AFCB_Ptr;
      Buf_Siz : Interfaces.C_Streams.size_t)
   is
      status : Integer;
      pragma Unreferenced (status);

   begin
      status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz);
   end Make_Buffered;

   ------------------------
   -- Make_Line_Buffered --
   ------------------------

   procedure Make_Line_Buffered
     (File     : AFCB_Ptr;
      Line_Siz : Interfaces.C_Streams.size_t)
   is
      status : Integer;
      pragma Unreferenced (status);

   begin
      status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
      --  No error checking???
   end Make_Line_Buffered;

   ---------------------
   -- Make_Unbuffered --
   ---------------------

   procedure Make_Unbuffered (File : AFCB_Ptr) is
      status : Integer;
      pragma Unreferenced (status);

   begin
      status := setvbuf (File.Stream, Null_Address, IONBF, 0);
      --  No error checking???
   end Make_Unbuffered;

   ----------
   -- Mode --
   ----------

   function Mode (File : AFCB_Ptr) return File_Mode is
   begin
      if File = null then
         raise Status_Error with "Mode: file not open";
      else
         return File.Mode;
      end if;
   end Mode;

   ----------
   -- Name --
   ----------

   function Name (File : AFCB_Ptr) return String is
   begin
      if File = null then
         raise Status_Error with "Name: file not open";
      else
         return File.Name.all (1 .. File.Name'Length - 1);
      end if;
   end Name;

   ----------
   -- Open --
   ----------

   procedure Open
     (File_Ptr  : in out AFCB_Ptr;
      Dummy_FCB : AFCB'Class;
      Mode      : File_Mode;
      Name      : String;
      Form      : String;
      Amethod   : Character;
      Creat     : Boolean;
      Text      : Boolean;
      C_Stream  : FILEs := NULL_Stream)
   is
      pragma Warnings (Off, Dummy_FCB);
      --  Yes we know this is never assigned a value. That's intended, since
      --  all we ever use of this value is the tag for dispatching purposes.

      procedure Tmp_Name (Buffer : Address);
      pragma Import (C, Tmp_Name, "__gnat_tmp_name");
      --  Set buffer (a String address) with a temporary filename

      function Get_Case_Sensitive return Integer;
      pragma Import (C, Get_Case_Sensitive,
                     "__gnat_get_file_names_case_sensitive");

      File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0;
      --  Set to indicate whether the operating system convention is for file
      --  names to be case sensitive (e.g., in Unix, set True), or not case
      --  sensitive (e.g., in Windows, set False). Declared locally to avoid
      --  breaking the Preelaborate rule that disallows function calls at the
      --  library level.

      Stream : FILEs := C_Stream;
      --  Stream which we open in response to this request

      Shared : Shared_Status_Type;
      --  Setting of Shared_Status field for file

      Fopstr : aliased Fopen_String;
      --  Mode string used in fopen call

      Formstr : aliased String (1 .. Form'Length + 1);
      --  Form string with ASCII.NUL appended, folded to lower case

      Is_Text_File : Boolean;

      Tempfile : constant Boolean := (Name'Length = 0);
      --  Indicates temporary file case

      Namelen : constant Integer := max_path_len;
      --  Length required for file name, not including final ASCII.NUL.
      --  Note that we used to reference L_tmpnam here, which is not reliable
      --  since __gnat_tmp_name does not always use tmpnam.

      Namestr : aliased String (1 .. Namelen + 1);
      --  Name as given or temporary file name with ASCII.NUL appended

      Fullname : aliased String (1 .. max_path_len + 1);
      --  Full name (as required for Name function, and as stored in the
      --  control block in the Name field) with ASCII.NUL appended.

      Full_Name_Len : Integer;
      --  Length of name actually stored in Fullname

      Encoding : CRTL.Filename_Encoding;
      --  Filename encoding specified into the form parameter

   begin
      if File_Ptr /= null then
         raise Status_Error with "file already open";
      end if;

      --  Acquire form string, setting required NUL terminator

      Formstr (1 .. Form'Length) := Form;
      Formstr (Formstr'Last) := ASCII.NUL;

      --  Convert form string to lower case

      for J in Formstr'Range loop
         if Formstr (J) in 'A' .. 'Z' then
            Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32);
         end if;
      end loop;

      --  Acquire setting of shared parameter

      declare
         V1, V2 : Natural;

      begin
         Form_Parameter (Formstr, "shared", V1, V2);

         if V1 = 0 then
            Shared := None;
         elsif Formstr (V1 .. V2) = "yes" then
            Shared := Yes;
         elsif Formstr (V1 .. V2) = "no" then
            Shared := No;
         else
            raise Use_Error with "invalid Form";
         end if;
      end;

      --  Acquire setting of encoding parameter

      declare
         V1, V2 : Natural;

      begin
         Form_Parameter (Formstr, "encoding", V1, V2);

         if V1 = 0 then
            Encoding := CRTL.Unspecified;
         elsif Formstr (V1 .. V2) = "utf8" then
            Encoding := CRTL.UTF8;
         elsif Formstr (V1 .. V2) = "8bits" then
            Encoding := CRTL.ASCII_8bits;
         else
            raise Use_Error with "invalid Form";
         end if;
      end;

      --  Acquire setting of text_translation parameter. Only needed if this is
      --  a [Wide_[Wide_]]Text_IO file, in which case we default to True, but
      --  if the Form says Text_Translation=No, we use binary mode, so new-line
      --  will be just LF, even on Windows.

      Is_Text_File := Text;

      if Is_Text_File then
         Is_Text_File :=
           Form_Boolean (Formstr, "text_translation", Default => True);
      end if;

      --  Acquire settings of target specific form parameters on VMS. Only
      --  Context is currently implemented, for forcing a byte stream mode
      --  read. On non-VMS systems, the settings are ultimately ignored in
      --  the implementation of __gnat_fopen.

      --  Should a warning be issued on non-VMS systems?  That's not possible
      --  without testing System.OpenVMS boolean which isn't present in most
      --  non-VMS versions of package System.

      Form_VMS_RMS_Keys (Formstr, VMS_Formstr);

      --  If we were given a stream (call from xxx.C_Streams.Open), then set
      --  the full name to the given one, and skip to end of processing.

      if Stream /= NULL_Stream then
         Full_Name_Len := Name'Length + 1;
         Fullname (1 .. Full_Name_Len - 1) := Name;
         Fullname (Full_Name_Len) := ASCII.NUL;

      --  Normal case of Open or Create

      else
         --  If temporary file case, get temporary file name and add to the
         --  list of temporary files to be deleted on exit.

         if Tempfile then
            if not Creat then
               raise Name_Error with "opening temp file without creating it";
            end if;

            Tmp_Name (Namestr'Address);

            if Namestr (1) = ASCII.NUL then
               raise Use_Error with "invalid temp file name";
            end if;

            --  Chain to temp file list, ensuring thread safety with a lock

            begin
               SSL.Lock_Task.all;
               Temp_Files :=
                 new Temp_File_Record'(Name => Namestr, Next => Temp_Files);
               SSL.Unlock_Task.all;

            exception
               when others =>
                  SSL.Unlock_Task.all;
                  raise;
            end;

         --  Normal case of non-null name given

         else
            if Name'Length > Namelen then
               raise Name_Error with "file name too long";
            end if;

            Namestr (1 .. Name'Length) := Name;
            Namestr (Name'Length + 1)  := ASCII.NUL;
         end if;

         --  Get full name in accordance with the advice of RM A.8.2(22)

         full_name (Namestr'Address, Fullname'Address);

         if Fullname (1) = ASCII.NUL then
            raise Use_Error with Errno_Message (Name);
         end if;

         Full_Name_Len := 1;
         while Full_Name_Len < Fullname'Last
           and then Fullname (Full_Name_Len) /= ASCII.NUL
         loop
            Full_Name_Len := Full_Name_Len + 1;
         end loop;

         --  Fullname is generated by calling system's full_name. The problem
         --  is, full_name does nothing about the casing, so a file name
         --  comparison may generally speaking not be valid on non-case-
         --  sensitive systems, and in particular we get unexpected failures
         --  on Windows/Vista because of this. So we use s-casuti to force
         --  the name to lower case.

         if not File_Names_Case_Sensitive then
            To_Lower (Fullname (1 .. Full_Name_Len));
         end if;

         --  If Shared=None or Shared=Yes, then check for the existence of
         --  another file with exactly the same full name.

         if Shared /= No then
            declare
               P : AFCB_Ptr;

            begin
               --  Take a task lock to protect Open_Files

               SSL.Lock_Task.all;

               --  Search list of open files

               P := Open_Files;
               while P /= null loop
                  if Fullname (1 .. Full_Name_Len) = P.Name.all then

                     --  If we get a match, and either file has Shared=None,
                     --  then raise Use_Error, since we don't allow two files
                     --  of the same name to be opened unless they specify the
                     --  required sharing mode.

                     if Shared = None
                       or else P.Shared_Status = None
                     then
                        raise Use_Error with "reopening shared file";

                     --  If both files have Shared=Yes, then we acquire the
                     --  stream from the located file to use as our stream.

                     elsif Shared = Yes
                       and then P.Shared_Status = Yes
                     then
                        Stream := P.Stream;
                        exit;

                     --  Otherwise one of the files has Shared=Yes and one has
                     --  Shared=No. If the current file has Shared=No then all
                     --  is well but we don't want to share any other file's
                     --  stream. If the current file has Shared=Yes, we would
                     --  like to share a stream, but not from a file that has
                     --  Shared=No, so either way, we just continue the search.

                     else
                        null;
                     end if;
                  end if;

                  P := P.Next;
               end loop;

               SSL.Unlock_Task.all;

            exception
               when others =>
                  SSL.Unlock_Task.all;
                  raise;
            end;
         end if;

         --  Open specified file if we did not find an existing stream

         if Stream = NULL_Stream then
            Fopen_Mode (Mode, Is_Text_File, Creat, Amethod, Fopstr);

            --  A special case, if we are opening (OPEN case) a file and the
            --  mode returned by Fopen_Mode is not "r" or "r+", then we first
            --  make sure that the file exists as required by Ada semantics.

            if not Creat and then Fopstr (1) /= 'r' then
               if file_exists (Namestr'Address) = 0 then
                  raise Name_Error with Errno_Message (Name);
               end if;
            end if;

            --  Now open the file. Note that we use the name as given in the
            --  original Open call for this purpose, since that seems the
            --  clearest implementation of the intent. It would presumably
            --  work to use the full name here, but if there is any difference,
            --  then we should use the name used in the call.

            --  Note: for a corresponding delete, we will use the full name,
            --  since by the time of the delete, the current working directory
            --  may have changed and we do not want to delete a different file.

            if VMS_Formstr = null then
               Stream := fopen (Namestr'Address, Fopstr'Address, Encoding,
                                Null_Address);
            else
               Stream := fopen (Namestr'Address, Fopstr'Address, Encoding,
                                VMS_Formstr.all'Address);
            end if;

            --   No need to keep this around

            if VMS_Formstr /= null then
               Free (VMS_Formstr);
            end if;

            if Stream = NULL_Stream then

               --  Raise Name_Error if trying to open a non-existent file.
               --  Otherwise raise Use_Error.

               --  Should we raise Device_Error for ENOSPC???

               declare
                  function Is_File_Not_Found_Error
                    (Errno_Value : Integer) return Integer;
                  pragma Import
                    (C, Is_File_Not_Found_Error,
                     "__gnat_is_file_not_found_error");
                  --  Non-zero when the given errno value indicates a non-
                  --  existing file.

                  Errno   : constant Integer := OS_Lib.Errno;
                  Message : constant String := Errno_Message (Name, Errno);

               begin
                  if Is_File_Not_Found_Error (Errno) /= 0 then
                     raise Name_Error with Message;
                  else
                     raise Use_Error with Message;
                  end if;
               end;
            end if;
         end if;
      end if;

      --  Stream has been successfully located or opened, so now we are
      --  committed to completing the opening of the file. Allocate block on
      --  heap and fill in its fields.

      File_Ptr := AFCB_Allocate (Dummy_FCB);

      File_Ptr.Is_Regular_File   := (is_regular_file (fileno (Stream)) /= 0);
      File_Ptr.Is_System_File    := False;
      File_Ptr.Is_Text_File      := Is_Text_File;
      File_Ptr.Shared_Status     := Shared;
      File_Ptr.Access_Method     := Amethod;
      File_Ptr.Stream            := Stream;
      File_Ptr.Form              := new String'(Formstr);
      File_Ptr.Name              := new String'(Fullname (1 .. Full_Name_Len));
      File_Ptr.Mode              := Mode;
      File_Ptr.Is_Temporary_File := Tempfile;
      File_Ptr.Encoding          := Encoding;

      Chain_File (File_Ptr);
      Append_Set (File_Ptr);
   end Open;

   ------------------------
   -- Raise_Device_Error --
   ------------------------

   procedure Raise_Device_Error
     (File  : AFCB_Ptr;
      Errno : Integer := OS_Lib.Errno)
   is
   begin
      --  Clear error status so that the same error is not reported twice

      if File /= null then
         clearerr (File.Stream);
      end if;

      raise Device_Error with OS_Lib.Errno_Message (Err => Errno);
   end Raise_Device_Error;

   --------------
   -- Read_Buf --
   --------------

   procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
      Nread : size_t;

   begin
      Nread := fread (Buf, 1, Siz, File.Stream);

      if Nread = Siz then
         return;

      elsif ferror (File.Stream) /= 0 then
         Raise_Device_Error (File);

      elsif Nread = 0 then
         raise End_Error;

      else -- 0 < Nread < Siz
         raise Data_Error with "not enough data read";
      end if;
   end Read_Buf;

   procedure Read_Buf
     (File  : AFCB_Ptr;
      Buf   : Address;
      Siz   : Interfaces.C_Streams.size_t;
      Count : out Interfaces.C_Streams.size_t)
   is
   begin
      Count := fread (Buf, 1, Siz, File.Stream);

      if Count = 0 and then ferror (File.Stream) /= 0 then
         Raise_Device_Error (File);
      end if;
   end Read_Buf;

   -----------
   -- Reset --
   -----------

   --  The reset which does not change the mode simply does a rewind

   procedure Reset (File_Ptr : access AFCB_Ptr) is
      File : AFCB_Ptr renames File_Ptr.all;
   begin
      Check_File_Open (File);
      Reset (File_Ptr, File.Mode);
   end Reset;

   --  The reset with a change in mode is done using freopen, and is not
   --  permitted except for regular files (since otherwise there is no name for
   --  the freopen, and in any case it seems meaningless).

   procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is
      File   : AFCB_Ptr renames File_Ptr.all;
      Fopstr : aliased Fopen_String;

   begin
      Check_File_Open (File);

      --  Change of mode not allowed for shared file or file with no name or
      --  file that is not a regular file, or for a system file. Note that we
      --  allow the "change" of mode if it is not in fact doing a change.

      if Mode /= File.Mode then
         if File.Shared_Status = Yes then
            raise Use_Error with "cannot change mode of shared file";
         elsif File.Name'Length <= 1 then
            raise Use_Error with "cannot change mode of temp file";
         elsif File.Is_System_File then
            raise Use_Error with "cannot change mode of system file";
         elsif not File.Is_Regular_File then
            raise Use_Error with "cannot change mode of non-regular file";
         end if;
      end if;

      --  For In_File or Inout_File for a regular file, we can just do a rewind
      --  if the mode is unchanged, which is more efficient than doing a full
      --  reopen.

      if Mode = File.Mode
        and then Mode in Read_File_Mode
      then
         rewind (File.Stream);

      --  Here the change of mode is permitted, we do it by reopening the file
      --  in the new mode and replacing the stream with a new stream.

      else
         Fopen_Mode
           (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr);

         Form_VMS_RMS_Keys (File.Form.all, VMS_Formstr);

         if VMS_Formstr = null then
            File.Stream := freopen
              (File.Name.all'Address, Fopstr'Address, File.Stream,
               File.Encoding, Null_Address);
         else
            File.Stream := freopen
              (File.Name.all'Address, Fopstr'Address, File.Stream,
               File.Encoding, VMS_Formstr.all'Address);
         end if;

         if VMS_Formstr /= null then
            Free (VMS_Formstr);
         end if;

         if File.Stream = NULL_Stream then
            Close (File_Ptr);
            raise Use_Error;
         else
            File.Mode := Mode;
            Append_Set (File);
         end if;
      end if;
   end Reset;

   ---------------
   -- Write_Buf --
   ---------------

   procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
   begin
      --  Note: for most purposes, the Siz and 1 parameters in the fwrite call
      --  could be reversed, but on VMS, this is a better choice, since for
      --  some file formats, reversing the parameters results in records of one
      --  byte each.

      SSL.Abort_Defer.all;

      if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
         if Siz /= 0 then
            SSL.Abort_Undefer.all;
            Raise_Device_Error (File);
         end if;
      end if;

      SSL.Abort_Undefer.all;
   end Write_Buf;

end System.File_IO;