1--  Copyright 1999-2014 Simon Wright <simon@pushface.org>
2
3--  This package is free software; you can redistribute it and/or
4--  modify it under terms of the GNU General Public License as
5--  published by the Free Software Foundation; either version 2, or
6--  (at your option) any later version. This package is distributed in
7--  the hope that it will be useful, but WITHOUT ANY WARRANTY; without
8--  even the implied warranty of MERCHANTABILITY or FITNESS FOR A
9--  PARTICULAR PURPOSE. See the GNU General Public License for more
10--  details. You should have received a copy of the GNU General Public
11--  License distributed with this package; see file COPYING.  If not,
12--  write to the Free Software Foundation, 59 Temple Place - Suite
13--  330, Boston, MA 02111-1307, USA.
14
15--  As a special exception, if other files instantiate generics from
16--  this unit, or you link this unit with other files to produce an
17--  executable, this unit does not by itself cause the resulting
18--  executable to be covered by the GNU General Public License.  This
19--  exception does not however invalidate any other reasons why the
20--  executable file might be covered by the GNU Public License.
21
22with Ada.Finalization;
23with Ada.Task_Identification;
24
25package BC.Support.Synchronization is
26
27   pragma Elaborate_Body;
28
29   --  Semaphores provide for mutual exclusion.
30   type Semaphore_Base is abstract tagged limited private;
31   procedure Seize (The_Semaphore : in out Semaphore_Base) is abstract;
32   procedure Release (The_Semaphore : in out Semaphore_Base) is abstract;
33   function None_Pending (On_The_Semaphore : Semaphore_Base) return Boolean
34      is abstract;
35
36
37   --  A Semaphore is like a standard POSIX mutex.
38   type Semaphore is new Semaphore_Base with private;
39   procedure Seize (The_Semaphore : in out Semaphore);
40   procedure Release (The_Semaphore : in out Semaphore);
41   function None_Pending (On_The_Semaphore : Semaphore) return Boolean;
42
43
44   --  A Recursive_Semaphore is like a POSIX recursive mutex; once
45   --  Seized by a task, that task can Seize again; other tasks are
46   --  blocked until the owning task has Released the semaphore as
47   --  many times as it Seized it.
48   type Recursive_Semaphore is new Semaphore_Base with private;
49   procedure Seize (The_Semaphore : in out Recursive_Semaphore);
50   procedure Release (The_Semaphore : in out Recursive_Semaphore);
51   function None_Pending
52     (On_The_Semaphore : Recursive_Semaphore) return Boolean;
53
54
55   --  Monitors support Locks.
56   type Monitor_Base is abstract tagged limited private;
57   procedure Seize_For_Reading (The_Monitor : in out Monitor_Base)
58      is abstract;
59   procedure Seize_For_Writing (The_Monitor : in out Monitor_Base)
60      is abstract;
61   procedure Release_From_Reading (The_Monitor : in out Monitor_Base)
62      is abstract;
63   procedure Release_From_Writing (The_Monitor : in out Monitor_Base)
64      is abstract;
65
66
67   --  Single_Monitors allow one task at a time to have access, be it
68   --  for reading or writing.
69   type Single_Monitor is new Monitor_Base with private;
70   procedure Seize_For_Reading (The_Monitor : in out Single_Monitor);
71   procedure Seize_For_Writing (The_Monitor : in out Single_Monitor);
72   procedure Release_From_Reading (The_Monitor : in out Single_Monitor);
73   procedure Release_From_Writing (The_Monitor : in out Single_Monitor);
74
75
76   --  Multiple_Monitors allow multiple readers; however, when a
77   --  writer owns the monitor it has exclusive access.
78   type Multiple_Monitor is new Monitor_Base with private;
79   procedure Seize_For_Reading (The_Monitor : in out Multiple_Monitor);
80   procedure Seize_For_Writing (The_Monitor : in out Multiple_Monitor);
81   procedure Release_From_Reading (The_Monitor : in out Multiple_Monitor);
82   procedure Release_From_Writing (The_Monitor : in out Multiple_Monitor);
83
84
85   --  A Lock is designed to provide "locking by declaration".
86   --    declare
87   --      L : Lock (Some_Monitor'Access);
88   --    begin
89   --      -- the monitor is locked
90   --    end;
91   --    -- the monitor is unlocked as L is finalized, even if an exception
92   --    -- occurs
93
94   type Lock_Base
95      is abstract new Ada.Finalization.Limited_Controlled with private;
96
97   --  A simple Lock provides mutual exclusion
98   type Lock (Using : access Semaphore_Base'Class)
99   is new Lock_Base with private;
100
101   --  Read_ and Write_ Locks support multiple reader/single writer
102   --  access provided the given Monitor supports it; otherwise they
103   --  merely provide mutual exclusion.
104   type Read_Lock (Using : access Monitor_Base'Class)
105   is new Lock_Base with private;
106
107   type Write_Lock (Using : access Monitor_Base'Class)
108   is new Lock_Base with private;
109
110private
111
112   type Semaphore_Base is abstract tagged limited null record;
113
114   protected type Semaphore_Type is
115      entry Seize;
116      procedure Release;
117      function None_Pending return Boolean;
118   private
119      Seized : Boolean := False;
120   end Semaphore_Type;
121
122   type Semaphore is new Semaphore_Base with record
123      S : Semaphore_Type;
124   end record;
125
126   protected type Recursive_Semaphore_Type is
127      entry Seize;
128      procedure Release;
129      function None_Pending return Boolean;
130   private
131      entry Waiting;
132      Owner : Ada.Task_Identification.Task_Id;
133      Count : Natural := 0;
134   end Recursive_Semaphore_Type;
135
136   type Recursive_Semaphore is new Semaphore_Base with record
137      S : Recursive_Semaphore_Type;
138   end record;
139
140   type Monitor_Base is abstract tagged limited null record;
141
142   type Single_Monitor is new Monitor_Base with record
143      The_Semaphore : Recursive_Semaphore;
144   end record;
145
146   --  Monitor_Type is due to Matthew Heaney <matthew_heaney@acm.org>.
147   --  The Booch C++ version was inoperative, at least in sjw's translation.
148
149   type Seize_Kind is (For_Reading, For_Writing);
150
151   protected type Monitor_Type is
152      entry Seize (Kind : Seize_Kind);
153      procedure Release_From_Reading;
154      procedure Release_From_Writing;
155   private
156      entry Waiting_To_Write;
157      Reader_Count : Natural := 0;
158      Writing : Boolean := False;
159   end Monitor_Type;
160
161   type Multiple_Monitor is new Monitor_Base with record
162      M : Monitor_Type;
163   end record;
164
165   type Lock_Base
166   is abstract new Ada.Finalization.Limited_Controlled with record
167      Finalized : Boolean := False;
168   end record;
169
170   type Lock (Using : access Semaphore_Base'Class)
171   is new Lock_Base with null record;
172   procedure Initialize (The_Lock : in out Lock);
173   procedure Finalize (The_Lock : in out Lock);
174
175   type Read_Lock (Using : access Monitor_Base'Class)
176   is new Lock_Base with null record;
177   procedure Initialize (The_Lock : in out Read_Lock);
178   procedure Finalize (The_Lock : in out Read_Lock);
179
180   type Write_Lock (Using : access Monitor_Base'Class)
181   is new Lock_Base with null record;
182   procedure Initialize (The_Lock : in out Write_Lock);
183   procedure Finalize (The_Lock : in out Write_Lock);
184
185end BC.Support.Synchronization;
186