1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                  S Y S T E M . G L O B A L _ L O C K S                   --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1999-2018, 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 3,  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.                                     --
17--                                                                          --
18-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
26--                                                                          --
27-- GNAT was originally developed  by the GNAT team at  New York University. --
28-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29--                                                                          --
30------------------------------------------------------------------------------
31
32with System.Soft_Links;
33
34package body System.Global_Locks is
35
36   type String_Access is access String;
37
38   Dir_Separator : Character;
39   pragma Import (C, Dir_Separator, "__gnat_dir_separator");
40
41   type Lock_File_Entry is record
42      Dir  : String_Access;
43      File : String_Access;
44   end record;
45
46   Last_Lock  : Lock_Type := Null_Lock;
47   Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry;
48
49   procedure Lock_File
50     (Dir     : String;
51      File    : String;
52      Wait    : Duration := 0.1;
53      Retries : Natural  := Natural'Last);
54   --  Create a lock file File in directory Dir. If the file cannot be
55   --  locked because someone already owns the lock, this procedure
56   --  waits Wait seconds and retries at most Retries times. If the file
57   --  still cannot be locked, Lock_Error is raised. The default is to try
58   --  every second, almost forever (Natural'Last times).
59
60   ------------------
61   -- Acquire_Lock --
62   ------------------
63
64   procedure Acquire_Lock (Lock : in out Lock_Type) is
65   begin
66      Lock_File
67        (Lock_Table (Lock).Dir.all,
68         Lock_Table (Lock).File.all);
69   end Acquire_Lock;
70
71   -----------------
72   -- Create_Lock --
73   -----------------
74
75   procedure Create_Lock (Lock : out Lock_Type; Name : String) is
76      L : Lock_Type;
77
78   begin
79      System.Soft_Links.Lock_Task.all;
80      Last_Lock := Last_Lock + 1;
81      L := Last_Lock;
82      System.Soft_Links.Unlock_Task.all;
83
84      if L > Lock_Table'Last then
85         raise Lock_Error;
86      end if;
87
88      for J in reverse Name'Range loop
89         if Name (J) = Dir_Separator then
90            Lock_Table (L).Dir := new String'(Name (Name'First .. J - 1));
91            Lock_Table (L).File := new String'(Name (J + 1 .. Name'Last));
92            exit;
93         end if;
94      end loop;
95
96      if Lock_Table (L).Dir = null then
97         Lock_Table (L).Dir  := new String'(".");
98         Lock_Table (L).File := new String'(Name);
99      end if;
100
101      Lock := L;
102   end Create_Lock;
103
104   ---------------
105   -- Lock_File --
106   ---------------
107
108   procedure Lock_File
109     (Dir     : String;
110      File    : String;
111      Wait    : Duration := 0.1;
112      Retries : Natural  := Natural'Last)
113   is
114      C_Dir  : aliased String := Dir & ASCII.NUL;
115      C_File : aliased String := File & ASCII.NUL;
116
117      function Try_Lock (Dir, File : System.Address) return Integer;
118      pragma Import (C, Try_Lock, "__gnat_try_lock");
119
120   begin
121      for I in 0 .. Retries loop
122         if Try_Lock (C_Dir'Address, C_File'Address) = 1 then
123            return;
124         end if;
125
126         exit when I = Retries;
127         delay Wait;
128      end loop;
129
130      raise Lock_Error;
131   end Lock_File;
132
133   ------------------
134   -- Release_Lock --
135   ------------------
136
137   procedure Release_Lock (Lock : in out Lock_Type) is
138      S : aliased String :=
139            Lock_Table (Lock).Dir.all & Dir_Separator &
140            Lock_Table (Lock).File.all & ASCII.NUL;
141
142      procedure unlink (A : System.Address);
143      pragma Import (C, unlink, "unlink");
144
145   begin
146      unlink (S'Address);
147   end Release_Lock;
148
149end System.Global_Locks;
150