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 --                                                                          --
  10 --             Copyright (C) 1997-1998, Florida State University            --
  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. It is --
  31 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
  32 -- State University (http://www.gnat.com).                                  --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 --  This is a POSIX-like version of this package.
  37 --  Note: this file can only be used for POSIX compliant systems.
  38
  39 with Interfaces.C;
  40 --  used for int
  41 --           size_t
  42 --           unsigned
  43
  44 with System.OS_Interface;
  45 --  used for various type, constant, and operations
  46
  47 with System.Storage_Elements;
  48 --  used for To_Address
  49 --           Integer_Address
  50
  51 with Unchecked_Conversion;
  52
  53 package body System.Interrupt_Management.Operations is
  54
  55    use Interfaces.C;
  56    use System.OS_Interface;
  57
  58    type Interrupt_Mask_Ptr is access all Interrupt_Mask;
  59
  60    function "+" is new
  61      Unchecked_Conversion (Interrupt_Mask_Ptr, sigset_t_ptr);
  62
  63    ---------------------
  64    -- Local Variables --
  65    ---------------------
  66
  67    Initial_Action : array (Signal) of aliased struct_sigaction;
  68
  69    Default_Action : aliased struct_sigaction;
  70
  71    Ignore_Action  : aliased struct_sigaction;
  72
  73    ----------------------------
  74    -- Thread_Block_Interrupt --
  75    ----------------------------
  76
  77    procedure Thread_Block_Interrupt
  78      (Interrupt : Interrupt_ID)
  79    is
  80       Result : Interfaces.C.int;
  81       Mask   : aliased sigset_t;
  82
  83    begin
  84       Result := sigemptyset (Mask'Access);
  85       pragma Assert (Result = 0);
  86       Result := sigaddset (Mask'Access, Signal (Interrupt));
  87       pragma Assert (Result = 0);
  88       Result := pthread_sigmask (SIG_BLOCK, Mask'Unchecked_Access, null);
  89       pragma Assert (Result = 0);
  90    end Thread_Block_Interrupt;
  91
  92    ------------------------------
  93    -- Thread_Unblock_Interrupt --
  94    ------------------------------
  95
  96    procedure Thread_Unblock_Interrupt
  97      (Interrupt : Interrupt_ID)
  98    is
  99       Mask   : aliased sigset_t;
 100       Result : Interfaces.C.int;
 101
 102    begin
 103       Result := sigemptyset (Mask'Access);
 104       pragma Assert (Result = 0);
 105       Result := sigaddset (Mask'Access, Signal (Interrupt));
 106       pragma Assert (Result = 0);
 107       Result := pthread_sigmask (SIG_UNBLOCK, Mask'Unchecked_Access, null);
 108       pragma Assert (Result = 0);
 109    end Thread_Unblock_Interrupt;
 110
 111    ------------------------
 112    -- Set_Interrupt_Mask --
 113    ------------------------
 114
 115    procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
 116       Result   : Interfaces.C.int;
 117
 118    begin
 119       Result := pthread_sigmask
 120         (SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), null);
 121       pragma Assert (Result = 0);
 122    end Set_Interrupt_Mask;
 123
 124    procedure Set_Interrupt_Mask
 125      (Mask  : access Interrupt_Mask;
 126       OMask : access Interrupt_Mask)
 127    is
 128       Result  : Interfaces.C.int;
 129
 130    begin
 131       Result := pthread_sigmask
 132         (SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), +Interrupt_Mask_Ptr (OMask));
 133       pragma Assert (Result = 0);
 134    end Set_Interrupt_Mask;
 135
 136    ------------------------
 137    -- Get_Interrupt_Mask --
 138    ------------------------
 139
 140    procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
 141       Result : Interfaces.C.int;
 142
 143    begin
 144       Result := pthread_sigmask
 145         (SIG_SETMASK, null, +Interrupt_Mask_Ptr (Mask));
 146       pragma Assert (Result = 0);
 147    end Get_Interrupt_Mask;
 148
 149    --------------------
 150    -- Interrupt_Wait --
 151    --------------------
 152
 153    function Interrupt_Wait
 154      (Mask : access Interrupt_Mask)
 155       return Interrupt_ID
 156    is
 157       Result : Interfaces.C.int;
 158       Sig    : aliased Signal;
 159
 160    begin
 161       Result := sigwait (Mask, Sig'Access);
 162
 163       if Result /= 0 then
 164          return 0;
 165       end if;
 166
 167       return Interrupt_ID (Sig);
 168    end Interrupt_Wait;
 169
 170    ----------------------------
 171    -- Install_Default_Action --
 172    ----------------------------
 173
 174    procedure Install_Default_Action (Interrupt : Interrupt_ID) is
 175       Result : Interfaces.C.int;
 176
 177    begin
 178       Result := sigaction
 179         (Signal (Interrupt),
 180          Initial_Action (Signal (Interrupt))'Access, null);
 181       pragma Assert (Result = 0);
 182    end Install_Default_Action;
 183
 184    ---------------------------
 185    -- Install_Ignore_Action --
 186    ---------------------------
 187
 188    procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
 189       Result : Interfaces.C.int;
 190
 191    begin
 192       Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null);
 193       pragma Assert (Result = 0);
 194    end Install_Ignore_Action;
 195
 196    -------------------------
 197    -- Fill_Interrupt_Mask --
 198    -------------------------
 199
 200    procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
 201       Result : Interfaces.C.int;
 202
 203    begin
 204       Result := sigfillset (Mask);
 205       pragma Assert (Result = 0);
 206    end Fill_Interrupt_Mask;
 207
 208    --------------------------
 209    -- Empty_Interrupt_Mask --
 210    --------------------------
 211
 212    procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
 213       Result : Interfaces.C.int;
 214
 215    begin
 216       Result := sigemptyset (Mask);
 217       pragma Assert (Result = 0);
 218    end Empty_Interrupt_Mask;
 219
 220    ---------------------------
 221    -- Add_To_Interrupt_Mask --
 222    ---------------------------
 223
 224    procedure Add_To_Interrupt_Mask
 225      (Mask      : access Interrupt_Mask;
 226       Interrupt : Interrupt_ID)
 227    is
 228       Result : Interfaces.C.int;
 229
 230    begin
 231       Result := sigaddset (Mask, Signal (Interrupt));
 232       pragma Assert (Result = 0);
 233    end Add_To_Interrupt_Mask;
 234
 235    --------------------------------
 236    -- Delete_From_Interrupt_Mask --
 237    --------------------------------
 238
 239    procedure Delete_From_Interrupt_Mask
 240      (Mask      : access Interrupt_Mask;
 241       Interrupt : Interrupt_ID)
 242    is
 243       Result : Interfaces.C.int;
 244
 245    begin
 246       Result := sigdelset (Mask, Signal (Interrupt));
 247       pragma Assert (Result = 0);
 248    end Delete_From_Interrupt_Mask;
 249
 250    ---------------
 251    -- Is_Member --
 252    ---------------
 253
 254    function Is_Member
 255      (Mask      : access Interrupt_Mask;
 256       Interrupt : Interrupt_ID) return Boolean
 257    is
 258       Result : Interfaces.C.int;
 259
 260    begin
 261       Result := sigismember (Mask, Signal (Interrupt));
 262       pragma Assert (Result = 0 or else Result = 1);
 263       return Result = 1;
 264    end Is_Member;
 265
 266    -------------------------
 267    -- Copy_Interrupt_Mask --
 268    -------------------------
 269
 270    procedure Copy_Interrupt_Mask
 271      (X : out Interrupt_Mask;
 272       Y : Interrupt_Mask)
 273    is
 274    begin
 275       X := Y;
 276    end Copy_Interrupt_Mask;
 277
 278    ----------------------------
 279    -- Interrupt_Self_Process --
 280    ----------------------------
 281
 282    procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
 283       Result : Interfaces.C.int;
 284
 285    begin
 286       Result := kill (getpid, Signal (Interrupt));
 287       pragma Assert (Result = 0);
 288    end Interrupt_Self_Process;
 289
 290 begin
 291
 292    declare
 293       mask    : aliased sigset_t;
 294       allmask : aliased sigset_t;
 295       Result  : Interfaces.C.int;
 296
 297    begin
 298       for Sig in 1 .. Signal'Last loop
 299          Result := sigaction
 300            (Sig, null, Initial_Action (Sig)'Unchecked_Access);
 301
 302          --  ??? [assert 1]
 303          --  we can't check Result here since sigaction will fail on
 304          --  SIGKILL, SIGSTOP, and possibly other signals
 305          --  pragma Assert (Result = 0);
 306
 307       end loop;
 308
 309       --  Setup the masks to be exported.
 310
 311       Result := sigemptyset (mask'Access);
 312       pragma Assert (Result = 0);
 313
 314       Result := sigfillset (allmask'Access);
 315       pragma Assert (Result = 0);
 316
 317       Default_Action.sa_flags   := 0;
 318       Default_Action.sa_mask    := mask;
 319       Default_Action.sa_handler :=
 320         Storage_Elements.To_Address
 321           (Storage_Elements.Integer_Address (SIG_DFL));
 322
 323       Ignore_Action.sa_flags   := 0;
 324       Ignore_Action.sa_mask    := mask;
 325       Ignore_Action.sa_handler :=
 326         Storage_Elements.To_Address
 327           (Storage_Elements.Integer_Address (SIG_IGN));
 328
 329       for I in Interrupt_ID loop
 330          if Keep_Unmasked (I) then
 331             Result := sigaddset (mask'Access, Signal (I));
 332             pragma Assert (Result = 0);
 333             Result := sigdelset (allmask'Access, Signal (I));
 334             pragma Assert (Result = 0);
 335          end if;
 336       end loop;
 337
 338       --  The Keep_Unmasked signals should be unmasked for Environment task
 339
 340       Result := pthread_sigmask (SIG_UNBLOCK, mask'Unchecked_Access, null);
 341       pragma Assert (Result = 0);
 342
 343       --  Get the signal mask of the Environment Task
 344
 345       Result := pthread_sigmask (SIG_SETMASK, null, mask'Unchecked_Access);
 346       pragma Assert (Result = 0);
 347
 348       --  Setup the constants exported
 349
 350       Environment_Mask := Interrupt_Mask (mask);
 351
 352       All_Tasks_Mask := Interrupt_Mask (allmask);
 353    end;
 354
 355 end System.Interrupt_Management.Operations;