aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.0/gcc/ada/s-shasto.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.0/gcc/ada/s-shasto.adb')
-rw-r--r--gcc-4.4.0/gcc/ada/s-shasto.adb585
1 files changed, 585 insertions, 0 deletions
diff --git a/gcc-4.4.0/gcc/ada/s-shasto.adb b/gcc-4.4.0/gcc/ada/s-shasto.adb
new file mode 100644
index 000000000..7038d796c
--- /dev/null
+++ b/gcc-4.4.0/gcc/ada/s-shasto.adb
@@ -0,0 +1,585 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . S H A R E D _ M E M O R Y --
+-- --
+-- B o d y --
+-- --
+-- 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 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.IO_Exceptions;
+with Ada.Streams;
+with Ada.Streams.Stream_IO;
+
+with System.Global_Locks;
+with System.Soft_Links;
+
+with System;
+with System.File_Control_Block;
+with System.File_IO;
+with System.HTable;
+
+with Ada.Unchecked_Deallocation;
+with Ada.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;
+
+ package SIO renames Ada.Streams.Stream_IO;
+
+ type String_Access is access String;
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => String, Name => String_Access);
+
+ Dir : String_Access;
+ -- Holds the directory
+
+ ------------------------------------------------
+ -- Variables for Shared Variable Access Files --
+ ------------------------------------------------
+
+ Max_Shared_Var_Files : constant := 20;
+ -- Maximum number of lock files that can be open
+
+ Shared_Var_Files_Open : Natural := 0;
+ -- Number of shared variable access files currently open
+
+ 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;
+ -- Number of hash headers, related (for efficiency purposes only)
+ -- to the maximum number of lock files..
+
+ 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;
+ -- 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;
+ -- Links for LRU chain
+ end record;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => Shared_Var_File_Entry,
+ Name => Shared_Var_File_Entry_Ptr);
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => File_Stream_Type'Class,
+ Name => File_Stream_Access);
+
+ function To_AFCB_Ptr is
+ new Ada.Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr);
+
+ LRU_Head : Shared_Var_File_Entry_Ptr;
+ LRU_Tail : Shared_Var_File_Entry_Ptr;
+ -- As lock files are opened, they are organized into a least recently
+ -- used chain, which is a doubly linked list using the Next and Prev
+ -- fields of Shared_Var_File_Entry records. The field LRU_Head points
+ -- to the least recently used entry, whose prev pointer is null, and
+ -- 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 : String_Access) return Hash_Header;
+ function Equal (F1, F2 : String_Access) return Boolean;
+ -- Hash and equality functions for hash table
+
+ 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);
+
+ --------------------------------
+ -- Variables for Lock Control --
+ --------------------------------
+
+ Global_Lock : Global_Locks.Lock_Type;
+
+ Lock_Count : Natural := 0;
+ -- Counts nesting of lock calls, 0 means lock is not held
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Initialize;
+ -- Called to initialize data structures for this package.
+ -- Has no effect except on the first call.
+
+ procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String);
+ -- The first parameter is a pointer to a newly allocated SFE, whose
+ -- File field is already set appropriately. Fname is the name of the
+ -- variable as passed to Shared_Var_RFile/Shared_Var_WFile. Enter_SFE
+ -- completes the SFE value, and enters it into the hash table. If the
+ -- hash table is already full, the least recently used entry is first
+ -- closed and discarded.
+
+ function Retrieve (File : String) return Shared_Var_File_Entry_Ptr;
+ -- Given a file name, this function searches the hash table to see if
+ -- the file is currently open. If so, then a pointer to the already
+ -- 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 --
+ ---------------
+
+ procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is
+ Freed : Shared_Var_File_Entry_Ptr;
+
+ begin
+ SFE.Name := new String'(Fname);
+
+ -- Release least recently used entry if we have to
+
+ 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;
+
+ -- Add new entry to hash table
+
+ SFT.Set (SFE.Name, SFE);
+
+ -- Add new entry at end of LRU chain
+
+ 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;
+
+ -----------
+ -- Equal --
+ -----------
+
+ function Equal (F1, F2 : String_Access) return Boolean is
+ begin
+ return F1.all = F2.all;
+ end Equal;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (F : String_Access) return Hash_Header is
+ N : Natural := 0;
+
+ begin
+ -- Add up characters of name, mod our table size
+
+ for J in F'Range loop
+ N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1);
+ end loop;
+
+ return N;
+ end Hash;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ 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;
+
+ ----------
+ -- Read --
+ ----------
+
+ 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;
+
+ --------------
+ -- Retrieve --
+ --------------
+
+ 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
+
+ -- Move to head of LRU chain
+
+ 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;
+
+ ----------------------
+ -- Shared_Var_Close --
+ ----------------------
+
+ procedure Shared_Var_Close (Var : SIO.Stream_Access) is
+ pragma Warnings (Off, Var);
+
+ begin
+ System.Soft_Links.Unlock_Task.all;
+ end Shared_Var_Close;
+
+ ---------------------
+ -- Shared_Var_Lock --
+ ---------------------
+
+ 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;
+
+ ----------------------
+ -- 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 --
+ ----------------------
+
+ 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);
+
+ -- Here if file is not already open, try to open it
+
+ 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));
+
+ -- File opened successfully, put new entry in hash table. Note
+ -- that in this case, file is positioned correctly for read.
+
+ Enter_SFE (SFE, Var);
+
+ exception
+ -- If we get an exception, it means that the file does not
+ -- exist, and in this case, we don't need the SFE and we
+ -- return null;
+
+ when IOX.Name_Error =>
+ Free (SFE);
+ System.Soft_Links.Unlock_Task.all;
+ return null;
+ end;
+
+ -- Here if file is already open, set file for reading
+
+ 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;
+
+ -----------------------
+ -- Shared_Var_Unlock --
+ -----------------------
+
+ 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;
+
+ ---------------------
+ -- Share_Var_WOpen --
+ ---------------------
+
+ 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
+ -- If we get an exception, it means that the file does not
+ -- exist, and in this case, we create the file.
+
+ when IOX.Name_Error =>
+
+ begin
+ SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S);
+
+ exception
+ -- Error if we cannot create the file
+
+ when others =>
+ raise Program_Error with
+ "Cannot create shared variable file for """ & S & '"';
+ end;
+ end;
+
+ -- Make new hash table entry for opened/created file. Note that
+ -- in both cases, the file is already in write mode at the start
+ -- of the file, ready to be written.
+
+ Enter_SFE (SFE, Var);
+
+ -- Here if file is already open, set file for writing
+
+ 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;
+
+ -----------
+ -- Write --
+ -----------
+
+ 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;