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 --          Copyright (C) 1998-2001 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
  34 with Ada.Exceptions;
  35 with Ada.IO_Exceptions;
  36 with Ada.Streams;
  37 with Ada.Streams.Stream_IO;
  38
  39 with GNAT.HTable;
  40 with System.Global_Locks;
  41 with GNAT.OS_Lib;
  42 with GNAT.Task_Lock;
  43
  44 use type GNAT.OS_Lib.String_Access;
  45
  46 with System;
  47 with System.File_Control_Block;
  48 with System.File_IO;
  49 with Unchecked_Deallocation;
  50 with Unchecked_Conversion;
  51
  52 package body System.Shared_Storage is
  53
  54    package AS renames Ada.Streams;
  55
  56    package OS renames GNAT.OS_Lib;
  57
  58    package IOX renames Ada.IO_Exceptions;
  59
  60    package FCB renames System.File_Control_Block;
  61
  62    package SFI renames System.File_IO;
  63
  64    package TSL renames GNAT.Task_Lock;
  65
  66    Dir : OS.String_Access;
  67    --  Holds the directory
  68
  69    ------------------------------------------------
  70    -- Variables for Shared Variable Access Files --
  71    ------------------------------------------------
  72
  73    Max_Shared_Var_Files : constant := 20;
  74    --  Maximum number of lock files that can be open
  75
  76    Shared_Var_Files_Open : Natural := 0;
  77    --  Number of shared variable access files currently open
  78
  79    type File_Stream_Type is new AS.Root_Stream_Type with record
  80       File : SIO.File_Type;
  81    end record;
  82    type File_Stream_Access is access all File_Stream_Type'Class;
  83
  84    procedure Read
  85      (Stream : in out File_Stream_Type;
  86       Item   : out AS.Stream_Element_Array;
  87       Last   : out AS.Stream_Element_Offset);
  88
  89    procedure Write
  90      (Stream : in out File_Stream_Type;
  91       Item   : in AS.Stream_Element_Array);
  92
  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..
  96
  97    type Shared_Var_File_Entry;
  98    type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry;
  99
 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
 103
 104       Stream : File_Stream_Access;
 105       --  Stream_IO file for the shared variable file
 106
 107       Next   : Shared_Var_File_Entry_Ptr;
 108       Prev   : Shared_Var_File_Entry_Ptr;
 109       --  Links for LRU chain
 110    end record;
 111
 112    procedure Free is new Unchecked_Deallocation
 113      (Object => Shared_Var_File_Entry,
 114       Name   => Shared_Var_File_Entry_Ptr);
 115
 116    procedure Free is new Unchecked_Deallocation
 117      (Object => File_Stream_Type'Class,
 118       Name   => File_Stream_Access);
 119
 120    function To_AFCB_Ptr is
 121      new Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr);
 122
 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.
 131
 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
 135
 136    package SFT is new GNAT.HTable.Simple_HTable
 137      (Header_Num => Hash_Header,
 138       Element    => Shared_Var_File_Entry_Ptr,
 139       No_Element => null,
 140       Key        => OS.String_Access,
 141       Hash       => Hash,
 142       Equal      => Equal);
 143
 144    --------------------------------
 145    -- Variables for Lock Control --
 146    --------------------------------
 147
 148    Global_Lock : Global_Locks.Lock_Type;
 149
 150    Lock_Count : Natural := 0;
 151    --  Counts nesting of lock calls, 0 means lock is not held
 152
 153    -----------------------
 154    -- Local Subprograms --
 155    -----------------------
 156
 157    procedure Initialize;
 158    --  Called to initialize data structures for this package.
 159    --  Has no effect except on the first call.
 160
 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.
 168
 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.
 174
 175    ---------------
 176    -- Enter_SFE --
 177    ---------------
 178
 179    procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is
 180       Freed : Shared_Var_File_Entry_Ptr;
 181
 182    begin
 183       SFE.Name := new String'(Fname);
 184
 185       --  Release least recently used entry if we have to
 186
 187       if Shared_Var_Files_Open =  Max_Shared_Var_Files then
 188          Freed := LRU_Head;
 189
 190          if Freed.Next /= null then
 191             Freed.Next.Prev := null;
 192          end if;
 193
 194          LRU_Head := Freed.Next;
 195          SFT.Remove (Freed.Name);
 196          SIO.Close (Freed.Stream.File);
 197          OS.Free (Freed.Name);
 198          Free (Freed.Stream);
 199          Free (Freed);
 200
 201       else
 202          Shared_Var_Files_Open := Shared_Var_Files_Open + 1;
 203       end if;
 204
 205       --  Add new entry to hash table
 206
 207       SFT.Set (SFE.Name, SFE);
 208
 209       --  Add new entry at end of LRU chain
 210
 211       if LRU_Head = null then
 212          LRU_Head := SFE;
 213          LRU_Tail := SFE;
 214
 215       else
 216          SFE.Prev := LRU_Tail;
 217          LRU_Tail.Next := SFE;
 218          LRU_Tail := SFE;
 219       end if;
 220    end Enter_SFE;
 221
 222    -----------
 223    -- Equal --
 224    -----------
 225
 226    function Equal (F1, F2 : OS.String_Access) return Boolean is
 227    begin
 228       return F1.all = F2.all;
 229    end Equal;
 230
 231    ----------
 232    -- Hash --
 233    ----------
 234
 235    function Hash (F : OS.String_Access) return Hash_Header is
 236       N : Natural := 0;
 237
 238    begin
 239       --  Add up characters of name, mod our table size
 240
 241       for J in F'Range loop
 242          N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1);
 243       end loop;
 244
 245       return N;
 246    end Hash;
 247
 248    ----------------
 249    -- Initialize --
 250    ----------------
 251
 252    procedure Initialize is
 253    begin
 254       if Dir = null then
 255          Dir := OS.Getenv ("SHARED_MEMORY_DIRECTORY");
 256          System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock");
 257       end if;
 258    end Initialize;
 259
 260    ----------
 261    -- Read --
 262    ----------
 263
 264    procedure Read
 265      (Stream : in out File_Stream_Type;
 266       Item   : out AS.Stream_Element_Array;
 267       Last   : out AS.Stream_Element_Offset) is
 268    begin
 269       SIO.Read (Stream.File, Item, Last);
 270    exception when others =>
 271       Last := Item'Last;
 272    end Read;
 273
 274    --------------
 275    -- Retrieve --
 276    --------------
 277
 278    function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is
 279       SFE : Shared_Var_File_Entry_Ptr;
 280
 281    begin
 282       Initialize;
 283       SFE := SFT.Get (File'Unrestricted_Access);
 284
 285       if SFE /= null then
 286
 287          --  Move to head of LRU chain
 288
 289          if SFE = LRU_Tail then
 290             null;
 291
 292          elsif SFE = LRU_Head then
 293             LRU_Head := LRU_Head.Next;
 294             LRU_Head.Prev := null;
 295
 296          else
 297             SFE.Next.Prev := SFE.Prev;
 298             SFE.Prev.Next := SFE.Next;
 299          end if;
 300
 301          SFE.Next := null;
 302          SFE.Prev := LRU_Tail;
 303          LRU_Tail.Next := SFE;
 304          LRU_Tail := SFE;
 305       end if;
 306
 307       return SFE;
 308    end Retrieve;
 309
 310    ----------------------
 311    -- Shared_Var_Close --
 312    ----------------------
 313
 314    procedure Shared_Var_Close (Var : in SIO.Stream_Access) is
 315       pragma Warnings (Off, Var);
 316    begin
 317       TSL.Unlock;
 318    end Shared_Var_Close;
 319
 320    ---------------------
 321    -- Shared_Var_Lock --
 322    ---------------------
 323
 324    procedure Shared_Var_Lock (Var : in String) is
 325       pragma Warnings (Off, Var);
 326
 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       pragma Warnings (Off, Var);
 413
 414    begin
 415       TSL.Lock;
 416       Initialize;
 417       Lock_Count := Lock_Count - 1;
 418
 419       if Lock_Count = 0 then
 420          System.Global_Locks.Release_Lock (Global_Lock);
 421       end if;
 422       TSL.Unlock;
 423
 424    exception
 425       when others =>
 426          TSL.Unlock;
 427          raise;
 428    end Shared_Var_Unlock;
 429
 430    ---------------------
 431    -- Share_Var_WOpen --
 432    ---------------------
 433
 434    function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is
 435       SFE : Shared_Var_File_Entry_Ptr;
 436
 437       use type Ada.Streams.Stream_IO.File_Mode;
 438
 439    begin
 440       TSL.Lock;
 441       SFE := Retrieve (Var);
 442
 443       if SFE = null then
 444          declare
 445             S  : aliased constant String := Dir.all & Var;
 446
 447          begin
 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));
 452
 453          exception
 454             --  If we get an exception, it means that the file does not
 455             --  exist, and in this case, we create the file.
 456
 457             when IOX.Name_Error =>
 458
 459                begin
 460                   SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S);
 461
 462                exception
 463                   --  Error if we cannot create the file
 464
 465                   when others =>
 466                      Ada.Exceptions.Raise_Exception
 467                        (Program_Error'Identity,
 468                         "Cannot create shared variable file for """ &
 469                         S & '"'); -- "
 470                end;
 471          end;
 472
 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.
 476
 477          Enter_SFE (SFE, Var);
 478
 479       --  Here if file is already open, set file for writing
 480
 481       else
 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));
 485          end if;
 486
 487          SIO.Set_Index (SFE.Stream.File, 1);
 488       end if;
 489
 490       return SIO.Stream_Access (SFE.Stream);
 491
 492    exception
 493       when others =>
 494          TSL.Unlock;
 495          raise;
 496    end Shared_Var_WOpen;
 497
 498    -----------
 499    -- Write --
 500    -----------
 501
 502    procedure Write
 503      (Stream : in out File_Stream_Type;
 504       Item   : in AS.Stream_Element_Array) is
 505    begin
 506       SIO.Write (Stream.File, Item);
 507    end Write;
 508
 509 end System.Shared_Storage;