-- --
-- B o d y --
-- --
--- $Revision: 1.59 $
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- 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_Streams; use Interfaces.C_Streams;
+with System.CRTL;
with System.Soft_Links;
with Unchecked_Deallocation;
package SSL renames System.Soft_Links;
+ use type System.CRTL.size_t;
+
----------------------
-- Global Variables --
----------------------
type Temp_File_Record_Ptr is access all Temp_File_Record;
type Temp_File_Record is record
- Name : String (1 .. L_tmpnam + 1);
+ Name : String (1 .. max_path_len + 1);
Next : Temp_File_Record_Ptr;
end record;
-- One of these is allocated for each temporary file created
-- 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.
procedure Chain_File (File : AFCB_Ptr) is
begin
-- Take a task lock, to protect the global data value Open_Files
- -- No exception handler needed, since we cannot get an exception.
SSL.Lock_Task.all;
+
+ -- Do the chaining operation locked
+
File.Next := Open_Files;
File.Prev := null;
Open_Files := File;
end if;
SSL.Unlock_Task.all;
+
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
end Chain_File;
---------------------
Check_File_Open (File);
AFCB_Close (File);
+ -- Take a task lock, to protect the global data value Open_Files
+
+ SSL.Lock_Task.all;
+
-- 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
end if;
-- Dechain file from list of open files and then free the storage
- -- Since this is a global data structure, we have to protect against
- -- multiple tasks attempting to access this list.
-
- -- Note that we do not use an exception handler to unlock here since
- -- no exception can occur inside the lock/unlock pair.
-
- begin
- SSL.Lock_Task.all;
-
- 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;
+ if File.Prev = null then
+ Open_Files := File.Next;
+ else
+ File.Prev.Next := File.Next;
+ end if;
- SSL.Unlock_Task.all;
- end;
+ 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
if Close_Status /= 0 then
raise Device_Error;
end if;
+
+ SSL.Unlock_Task.all;
+
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
end Close;
------------
-- task just before terminating execution.
procedure Finalize (V : in out File_IO_Clean_Up_Type) is
- Discard : int;
+ pragma Warnings (Off, V);
+
Fptr1 : 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)
Temp_Files := Temp_Files.Next;
end loop;
+ SSL.Unlock_Task.all;
+
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
end Finalize;
-----------
-------------------
procedure Make_Buffered
- (File : AFCB_Ptr;
- Buf_Siz : Interfaces.C_Streams.size_t) is
- status : Integer;
+ (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);
procedure Make_Line_Buffered
(File : AFCB_Ptr;
- Line_Siz : Interfaces.C_Streams.size_t) is
- status : Integer;
+ Line_Siz : Interfaces.C_Streams.size_t)
+ is
+ status : Integer;
+ pragma Unreferenced (status);
begin
status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
procedure Make_Unbuffered (File : AFCB_Ptr) is
status : Integer;
+ pragma Unreferenced (status);
begin
status := setvbuf (File.Stream, Null_Address, IONBF, 0);
procedure Open
(File_Ptr : in out AFCB_Ptr;
- Dummy_FCB : in out AFCB'Class;
+ Dummy_FCB : in AFCB'Class;
Mode : File_Mode;
Name : String;
Form : String;
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.
end;
-- If we were given a stream (call from xxx.C_Streams.Open), then set
- -- full name to null and that is all we have to do in this case so
- -- skip to end of processing.
+ -- the full name to the given one, and skip to end of processing.
if Stream /= NULL_Stream then
- Fullname (1) := ASCII.Nul;
- Full_Name_Len := 1;
+ 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
-- Normal case of non-null name given
else
+ if Name'Length > Namelen then
+ raise Name_Error;
+ end if;
+
Namestr (1 .. Name'Length) := Name;
Namestr (Name'Length + 1) := ASCII.NUL;
end if;
raise Use_Error;
end if;
- for J in Fullname'Range loop
- if Fullname (J) = ASCII.NUL then
- Full_Name_Len := J;
- exit;
- 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;
-- If Shared=None or Shared=Yes, then check for the existence
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
P := P.Next;
end loop;
+
+ SSL.Unlock_Task.all;
+
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
end;
end if;
OSDN Git Service
