libguile/scmsigs.c

   1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include <signal.h>
  45 #include "_scm.h"
  46
  47 #include "async.h"
  48 #include "eval.h"
  49 #include "scmsigs.h"
  50
  51 #ifdef HAVE_UNISTD_H
  52 #include <unistd.h>
  53 #endif
  54
  55 /* The thread system has its own sleep and usleep functions.  */
  56 #ifndef USE_THREADS
  57
  58 #if defined(MISSING_SLEEP_DECL)
  59 int sleep ();
  60 #endif
  61
  62 #if defined(HAVE_USLEEP) && defined(MISSING_USLEEP_DECL)
  63 int usleep ();
  64 #endif
  65
  66 #endif
  67
  68 \f
  69
  70 #ifdef USE_MIT_PTHREADS
  71 #undef signal
  72 #define signal pthread_signal
  73 #endif
  74
  75 \f
  76
  77 /* SIGRETTYPE is the type that signal handlers return.  See <signal.h> */
  78
  79 #ifdef RETSIGTYPE
  80 # define SIGRETTYPE RETSIGTYPE
  81 #else
  82 # ifdef STDC_HEADERS
  83 #  define SIGRETTYPE void
  84 # else
  85 #  define SIGRETTYPE int
  86 # endif
  87 #endif
  88
  89 \f
  90
  91 /* take_signal is installed as the C signal handler whenever a Scheme
  92    handler is set.  when a signal arrives, take_signal marks the corresponding
  93    element of got_signal and marks signal_async.  the thunk in signal_async
  94    (sys_deliver_signals) will be run at the next opportunity, outside a
  95    critical section. sys_deliver_signals runs each Scheme handler for
  96    which got_signal is set.  */
  97
  98 static SCM signal_async;
  99
 100 static char got_signal[NSIG];
 101
 102 /* a Scheme vector of handler procedures.  */
 103 static SCM *signal_handlers;
 104
 105 /* saves the original C handlers, when a new handler is installed.
 106    set to SIG_ERR if the original handler is installed.  */
 107 #ifdef HAVE_SIGACTION
 108 static struct sigaction orig_handlers[NSIG];
 109 #else
 110 static SIGRETTYPE (*orig_handlers)(int)[NSIG];
 111 #endif
 112
 113 static SIGRETTYPE
 114 take_signal (int signum)
 115 {
 116   int saved_errno = errno;
 117   SCM ignored;
 118   if (!scm_ints_disabled)
 119     {
 120       /* For reasons of speed, the SCM_NEWCELL macro doesn't defer
 121          interrupts.  Instead, it first sets its argument to point to
 122          the first cell in the list, and then advances the freelist
 123          pointer to the next cell.  Now, if this procedure is
 124          interrupted, the only anomalous state possible is to have
 125          both SCM_NEWCELL's argument and scm_freelist pointing to the
 126          same cell.  To deal with this case, we always throw away the
 127          first cell in scm_freelist here.
 128
 129          At least, that's the theory.  I'm not convinced that that's
 130          the only anomalous path we need to worry about.  */
 131       SCM_NEWCELL (ignored);
 132     }
 133   got_signal[signum] = 1;
 134 #if HAVE_SIGACTION
 135   /* unblock the signal before the scheme handler gets to run, since
 136      it may use longjmp to escape (i.e., throw an exception).  */
 137   {
 138     sigset_t set;
 139     sigemptyset (&set);
 140     sigaddset (&set, signum);
 141     sigprocmask (SIG_UNBLOCK, &set, NULL);
 142   }
 143 #endif
 144   scm_system_async_mark (signal_async);
 145   errno = saved_errno;
 146 }
 147
 148 static SCM
 149 sys_deliver_signals (void)
 150 {
 151   int i;
 152
 153   for (i = 0; i < NSIG; i++)
 154     {
 155       if (got_signal[i])
 156         {
 157           /* The flag is reset before calling the handler in case the
 158              handler doesn't return.  If the handler doesn't return
 159              but leaves other signals flagged, they their handlers
 160              will be applied some time later when the async is checked
 161              again.  It would probably be better to reset the flags
 162              after doing a longjmp.  */
 163           got_signal[i] = 0;
 164 #ifndef HAVE_SIGACTION
 165           signal (i, take_signal);
 166 #endif
 167           scm_apply (SCM_VELTS (*signal_handlers)[i],
 168                      scm_listify (SCM_MAKINUM (i), SCM_UNDEFINED),
 169                      SCM_EOL);
 170         }
 171     }
 172   return SCM_UNSPECIFIED;
 173 }
 174
 175 /* user interface for installation of signal handlers.  */
 176 SCM_PROC(s_sigaction, "sigaction", 1, 2, 0, scm_sigaction);
 177 SCM
 178 scm_sigaction (SCM signum, SCM handler, SCM flags)
 179 {
 180   int csig;
 181 #ifdef HAVE_SIGACTION
 182   struct sigaction action;
 183   struct sigaction old_action;
 184 #else
 185   SIGRETTYPE (* chandler) (int);
 186   SIGRETTYPE (* old_chandler) (int);
 187 #endif
 188   int query_only = 0;
 189   int save_handler = 0;
 190   SCM *scheme_handlers = SCM_VELTS (*signal_handlers);
 191   SCM old_handler;
 192
 193   SCM_ASSERT (SCM_INUMP (signum), signum, SCM_ARG1, s_sigaction);
 194   csig = SCM_INUM (signum);
 195 #if defined(HAVE_SIGACTION)
 196 #if defined(SA_RESTART) && defined(HAVE_RESTARTABLE_SYSCALLS)
 197   /* don't allow SA_RESTART to be omitted if HAVE_RESTARTABLE_SYSCALLS
 198      is defined, since libguile would be likely to produce spurious
 199      EINTR errors.  */
 200   action.sa_flags = SA_RESTART;
 201 #else
 202   action.sa_flags = 0;
 203 #endif
 204   if (!SCM_UNBNDP (flags))
 205     {
 206       SCM_ASSERT (SCM_INUMP (flags), flags, SCM_ARG3, s_sigaction);
 207       action.sa_flags |= SCM_INUM (flags);
 208     }
 209   sigemptyset (&action.sa_mask);
 210 #endif
 211   SCM_DEFER_INTS;
 212   old_handler = scheme_handlers[csig];
 213   if (SCM_UNBNDP (handler))
 214     query_only = 1;
 215   else if (scm_integer_p (handler) == SCM_BOOL_T)
 216     {
 217       if (scm_num2long (handler, (char *) SCM_ARG2, s_sigaction)
 218           == (long) SIG_DFL
 219           || scm_num2long (handler, (char *) SCM_ARG2, s_sigaction)
 220           == (long) SIG_IGN)
 221         {
 222 #ifdef HAVE_SIGACTION
 223           action.sa_handler = (SIGRETTYPE (*) (int)) SCM_INUM (handler);
 224 #else
 225           chandler = (SIGRETTYPE (*) (int)) SCM_INUM (handler);
 226 #endif
 227           scheme_handlers[csig] = SCM_BOOL_F;
 228         }
 229       else
 230         scm_out_of_range (s_sigaction, handler);
 231     }
 232   else if (SCM_FALSEP (handler))
 233     {
 234       /* restore the default handler.  */
 235 #ifdef HAVE_SIGACTION
 236       if (orig_handlers[csig].sa_handler == SIG_ERR)
 237         query_only = 1;
 238       else
 239         {
 240           action = orig_handlers[csig];
 241           orig_handlers[csig].sa_handler = SIG_ERR;
 242           scheme_handlers[csig] = SCM_BOOL_F;
 243         }
 244 #else
 245       if (orig_handlers[csig] == SIG_ERR)
 246         query_only = 1;
 247       else
 248         {
 249           chandler = orig_handlers[csig];
 250           orig_handlers[csig] = SIG_ERR;
 251           scheme_handlers[csig] = SCM_BOOL_F;
 252         }
 253 #endif
 254     }
 255   else
 256     {
 257       SCM_ASSERT (SCM_NIMP (handler), handler, SCM_ARG2, s_sigaction);
 258 #ifdef HAVE_SIGACTION
 259       action.sa_handler = take_signal;
 260       if (orig_handlers[csig].sa_handler == SIG_ERR)
 261         save_handler = 1;
 262 #else
 263       chandler = take_signal;
 264       if (orig_handlers[csig] == SIG_ERR)
 265         save_handler = 1;
 266 #endif
 267       scheme_handlers[csig] = handler;
 268     }
 269 #ifdef HAVE_SIGACTION
 270   if (query_only)
 271     {
 272       if (sigaction (csig, 0, &old_action) == -1)
 273         scm_syserror (s_sigaction);
 274     }
 275   else
 276     {
 277       if (sigaction (csig, &action , &old_action) == -1)
 278         scm_syserror (s_sigaction);
 279       if (save_handler)
 280         orig_handlers[csig] = old_action;
 281     }
 282   if (old_action.sa_handler == SIG_DFL || old_action.sa_handler == SIG_IGN)
 283     old_handler = scm_long2num ((long) old_action.sa_handler);
 284   SCM_ALLOW_INTS;
 285   return scm_cons (old_handler, SCM_MAKINUM (old_action.sa_flags));
 286 #else
 287   if (query_only)
 288     {
 289       if ((old_chandler = signal (csig, SIG_IGN)) == SIG_ERR)
 290         scm_syserror (s_sigaction);
 291       if (signal (csig, old_chandler) == SIG_ERR)
 292         scm_syserror (s_sigaction);
 293     }
 294   else
 295     {
 296       if ((old_chandler = signal (csig, chandler)) == SIG_ERR)
 297         scm_syserror (s_sigaction);
 298       if (save_handler)
 299         orig_handlers[csig] = old_chandler;
 300     }
 301   if (old_chandler == SIG_DFL || old_chandler == SIG_IGN)
 302     old_handler = scm_long2num (old_chandler);
 303   SCM_ALLOW_INTS;
 304   return scm_cons (old_handler, SCM_MAKINUM (0));
 305 #endif
 306 }
 307
 308 SCM_PROC (s_restore_signals, "restore-signals", 0, 0, 0, scm_restore_signals);
 309 SCM
 310 scm_restore_signals (void)
 311 {
 312   int i;
 313   SCM *scheme_handlers = SCM_VELTS (*signal_handlers);
 314
 315   for (i = 0; i < NSIG; i++)
 316     {
 317 #ifdef HAVE_SIGACTION
 318       if (orig_handlers[i].sa_handler != SIG_ERR)
 319         {
 320           if (sigaction (i, &orig_handlers[i], NULL) == -1)
 321             scm_syserror (s_restore_signals);
 322           orig_handlers[i].sa_handler = SIG_ERR;
 323           scheme_handlers[i] = SCM_BOOL_F;
 324         }
 325 #else
 326       if (orig_handlers[i] != SIG_ERR)
 327         {
 328           if (signal (i, orig_handlers[i]) == SIG_ERR)
 329             scm_syserror (s_restore_signals);
 330           orig_handlers[i] = SIG_ERR;
 331           scheme_handlers[i] = SCM_BOOL_F;
 332         }
 333 #endif
 334     }
 335   return SCM_UNSPECIFIED;
 336 }
 337
 338 SCM_PROC(s_alarm, "alarm", 1, 0, 0, scm_alarm);
 339
 340 SCM
 341 scm_alarm (i)
 342      SCM i;
 343 {
 344   unsigned int j;
 345   SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_alarm);
 346   j = alarm (SCM_INUM (i));
 347   return SCM_MAKINUM (j);
 348 }
 349
 350 #ifdef HAVE_PAUSE
 351 SCM_PROC(s_pause, "pause", 0, 0, 0, scm_pause);
 352
 353 SCM
 354 scm_pause ()
 355 {
 356   pause ();
 357   return SCM_UNSPECIFIED;
 358 }
 359 #endif
 360
 361 SCM_PROC(s_sleep, "sleep", 1, 0, 0, scm_sleep);
 362
 363 SCM
 364 scm_sleep (i)
 365      SCM i;
 366 {
 367   unsigned long j;
 368   SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_sleep);
 369 #ifdef USE_THREADS
 370   j = scm_thread_sleep (SCM_INUM(i));
 371 #else
 372   j = sleep (SCM_INUM(i));
 373 #endif
 374   return scm_ulong2num (j);
 375 }
 376
 377 #if defined(USE_THREADS) || defined(HAVE_USLEEP)
 378 SCM_PROC(s_usleep, "usleep", 1, 0, 0, scm_usleep);
 379
 380 SCM
 381 scm_usleep (i)
 382      SCM i;
 383 {
 384   SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_usleep);
 385
 386 #ifdef USE_THREADS
 387   /* If we have threads, we use the thread system's sleep function.  */
 388   {
 389     unsigned long j = scm_thread_usleep (SCM_INUM (i));
 390     return scm_ulong2num (j);
 391   }
 392 #else
 393 #ifdef USLEEP_RETURNS_VOID
 394   usleep (SCM_INUM (i));
 395   return SCM_INUM0;
 396 #else
 397   {
 398     int j = usleep (SCM_INUM (i));
 399     return SCM_MAKINUM (j);
 400   }
 401 #endif
 402 #endif
 403 }
 404 #endif /* GUILE_ISELECT || HAVE_USLEEP */
 405
 406 SCM_PROC(s_raise, "raise", 1, 0, 0, scm_raise);
 407
 408 SCM
 409 scm_raise(sig)
 410      SCM sig;
 411 {
 412   SCM_ASSERT(SCM_INUMP(sig), sig, SCM_ARG1, s_raise);
 413   SCM_DEFER_INTS;
 414   if (kill (getpid (), (int) SCM_INUM (sig)) != 0)
 415     scm_syserror (s_raise);
 416   SCM_ALLOW_INTS;
 417   return SCM_UNSPECIFIED;
 418 }
 419
 420 \f
 421
 422 void
 423 scm_init_scmsigs ()
 424 {
 425   SCM thunk;
 426   int i;
 427
 428   signal_handlers =
 429     SCM_CDRLOC (scm_sysintern ("signal-handlers",
 430                                scm_make_vector (SCM_MAKINUM (NSIG),
 431                                                 SCM_BOOL_F)));
 432   thunk = scm_make_gsubr ("%deliver-signals", 0, 0, 0,
 433                           sys_deliver_signals);
 434   signal_async = scm_system_async (thunk);
 435
 436   for (i = 0; i < NSIG; i++)
 437     {
 438       got_signal[i] = 0;
 439 #ifdef HAVE_SIGACTION
 440       orig_handlers[i].sa_handler = SIG_ERR;
 441
 442 #else
 443       orig_handlers[i] = SIG_ERR;
 444 #endif
 445
 446 #ifdef HAVE_RESTARTABLE_SYSCALLS
 447       /* If HAVE_RESTARTABLE_SYSCALLS is defined, it's important that
 448          signals really are restartable.  don't rely on the same
 449          run-time that configure got: reset the default for every signal.
 450       */
 451 #ifdef HAVE_SIGINTERRUPT
 452       siginterrupt (i, 0);
 453 #elif defined(SA_RESTART)
 454       {
 455         struct sigaction action;
 456
 457         sigaction (i, NULL, &action);
 458         if (!(action.sa_flags & SA_RESTART))
 459           {
 460             action.sa_flags &= SA_RESTART;
 461             sigaction (i, &action, NULL);
 462           }
 463       }
 464 #endif
 465       /* if neither siginterrupt nor SA_RESTART are available we may
 466          as well assume that signals are always restartable.  */
 467 #endif
 468     }
 469
 470   scm_sysintern ("NSIG", scm_long2num (NSIG));
 471   scm_sysintern ("SIG_IGN", scm_long2num ((long) SIG_IGN));
 472   scm_sysintern ("SIG_DFL", scm_long2num ((long) SIG_DFL));
 473 #ifdef SA_NOCLDSTOP
 474   scm_sysintern ("SA_NOCLDSTOP", scm_long2num (SA_NOCLDSTOP));
 475 #endif
 476 #ifdef SA_RESTART
 477   scm_sysintern ("SA_RESTART", scm_long2num (SA_RESTART));
 478 #endif
 479
 480 #include "scmsigs.x"
 481 }
 482