with Ada.Exceptions;
with Ada.IO_Exceptions;
with Ada.Streams;
with System.Global_Locks;
with System.Soft_Links;
with System;
with System.File_Control_Block;
with System.File_IO;
with System.HTable;
with Unchecked_Deallocation;
with Unchecked_Conversion;
package body System.Shared_Storage is
package AS renames Ada.Streams;
package IOX renames Ada.IO_Exceptions;
package FCB renames System.File_Control_Block;
package SFI renames System.File_IO;
type String_Access is access String;
procedure Free is new Unchecked_Deallocation
(Object => String, Name => String_Access);
Dir : String_Access;
Max_Shared_Var_Files : constant := 20;
Shared_Var_Files_Open : Natural := 0;
type File_Stream_Type is new AS.Root_Stream_Type with record
File : SIO.File_Type;
end record;
type File_Stream_Access is access all File_Stream_Type'Class;
procedure Read
(Stream : in out File_Stream_Type;
Item : out AS.Stream_Element_Array;
Last : out AS.Stream_Element_Offset);
procedure Write
(Stream : in out File_Stream_Type;
Item : AS.Stream_Element_Array);
subtype Hash_Header is Natural range 0 .. 30;
type Shared_Var_File_Entry;
type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry;
type Shared_Var_File_Entry is record
Name : String_Access;
Stream : File_Stream_Access;
Next : Shared_Var_File_Entry_Ptr;
Prev : Shared_Var_File_Entry_Ptr;
end record;
procedure Free is new Unchecked_Deallocation
(Object => Shared_Var_File_Entry,
Name => Shared_Var_File_Entry_Ptr);
procedure Free is new 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);
LRU_Head : Shared_Var_File_Entry_Ptr;
LRU_Tail : Shared_Var_File_Entry_Ptr;
function Hash (F : String_Access) return Hash_Header;
function Equal (F1, F2 : String_Access) return Boolean;
package SFT is new System.HTable.Simple_HTable
(Header_Num => Hash_Header,
Element => Shared_Var_File_Entry_Ptr,
No_Element => null,
Key => String_Access,
Hash => Hash,
Equal => Equal);
Global_Lock : Global_Locks.Lock_Type;
Lock_Count : Natural := 0;
procedure Initialize;
procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String);
function Retrieve (File : String) return Shared_Var_File_Entry_Ptr;
procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is
Freed : Shared_Var_File_Entry_Ptr;
begin
SFE.Name := new String'(Fname);
if Shared_Var_Files_Open = Max_Shared_Var_Files then
Freed := LRU_Head;
if Freed.Next /= null then
Freed.Next.Prev := null;
end if;
LRU_Head := Freed.Next;
SFT.Remove (Freed.Name);
SIO.Close (Freed.Stream.File);
Free (Freed.Name);
Free (Freed.Stream);
Free (Freed);
else
Shared_Var_Files_Open := Shared_Var_Files_Open + 1;
end if;
SFT.Set (SFE.Name, SFE);
if LRU_Head = null then
LRU_Head := SFE;
LRU_Tail := SFE;
else
SFE.Prev := LRU_Tail;
LRU_Tail.Next := SFE;
LRU_Tail := SFE;
end if;
end Enter_SFE;
function Equal (F1, F2 : String_Access) return Boolean is
begin
return F1.all = F2.all;
end Equal;
function Hash (F : String_Access) return Hash_Header is
N : Natural := 0;
begin
for J in F'Range loop
N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1);
end loop;
return N;
end Hash;
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
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
begin
SIO.Read (Stream.File, Item, Last);
exception when others =>
Last := Item'Last;
end Read;
function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is
SFE : Shared_Var_File_Entry_Ptr;
begin
Initialize;
SFE := SFT.Get (File'Unrestricted_Access);
if SFE /= null then
if SFE = LRU_Tail then
null;
elsif SFE = LRU_Head then
LRU_Head := LRU_Head.Next;
LRU_Head.Prev := null;
else
SFE.Next.Prev := SFE.Prev;
SFE.Prev.Next := SFE.Next;
end if;
SFE.Next := null;
SFE.Prev := LRU_Tail;
LRU_Tail.Next := SFE;
LRU_Tail := SFE;
end if;
return SFE;
end Retrieve;
procedure Shared_Var_Close (Var : SIO.Stream_Access) is
pragma Warnings (Off, Var);
begin
System.Soft_Links.Unlock_Task.all;
end Shared_Var_Close;
procedure Shared_Var_Lock (Var : String) is
pragma Warnings (Off, Var);
begin
System.Soft_Links.Lock_Task.all;
Initialize;
if Lock_Count /= 0 then
Lock_Count := Lock_Count + 1;
System.Soft_Links.Unlock_Task.all;
else
Lock_Count := 1;
System.Soft_Links.Unlock_Task.all;
System.Global_Locks.Acquire_Lock (Global_Lock);
end if;
exception
when others =>
System.Soft_Links.Unlock_Task.all;
raise;
end Shared_Var_Lock;
function Shared_Var_ROpen (Var : String) return SIO.Stream_Access is
SFE : Shared_Var_File_Entry_Ptr;
use type Ada.Streams.Stream_IO.File_Mode;
begin
System.Soft_Links.Lock_Task.all;
SFE := Retrieve (Var);
if SFE = null then
declare
S : aliased constant String := Dir.all & Var;
begin
SFE := new Shared_Var_File_Entry;
SFE.Stream := new File_Stream_Type;
SIO.Open (SFE.Stream.File, SIO.In_File, Name => S);
SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
Enter_SFE (SFE, Var);
exception
when IOX.Name_Error =>
Free (SFE);
System.Soft_Links.Unlock_Task.all;
return null;
end;
else
if SIO.Mode (SFE.Stream.File) /= SIO.In_File then
SIO.Set_Mode (SFE.Stream.File, SIO.In_File);
SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
end if;
SIO.Set_Index (SFE.Stream.File, 1);
end if;
return SIO.Stream_Access (SFE.Stream);
exception
when others =>
System.Soft_Links.Unlock_Task.all;
raise;
end Shared_Var_ROpen;
procedure Shared_Var_Unlock (Var : String) is
pragma Warnings (Off, Var);
begin
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;
System.Soft_Links.Unlock_Task.all;
exception
when others =>
System.Soft_Links.Unlock_Task.all;
raise;
end Shared_Var_Unlock;
function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is
SFE : Shared_Var_File_Entry_Ptr;
use type Ada.Streams.Stream_IO.File_Mode;
begin
System.Soft_Links.Lock_Task.all;
SFE := Retrieve (Var);
if SFE = null then
declare
S : aliased constant String := Dir.all & Var;
begin
SFE := new Shared_Var_File_Entry;
SFE.Stream := new File_Stream_Type;
SIO.Open (SFE.Stream.File, SIO.Out_File, Name => S);
SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
exception
when IOX.Name_Error =>
begin
SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S);
exception
when others =>
Ada.Exceptions.Raise_Exception
(Program_Error'Identity,
"Cannot create shared variable file for """ &
S & '"'); end;
end;
Enter_SFE (SFE, Var);
else
if SIO.Mode (SFE.Stream.File) /= SIO.Out_File then
SIO.Set_Mode (SFE.Stream.File, SIO.Out_File);
SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
end if;
SIO.Set_Index (SFE.Stream.File, 1);
end if;
return SIO.Stream_Access (SFE.Stream);
exception
when others =>
System.Soft_Links.Unlock_Task.all;
raise;
end Shared_Var_WOpen;
procedure Write
(Stream : in out File_Stream_Type;
Item : AS.Stream_Element_Array)
is
begin
SIO.Write (Stream.File, Item);
end Write;
end System.Shared_Storage;