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-2001 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 ------------------------------------------------------------------------------
35 with Ada
.IO_Exceptions
;
37 with Ada
.Streams
.Stream_IO
;
40 with System
.Global_Locks
;
44 use type GNAT
.OS_Lib
.String_Access
;
47 with System
.File_Control_Block
;
49 with Unchecked_Deallocation
;
50 with Unchecked_Conversion
;
52 package body System
.Shared_Storage
is
54 package AS
renames Ada
.Streams
;
56 package OS
renames GNAT
.OS_Lib
;
58 package IOX
renames Ada
.IO_Exceptions
;
60 package FCB
renames System
.File_Control_Block
;
62 package SFI
renames System
.File_IO
;
64 package TSL
renames GNAT
.Task_Lock
;
66 Dir
: OS
.String_Access
;
67 -- Holds the directory
69 ------------------------------------------------
70 -- Variables for Shared Variable Access Files --
71 ------------------------------------------------
73 Max_Shared_Var_Files
: constant := 20;
74 -- Maximum number of lock files that can be open
76 Shared_Var_Files_Open
: Natural := 0;
77 -- Number of shared variable access files currently open
79 type File_Stream_Type
is new AS
.Root_Stream_Type
with record
82 type File_Stream_Access
is access all File_Stream_Type
'Class;
85 (Stream
: in out File_Stream_Type
;
86 Item
: out AS
.Stream_Element_Array
;
87 Last
: out AS
.Stream_Element_Offset
);
90 (Stream
: in out File_Stream_Type
;
91 Item
: in AS
.Stream_Element_Array
);
93 subtype Hash_Header
is Natural range 0 .. 30;
94 -- Number of hash headers, related (for efficiency purposes only)
95 -- to the maximum number of lock files..
97 type Shared_Var_File_Entry
;
98 type Shared_Var_File_Entry_Ptr
is access Shared_Var_File_Entry
;
100 type Shared_Var_File_Entry
is record
101 Name
: OS
.String_Access
;
102 -- Name of variable, as passed to Read_File/Write_File routines
104 Stream
: File_Stream_Access
;
105 -- Stream_IO file for the shared variable file
107 Next
: Shared_Var_File_Entry_Ptr
;
108 Prev
: Shared_Var_File_Entry_Ptr
;
109 -- Links for LRU chain
112 procedure Free
is new Unchecked_Deallocation
113 (Object
=> Shared_Var_File_Entry
,
114 Name
=> Shared_Var_File_Entry_Ptr
);
116 procedure Free
is new Unchecked_Deallocation
117 (Object
=> File_Stream_Type
'Class,
118 Name
=> File_Stream_Access
);
120 function To_AFCB_Ptr
is
121 new Unchecked_Conversion
(SIO
.File_Type
, FCB
.AFCB_Ptr
);
123 LRU_Head
: Shared_Var_File_Entry_Ptr
;
124 LRU_Tail
: Shared_Var_File_Entry_Ptr
;
125 -- As lock files are opened, they are organized into a least recently
126 -- used chain, which is a doubly linked list using the Next and Prev
127 -- fields of Shared_Var_File_Entry records. The field LRU_Head points
128 -- to the least recently used entry, whose prev pointer is null, and
129 -- LRU_Tail points to the most recently used entry, whose next pointer
130 -- is null. These pointers are null only if the list is empty.
132 function Hash
(F
: OS
.String_Access
) return Hash_Header
;
133 function Equal
(F1
, F2
: OS
.String_Access
) return Boolean;
134 -- Hash and equality functions for hash table
136 package SFT
is new GNAT
.HTable
.Simple_HTable
137 (Header_Num
=> Hash_Header
,
138 Element
=> Shared_Var_File_Entry_Ptr
,
140 Key
=> OS
.String_Access
,
144 --------------------------------
145 -- Variables for Lock Control --
146 --------------------------------
148 Global_Lock
: Global_Locks
.Lock_Type
;
150 Lock_Count
: Natural := 0;
151 -- Counts nesting of lock calls, 0 means lock is not held
153 -----------------------
154 -- Local Subprograms --
155 -----------------------
157 procedure Initialize
;
158 -- Called to initialize data structures for this package.
159 -- Has no effect except on the first call.
161 procedure Enter_SFE
(SFE
: Shared_Var_File_Entry_Ptr
; Fname
: String);
162 -- The first parameter is a pointer to a newly allocated SFE, whose
163 -- File field is already set appropriately. Fname is the name of the
164 -- variable as passed to Shared_Var_RFile/Shared_Var_WFile. Enter_SFE
165 -- completes the SFE value, and enters it into the hash table. If the
166 -- hash table is already full, the least recently used entry is first
167 -- closed and discarded.
169 function Retrieve
(File
: String) return Shared_Var_File_Entry_Ptr
;
170 -- Given a file name, this function searches the hash table to see if
171 -- the file is currently open. If so, then a pointer to the already
172 -- created entry is returned, after first moving it to the head of
173 -- the LRU chain. If not, then null is returned.
179 procedure Enter_SFE
(SFE
: Shared_Var_File_Entry_Ptr
; Fname
: String) is
180 Freed
: Shared_Var_File_Entry_Ptr
;
183 SFE
.Name
:= new String'(Fname);
185 -- Release least recently used entry if we have to
187 if Shared_Var_Files_Open = Max_Shared_Var_Files then
190 if Freed.Next /= null then
191 Freed.Next.Prev := null;
194 LRU_Head := Freed.Next;
195 SFT.Remove (Freed.Name);
196 SIO.Close (Freed.Stream.File);
197 OS.Free (Freed.Name);
202 Shared_Var_Files_Open := Shared_Var_Files_Open + 1;
205 -- Add new entry to hash table
207 SFT.Set (SFE.Name, SFE);
209 -- Add new entry at end of LRU chain
211 if LRU_Head = null then
216 SFE.Prev := LRU_Tail;
217 LRU_Tail.Next := SFE;
226 function Equal (F1, F2 : OS.String_Access) return Boolean is
228 return F1.all = F2.all;
235 function Hash (F : OS.String_Access) return Hash_Header is
239 -- Add up characters of name, mod our table size
241 for J in F'Range loop
242 N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1);
252 procedure Initialize is
255 Dir := OS.Getenv ("SHARED_MEMORY_DIRECTORY");
256 System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock");
265 (Stream : in out File_Stream_Type;
266 Item : out AS.Stream_Element_Array;
267 Last : out AS.Stream_Element_Offset) is
269 SIO.Read (Stream.File, Item, Last);
270 exception when others =>
278 function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is
279 SFE : Shared_Var_File_Entry_Ptr;
283 SFE := SFT.Get (File'Unrestricted_Access);
287 -- Move to head of LRU chain
289 if SFE = LRU_Tail then
292 elsif SFE = LRU_Head then
293 LRU_Head := LRU_Head.Next;
294 LRU_Head.Prev := null;
297 SFE.Next.Prev := SFE.Prev;
298 SFE.Prev.Next := SFE.Next;
302 SFE.Prev := LRU_Tail;
303 LRU_Tail.Next := SFE;
310 ----------------------
311 -- Shared_Var_Close --
312 ----------------------
314 procedure Shared_Var_Close (Var : in SIO.Stream_Access) is
315 pragma Warnings (Off, Var);
318 end Shared_Var_Close;
320 ---------------------
321 -- Shared_Var_Lock --
322 ---------------------
324 procedure Shared_Var_Lock (Var : in String) is
325 pragma Warnings (Off, Var);
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
412 pragma Warnings (Off, Var);
417 Lock_Count := Lock_Count - 1;
419 if Lock_Count = 0 then
420 System.Global_Locks.Release_Lock (Global_Lock);
428 end Shared_Var_Unlock;
430 ---------------------
431 -- Share_Var_WOpen --
432 ---------------------
434 function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is
435 SFE : Shared_Var_File_Entry_Ptr;
437 use type Ada.Streams.Stream_IO.File_Mode;
441 SFE := Retrieve (Var);
445 S : aliased constant String := Dir.all & Var;
448 SFE := new Shared_Var_File_Entry;
449 SFE.Stream := new File_Stream_Type;
450 SIO.Open (SFE.Stream.File, SIO.Out_File, Name => S);
451 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
454 -- If we get an exception, it means that the file does not
455 -- exist, and in this case, we create the file.
457 when IOX.Name_Error =>
460 SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S);
463 -- Error if we cannot create the file
466 Ada.Exceptions.Raise_Exception
467 (Program_Error'Identity,
468 "Cannot create shared variable file for """ &
473 -- Make new hash table entry for opened/created file. Note that
474 -- in both cases, the file is already in write mode at the start
475 -- of the file, ready to be written.
477 Enter_SFE
(SFE
, Var
);
479 -- Here if file is already open, set file for writing
482 if SIO
.Mode
(SFE
.Stream
.File
) /= SIO
.Out_File
then
483 SIO
.Set_Mode
(SFE
.Stream
.File
, SIO
.Out_File
);
484 SFI
.Make_Unbuffered
(To_AFCB_Ptr
(SFE
.Stream
.File
));
487 SIO
.Set_Index
(SFE
.Stream
.File
, 1);
490 return SIO
.Stream_Access
(SFE
.Stream
);
496 end Shared_Var_WOpen
;
503 (Stream
: in out File_Stream_Type
;
504 Item
: in AS
.Stream_Element_Array
) is
506 SIO
.Write
(Stream
.File
, Item
);
509 end System
.Shared_Storage
;