1------------------------------------------------------------------------------
2--                                                                          --
3--                 GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS              --
4--                                                                          --
5--                   SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS                 --
6--                                                                          --
7--                                  B o d y                                 --
8--                                                                          --
9--             Copyright (C) 1991-1994, Florida State University            --
10--             Copyright (C) 1995-2003, Ada Core Technologies               --
11--                                                                          --
12-- GNARL is free software; you can  redistribute it  and/or modify it under --
13-- terms of the  GNU General Public License as published  by the Free Soft- --
14-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
15-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
17-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
18-- for  more details.  You should have  received  a copy of the GNU General --
19-- Public License  distributed with GNARL; see file COPYING.  If not, write --
20-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
21-- MA 02111-1307, USA.                                                      --
22--                                                                          --
23-- As a special exception,  if other files  instantiate  generics from this --
24-- unit, or you link  this unit with other files  to produce an executable, --
25-- this  unit  does not  by itself cause  the resulting  executable  to  be --
26-- covered  by the  GNU  General  Public  License.  This exception does not --
27-- however invalidate  any other reasons why  the executable file  might be --
28-- covered by the  GNU Public License.                                      --
29--                                                                          --
30-- GNARL was developed by the GNARL team at Florida State University.       --
31-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
32--                                                                          --
33------------------------------------------------------------------------------
34
35--  This is a POSIX-like version of this package.
36--  Note: this file can only be used for POSIX compliant systems.
37
38with Interfaces.C;
39--  used for int
40--           size_t
41--           unsigned
42
43with System.OS_Interface;
44--  used for various type, constant, and operations
45
46with System.Storage_Elements;
47--  used for To_Address
48--           Integer_Address
49
50with Unchecked_Conversion;
51
52package body System.Interrupt_Management.Operations is
53
54   use Interfaces.C;
55   use System.OS_Interface;
56
57   type Interrupt_Mask_Ptr is access all Interrupt_Mask;
58
59   function "+" is new
60     Unchecked_Conversion (Interrupt_Mask_Ptr, sigset_t_ptr);
61
62   ---------------------
63   -- Local Variables --
64   ---------------------
65
66   Initial_Action : array (Signal) of aliased struct_sigaction;
67
68   Default_Action : aliased struct_sigaction;
69
70   Ignore_Action  : aliased struct_sigaction;
71
72   ----------------------------
73   -- Thread_Block_Interrupt --
74   ----------------------------
75
76   procedure Thread_Block_Interrupt
77     (Interrupt : Interrupt_ID)
78   is
79      Result : Interfaces.C.int;
80      Mask   : aliased sigset_t;
81
82   begin
83      Result := sigemptyset (Mask'Access);
84      pragma Assert (Result = 0);
85      Result := sigaddset (Mask'Access, Signal (Interrupt));
86      pragma Assert (Result = 0);
87      Result := pthread_sigmask (SIG_BLOCK, Mask'Unchecked_Access, null);
88      pragma Assert (Result = 0);
89   end Thread_Block_Interrupt;
90
91   ------------------------------
92   -- Thread_Unblock_Interrupt --
93   ------------------------------
94
95   procedure Thread_Unblock_Interrupt
96     (Interrupt : Interrupt_ID)
97   is
98      Mask   : aliased sigset_t;
99      Result : Interfaces.C.int;
100
101   begin
102      Result := sigemptyset (Mask'Access);
103      pragma Assert (Result = 0);
104      Result := sigaddset (Mask'Access, Signal (Interrupt));
105      pragma Assert (Result = 0);
106      Result := pthread_sigmask (SIG_UNBLOCK, Mask'Unchecked_Access, null);
107      pragma Assert (Result = 0);
108   end Thread_Unblock_Interrupt;
109
110   ------------------------
111   -- Set_Interrupt_Mask --
112   ------------------------
113
114   procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
115      Result   : Interfaces.C.int;
116
117   begin
118      Result := pthread_sigmask
119        (SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), null);
120      pragma Assert (Result = 0);
121   end Set_Interrupt_Mask;
122
123   procedure Set_Interrupt_Mask
124     (Mask  : access Interrupt_Mask;
125      OMask : access Interrupt_Mask)
126   is
127      Result  : Interfaces.C.int;
128
129   begin
130      Result := pthread_sigmask
131        (SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), +Interrupt_Mask_Ptr (OMask));
132      pragma Assert (Result = 0);
133   end Set_Interrupt_Mask;
134
135   ------------------------
136   -- Get_Interrupt_Mask --
137   ------------------------
138
139   procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
140      Result : Interfaces.C.int;
141
142   begin
143      Result := pthread_sigmask
144        (SIG_SETMASK, null, +Interrupt_Mask_Ptr (Mask));
145      pragma Assert (Result = 0);
146   end Get_Interrupt_Mask;
147
148   --------------------
149   -- Interrupt_Wait --
150   --------------------
151
152   function Interrupt_Wait
153     (Mask : access Interrupt_Mask)
154      return Interrupt_ID
155   is
156      Result : Interfaces.C.int;
157      Sig    : aliased Signal;
158
159   begin
160      Result := sigwait (Mask, Sig'Access);
161
162      if Result /= 0 then
163         return 0;
164      end if;
165
166      return Interrupt_ID (Sig);
167   end Interrupt_Wait;
168
169   ----------------------------
170   -- Install_Default_Action --
171   ----------------------------
172
173   procedure Install_Default_Action (Interrupt : Interrupt_ID) is
174      Result : Interfaces.C.int;
175
176   begin
177      Result := sigaction
178        (Signal (Interrupt),
179         Initial_Action (Signal (Interrupt))'Access, null);
180      pragma Assert (Result = 0);
181   end Install_Default_Action;
182
183   ---------------------------
184   -- Install_Ignore_Action --
185   ---------------------------
186
187   procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
188      Result : Interfaces.C.int;
189
190   begin
191      Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null);
192      pragma Assert (Result = 0);
193   end Install_Ignore_Action;
194
195   -------------------------
196   -- Fill_Interrupt_Mask --
197   -------------------------
198
199   procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
200      Result : Interfaces.C.int;
201
202   begin
203      Result := sigfillset (Mask);
204      pragma Assert (Result = 0);
205   end Fill_Interrupt_Mask;
206
207   --------------------------
208   -- Empty_Interrupt_Mask --
209   --------------------------
210
211   procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
212      Result : Interfaces.C.int;
213
214   begin
215      Result := sigemptyset (Mask);
216      pragma Assert (Result = 0);
217   end Empty_Interrupt_Mask;
218
219   ---------------------------
220   -- Add_To_Interrupt_Mask --
221   ---------------------------
222
223   procedure Add_To_Interrupt_Mask
224     (Mask      : access Interrupt_Mask;
225      Interrupt : Interrupt_ID)
226   is
227      Result : Interfaces.C.int;
228
229   begin
230      Result := sigaddset (Mask, Signal (Interrupt));
231      pragma Assert (Result = 0);
232   end Add_To_Interrupt_Mask;
233
234   --------------------------------
235   -- Delete_From_Interrupt_Mask --
236   --------------------------------
237
238   procedure Delete_From_Interrupt_Mask
239     (Mask      : access Interrupt_Mask;
240      Interrupt : Interrupt_ID)
241   is
242      Result : Interfaces.C.int;
243
244   begin
245      Result := sigdelset (Mask, Signal (Interrupt));
246      pragma Assert (Result = 0);
247   end Delete_From_Interrupt_Mask;
248
249   ---------------
250   -- Is_Member --
251   ---------------
252
253   function Is_Member
254     (Mask      : access Interrupt_Mask;
255      Interrupt : Interrupt_ID) return Boolean
256   is
257      Result : Interfaces.C.int;
258
259   begin
260      Result := sigismember (Mask, Signal (Interrupt));
261      pragma Assert (Result = 0 or else Result = 1);
262      return Result = 1;
263   end Is_Member;
264
265   -------------------------
266   -- Copy_Interrupt_Mask --
267   -------------------------
268
269   procedure Copy_Interrupt_Mask
270     (X : out Interrupt_Mask;
271      Y : Interrupt_Mask)
272   is
273   begin
274      X := Y;
275   end Copy_Interrupt_Mask;
276
277   ----------------------------
278   -- Interrupt_Self_Process --
279   ----------------------------
280
281   procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
282      Result : Interfaces.C.int;
283
284   begin
285      Result := kill (getpid, Signal (Interrupt));
286      pragma Assert (Result = 0);
287   end Interrupt_Self_Process;
288
289begin
290
291   declare
292      mask    : aliased sigset_t;
293      allmask : aliased sigset_t;
294      Result  : Interfaces.C.int;
295
296   begin
297      for Sig in 1 .. Signal'Last loop
298         Result := sigaction
299           (Sig, null, Initial_Action (Sig)'Unchecked_Access);
300
301         --  ??? [assert 1]
302         --  we can't check Result here since sigaction will fail on
303         --  SIGKILL, SIGSTOP, and possibly other signals
304         --  pragma Assert (Result = 0);
305
306      end loop;
307
308      --  Setup the masks to be exported.
309
310      Result := sigemptyset (mask'Access);
311      pragma Assert (Result = 0);
312
313      Result := sigfillset (allmask'Access);
314      pragma Assert (Result = 0);
315
316      Default_Action.sa_flags   := 0;
317      Default_Action.sa_mask    := mask;
318      Default_Action.sa_handler :=
319        Storage_Elements.To_Address
320          (Storage_Elements.Integer_Address (SIG_DFL));
321
322      Ignore_Action.sa_flags   := 0;
323      Ignore_Action.sa_mask    := mask;
324      Ignore_Action.sa_handler :=
325        Storage_Elements.To_Address
326          (Storage_Elements.Integer_Address (SIG_IGN));
327
328      for J in Interrupt_ID loop
329
330         --  We need to check whether J is in Keep_Unmasked because
331         --  the index type of the Keep_Unmasked array is not always
332         --  Interrupt_ID; it may be a subtype of Interrupt_ID.
333
334         if J in Keep_Unmasked'Range and then Keep_Unmasked (J) then
335            Result := sigaddset (mask'Access, Signal (J));
336            pragma Assert (Result = 0);
337            Result := sigdelset (allmask'Access, Signal (J));
338            pragma Assert (Result = 0);
339         end if;
340      end loop;
341
342      --  The Keep_Unmasked signals should be unmasked for Environment task
343
344      Result := pthread_sigmask (SIG_UNBLOCK, mask'Unchecked_Access, null);
345      pragma Assert (Result = 0);
346
347      --  Get the signal mask of the Environment Task
348
349      Result := pthread_sigmask (SIG_SETMASK, null, mask'Unchecked_Access);
350      pragma Assert (Result = 0);
351
352      --  Setup the constants exported
353
354      Environment_Mask := Interrupt_Mask (mask);
355
356      All_Tasks_Mask := Interrupt_Mask (allmask);
357   end;
358
359end System.Interrupt_Management.Operations;
360