1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S Y S T E M . S H A R E D _ M E M O R Y -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1998-2002 Free Software Foundation, Inc. -- 10-- -- 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. -- 21-- -- 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. -- 28-- -- 29-- GNAT was originally developed by the GNAT team at New York University. -- 30-- Extensive contributions were provided by Ada Core Technologies Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34with Ada.Exceptions; 35with Ada.IO_Exceptions; 36with Ada.Streams; 37with Ada.Streams.Stream_IO; 38 39with System.Global_Locks; 40with System.Soft_Links; 41 42with System; 43with System.File_Control_Block; 44with System.File_IO; 45with System.HTable; 46 47with Unchecked_Deallocation; 48with Unchecked_Conversion; 49 50package body System.Shared_Storage is 51 52 package AS renames Ada.Streams; 53 54 package IOX renames Ada.IO_Exceptions; 55 56 package FCB renames System.File_Control_Block; 57 58 package SFI renames System.File_IO; 59 60 type String_Access is access String; 61 procedure Free is new Unchecked_Deallocation 62 (Object => String, Name => String_Access); 63 64 Dir : String_Access; 65 -- Holds the directory 66 67 ------------------------------------------------ 68 -- Variables for Shared Variable Access Files -- 69 ------------------------------------------------ 70 71 Max_Shared_Var_Files : constant := 20; 72 -- Maximum number of lock files that can be open 73 74 Shared_Var_Files_Open : Natural := 0; 75 -- Number of shared variable access files currently open 76 77 type File_Stream_Type is new AS.Root_Stream_Type with record 78 File : SIO.File_Type; 79 end record; 80 type File_Stream_Access is access all File_Stream_Type'Class; 81 82 procedure Read 83 (Stream : in out File_Stream_Type; 84 Item : out AS.Stream_Element_Array; 85 Last : out AS.Stream_Element_Offset); 86 87 procedure Write 88 (Stream : in out File_Stream_Type; 89 Item : in AS.Stream_Element_Array); 90 91 subtype Hash_Header is Natural range 0 .. 30; 92 -- Number of hash headers, related (for efficiency purposes only) 93 -- to the maximum number of lock files.. 94 95 type Shared_Var_File_Entry; 96 type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry; 97 98 type Shared_Var_File_Entry is record 99 Name : String_Access; 100 -- Name of variable, as passed to Read_File/Write_File routines 101 102 Stream : File_Stream_Access; 103 -- Stream_IO file for the shared variable file 104 105 Next : Shared_Var_File_Entry_Ptr; 106 Prev : Shared_Var_File_Entry_Ptr; 107 -- Links for LRU chain 108 end record; 109 110 procedure Free is new Unchecked_Deallocation 111 (Object => Shared_Var_File_Entry, 112 Name => Shared_Var_File_Entry_Ptr); 113 114 procedure Free is new Unchecked_Deallocation 115 (Object => File_Stream_Type'Class, 116 Name => File_Stream_Access); 117 118 function To_AFCB_Ptr is 119 new Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr); 120 121 LRU_Head : Shared_Var_File_Entry_Ptr; 122 LRU_Tail : Shared_Var_File_Entry_Ptr; 123 -- As lock files are opened, they are organized into a least recently 124 -- used chain, which is a doubly linked list using the Next and Prev 125 -- fields of Shared_Var_File_Entry records. The field LRU_Head points 126 -- to the least recently used entry, whose prev pointer is null, and 127 -- LRU_Tail points to the most recently used entry, whose next pointer 128 -- is null. These pointers are null only if the list is empty. 129 130 function Hash (F : String_Access) return Hash_Header; 131 function Equal (F1, F2 : String_Access) return Boolean; 132 -- Hash and equality functions for hash table 133 134 package SFT is new System.HTable.Simple_HTable 135 (Header_Num => Hash_Header, 136 Element => Shared_Var_File_Entry_Ptr, 137 No_Element => null, 138 Key => String_Access, 139 Hash => Hash, 140 Equal => Equal); 141 142 -------------------------------- 143 -- Variables for Lock Control -- 144 -------------------------------- 145 146 Global_Lock : Global_Locks.Lock_Type; 147 148 Lock_Count : Natural := 0; 149 -- Counts nesting of lock calls, 0 means lock is not held 150 151 ----------------------- 152 -- Local Subprograms -- 153 ----------------------- 154 155 procedure Initialize; 156 -- Called to initialize data structures for this package. 157 -- Has no effect except on the first call. 158 159 procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String); 160 -- The first parameter is a pointer to a newly allocated SFE, whose 161 -- File field is already set appropriately. Fname is the name of the 162 -- variable as passed to Shared_Var_RFile/Shared_Var_WFile. Enter_SFE 163 -- completes the SFE value, and enters it into the hash table. If the 164 -- hash table is already full, the least recently used entry is first 165 -- closed and discarded. 166 167 function Retrieve (File : String) return Shared_Var_File_Entry_Ptr; 168 -- Given a file name, this function searches the hash table to see if 169 -- the file is currently open. If so, then a pointer to the already 170 -- created entry is returned, after first moving it to the head of 171 -- the LRU chain. If not, then null is returned. 172 173 --------------- 174 -- Enter_SFE -- 175 --------------- 176 177 procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is 178 Freed : Shared_Var_File_Entry_Ptr; 179 180 begin 181 SFE.Name := new String'(Fname); 182 183 -- Release least recently used entry if we have to 184 185 if Shared_Var_Files_Open = Max_Shared_Var_Files then 186 Freed := LRU_Head; 187 188 if Freed.Next /= null then 189 Freed.Next.Prev := null; 190 end if; 191 192 LRU_Head := Freed.Next; 193 SFT.Remove (Freed.Name); 194 SIO.Close (Freed.Stream.File); 195 Free (Freed.Name); 196 Free (Freed.Stream); 197 Free (Freed); 198 199 else 200 Shared_Var_Files_Open := Shared_Var_Files_Open + 1; 201 end if; 202 203 -- Add new entry to hash table 204 205 SFT.Set (SFE.Name, SFE); 206 207 -- Add new entry at end of LRU chain 208 209 if LRU_Head = null then 210 LRU_Head := SFE; 211 LRU_Tail := SFE; 212 213 else 214 SFE.Prev := LRU_Tail; 215 LRU_Tail.Next := SFE; 216 LRU_Tail := SFE; 217 end if; 218 end Enter_SFE; 219 220 ----------- 221 -- Equal -- 222 ----------- 223 224 function Equal (F1, F2 : String_Access) return Boolean is 225 begin 226 return F1.all = F2.all; 227 end Equal; 228 229 ---------- 230 -- Hash -- 231 ---------- 232 233 function Hash (F : String_Access) return Hash_Header is 234 N : Natural := 0; 235 236 begin 237 -- Add up characters of name, mod our table size 238 239 for J in F'Range loop 240 N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1); 241 end loop; 242 243 return N; 244 end Hash; 245 246 ---------------- 247 -- Initialize -- 248 ---------------- 249 250 procedure Initialize is 251 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); 252 pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr"); 253 254 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); 255 pragma Import (C, Strncpy, "strncpy"); 256 257 Dir_Name : aliased constant String := 258 "SHARED_MEMORY_DIRECTORY" & ASCII.NUL; 259 260 Env_Value_Ptr : aliased Address; 261 Env_Value_Length : aliased Integer; 262 263 begin 264 if Dir = null then 265 Get_Env_Value_Ptr 266 (Dir_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); 267 268 Dir := new String (1 .. Env_Value_Length); 269 270 if Env_Value_Length > 0 then 271 Strncpy (Dir.all'Address, Env_Value_Ptr, Env_Value_Length); 272 end if; 273 274 System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock"); 275 end if; 276 end Initialize; 277 278 ---------- 279 -- Read -- 280 ---------- 281 282 procedure Read 283 (Stream : in out File_Stream_Type; 284 Item : out AS.Stream_Element_Array; 285 Last : out AS.Stream_Element_Offset) 286 is 287 begin 288 SIO.Read (Stream.File, Item, Last); 289 290 exception when others => 291 Last := Item'Last; 292 end Read; 293 294 -------------- 295 -- Retrieve -- 296 -------------- 297 298 function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is 299 SFE : Shared_Var_File_Entry_Ptr; 300 301 begin 302 Initialize; 303 SFE := SFT.Get (File'Unrestricted_Access); 304 305 if SFE /= null then 306 307 -- Move to head of LRU chain 308 309 if SFE = LRU_Tail then 310 null; 311 312 elsif SFE = LRU_Head then 313 LRU_Head := LRU_Head.Next; 314 LRU_Head.Prev := null; 315 316 else 317 SFE.Next.Prev := SFE.Prev; 318 SFE.Prev.Next := SFE.Next; 319 end if; 320 321 SFE.Next := null; 322 SFE.Prev := LRU_Tail; 323 LRU_Tail.Next := SFE; 324 LRU_Tail := SFE; 325 end if; 326 327 return SFE; 328 end Retrieve; 329 330 ---------------------- 331 -- Shared_Var_Close -- 332 ---------------------- 333 334 procedure Shared_Var_Close (Var : in SIO.Stream_Access) is 335 pragma Warnings (Off, Var); 336 337 begin 338 System.Soft_Links.Unlock_Task.all; 339 end Shared_Var_Close; 340 341 --------------------- 342 -- Shared_Var_Lock -- 343 --------------------- 344 345 procedure Shared_Var_Lock (Var : in String) is 346 pragma Warnings (Off, Var); 347 348 begin 349 System.Soft_Links.Lock_Task.all; 350 Initialize; 351 352 if Lock_Count /= 0 then 353 Lock_Count := Lock_Count + 1; 354 System.Soft_Links.Unlock_Task.all; 355 356 else 357 Lock_Count := 1; 358 System.Soft_Links.Unlock_Task.all; 359 System.Global_Locks.Acquire_Lock (Global_Lock); 360 end if; 361 362 exception 363 when others => 364 System.Soft_Links.Unlock_Task.all; 365 raise; 366 end Shared_Var_Lock; 367 368 ---------------------- 369 -- Shared_Var_ROpen -- 370 ---------------------- 371 372 function Shared_Var_ROpen (Var : String) return SIO.Stream_Access is 373 SFE : Shared_Var_File_Entry_Ptr; 374 375 use type Ada.Streams.Stream_IO.File_Mode; 376 377 begin 378 System.Soft_Links.Lock_Task.all; 379 SFE := Retrieve (Var); 380 381 -- Here if file is not already open, try to open it 382 383 if SFE = null then 384 declare 385 S : aliased constant String := Dir.all & Var; 386 387 begin 388 SFE := new Shared_Var_File_Entry; 389 SFE.Stream := new File_Stream_Type; 390 SIO.Open (SFE.Stream.File, SIO.In_File, Name => S); 391 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); 392 393 -- File opened successfully, put new entry in hash table. Note 394 -- that in this case, file is positioned correctly for read. 395 396 Enter_SFE (SFE, Var); 397 398 exception 399 -- If we get an exception, it means that the file does not 400 -- exist, and in this case, we don't need the SFE and we 401 -- return null; 402 403 when IOX.Name_Error => 404 Free (SFE); 405 System.Soft_Links.Unlock_Task.all; 406 return null; 407 end; 408 409 -- Here if file is already open, set file for reading 410 411 else 412 if SIO.Mode (SFE.Stream.File) /= SIO.In_File then 413 SIO.Set_Mode (SFE.Stream.File, SIO.In_File); 414 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); 415 end if; 416 417 SIO.Set_Index (SFE.Stream.File, 1); 418 end if; 419 420 return SIO.Stream_Access (SFE.Stream); 421 422 exception 423 when others => 424 System.Soft_Links.Unlock_Task.all; 425 raise; 426 end Shared_Var_ROpen; 427 428 ----------------------- 429 -- Shared_Var_Unlock -- 430 ----------------------- 431 432 procedure Shared_Var_Unlock (Var : in String) is 433 pragma Warnings (Off, Var); 434 435 begin 436 System.Soft_Links.Lock_Task.all; 437 Initialize; 438 Lock_Count := Lock_Count - 1; 439 440 if Lock_Count = 0 then 441 System.Global_Locks.Release_Lock (Global_Lock); 442 end if; 443 System.Soft_Links.Unlock_Task.all; 444 445 exception 446 when others => 447 System.Soft_Links.Unlock_Task.all; 448 raise; 449 end Shared_Var_Unlock; 450 451 --------------------- 452 -- Share_Var_WOpen -- 453 --------------------- 454 455 function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is 456 SFE : Shared_Var_File_Entry_Ptr; 457 458 use type Ada.Streams.Stream_IO.File_Mode; 459 460 begin 461 System.Soft_Links.Lock_Task.all; 462 SFE := Retrieve (Var); 463 464 if SFE = null then 465 declare 466 S : aliased constant String := Dir.all & Var; 467 468 begin 469 SFE := new Shared_Var_File_Entry; 470 SFE.Stream := new File_Stream_Type; 471 SIO.Open (SFE.Stream.File, SIO.Out_File, Name => S); 472 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); 473 474 exception 475 -- If we get an exception, it means that the file does not 476 -- exist, and in this case, we create the file. 477 478 when IOX.Name_Error => 479 480 begin 481 SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S); 482 483 exception 484 -- Error if we cannot create the file 485 486 when others => 487 Ada.Exceptions.Raise_Exception 488 (Program_Error'Identity, 489 "Cannot create shared variable file for """ & 490 S & '"'); -- " 491 end; 492 end; 493 494 -- Make new hash table entry for opened/created file. Note that 495 -- in both cases, the file is already in write mode at the start 496 -- of the file, ready to be written. 497 498 Enter_SFE (SFE, Var); 499 500 -- Here if file is already open, set file for writing 501 502 else 503 if SIO.Mode (SFE.Stream.File) /= SIO.Out_File then 504 SIO.Set_Mode (SFE.Stream.File, SIO.Out_File); 505 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); 506 end if; 507 508 SIO.Set_Index (SFE.Stream.File, 1); 509 end if; 510 511 return SIO.Stream_Access (SFE.Stream); 512 513 exception 514 when others => 515 System.Soft_Links.Unlock_Task.all; 516 raise; 517 end Shared_Var_WOpen; 518 519 ----------- 520 -- Write -- 521 ----------- 522 523 procedure Write 524 (Stream : in out File_Stream_Type; 525 Item : in AS.Stream_Element_Array) 526 is 527 begin 528 SIO.Write (Stream.File, Item); 529 end Write; 530 531end System.Shared_Storage; 532