Fix unused warnings.
[official-gcc/graphite-test-results.git] / gcc / ada / s-inmaop-vms.adb
blobb99b155f38c8e3fc737426d419bde181623b948b
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
10 -- --
11 -- GNARL 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 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
32 -- This is a OpenVMS/Alpha version of this package
34 with System.OS_Interface;
35 with System.Aux_DEC;
36 with System.Parameters;
37 with System.Tasking;
38 with System.Tasking.Initialization;
39 with System.Task_Primitives;
40 with System.Task_Primitives.Operations;
41 with System.Task_Primitives.Operations.DEC;
43 with Ada.Unchecked_Conversion;
45 package body System.Interrupt_Management.Operations is
47 use System.OS_Interface;
48 use System.Parameters;
49 use System.Tasking;
50 use type unsigned_short;
52 function To_Address is
53 new Ada.Unchecked_Conversion
54 (Task_Id, System.Task_Primitives.Task_Address);
56 package POP renames System.Task_Primitives.Operations;
58 ----------------------------
59 -- Thread_Block_Interrupt --
60 ----------------------------
62 procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID) is
63 pragma Warnings (Off, Interrupt);
64 begin
65 null;
66 end Thread_Block_Interrupt;
68 ------------------------------
69 -- Thread_Unblock_Interrupt --
70 ------------------------------
72 procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID) is
73 pragma Warnings (Off, Interrupt);
74 begin
75 null;
76 end Thread_Unblock_Interrupt;
78 ------------------------
79 -- Set_Interrupt_Mask --
80 ------------------------
82 procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
83 pragma Warnings (Off, Mask);
84 begin
85 null;
86 end Set_Interrupt_Mask;
88 procedure Set_Interrupt_Mask
89 (Mask : access Interrupt_Mask;
90 OMask : access Interrupt_Mask)
92 pragma Warnings (Off, Mask);
93 pragma Warnings (Off, OMask);
94 begin
95 null;
96 end Set_Interrupt_Mask;
98 ------------------------
99 -- Get_Interrupt_Mask --
100 ------------------------
102 procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
103 pragma Warnings (Off, Mask);
104 begin
105 null;
106 end Get_Interrupt_Mask;
108 --------------------
109 -- Interrupt_Wait --
110 --------------------
112 function To_unsigned_long is new
113 Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, unsigned_long);
115 function Interrupt_Wait (Mask : access Interrupt_Mask)
116 return Interrupt_ID
118 Self_ID : constant Task_Id := Self;
119 Iosb : IO_Status_Block_Type := (0, 0, 0);
120 Status : Cond_Value_Type;
122 begin
124 -- A QIO read is registered. The system call returns immediately
125 -- after scheduling an AST to be fired when the operation
126 -- completes.
128 Sys_QIO
129 (Status => Status,
130 Chan => Rcv_Interrupt_Chan,
131 Func => IO_READVBLK,
132 Iosb => Iosb,
133 Astadr =>
134 POP.DEC.Interrupt_AST_Handler'Access,
135 Astprm => To_Address (Self_ID),
136 P1 => To_unsigned_long (Interrupt_Mailbox'Address),
137 P2 => Interrupt_ID'Size / 8);
139 pragma Assert ((Status and 1) = 1);
141 loop
143 -- Wait to be woken up. Could be that the AST has fired,
144 -- in which case the Iosb.Status variable will be non-zero,
145 -- or maybe the wait is being aborted.
147 POP.Sleep
148 (Self_ID,
149 System.Tasking.Interrupt_Server_Blocked_On_Event_Flag);
151 if Iosb.Status /= 0 then
152 if (Iosb.Status and 1) = 1
153 and then Mask (Signal (Interrupt_Mailbox))
154 then
155 return Interrupt_Mailbox;
156 else
157 return 0;
158 end if;
159 else
160 POP.Unlock (Self_ID);
162 if Single_Lock then
163 POP.Unlock_RTS;
164 end if;
166 System.Tasking.Initialization.Undefer_Abort (Self_ID);
167 System.Tasking.Initialization.Defer_Abort (Self_ID);
169 if Single_Lock then
170 POP.Lock_RTS;
171 end if;
173 POP.Write_Lock (Self_ID);
174 end if;
175 end loop;
176 end Interrupt_Wait;
178 ----------------------------
179 -- Install_Default_Action --
180 ----------------------------
182 procedure Install_Default_Action (Interrupt : Interrupt_ID) is
183 pragma Warnings (Off, Interrupt);
184 begin
185 null;
186 end Install_Default_Action;
188 ---------------------------
189 -- Install_Ignore_Action --
190 ---------------------------
192 procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
193 pragma Warnings (Off, Interrupt);
194 begin
195 null;
196 end Install_Ignore_Action;
198 -------------------------
199 -- Fill_Interrupt_Mask --
200 -------------------------
202 procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
203 begin
204 Mask.all := (others => True);
205 end Fill_Interrupt_Mask;
207 --------------------------
208 -- Empty_Interrupt_Mask --
209 --------------------------
211 procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
212 begin
213 Mask.all := (others => False);
214 end Empty_Interrupt_Mask;
216 ---------------------------
217 -- Add_To_Interrupt_Mask --
218 ---------------------------
220 procedure Add_To_Interrupt_Mask
221 (Mask : access Interrupt_Mask;
222 Interrupt : Interrupt_ID)
224 begin
225 Mask (Signal (Interrupt)) := True;
226 end Add_To_Interrupt_Mask;
228 --------------------------------
229 -- Delete_From_Interrupt_Mask --
230 --------------------------------
232 procedure Delete_From_Interrupt_Mask
233 (Mask : access Interrupt_Mask;
234 Interrupt : Interrupt_ID)
236 begin
237 Mask (Signal (Interrupt)) := False;
238 end Delete_From_Interrupt_Mask;
240 ---------------
241 -- Is_Member --
242 ---------------
244 function Is_Member
245 (Mask : access Interrupt_Mask;
246 Interrupt : Interrupt_ID) return Boolean
248 begin
249 return Mask (Signal (Interrupt));
250 end Is_Member;
252 -------------------------
253 -- Copy_Interrupt_Mask --
254 -------------------------
256 procedure Copy_Interrupt_Mask
257 (X : out Interrupt_Mask;
258 Y : Interrupt_Mask)
260 begin
261 X := Y;
262 end Copy_Interrupt_Mask;
264 ----------------------------
265 -- Interrupt_Self_Process --
266 ----------------------------
268 procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
269 Status : Cond_Value_Type;
270 begin
271 Sys_QIO
272 (Status => Status,
273 Chan => Snd_Interrupt_Chan,
274 Func => IO_WRITEVBLK,
275 P1 => To_unsigned_long (Interrupt'Address),
276 P2 => Interrupt_ID'Size / 8);
278 -- The following could use a comment ???
280 pragma Assert ((Status and 1) = 1);
281 end Interrupt_Self_Process;
283 --------------------------
284 -- Setup_Interrupt_Mask --
285 --------------------------
287 procedure Setup_Interrupt_Mask is
288 begin
289 null;
290 end Setup_Interrupt_Mask;
292 begin
293 Interrupt_Management.Initialize;
294 Environment_Mask := (others => False);
295 All_Tasks_Mask := (others => True);
297 for J in Interrupt_ID loop
298 if Keep_Unmasked (J) then
299 Environment_Mask (Signal (J)) := True;
300 All_Tasks_Mask (Signal (J)) := False;
301 end if;
302 end loop;
303 end System.Interrupt_Management.Operations;