1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . S H A R E D _ M E M O R Y --
9 -- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Ada.IO_Exceptions;
37 with System.Global_Locks;
38 with System.Soft_Links;
41 with System.File_Control_Block;
45 with Ada.Unchecked_Deallocation;
46 with Ada.Unchecked_Conversion;
48 package body System.Shared_Storage is
50 package AS renames Ada.Streams;
52 package IOX renames Ada.IO_Exceptions;
54 package FCB renames System.File_Control_Block;
56 package SFI renames System.File_IO;
58 type String_Access is access String;
59 procedure Free is new Ada.Unchecked_Deallocation
60 (Object => String, Name => String_Access);
63 -- Holds the directory
65 ------------------------------------------------
66 -- Variables for Shared Variable Access Files --
67 ------------------------------------------------
69 Max_Shared_Var_Files : constant := 20;
70 -- Maximum number of lock files that can be open
72 Shared_Var_Files_Open : Natural := 0;
73 -- Number of shared variable access files currently open
75 type File_Stream_Type is new AS.Root_Stream_Type with record
78 type File_Stream_Access is access all File_Stream_Type'Class;
81 (Stream : in out File_Stream_Type;
82 Item : out AS.Stream_Element_Array;
83 Last : out AS.Stream_Element_Offset);
86 (Stream : in out File_Stream_Type;
87 Item : AS.Stream_Element_Array);
89 subtype Hash_Header is Natural range 0 .. 30;
90 -- Number of hash headers, related (for efficiency purposes only)
91 -- to the maximum number of lock files..
93 type Shared_Var_File_Entry;
94 type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry;
96 type Shared_Var_File_Entry is record
98 -- Name of variable, as passed to Read_File/Write_File routines
100 Stream : File_Stream_Access;
101 -- Stream_IO file for the shared variable file
103 Next : Shared_Var_File_Entry_Ptr;
104 Prev : Shared_Var_File_Entry_Ptr;
105 -- Links for LRU chain
108 procedure Free is new Ada.Unchecked_Deallocation
109 (Object => Shared_Var_File_Entry,
110 Name => Shared_Var_File_Entry_Ptr);
112 procedure Free is new Ada.Unchecked_Deallocation
113 (Object => File_Stream_Type'Class,
114 Name => File_Stream_Access);
116 function To_AFCB_Ptr is
117 new Ada.Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr);
119 LRU_Head : Shared_Var_File_Entry_Ptr;
120 LRU_Tail : Shared_Var_File_Entry_Ptr;
121 -- As lock files are opened, they are organized into a least recently
122 -- used chain, which is a doubly linked list using the Next and Prev
123 -- fields of Shared_Var_File_Entry records. The field LRU_Head points
124 -- to the least recently used entry, whose prev pointer is null, and
125 -- LRU_Tail points to the most recently used entry, whose next pointer
126 -- is null. These pointers are null only if the list is empty.
128 function Hash (F : String_Access) return Hash_Header;
129 function Equal (F1, F2 : String_Access) return Boolean;
130 -- Hash and equality functions for hash table
132 package SFT is new System.HTable.Simple_HTable
133 (Header_Num => Hash_Header,
134 Element => Shared_Var_File_Entry_Ptr,
136 Key => String_Access,
140 --------------------------------
141 -- Variables for Lock Control --
142 --------------------------------
144 Global_Lock : Global_Locks.Lock_Type;
146 Lock_Count : Natural := 0;
147 -- Counts nesting of lock calls, 0 means lock is not held
149 -----------------------
150 -- Local Subprograms --
151 -----------------------
153 procedure Initialize;
154 -- Called to initialize data structures for this package.
155 -- Has no effect except on the first call.
157 procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String);
158 -- The first parameter is a pointer to a newly allocated SFE, whose
159 -- File field is already set appropriately. Fname is the name of the
160 -- variable as passed to Shared_Var_RFile/Shared_Var_WFile. Enter_SFE
161 -- completes the SFE value, and enters it into the hash table. If the
162 -- hash table is already full, the least recently used entry is first
163 -- closed and discarded.
165 function Retrieve (File : String) return Shared_Var_File_Entry_Ptr;
166 -- Given a file name, this function searches the hash table to see if
167 -- the file is currently open. If so, then a pointer to the already
168 -- created entry is returned, after first moving it to the head of
169 -- the LRU chain. If not, then null is returned.
175 procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is
176 Freed : Shared_Var_File_Entry_Ptr;
179 SFE.Name := new String'(Fname);
181 -- Release least recently used entry if we have to
183 if Shared_Var_Files_Open = Max_Shared_Var_Files then
186 if Freed.Next /= null then
187 Freed.Next.Prev := null;
190 LRU_Head := Freed.Next;
191 SFT.Remove (Freed.Name);
192 SIO.Close (Freed.Stream.File);
198 Shared_Var_Files_Open := Shared_Var_Files_Open + 1;
201 -- Add new entry to hash table
203 SFT.Set (SFE.Name, SFE);
205 -- Add new entry at end of LRU chain
207 if LRU_Head = null then
212 SFE.Prev := LRU_Tail;
213 LRU_Tail.Next := SFE;
222 function Equal (F1, F2 : String_Access) return Boolean is
224 return F1.all = F2.all;
231 function Hash (F : String_Access) return Hash_Header is
235 -- Add up characters of name, mod our table size
237 for J in F'Range loop
238 N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1);
248 procedure Initialize is
249 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
250 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
252 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
253 pragma Import (C, Strncpy, "strncpy");
255 Dir_Name : aliased constant String :=
256 "SHARED_MEMORY_DIRECTORY" & ASCII.NUL;
258 Env_Value_Ptr : aliased Address;
259 Env_Value_Length : aliased Integer;
264 (Dir_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
266 Dir := new String (1 .. Env_Value_Length);
268 if Env_Value_Length > 0 then
269 Strncpy (Dir.all'Address, Env_Value_Ptr, Env_Value_Length);
272 System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock");
281 (Stream : in out File_Stream_Type;
282 Item : out AS.Stream_Element_Array;
283 Last : out AS.Stream_Element_Offset)
286 SIO.Read (Stream.File, Item, Last);
288 exception when others =>
296 function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is
297 SFE : Shared_Var_File_Entry_Ptr;
301 SFE := SFT.Get (File'Unrestricted_Access);
305 -- Move to head of LRU chain
307 if SFE = LRU_Tail then
310 elsif SFE = LRU_Head then
311 LRU_Head := LRU_Head.Next;
312 LRU_Head.Prev := null;
315 SFE.Next.Prev := SFE.Prev;
316 SFE.Prev.Next := SFE.Next;
320 SFE.Prev := LRU_Tail;
321 LRU_Tail.Next := SFE;
328 ----------------------
329 -- Shared_Var_Close --
330 ----------------------
332 procedure Shared_Var_Close (Var : SIO.Stream_Access) is
333 pragma Warnings (Off, Var);
336 System.Soft_Links.Unlock_Task.all;
337 end Shared_Var_Close;
339 ---------------------
340 -- Shared_Var_Lock --
341 ---------------------
343 procedure Shared_Var_Lock (Var : String) is
344 pragma Warnings (Off, Var);
347 System.Soft_Links.Lock_Task.all;
350 if Lock_Count /= 0 then
351 Lock_Count := Lock_Count + 1;
352 System.Soft_Links.Unlock_Task.all;
356 System.Soft_Links.Unlock_Task.all;
357 System.Global_Locks.Acquire_Lock (Global_Lock);
362 System.Soft_Links.Unlock_Task.all;
366 ----------------------
367 -- Shared_Var_ROpen --
368 ----------------------
370 function Shared_Var_ROpen (Var : String) return SIO.Stream_Access is
371 SFE : Shared_Var_File_Entry_Ptr;
373 use type Ada.Streams.Stream_IO.File_Mode;
376 System.Soft_Links.Lock_Task.all;
377 SFE := Retrieve (Var);
379 -- Here if file is not already open, try to open it
383 S : aliased constant String := Dir.all & Var;
386 SFE := new Shared_Var_File_Entry;
387 SFE.Stream := new File_Stream_Type;
388 SIO.Open (SFE.Stream.File, SIO.In_File, Name => S);
389 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
391 -- File opened successfully, put new entry in hash table. Note
392 -- that in this case, file is positioned correctly for read.
394 Enter_SFE (SFE, Var);
397 -- If we get an exception, it means that the file does not
398 -- exist, and in this case, we don't need the SFE and we
401 when IOX.Name_Error =>
403 System.Soft_Links.Unlock_Task.all;
407 -- Here if file is already open, set file for reading
410 if SIO.Mode (SFE.Stream.File) /= SIO.In_File then
411 SIO.Set_Mode (SFE.Stream.File, SIO.In_File);
412 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
415 SIO.Set_Index (SFE.Stream.File, 1);
418 return SIO.Stream_Access (SFE.Stream);
422 System.Soft_Links.Unlock_Task.all;
424 end Shared_Var_ROpen;
426 -----------------------
427 -- Shared_Var_Unlock --
428 -----------------------
430 procedure Shared_Var_Unlock (Var : String) is
431 pragma Warnings (Off, Var);
434 System.Soft_Links.Lock_Task.all;
436 Lock_Count := Lock_Count - 1;
438 if Lock_Count = 0 then
439 System.Global_Locks.Release_Lock (Global_Lock);
441 System.Soft_Links.Unlock_Task.all;
445 System.Soft_Links.Unlock_Task.all;
447 end Shared_Var_Unlock;
449 ---------------------
450 -- Share_Var_WOpen --
451 ---------------------
453 function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is
454 SFE : Shared_Var_File_Entry_Ptr;
456 use type Ada.Streams.Stream_IO.File_Mode;
459 System.Soft_Links.Lock_Task.all;
460 SFE := Retrieve (Var);
464 S : aliased constant String := Dir.all & Var;
467 SFE := new Shared_Var_File_Entry;
468 SFE.Stream := new File_Stream_Type;
469 SIO.Open (SFE.Stream.File, SIO.Out_File, Name => S);
470 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
473 -- If we get an exception, it means that the file does not
474 -- exist, and in this case, we create the file.
476 when IOX.Name_Error =>
479 SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S);
482 -- Error if we cannot create the file
485 raise Program_Error with
486 "Cannot create shared variable file for """ & S & '"';
490 -- Make new hash table entry for opened/created file. Note that
491 -- in both cases, the file is already in write mode at the start
492 -- of the file, ready to be written.
494 Enter_SFE (SFE, Var);
496 -- Here if file is already open, set file for writing
499 if SIO.Mode (SFE.Stream.File) /= SIO.Out_File then
500 SIO.Set_Mode (SFE.Stream.File, SIO.Out_File);
501 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
504 SIO.Set_Index (SFE.Stream.File, 1);
507 return SIO.Stream_Access (SFE.Stream);
511 System.Soft_Links.Unlock_Task.all;
513 end Shared_Var_WOpen;
520 (Stream : in out File_Stream_Type;
521 Item : AS.Stream_Element_Array)
524 SIO.Write (Stream.File, Item);
527 end System.Shared_Storage;