gcc/ada/7sinmaop.adb

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