1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . S H A R E D _ M E M O R Y --
11 -- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- Extensive contributions were provided by Ada Core Technologies Inc. --
34 ------------------------------------------------------------------------------
37 with Ada
.IO_Exceptions
;
39 with Ada
.Streams
.Stream_IO
;
42 with System
.Global_Locks
;
46 use type GNAT
.OS_Lib
.String_Access
;
49 with System
.File_Control_Block
;
51 with Unchecked_Deallocation
;
52 with Unchecked_Conversion
;
54 package body System
.Shared_Storage
is
56 package AS
renames Ada
.Streams
;
58 package OS
renames GNAT
.OS_Lib
;
60 package IOX
renames Ada
.IO_Exceptions
;
62 package FCB
renames System
.File_Control_Block
;
64 package SFI
renames System
.File_IO
;
66 package TSL
renames GNAT
.Task_Lock
;
68 Dir
: OS
.String_Access
;
69 -- Holds the directory
71 ------------------------------------------------
72 -- Variables for Shared Variable Access Files --
73 ------------------------------------------------
75 Max_Shared_Var_Files
: constant := 20;
76 -- Maximum number of lock files that can be open
78 Shared_Var_Files_Open
: Natural := 0;
79 -- Number of shared variable access files currently open
81 type File_Stream_Type
is new AS
.Root_Stream_Type
with
85 type File_Stream_Access
is access all File_Stream_Type
'Class;
88 (Stream
: in out File_Stream_Type
;
89 Item
: out AS
.Stream_Element_Array
;
90 Last
: out AS
.Stream_Element_Offset
);
93 (Stream
: in out File_Stream_Type
;
94 Item
: in AS
.Stream_Element_Array
);
96 subtype Hash_Header
is Natural range 0 .. 30;
97 -- Number of hash headers, related (for efficiency purposes only)
98 -- to the maximum number of lock files..
100 type Shared_Var_File_Entry
;
101 type Shared_Var_File_Entry_Ptr
is access Shared_Var_File_Entry
;
103 type Shared_Var_File_Entry
is record
104 Name
: OS
.String_Access
;
105 -- Name of variable, as passed to Read_File/Write_File routines
107 Stream
: File_Stream_Access
;
108 -- Stream_IO file for the shared variable file
110 Next
: Shared_Var_File_Entry_Ptr
;
111 Prev
: Shared_Var_File_Entry_Ptr
;
112 -- Links for LRU chain
115 procedure Free
is new Unchecked_Deallocation
116 (Object
=> Shared_Var_File_Entry
,
117 Name
=> Shared_Var_File_Entry_Ptr
);
119 procedure Free
is new Unchecked_Deallocation
120 (Object
=> File_Stream_Type
'Class,
121 Name
=> File_Stream_Access
);
123 function To_AFCB_Ptr
is
124 new Unchecked_Conversion
(SIO
.File_Type
, FCB
.AFCB_Ptr
);
126 LRU_Head
: Shared_Var_File_Entry_Ptr
;
127 LRU_Tail
: Shared_Var_File_Entry_Ptr
;
128 -- As lock files are opened, they are organized into a least recently
129 -- used chain, which is a doubly linked list using the Next and Prev
130 -- fields of Shared_Var_File_Entry records. The field LRU_Head points
131 -- to the least recently used entry, whose prev pointer is null, and
132 -- LRU_Tail points to the most recently used entry, whose next pointer
133 -- is null. These pointers are null only if the list is empty.
135 function Hash
(F
: OS
.String_Access
) return Hash_Header
;
136 function Equal
(F1
, F2
: OS
.String_Access
) return Boolean;
137 -- Hash and equality functions for hash table
139 package SFT
is new GNAT
.HTable
.Simple_HTable
140 (Header_Num
=> Hash_Header
,
141 Element
=> Shared_Var_File_Entry_Ptr
,
143 Key
=> OS
.String_Access
,
147 --------------------------------
148 -- Variables for Lock Control --
149 --------------------------------
151 Global_Lock
: Global_Locks
.Lock_Type
;
153 Lock_Count
: Natural := 0;
154 -- Counts nesting of lock calls, 0 means lock is not held
156 -----------------------
157 -- Local Subprograms --
158 -----------------------
160 procedure Initialize
;
161 -- Called to initialize data structures for this package.
162 -- Has no effect except on the first call.
164 procedure Enter_SFE
(SFE
: Shared_Var_File_Entry_Ptr
; Fname
: String);
165 -- The first parameter is a pointer to a newly allocated SFE, whose
166 -- File field is already set appropriately. Fname is the name of the
167 -- variable as passed to Shared_Var_RFile/Shared_Var_WFile. Enter_SFE
168 -- completes the SFE value, and enters it into the hash table. If the
169 -- hash table is already full, the least recently used entry is first
170 -- closed and discarded.
172 function Retrieve
(File
: String) return Shared_Var_File_Entry_Ptr
;
173 -- Given a file name, this function searches the hash table to see if
174 -- the file is currently open. If so, then a pointer to the already
175 -- created entry is returned, after first moving it to the head of
176 -- the LRU chain. If not, then null is returned.
182 procedure Enter_SFE
(SFE
: Shared_Var_File_Entry_Ptr
; Fname
: String) is
183 Freed
: Shared_Var_File_Entry_Ptr
;
186 SFE
.Name
:= new String'(Fname);
188 -- Release least recently used entry if we have to
190 if Shared_Var_Files_Open = Max_Shared_Var_Files then
193 if Freed.Next /= null then
194 Freed.Next.Prev := null;
197 LRU_Head := Freed.Next;
198 SFT.Remove (Freed.Name);
199 SIO.Close (Freed.Stream.File);
200 OS.Free (Freed.Name);
205 Shared_Var_Files_Open := Shared_Var_Files_Open + 1;
208 -- Add new entry to hash table
210 SFT.Set (SFE.Name, SFE);
212 -- Add new entry at end of LRU chain
214 if LRU_Head = null then
219 SFE.Prev := LRU_Tail;
220 LRU_Tail.Next := SFE;
229 function Equal (F1, F2 : OS.String_Access) return Boolean is
231 return F1.all = F2.all;
238 function Hash (F : OS.String_Access) return Hash_Header is
242 -- Add up characters of name, mod our table size
244 for J in F'Range loop
245 N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1);
255 procedure Initialize is
258 Dir := OS.Getenv ("SHARED_MEMORY_DIRECTORY");
259 System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock");
268 (Stream : in out File_Stream_Type;
269 Item : out AS.Stream_Element_Array;
270 Last : out AS.Stream_Element_Offset) is
272 SIO.Read (Stream.File, Item, Last);
273 exception when others =>
281 function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is
282 SFE : Shared_Var_File_Entry_Ptr;
286 SFE := SFT.Get (File'Unrestricted_Access);
290 -- Move to head of LRU chain
292 if SFE = LRU_Tail then
295 elsif SFE = LRU_Head then
296 LRU_Head := LRU_Head.Next;
297 LRU_Head.Prev := null;
300 SFE.Next.Prev := SFE.Prev;
301 SFE.Prev.Next := SFE.Next;
305 SFE.Prev := LRU_Tail;
306 LRU_Tail.Next := SFE;
313 ----------------------
314 -- Shared_Var_Close --
315 ----------------------
317 procedure Shared_Var_Close (Var : in SIO.Stream_Access) is
320 end Shared_Var_Close;
322 ---------------------
323 -- Shared_Var_Lock --
324 ---------------------
326 procedure Shared_Var_Lock (Var : in String) is
331 if Lock_Count /= 0 then
332 Lock_Count := Lock_Count + 1;
338 System.Global_Locks.Acquire_Lock (Global_Lock);
347 ----------------------
348 -- Shared_Var_ROpen --
349 ----------------------
351 function Shared_Var_ROpen (Var : String) return SIO.Stream_Access is
352 SFE : Shared_Var_File_Entry_Ptr;
354 use type Ada.Streams.Stream_IO.File_Mode;
358 SFE := Retrieve (Var);
360 -- Here if file is not already open, try to open it
364 S : aliased constant String := Dir.all & Var;
367 SFE := new Shared_Var_File_Entry;
368 SFE.Stream := new File_Stream_Type;
369 SIO.Open (SFE.Stream.File, SIO.In_File, Name => S);
370 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
372 -- File opened successfully, put new entry in hash table. Note
373 -- that in this case, file is positioned correctly for read.
375 Enter_SFE (SFE, Var);
378 -- If we get an exception, it means that the file does not
379 -- exist, and in this case, we don't need the SFE and we
382 when IOX.Name_Error =>
388 -- Here if file is already open, set file for reading
391 if SIO.Mode (SFE.Stream.File) /= SIO.In_File then
392 SIO.Set_Mode (SFE.Stream.File, SIO.In_File);
393 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
396 SIO.Set_Index (SFE.Stream.File, 1);
399 return SIO.Stream_Access (SFE.Stream);
405 end Shared_Var_ROpen;
407 -----------------------
408 -- Shared_Var_Unlock --
409 -----------------------
411 procedure Shared_Var_Unlock (Var : in String) is
415 Lock_Count := Lock_Count - 1;
417 if Lock_Count = 0 then
418 System.Global_Locks.Release_Lock (Global_Lock);
426 end Shared_Var_Unlock;
428 ---------------------
429 -- Share_Var_WOpen --
430 ---------------------
432 function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is
433 SFE : Shared_Var_File_Entry_Ptr;
435 use type Ada.Streams.Stream_IO.File_Mode;
439 SFE := Retrieve (Var);
443 S : aliased constant String := Dir.all & Var;
446 SFE := new Shared_Var_File_Entry;
447 SFE.Stream := new File_Stream_Type;
448 SIO.Open (SFE.Stream.File, SIO.Out_File, Name => S);
449 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
452 -- If we get an exception, it means that the file does not
453 -- exist, and in this case, we create the file.
455 when IOX.Name_Error =>
458 SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S);
461 -- Error if we cannot create the file
464 Ada.Exceptions.Raise_Exception
465 (Program_Error'Identity,
466 "Cannot create shared variable file for """ &
471 -- Make new hash table entry for opened/created file. Note that
472 -- in both cases, the file is already in write mode at the start
473 -- of the file, ready to be written.
475 Enter_SFE
(SFE
, Var
);
477 -- Here if file is already open, set file for writing
480 if SIO
.Mode
(SFE
.Stream
.File
) /= SIO
.Out_File
then
481 SIO
.Set_Mode
(SFE
.Stream
.File
, SIO
.Out_File
);
482 SFI
.Make_Unbuffered
(To_AFCB_Ptr
(SFE
.Stream
.File
));
485 SIO
.Set_Index
(SFE
.Stream
.File
, 1);
488 return SIO
.Stream_Access
(SFE
.Stream
);
494 end Shared_Var_WOpen
;
501 (Stream
: in out File_Stream_Type
;
502 Item
: in AS
.Stream_Element_Array
) is
504 SIO
.Write
(Stream
.File
, Item
);
507 end System
.Shared_Storage
;