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-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
  34 with Ada.Exceptions;
  35 with Ada.IO_Exceptions;
  36 with Ada.Streams;
  37 with Ada.Streams.Stream_IO;
  38
  39 with System.Global_Locks;
  40 with System.Soft_Links;
  41
  42 with System;
  43 with System.File_Control_Block;
  44 with System.File_IO;
  45 with System.HTable;
  46
  47 with Unchecked_Deallocation;
  48 with Unchecked_Conversion;
  49
  50 package 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
 531 end System.Shared_Storage;