1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
9 -- Copyright (C) 1991-1994, Florida State University --
10 -- Copyright (C) 1995-2003, Ada Core Technologies --
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. --
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. --
30 -- GNARL was developed by the GNARL team at Florida State University. --
31 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
33 ------------------------------------------------------------------------------
35 -- This is a POSIX-like version of this package.
36 -- Note: this file can only be used for POSIX compliant systems.
43 with System.OS_Interface;
44 -- used for various type, constant, and operations
46 with System.Storage_Elements;
47 -- used for To_Address
50 with Unchecked_Conversion;
52 package body System.Interrupt_Management.Operations is
55 use System.OS_Interface;
57 type Interrupt_Mask_Ptr is access all Interrupt_Mask;
60 Unchecked_Conversion (Interrupt_Mask_Ptr, sigset_t_ptr);
66 Initial_Action : array (Signal) of aliased struct_sigaction;
68 Default_Action : aliased struct_sigaction;
70 Ignore_Action : aliased struct_sigaction;
72 ----------------------------
73 -- Thread_Block_Interrupt --
74 ----------------------------
76 procedure Thread_Block_Interrupt
77 (Interrupt : Interrupt_ID)
79 Result : Interfaces.C.int;
80 Mask : aliased sigset_t;
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;
91 ------------------------------
92 -- Thread_Unblock_Interrupt --
93 ------------------------------
95 procedure Thread_Unblock_Interrupt
96 (Interrupt : Interrupt_ID)
98 Mask : aliased sigset_t;
99 Result : Interfaces.C.int;
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;
110 ------------------------
111 -- Set_Interrupt_Mask --
112 ------------------------
114 procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
115 Result : Interfaces.C.int;
118 Result := pthread_sigmask
119 (SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), null);
120 pragma Assert (Result = 0);
121 end Set_Interrupt_Mask;
123 procedure Set_Interrupt_Mask
124 (Mask : access Interrupt_Mask;
125 OMask : access Interrupt_Mask)
127 Result : Interfaces.C.int;
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;
135 ------------------------
136 -- Get_Interrupt_Mask --
137 ------------------------
139 procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
140 Result : Interfaces.C.int;
143 Result := pthread_sigmask
144 (SIG_SETMASK, null, +Interrupt_Mask_Ptr (Mask));
145 pragma Assert (Result = 0);
146 end Get_Interrupt_Mask;
152 function Interrupt_Wait
153 (Mask : access Interrupt_Mask)
156 Result : Interfaces.C.int;
157 Sig : aliased Signal;
160 Result := sigwait (Mask, Sig'Access);
166 return Interrupt_ID (Sig);
169 ----------------------------
170 -- Install_Default_Action --
171 ----------------------------
173 procedure Install_Default_Action (Interrupt : Interrupt_ID) is
174 Result : Interfaces.C.int;
179 Initial_Action (Signal (Interrupt))'Access, null);
180 pragma Assert (Result = 0);
181 end Install_Default_Action;
183 ---------------------------
184 -- Install_Ignore_Action --
185 ---------------------------
187 procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
188 Result : Interfaces.C.int;
191 Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null);
192 pragma Assert (Result = 0);
193 end Install_Ignore_Action;
195 -------------------------
196 -- Fill_Interrupt_Mask --
197 -------------------------
199 procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
200 Result : Interfaces.C.int;
203 Result := sigfillset (Mask);
204 pragma Assert (Result = 0);
205 end Fill_Interrupt_Mask;
207 --------------------------
208 -- Empty_Interrupt_Mask --
209 --------------------------
211 procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
212 Result : Interfaces.C.int;
215 Result := sigemptyset (Mask);
216 pragma Assert (Result = 0);
217 end Empty_Interrupt_Mask;
219 ---------------------------
220 -- Add_To_Interrupt_Mask --
221 ---------------------------
223 procedure Add_To_Interrupt_Mask
224 (Mask : access Interrupt_Mask;
225 Interrupt : Interrupt_ID)
227 Result : Interfaces.C.int;
230 Result := sigaddset (Mask, Signal (Interrupt));
231 pragma Assert (Result = 0);
232 end Add_To_Interrupt_Mask;
234 --------------------------------
235 -- Delete_From_Interrupt_Mask --
236 --------------------------------
238 procedure Delete_From_Interrupt_Mask
239 (Mask : access Interrupt_Mask;
240 Interrupt : Interrupt_ID)
242 Result : Interfaces.C.int;
245 Result := sigdelset (Mask, Signal (Interrupt));
246 pragma Assert (Result = 0);
247 end Delete_From_Interrupt_Mask;
254 (Mask : access Interrupt_Mask;
255 Interrupt : Interrupt_ID) return Boolean
257 Result : Interfaces.C.int;
260 Result := sigismember (Mask, Signal (Interrupt));
261 pragma Assert (Result = 0 or else Result = 1);
265 -------------------------
266 -- Copy_Interrupt_Mask --
267 -------------------------
269 procedure Copy_Interrupt_Mask
270 (X : out Interrupt_Mask;
275 end Copy_Interrupt_Mask;
277 ----------------------------
278 -- Interrupt_Self_Process --
279 ----------------------------
281 procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
282 Result : Interfaces.C.int;
285 Result := kill (getpid, Signal (Interrupt));
286 pragma Assert (Result = 0);
287 end Interrupt_Self_Process;
292 mask : aliased sigset_t;
293 allmask : aliased sigset_t;
294 Result : Interfaces.C.int;
297 for Sig in 1 .. Signal'Last loop
299 (Sig, null, Initial_Action (Sig)'Unchecked_Access);
302 -- we can't check Result here since sigaction will fail on
303 -- SIGKILL, SIGSTOP, and possibly other signals
304 -- pragma Assert (Result = 0);
308 -- Setup the masks to be exported.
310 Result := sigemptyset (mask'Access);
311 pragma Assert (Result = 0);
313 Result := sigfillset (allmask'Access);
314 pragma Assert (Result = 0);
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));
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));
328 for J in Interrupt_ID loop
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.
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);
342 -- The Keep_Unmasked signals should be unmasked for Environment task
344 Result := pthread_sigmask (SIG_UNBLOCK, mask'Unchecked_Access, null);
345 pragma Assert (Result = 0);
347 -- Get the signal mask of the Environment Task
349 Result := pthread_sigmask (SIG_SETMASK, null, mask'Unchecked_Access);
350 pragma Assert (Result = 0);
352 -- Setup the constants exported
354 Environment_Mask := Interrupt_Mask (mask);
356 All_Tasks_Mask := Interrupt_Mask (allmask);
359 end System.Interrupt_Management.Operations;