From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/s-shasto.adb | 585 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 585 insertions(+) create mode 100644 gcc/ada/s-shasto.adb (limited to 'gcc/ada/s-shasto.adb') diff --git a/gcc/ada/s-shasto.adb b/gcc/ada/s-shasto.adb new file mode 100644 index 000000000..783fdc4a9 --- /dev/null +++ b/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-2010, 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 -- +-- . -- +-- -- +-- 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; -- cgit v1.2.3