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 --                            $Revision: 1.11 $
  10 --                                                                          --
  11 --          Copyright (C) 1998-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  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.                                                      --
  23 --                                                                          --
  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.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with Ada.Exceptions;
  37 with Ada.IO_Exceptions;
  38 with Ada.Streams;
  39 with Ada.Streams.Stream_IO;
  40
  41 with GNAT.HTable;
  42 with System.Global_Locks;
  43 with GNAT.OS_Lib;
  44 with GNAT.Task_Lock;
  45
  46 use type GNAT.OS_Lib.String_Access;
  47
  48 with System;
  49 with System.File_Control_Block;
  50 with System.File_IO;
  51 with Unchecked_Deallocation;
  52 with Unchecked_Conversion;
  53
  54 package body System.Shared_Storage is
  55
  56    package AS renames Ada.Streams;
  57
  58    package OS renames GNAT.OS_Lib;
  59
  60    package IOX renames Ada.IO_Exceptions;
  61
  62    package FCB renames System.File_Control_Block;
  63
  64    package SFI renames System.File_IO;
  65
  66    package TSL renames GNAT.Task_Lock;
  67
  68    Dir : OS.String_Access;
  69    --  Holds the directory
  70
  71    ------------------------------------------------
  72    -- Variables for Shared Variable Access Files --
  73    ------------------------------------------------
  74
  75    Max_Shared_Var_Files : constant := 20;
  76    --  Maximum number of lock files that can be open
  77
  78    Shared_Var_Files_Open : Natural := 0;
  79    --  Number of shared variable access files currently open
  80
  81    type File_Stream_Type is new AS.Root_Stream_Type with
  82       record
  83          File : SIO.File_Type;
  84       end record;
  85    type File_Stream_Access is access all File_Stream_Type'Class;
  86
  87    procedure Read
  88      (Stream : in out File_Stream_Type;
  89       Item   : out AS.Stream_Element_Array;
  90       Last   : out AS.Stream_Element_Offset);
  91
  92    procedure Write
  93      (Stream : in out File_Stream_Type;
  94       Item   : in AS.Stream_Element_Array);
  95
  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..
  99
 100    type Shared_Var_File_Entry;
 101    type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry;
 102
 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
 106
 107       Stream : File_Stream_Access;
 108       --  Stream_IO file for the shared variable file
 109
 110       Next   : Shared_Var_File_Entry_Ptr;
 111       Prev   : Shared_Var_File_Entry_Ptr;
 112       --  Links for LRU chain
 113    end record;
 114
 115    procedure Free is new Unchecked_Deallocation
 116      (Object => Shared_Var_File_Entry,
 117       Name   => Shared_Var_File_Entry_Ptr);
 118
 119    procedure Free is new Unchecked_Deallocation
 120      (Object => File_Stream_Type'Class,
 121       Name   => File_Stream_Access);
 122
 123    function To_AFCB_Ptr is
 124      new Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr);
 125
 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.
 134
 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
 138
 139    package SFT is new GNAT.HTable.Simple_HTable
 140      (Header_Num => Hash_Header,
 141       Element    => Shared_Var_File_Entry_Ptr,
 142       No_Element => null,
 143       Key        => OS.String_Access,
 144       Hash       => Hash,
 145       Equal      => Equal);
 146
 147    --------------------------------
 148    -- Variables for Lock Control --
 149    --------------------------------
 150
 151    Global_Lock : Global_Locks.Lock_Type;
 152
 153    Lock_Count : Natural := 0;
 154    --  Counts nesting of lock calls, 0 means lock is not held
 155
 156    -----------------------
 157    -- Local Subprograms --
 158    -----------------------
 159
 160    procedure Initialize;
 161    --  Called to initialize data structures for this package.
 162    --  Has no effect except on the first call.
 163
 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.
 171
 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.
 177
 178    ---------------
 179    -- Enter_SFE --
 180    ---------------
 181
 182    procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is
 183       Freed : Shared_Var_File_Entry_Ptr;
 184
 185    begin
 186       SFE.Name := new String'(Fname);
 187
 188       --  Release least recently used entry if we have to
 189
 190       if Shared_Var_Files_Open =  Max_Shared_Var_Files then
 191          Freed := LRU_Head;
 192
 193          if Freed.Next /= null then
 194             Freed.Next.Prev := null;
 195          end if;
 196
 197          LRU_Head := Freed.Next;
 198          SFT.Remove (Freed.Name);
 199          SIO.Close (Freed.Stream.File);
 200          OS.Free (Freed.Name);
 201          Free (Freed.Stream);
 202          Free (Freed);
 203
 204       else
 205          Shared_Var_Files_Open := Shared_Var_Files_Open + 1;
 206       end if;
 207
 208       --  Add new entry to hash table
 209
 210       SFT.Set (SFE.Name, SFE);
 211
 212       --  Add new entry at end of LRU chain
 213
 214       if LRU_Head = null then
 215          LRU_Head := SFE;
 216          LRU_Tail := SFE;
 217
 218       else
 219          SFE.Prev := LRU_Tail;
 220          LRU_Tail.Next := SFE;
 221          LRU_Tail := SFE;
 222       end if;
 223    end Enter_SFE;
 224
 225    -----------
 226    -- Equal --
 227    -----------
 228
 229    function Equal (F1, F2 : OS.String_Access) return Boolean is
 230    begin
 231       return F1.all = F2.all;
 232    end Equal;
 233
 234    ----------
 235    -- Hash --
 236    ----------
 237
 238    function Hash (F : OS.String_Access) return Hash_Header is
 239       N : Natural := 0;
 240
 241    begin
 242       --  Add up characters of name, mod our table size
 243
 244       for J in F'Range loop
 245          N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1);
 246       end loop;
 247
 248       return N;
 249    end Hash;
 250
 251    ----------------
 252    -- Initialize --
 253    ----------------
 254
 255    procedure Initialize is
 256    begin
 257       if Dir = null then
 258          Dir := OS.Getenv ("SHARED_MEMORY_DIRECTORY");
 259          System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock");
 260       end if;
 261    end Initialize;
 262
 263    ----------
 264    -- Read --
 265    ----------
 266
 267    procedure Read
 268      (Stream : in out File_Stream_Type;
 269       Item   : out AS.Stream_Element_Array;
 270       Last   : out AS.Stream_Element_Offset) is
 271    begin
 272       SIO.Read (Stream.File, Item, Last);
 273    exception when others =>
 274       Last := Item'Last;
 275    end Read;
 276
 277    --------------
 278    -- Retrieve --
 279    --------------
 280
 281    function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is
 282       SFE : Shared_Var_File_Entry_Ptr;
 283
 284    begin
 285       Initialize;
 286       SFE := SFT.Get (File'Unrestricted_Access);
 287
 288       if SFE /= null then
 289
 290          --  Move to head of LRU chain
 291
 292          if SFE = LRU_Tail then
 293             null;
 294
 295          elsif SFE = LRU_Head then
 296             LRU_Head := LRU_Head.Next;
 297             LRU_Head.Prev := null;
 298
 299          else
 300             SFE.Next.Prev := SFE.Prev;
 301             SFE.Prev.Next := SFE.Next;
 302          end if;
 303
 304          SFE.Next := null;
 305          SFE.Prev := LRU_Tail;
 306          LRU_Tail.Next := SFE;
 307          LRU_Tail := SFE;
 308       end if;
 309
 310       return SFE;
 311    end Retrieve;
 312
 313    ----------------------
 314    -- Shared_Var_Close --
 315    ----------------------
 316
 317    procedure Shared_Var_Close (Var : in SIO.Stream_Access) is
 318    begin
 319       TSL.Unlock;
 320    end Shared_Var_Close;
 321
 322    ---------------------
 323    -- Shared_Var_Lock --
 324    ---------------------
 325
 326    procedure Shared_Var_Lock (Var : in String) is
 327    begin
 328       TSL.Lock;
 329       Initialize;
 330
 331       if Lock_Count /= 0 then
 332          Lock_Count := Lock_Count + 1;
 333          TSL.Unlock;
 334
 335       else
 336          Lock_Count := 1;
 337          TSL.Unlock;
 338          System.Global_Locks.Acquire_Lock (Global_Lock);
 339       end if;
 340
 341    exception
 342       when others =>
 343          TSL.Unlock;
 344          raise;
 345    end Shared_Var_Lock;
 346
 347    ----------------------
 348    -- Shared_Var_ROpen --
 349    ----------------------
 350
 351    function Shared_Var_ROpen (Var : String) return SIO.Stream_Access is
 352       SFE : Shared_Var_File_Entry_Ptr;
 353
 354       use type Ada.Streams.Stream_IO.File_Mode;
 355
 356    begin
 357       TSL.Lock;
 358       SFE := Retrieve (Var);
 359
 360       --  Here if file is not already open, try to open it
 361
 362       if SFE = null then
 363          declare
 364             S  : aliased constant String := Dir.all & Var;
 365
 366          begin
 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));
 371
 372             --  File opened successfully, put new entry in hash table. Note
 373             --  that in this case, file is positioned correctly for read.
 374
 375             Enter_SFE (SFE, Var);
 376
 377             exception
 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
 380                --  return null;
 381
 382                when IOX.Name_Error =>
 383                   Free (SFE);
 384                   TSL.Unlock;
 385                   return null;
 386          end;
 387
 388       --  Here if file is already open, set file for reading
 389
 390       else
 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));
 394          end if;
 395
 396          SIO.Set_Index (SFE.Stream.File, 1);
 397       end if;
 398
 399       return SIO.Stream_Access (SFE.Stream);
 400
 401    exception
 402       when others =>
 403          TSL.Unlock;
 404          raise;
 405    end Shared_Var_ROpen;
 406
 407    -----------------------
 408    -- Shared_Var_Unlock --
 409    -----------------------
 410
 411    procedure Shared_Var_Unlock (Var : in String) is
 412    begin
 413       TSL.Lock;
 414       Initialize;
 415       Lock_Count := Lock_Count - 1;
 416
 417       if Lock_Count = 0 then
 418          System.Global_Locks.Release_Lock (Global_Lock);
 419       end if;
 420       TSL.Unlock;
 421
 422    exception
 423       when others =>
 424          TSL.Unlock;
 425          raise;
 426    end Shared_Var_Unlock;
 427
 428    ---------------------
 429    -- Share_Var_WOpen --
 430    ---------------------
 431
 432    function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is
 433       SFE : Shared_Var_File_Entry_Ptr;
 434
 435       use type Ada.Streams.Stream_IO.File_Mode;
 436
 437    begin
 438       TSL.Lock;
 439       SFE := Retrieve (Var);
 440
 441       if SFE = null then
 442          declare
 443             S  : aliased constant String := Dir.all & Var;
 444
 445          begin
 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));
 450
 451          exception
 452             --  If we get an exception, it means that the file does not
 453             --  exist, and in this case, we create the file.
 454
 455             when IOX.Name_Error =>
 456
 457                begin
 458                   SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S);
 459
 460                exception
 461                   --  Error if we cannot create the file
 462
 463                   when others =>
 464                      Ada.Exceptions.Raise_Exception
 465                        (Program_Error'Identity,
 466                         "Cannot create shared variable file for """ &
 467                         S & '"'); -- "
 468                end;
 469          end;
 470
 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.
 474
 475          Enter_SFE (SFE, Var);
 476
 477       --  Here if file is already open, set file for writing
 478
 479       else
 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));
 483          end if;
 484
 485          SIO.Set_Index (SFE.Stream.File, 1);
 486       end if;
 487
 488       return SIO.Stream_Access (SFE.Stream);
 489
 490    exception
 491       when others =>
 492          TSL.Unlock;
 493          raise;
 494    end Shared_Var_WOpen;
 495
 496    -----------
 497    -- Write --
 498    -----------
 499
 500    procedure Write
 501      (Stream : in out File_Stream_Type;
 502       Item   : in AS.Stream_Element_Array) is
 503    begin
 504       SIO.Write (Stream.File, Item);
 505    end Write;
 506
 507 end System.Shared_Storage;