diff options
Diffstat (limited to 'gcc/ada/s-fileio.adb')
| -rw-r--r-- | gcc/ada/s-fileio.adb | 300 |
1 files changed, 185 insertions, 115 deletions
diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index df45003cd1a..f93fee25e33 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -31,7 +31,10 @@ with Ada.Finalization; use Ada.Finalization; with Ada.IO_Exceptions; use Ada.IO_Exceptions; +with Ada.Unchecked_Conversion; + with Interfaces.C; +with Interfaces.C.Strings; use Interfaces.C.Strings; with Interfaces.C_Streams; use Interfaces.C_Streams; with System.CRTL; @@ -48,7 +51,7 @@ package body System.File_IO is package SSL renames System.Soft_Links; use type Interfaces.C.int; - use type System.CRTL.size_t; + use type CRTL.size_t; ---------------------- -- Global Variables -- @@ -126,6 +129,23 @@ package body System.File_IO is -- call to fopen or freopen. Amethod is the character designating -- the access method from the Access_Method field of the FCB. + function Errno_Message + (Errno : Integer := OS_Lib.Errno) return String; + function Errno_Message + (Name : String; + Errno : Integer := OS_Lib.Errno) return String; + -- Return a message suitable for "raise ... with Errno_Message (...)". + -- Errno defaults to the current errno, but should be passed explicitly if + -- there is significant code in between the call that sets errno and the + -- call to Errno_Message, in case that code also sets errno. The version + -- with Name includes that file name in the message. + + 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. + ---------------- -- Append_Set -- ---------------- @@ -134,7 +154,7 @@ package body System.File_IO is begin if File.Mode = Append_File then if fseek (File.Stream, 0, SEEK_END) /= 0 then - raise Device_Error; + Raise_Device_Error (File); end if; end if; end Append_Set; @@ -174,7 +194,7 @@ package body System.File_IO is procedure Check_File_Open (File : AFCB_Ptr) is begin if File = null then - raise Status_Error; + raise Status_Error with "file not open"; end if; end Check_File_Open; @@ -185,9 +205,9 @@ package body System.File_IO is procedure Check_Read_Status (File : AFCB_Ptr) is begin if File = null then - raise Status_Error; + raise Status_Error with "file not open"; elsif File.Mode > Inout_File then - raise Mode_Error; + raise Mode_Error with "file not readable"; end if; end Check_Read_Status; @@ -198,9 +218,9 @@ package body System.File_IO is procedure Check_Write_Status (File : AFCB_Ptr) is begin if File = null then - raise Status_Error; + raise Status_Error with "file not open"; elsif File.Mode = In_File then - raise Mode_Error; + raise Mode_Error with "file not writable"; end if; end Check_Write_Status; @@ -212,6 +232,7 @@ package body System.File_IO is Close_Status : int := 0; Dup_Strm : Boolean := False; File : AFCB_Ptr renames File_Ptr.all; + Errno : Integer; begin -- Take a task lock, to protect the global data value Open_Files @@ -223,15 +244,14 @@ package body System.File_IO is -- 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). + -- 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 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 @@ -240,9 +260,7 @@ package body System.File_IO is begin P := Open_Files; while P /= null loop - if P /= File - and then File.Stream = P.Stream - then + if P /= File and then File.Stream = P.Stream then Dup_Strm := True; exit; end if; @@ -256,6 +274,10 @@ package body System.File_IO is 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; @@ -284,7 +306,7 @@ package body System.File_IO is File := null; if Close_Status /= 0 then - raise Device_Error; + Raise_Device_Error (null, Errno); end if; SSL.Unlock_Task.all; @@ -301,11 +323,12 @@ package body System.File_IO is 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; + raise Use_Error with "cannot delete non-regular file"; end if; declare @@ -314,12 +337,12 @@ package body System.File_IO is 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! + -- 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; + raise Use_Error with Errno_Message; end if; end; end Delete; @@ -347,13 +370,45 @@ package body System.File_IO is end if; end End_Of_File; + ------------------- + -- Errno_Message -- + ------------------- + + function Errno_Message (Errno : Integer := OS_Lib.Errno) return String is + pragma Warnings (Off); + function To_Chars_Ptr is + new Ada.Unchecked_Conversion (System.Address, chars_ptr); + -- On VMS, the compiler warns because System.Address is 64 bits, but + -- chars_ptr is 32 bits. It should be safe, though, because strerror + -- will return a 32-bit pointer. + pragma Warnings (On); + + Message : constant chars_ptr := + To_Chars_Ptr (CRTL.strerror (Errno)); + + begin + if Message = Null_Ptr then + return "errno =" & Errno'Img; + else + return Value (Message); + end if; + end Errno_Message; + + function Errno_Message + (Name : String; + Errno : Integer := OS_Lib.Errno) return String + is + begin + return Name & ": " & String'(Errno_Message (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. + -- 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); @@ -369,8 +424,8 @@ package body System.File_IO is 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) + -- 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 @@ -379,9 +434,9 @@ package body System.File_IO is 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. + -- 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); @@ -404,10 +459,8 @@ package body System.File_IO is begin Check_Write_Status (File); - if fflush (File.Stream) = 0 then - return; - else - raise Device_Error; + if fflush (File.Stream) /= 0 then + Raise_Device_Error (File); end if; end Flush; @@ -429,20 +482,20 @@ package body System.File_IO is -- 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: 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 ACVT tests insist on! + -- 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 - -- added to the mode, depending on the setting of Text. + -- 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; @@ -510,7 +563,7 @@ package body System.File_IO is function Form (File : AFCB_Ptr) return String is begin if File = null then - raise Status_Error; + raise Status_Error with "Form: file not open"; else return File.Form.all (1 .. File.Form'Length - 1); end if; @@ -523,8 +576,7 @@ package body System.File_IO is function Form_Boolean (Form : String; Keyword : String; - Default : Boolean) - return Boolean + Default : Boolean) return Boolean is V1, V2 : Natural; pragma Unreferenced (V2); @@ -542,7 +594,7 @@ package body System.File_IO is return False; else - raise Use_Error; + raise Use_Error with "invalid Form"; end if; end Form_Boolean; @@ -553,8 +605,7 @@ package body System.File_IO is function Form_Integer (Form : String; Keyword : String; - Default : Integer) - return Integer + Default : Integer) return Integer is V1, V2 : Natural; V : Integer; @@ -570,13 +621,13 @@ package body System.File_IO is for J in V1 .. V2 loop if Form (J) not in '0' .. '9' then - raise Use_Error; + 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; + raise Use_Error with "invalid Form"; end if; end loop; @@ -593,11 +644,9 @@ package body System.File_IO is Keyword : String; Start : out Natural; Stop : out Natural) - is + is Klen : constant Integer := Keyword'Length; - -- Start of processing for Form_Parameter - begin for J in Form'First + Klen .. Form'Last - 1 loop if Form (J) = '=' @@ -663,6 +712,7 @@ package body System.File_IO is begin status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz); + -- No error checking??? end Make_Line_Buffered; --------------------- @@ -675,6 +725,7 @@ package body System.File_IO is begin status := setvbuf (File.Stream, Null_Address, IONBF, 0); + -- No error checking??? end Make_Unbuffered; ---------- @@ -684,7 +735,7 @@ package body System.File_IO is function Mode (File : AFCB_Ptr) return File_Mode is begin if File = null then - raise Status_Error; + raise Status_Error with "Mode: file not open"; else return File.Mode; end if; @@ -697,7 +748,7 @@ package body System.File_IO is function Name (File : AFCB_Ptr) return String is begin if File = null then - raise Status_Error; + raise Status_Error with "Name: file not open"; else return File.Name.all (1 .. File.Name'Length - 1); end if; @@ -724,7 +775,7 @@ package body System.File_IO is procedure Tmp_Name (Buffer : Address); pragma Import (C, Tmp_Name, "__gnat_tmp_name"); - -- set buffer (a String address) with a temporary filename + -- Set buffer (a String address) with a temporary filename Stream : FILEs := C_Stream; -- Stream which we open in response to this request @@ -744,9 +795,9 @@ package body System.File_IO is -- 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. + -- 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 @@ -758,12 +809,12 @@ package body System.File_IO is Full_Name_Len : Integer; -- Length of name actually stored in Fullname - Encoding : System.CRTL.Filename_Encoding; + Encoding : CRTL.Filename_Encoding; -- Filename encoding specified into the form parameter begin if File_Ptr /= null then - raise Status_Error; + raise Status_Error with "file already open"; end if; -- Acquire form string, setting required NUL terminator @@ -797,7 +848,7 @@ package body System.File_IO is Shared := No; else - raise Use_Error; + raise Use_Error with "invalid Form"; end if; end; @@ -810,16 +861,16 @@ package body System.File_IO is Form_Parameter (Formstr, "encoding", V1, V2); if V1 = 0 then - Encoding := System.CRTL.Unspecified; + Encoding := CRTL.Unspecified; elsif Formstr (V1 .. V2) = "utf8" then - Encoding := System.CRTL.UTF8; + Encoding := CRTL.UTF8; elsif Formstr (V1 .. V2) = "8bits" then - Encoding := System.CRTL.ASCII_8bits; + Encoding := CRTL.ASCII_8bits; else - raise Use_Error; + raise Use_Error with "invalid Form"; end if; end; @@ -851,13 +902,13 @@ package body System.File_IO is if Tempfile then if not Creat then - raise Name_Error; + 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; + raise Use_Error with "invalid temp file name"; end if; -- Chain to temp file list, ensuring thread safety with a lock @@ -878,7 +929,7 @@ package body System.File_IO is else if Name'Length > Namelen then - raise Name_Error; + raise Name_Error with "file name too long"; end if; Namestr (1 .. Name'Length) := Name; @@ -890,7 +941,7 @@ package body System.File_IO is full_name (Namestr'Address, Fullname'Address); if Fullname (1) = ASCII.NUL then - raise Use_Error; + raise Use_Error with Errno_Message (Name); end if; Full_Name_Len := 1; @@ -902,7 +953,7 @@ package body System.File_IO is -- 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 + -- 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. @@ -911,8 +962,8 @@ package body System.File_IO is 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=None or Shared=Yes, then check for the existence of + -- another file with exactly the same full name. if Shared /= No then declare @@ -937,7 +988,7 @@ package body System.File_IO is if Shared = None or else P.Shared_Status = None then - raise Use_Error; + 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. @@ -983,7 +1034,7 @@ package body System.File_IO is if not Creat and then Fopstr (1) /= 'r' then if file_exists (Namestr'Address) = 0 then - raise Name_Error; + raise Name_Error with Errno_Message (Name); end if; end if; @@ -1007,10 +1058,8 @@ package body System.File_IO is -- Should we raise Device_Error for ENOSPC??? declare - subtype Cint is Interfaces.C.int; - function Is_File_Not_Found_Error - (Errno_Value : Cint) return Cint; + (Errno_Value : Integer) return Integer; -- Non-zero when the given errno value indicates a non- -- existing file. @@ -1018,13 +1067,13 @@ package body System.File_IO is (C, Is_File_Not_Found_Error, "__gnat_is_file_not_found_error"); + Errno : constant Integer := OS_Lib.Errno; + Message : constant String := Errno_Message (Name, Errno); begin - if - Is_File_Not_Found_Error (Cint (System.OS_Lib.Errno)) /= 0 - then - raise Name_Error; + if Is_File_Not_Found_Error (Errno) /= 0 then + raise Name_Error with Message; else - raise Use_Error; + raise Use_Error with Message; end if; end; end if; @@ -1032,8 +1081,8 @@ package body System.File_IO is 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. + -- committed to completing the opening of the file. Allocate block on + -- heap and fill in its fields. File_Ptr := AFCB_Allocate (Dummy_FCB); @@ -1053,6 +1102,23 @@ package body System.File_IO is 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 Errno_Message (Errno); + end Raise_Device_Error; + -------------- -- Read_Buf -- -------------- @@ -1067,13 +1133,13 @@ package body System.File_IO is return; elsif ferror (File.Stream) /= 0 then - raise Device_Error; + Raise_Device_Error (File); elsif Nread = 0 then raise End_Error; else -- 0 < Nread < Siz - raise Data_Error; + raise Data_Error with "not enough data read"; end if; end Read_Buf; @@ -1088,7 +1154,7 @@ package body System.File_IO is Count := fread (Buf, 1, Siz, File.Stream); if Count = 0 and then ferror (File.Stream) /= 0 then - raise Device_Error; + Raise_Device_Error (File); end if; end Read_Buf; @@ -1105,9 +1171,9 @@ package body System.File_IO is 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) + -- 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; @@ -1120,25 +1186,29 @@ package body System.File_IO is -- 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 - and then (File.Shared_Status = Yes - or else File.Name'Length <= 1 - or else File.Is_System_File - or else not File.Is_Regular_File) - then - raise Use_Error; + 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. + -- 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. - elsif Mode = File.Mode + if Mode = File.Mode and then Mode <= Inout_File 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. + -- 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 @@ -1164,17 +1234,17 @@ package body System.File_IO is 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. + -- 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; + Raise_Device_Error (File); end if; end if; |