gcc/ada/s-shasto.adb

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