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, AdaCore                     --
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
32--  This implementation is specific to NT
33
34with System.OS_Interface;
35with System.Task_Lock;
36with System.Win32;
37
38with Interfaces.C.Strings;
39
40package body System.Global_Locks is
41
42   package TSL renames System.Task_Lock;
43   package OSI renames System.OS_Interface;
44   package ICS renames Interfaces.C.Strings;
45
46   subtype Lock_File_Entry is Win32.HANDLE;
47
48   Last_Lock  : Lock_Type := Null_Lock;
49   Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry;
50
51   -----------------
52   -- Create_Lock --
53   -----------------
54
55   procedure Create_Lock (Lock : out Lock_Type; Name : String) is
56      L : Lock_Type;
57
58   begin
59      TSL.Lock;
60      Last_Lock := Last_Lock + 1;
61      L := Last_Lock;
62      TSL.Unlock;
63
64      if L > Lock_Table'Last then
65         raise Lock_Error;
66      end if;
67
68      Lock_Table (L) :=
69        OSI.CreateMutex (null, Win32.FALSE, ICS.New_String (Name));
70      Lock := L;
71   end Create_Lock;
72
73   ------------------
74   -- Acquire_Lock --
75   ------------------
76
77   procedure Acquire_Lock (Lock : in out Lock_Type) is
78      use type Win32.DWORD;
79
80      Res : Win32.DWORD;
81
82   begin
83      Res := OSI.WaitForSingleObject (Lock_Table (Lock), OSI.Wait_Infinite);
84
85      if Res = OSI.WAIT_FAILED then
86         raise Lock_Error;
87      end if;
88   end Acquire_Lock;
89
90   ------------------
91   -- Release_Lock --
92   ------------------
93
94   procedure Release_Lock (Lock : in out Lock_Type) is
95      use type Win32.BOOL;
96
97      Res : Win32.BOOL;
98
99   begin
100      Res := OSI.ReleaseMutex (Lock_Table (Lock));
101
102      if Res = Win32.FALSE then
103         raise Lock_Error;
104      end if;
105   end Release_Lock;
106
107end System.Global_Locks;
108