-- --
-- B o d y --
-- --
--- --
--- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
--- --
+-- Copyright (C) 1998-2009, 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 2, or (at your option) any later ver- --
+-- 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. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
+-- 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. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with Ada.Exceptions;
with Ada.IO_Exceptions;
with Ada.Streams;
with Ada.Streams.Stream_IO;
-with GNAT.HTable;
with System.Global_Locks;
-with GNAT.OS_Lib;
-with GNAT.Task_Lock;
-
-use type GNAT.OS_Lib.String_Access;
+with System.Soft_Links;
with System;
with System.File_Control_Block;
with System.File_IO;
-with Unchecked_Deallocation;
-with Unchecked_Conversion;
+with System.HTable;
+
+with Ada.Unchecked_Deallocation;
+with Ada.Unchecked_Conversion;
package body System.Shared_Storage is
package AS renames Ada.Streams;
- package OS renames GNAT.OS_Lib;
-
package IOX renames Ada.IO_Exceptions;
package FCB renames System.File_Control_Block;
package SFI renames System.File_IO;
- package TSL renames GNAT.Task_Lock;
+ package SIO renames Ada.Streams.Stream_IO;
- Dir : OS.String_Access;
+ type String_Access is access String;
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => String, Name => String_Access);
+
+ Dir : String_Access;
-- Holds the directory
------------------------------------------------
procedure Write
(Stream : in out File_Stream_Type;
- Item : in AS.Stream_Element_Array);
+ Item : AS.Stream_Element_Array);
subtype Hash_Header is Natural range 0 .. 30;
-- Number of hash headers, related (for efficiency purposes only)
type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry;
type Shared_Var_File_Entry is record
- Name : OS.String_Access;
+ Name : String_Access;
-- Name of variable, as passed to Read_File/Write_File routines
Stream : File_Stream_Access;
-- Stream_IO file for the shared variable file
- Next : Shared_Var_File_Entry_Ptr;
- Prev : Shared_Var_File_Entry_Ptr;
+ Next : Shared_Var_File_Entry_Ptr;
+ Prev : Shared_Var_File_Entry_Ptr;
-- Links for LRU chain
end record;
- procedure Free is new Unchecked_Deallocation
+ procedure Free is new Ada.Unchecked_Deallocation
(Object => Shared_Var_File_Entry,
Name => Shared_Var_File_Entry_Ptr);
- procedure Free is new Unchecked_Deallocation
+ procedure Free is new Ada.Unchecked_Deallocation
(Object => File_Stream_Type'Class,
Name => File_Stream_Access);
function To_AFCB_Ptr is
- new Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr);
+ new Ada.Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr);
LRU_Head : Shared_Var_File_Entry_Ptr;
LRU_Tail : Shared_Var_File_Entry_Ptr;
-- LRU_Tail points to the most recently used entry, whose next pointer
-- is null. These pointers are null only if the list is empty.
- function Hash (F : OS.String_Access) return Hash_Header;
- function Equal (F1, F2 : OS.String_Access) return Boolean;
+ function Hash (F : String_Access) return Hash_Header;
+ function Equal (F1, F2 : String_Access) return Boolean;
-- Hash and equality functions for hash table
- package SFT is new GNAT.HTable.Simple_HTable
+ package SFT is new System.HTable.Simple_HTable
(Header_Num => Hash_Header,
Element => Shared_Var_File_Entry_Ptr,
No_Element => null,
- Key => OS.String_Access,
+ Key => String_Access,
Hash => Hash,
Equal => Equal);
-- created entry is returned, after first moving it to the head of
-- the LRU chain. If not, then null is returned.
+ function Shared_Var_ROpen (Var : String) return SIO.Stream_Access;
+ -- As described above, this routine returns null if the
+ -- corresponding shared storage does not exist, and otherwise, if
+ -- the storage does exist, a Stream_Access value that references
+ -- the shared storage, ready to read the current value.
+
+ function Shared_Var_WOpen (Var : String) return SIO.Stream_Access;
+ -- As described above, this routine returns a Stream_Access value
+ -- that references the shared storage, ready to write the new
+ -- value. The storage is created by this call if it does not
+ -- already exist.
+
+ procedure Shared_Var_Close (Var : SIO.Stream_Access);
+ -- This routine signals the end of a read/assign operation. It can
+ -- be useful to embrace a read/write operation between a call to
+ -- open and a call to close which protect the whole operation.
+ -- Otherwise, two simultaneous operations can result in the
+ -- raising of exception Data_Error by setting the access mode of
+ -- the variable in an incorrect mode.
+
---------------
-- Enter_SFE --
---------------
LRU_Head := Freed.Next;
SFT.Remove (Freed.Name);
SIO.Close (Freed.Stream.File);
- OS.Free (Freed.Name);
+ Free (Freed.Name);
Free (Freed.Stream);
Free (Freed);
-- Equal --
-----------
- function Equal (F1, F2 : OS.String_Access) return Boolean is
+ function Equal (F1, F2 : String_Access) return Boolean is
begin
return F1.all = F2.all;
end Equal;
-- Hash --
----------
- function Hash (F : OS.String_Access) return Hash_Header is
+ function Hash (F : String_Access) return Hash_Header is
N : Natural := 0;
begin
----------------
procedure Initialize is
+ procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
+ pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
+
+ procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
+ pragma Import (C, Strncpy, "strncpy");
+
+ Dir_Name : aliased constant String :=
+ "SHARED_MEMORY_DIRECTORY" & ASCII.NUL;
+
+ Env_Value_Ptr : aliased Address;
+ Env_Value_Length : aliased Integer;
+
begin
if Dir = null then
- Dir := OS.Getenv ("SHARED_MEMORY_DIRECTORY");
+ Get_Env_Value_Ptr
+ (Dir_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
+
+ Dir := new String (1 .. Env_Value_Length);
+
+ if Env_Value_Length > 0 then
+ Strncpy (Dir.all'Address, Env_Value_Ptr, Env_Value_Length);
+ end if;
+
System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock");
end if;
end Initialize;
procedure Read
(Stream : in out File_Stream_Type;
Item : out AS.Stream_Element_Array;
- Last : out AS.Stream_Element_Offset) is
+ Last : out AS.Stream_Element_Offset)
+ is
begin
SIO.Read (Stream.File, Item, Last);
+
exception when others =>
Last := Item'Last;
end Read;
-- Shared_Var_Close --
----------------------
- procedure Shared_Var_Close (Var : in SIO.Stream_Access) is
+ procedure Shared_Var_Close (Var : SIO.Stream_Access) is
pragma Warnings (Off, Var);
+
begin
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
end Shared_Var_Close;
---------------------
-- Shared_Var_Lock --
---------------------
- procedure Shared_Var_Lock (Var : in String) is
+ procedure Shared_Var_Lock (Var : String) is
pragma Warnings (Off, Var);
begin
- TSL.Lock;
+ System.Soft_Links.Lock_Task.all;
Initialize;
if Lock_Count /= 0 then
Lock_Count := Lock_Count + 1;
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
else
Lock_Count := 1;
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
System.Global_Locks.Acquire_Lock (Global_Lock);
end if;
exception
when others =>
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
raise;
end Shared_Var_Lock;
----------------------
+ -- Shared_Var_Procs --
+ ----------------------
+
+ package body Shared_Var_Procs is
+
+ use type SIO.Stream_Access;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read is
+ S : SIO.Stream_Access := null;
+ begin
+ S := Shared_Var_ROpen (Full_Name);
+ if S /= null then
+ Typ'Read (S, V);
+ Shared_Var_Close (S);
+ end if;
+ end Read;
+
+ ------------
+ -- Write --
+ ------------
+
+ procedure Write is
+ S : SIO.Stream_Access := null;
+ begin
+ S := Shared_Var_WOpen (Full_Name);
+ Typ'Write (S, V);
+ Shared_Var_Close (S);
+ return;
+ end Write;
+
+ end Shared_Var_Procs;
+
+ ----------------------
-- Shared_Var_ROpen --
----------------------
use type Ada.Streams.Stream_IO.File_Mode;
begin
- TSL.Lock;
+ System.Soft_Links.Lock_Task.all;
SFE := Retrieve (Var);
-- Here if file is not already open, try to open it
when IOX.Name_Error =>
Free (SFE);
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
return null;
end;
exception
when others =>
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
raise;
end Shared_Var_ROpen;
-- Shared_Var_Unlock --
-----------------------
- procedure Shared_Var_Unlock (Var : in String) is
+ procedure Shared_Var_Unlock (Var : String) is
pragma Warnings (Off, Var);
begin
- TSL.Lock;
+ System.Soft_Links.Lock_Task.all;
Initialize;
Lock_Count := Lock_Count - 1;
if Lock_Count = 0 then
System.Global_Locks.Release_Lock (Global_Lock);
end if;
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
exception
when others =>
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
raise;
end Shared_Var_Unlock;
use type Ada.Streams.Stream_IO.File_Mode;
begin
- TSL.Lock;
+ System.Soft_Links.Lock_Task.all;
SFE := Retrieve (Var);
if SFE = null then
-- Error if we cannot create the file
when others =>
- Ada.Exceptions.Raise_Exception
- (Program_Error'Identity,
- "Cannot create shared variable file for """ &
- S & '"'); -- "
+ raise Program_Error with
+ "Cannot create shared variable file for """ & S & '"';
end;
end;
exception
when others =>
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
raise;
end Shared_Var_WOpen;
procedure Write
(Stream : in out File_Stream_Type;
- Item : in AS.Stream_Element_Array) is
+ Item : AS.Stream_Element_Array)
+ is
begin
SIO.Write (Stream.File, Item);
end Write;
OSDN Git Service
