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
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <stdio.h>
  48 #include <signal.h>
  49 #include "libguile/_scm.h"
  50
  51 #include "libguile/async.h"
  52 #include "libguile/eval.h"
  53 #include "libguile/vectors.h"
  54
  55 #include "libguile/validate.h"
  56 #include "libguile/scmsigs.h"
  57
  58 #ifdef HAVE_UNISTD_H
  59 #include <unistd.h>
  60 #endif
  61
  62 /* The thread system has its own sleep and usleep functions.  */
  63 #ifndef USE_THREADS
  64
  65 #if defined(MISSING_SLEEP_DECL)
  66 int sleep ();
  67 #endif
  68
  69 #if defined(HAVE_USLEEP) && defined(MISSING_USLEEP_DECL)
  70 int usleep ();
  71 #endif
  72
  73 #endif
  74
  75 \f
  76
  77 #ifdef USE_MIT_PTHREADS
  78 #undef signal
  79 #define signal pthread_signal
  80 #endif
  81
  82 \f
  83
  84 /* SIGRETTYPE is the type that signal handlers return.  See <signal.h> */
  85
  86 #ifdef RETSIGTYPE
  87 # define SIGRETTYPE RETSIGTYPE
  88 #else
  89 # ifdef STDC_HEADERS
  90 #  define SIGRETTYPE void
  91 # else
  92 #  define SIGRETTYPE int
  93 # endif
  94 #endif
  95
  96 \f
  97
  98 /* take_signal is installed as the C signal handler whenever a Scheme
  99    handler is set.  when a signal arrives, take_signal marks the corresponding
 100    element of got_signal and marks signal_async.  the thunk in signal_async
 101    (sys_deliver_signals) will be run at the next opportunity, outside a
 102    critical section. sys_deliver_signals runs each Scheme handler for
 103    which got_signal is set.  */
 104
 105 static SCM signal_async;
 106
 107 static char got_signal[NSIG];
 108
 109 /* a Scheme vector of handler procedures.  */
 110 static SCM *signal_handlers;
 111
 112 /* saves the original C handlers, when a new handler is installed.
 113    set to SIG_ERR if the original handler is installed.  */
 114 #ifdef HAVE_SIGACTION
 115 static struct sigaction orig_handlers[NSIG];
 116 #else
 117 static SIGRETTYPE (*orig_handlers)(int)[NSIG];
 118 #endif
 119
 120 static SIGRETTYPE
 121 take_signal (int signum)
 122 {
 123   int saved_errno = errno;
 124   SCM ignored;
 125   if (!scm_ints_disabled)
 126     {
 127       /* For reasons of speed, the SCM_NEWCELL macro doesn't defer
 128          interrupts.  Instead, it first sets its argument to point to
 129          the first cell in the list, and then advances the freelist
 130          pointer to the next cell.  Now, if this procedure is
 131          interrupted, the only anomalous state possible is to have
 132          both SCM_NEWCELL's argument and scm_freelist pointing to the
 133          same cell.  To deal with this case, we always throw away the
 134          first cell in scm_freelist here.
 135
 136          At least, that's the theory.  I'm not convinced that that's
 137          the only anomalous path we need to worry about.  */
 138       SCM_NEWCELL (ignored);
 139     }
 140   got_signal[signum] = 1;
 141 #if HAVE_SIGACTION
 142   /* unblock the signal before the scheme handler gets to run, since
 143      it may use longjmp to escape (i.e., throw an exception).  */
 144   {
 145     sigset_t set;
 146     sigemptyset (&set);
 147     sigaddset (&set, signum);
 148     sigprocmask (SIG_UNBLOCK, &set, NULL);
 149   }
 150 #endif
 151   scm_system_async_mark (signal_async);
 152   errno = saved_errno;
 153 }
 154
 155 static SCM
 156 sys_deliver_signals (void)
 157 {
 158   int i;
 159
 160   for (i = 0; i < NSIG; i++)
 161     {
 162       if (got_signal[i])
 163         {
 164           /* The flag is reset before calling the handler in case the
 165              handler doesn't return.  If the handler doesn't return
 166              but leaves other signals flagged, they their handlers
 167              will be applied some time later when the async is checked
 168              again.  It would probably be better to reset the flags
 169              after doing a longjmp.  */
 170           got_signal[i] = 0;
 171 #ifndef HAVE_SIGACTION
 172           signal (i, take_signal);
 173 #endif
 174           scm_apply (SCM_VELTS (*signal_handlers)[i],
 175                      scm_listify (SCM_MAKINUM (i), SCM_UNDEFINED),
 176                      SCM_EOL);
 177         }
 178     }
 179   return SCM_UNSPECIFIED;
 180 }
 181
 182 /* user interface for installation of signal handlers.  */
 183 SCM_DEFINE (scm_sigaction, "sigaction", 1, 2, 0,
 184            (SCM signum, SCM handler, SCM flags),
 185             "Install or report the signal hander for a specified signal.\n\n"
 186             "@var{signum} is the signal number, which can be specified using the value\n"
 187             "of variables such as @code{SIGINT}.\n\n"
 188             "If @var{action} is omitted, @code{sigaction} returns a pair: the\n"
 189             "CAR is the current\n"
 190             "signal hander, which will be either an integer with the value @code{SIG_DFL}\n"
 191             "(default action) or @code{SIG_IGN} (ignore), or the Scheme procedure which\n"
 192             "handles the signal, or @code{#f} if a non-Scheme procedure handles the\n"
 193             "signal.  The CDR contains the current @code{sigaction} flags for the handler.\n\n"
 194             "If @var{action} is provided, it is installed as the new handler for\n"
 195             "@var{signum}.  @var{action} can be a Scheme procedure taking one\n"
 196             "argument, or the value of @code{SIG_DFL} (default action) or\n"
 197             "@code{SIG_IGN} (ignore), or @code{#f} to restore whatever signal handler\n"
 198             "was installed before @code{sigaction} was first used.  Flags can\n"
 199             "optionally be specified for the new handler (@code{SA_RESTART} will\n"
 200             "always be added if it's available and the system is using rstartable\n"
 201             "system calls.)  The return value is a pair with information about the\n"
 202             "old handler as described above.\n\n"
 203             "This interface does not provide access to the \"signal blocking\"\n"
 204             "facility.  Maybe this is not needed, since the thread support may\n"
 205             "provide solutions to the problem of consistent access to data\n"
 206             "structures.")
 207 #define FUNC_NAME s_scm_sigaction
 208 {
 209   int csig;
 210 #ifdef HAVE_SIGACTION
 211   struct sigaction action;
 212   struct sigaction old_action;
 213 #else
 214   SIGRETTYPE (* chandler) (int);
 215   SIGRETTYPE (* old_chandler) (int);
 216 #endif
 217   int query_only = 0;
 218   int save_handler = 0;
 219   SCM *scheme_handlers = SCM_VELTS (*signal_handlers);
 220   SCM old_handler;
 221
 222   SCM_VALIDATE_INUM_COPY (1,signum,csig);
 223 #if defined(HAVE_SIGACTION)
 224 #if defined(SA_RESTART) && defined(HAVE_RESTARTABLE_SYSCALLS)
 225   /* don't allow SA_RESTART to be omitted if HAVE_RESTARTABLE_SYSCALLS
 226      is defined, since libguile would be likely to produce spurious
 227      EINTR errors.  */
 228   action.sa_flags = SA_RESTART;
 229 #else
 230   action.sa_flags = 0;
 231 #endif
 232   if (!SCM_UNBNDP (flags))
 233     {
 234       SCM_VALIDATE_INUM (3,flags);
 235       action.sa_flags |= SCM_INUM (flags);
 236     }
 237   sigemptyset (&action.sa_mask);
 238 #endif
 239   SCM_DEFER_INTS;
 240   old_handler = scheme_handlers[csig];
 241   if (SCM_UNBNDP (handler))
 242     query_only = 1;
 243   else if (SCM_TRUE_P (scm_integer_p (handler)))
 244     {
 245       if (SCM_NUM2LONG (2,handler) == (long) SIG_DFL
 246           || SCM_NUM2LONG (2,handler) == (long) SIG_IGN)
 247         {
 248 #ifdef HAVE_SIGACTION
 249           action.sa_handler = (SIGRETTYPE (*) (int)) SCM_INUM (handler);
 250 #else
 251           chandler = (SIGRETTYPE (*) (int)) SCM_INUM (handler);
 252 #endif
 253           scheme_handlers[csig] = SCM_BOOL_F;
 254         }
 255       else
 256         SCM_OUT_OF_RANGE (2, handler);
 257     }
 258   else if (SCM_FALSEP (handler))
 259     {
 260       /* restore the default handler.  */
 261 #ifdef HAVE_SIGACTION
 262       if (orig_handlers[csig].sa_handler == SIG_ERR)
 263         query_only = 1;
 264       else
 265         {
 266           action = orig_handlers[csig];
 267           orig_handlers[csig].sa_handler = SIG_ERR;
 268           scheme_handlers[csig] = SCM_BOOL_F;
 269         }
 270 #else
 271       if (orig_handlers[csig] == SIG_ERR)
 272         query_only = 1;
 273       else
 274         {
 275           chandler = orig_handlers[csig];
 276           orig_handlers[csig] = SIG_ERR;
 277           scheme_handlers[csig] = SCM_BOOL_F;
 278         }
 279 #endif
 280     }
 281   else
 282     {
 283       SCM_VALIDATE_NIM (2,handler);
 284 #ifdef HAVE_SIGACTION
 285       action.sa_handler = take_signal;
 286       if (orig_handlers[csig].sa_handler == SIG_ERR)
 287         save_handler = 1;
 288 #else
 289       chandler = take_signal;
 290       if (orig_handlers[csig] == SIG_ERR)
 291         save_handler = 1;
 292 #endif
 293       scheme_handlers[csig] = handler;
 294     }
 295 #ifdef HAVE_SIGACTION
 296   if (query_only)
 297     {
 298       if (sigaction (csig, 0, &old_action) == -1)
 299         SCM_SYSERROR;
 300     }
 301   else
 302     {
 303       if (sigaction (csig, &action , &old_action) == -1)
 304         SCM_SYSERROR;
 305       if (save_handler)
 306         orig_handlers[csig] = old_action;
 307     }
 308   if (old_action.sa_handler == SIG_DFL || old_action.sa_handler == SIG_IGN)
 309     old_handler = scm_long2num ((long) old_action.sa_handler);
 310   SCM_ALLOW_INTS;
 311   return scm_cons (old_handler, SCM_MAKINUM (old_action.sa_flags));
 312 #else
 313   if (query_only)
 314     {
 315       if ((old_chandler = signal (csig, SIG_IGN)) == SIG_ERR)
 316         SCM_SYSERROR;
 317       if (signal (csig, old_chandler) == SIG_ERR)
 318         SCM_SYSERROR;
 319     }
 320   else
 321     {
 322       if ((old_chandler = signal (csig, chandler)) == SIG_ERR)
 323         SCM_SYSERROR;
 324       if (save_handler)
 325         orig_handlers[csig] = old_chandler;
 326     }
 327   if (old_chandler == SIG_DFL || old_chandler == SIG_IGN)
 328     old_handler = scm_long2num (old_chandler);
 329   SCM_ALLOW_INTS;
 330   return scm_cons (old_handler, SCM_MAKINUM (0));
 331 #endif
 332 }
 333 #undef FUNC_NAME
 334
 335 SCM_DEFINE (scm_restore_signals, "restore-signals", 0, 0, 0,
 336             (void),
 337             "Return all signal handlers to the values they had before any call to\n"
 338             "@code{sigaction} was made.  The return value is unspecified.")
 339 #define FUNC_NAME s_scm_restore_signals
 340 {
 341   int i;
 342   SCM *scheme_handlers = SCM_VELTS (*signal_handlers);
 343
 344   for (i = 0; i < NSIG; i++)
 345     {
 346 #ifdef HAVE_SIGACTION
 347       if (orig_handlers[i].sa_handler != SIG_ERR)
 348         {
 349           if (sigaction (i, &orig_handlers[i], NULL) == -1)
 350             SCM_SYSERROR;
 351           orig_handlers[i].sa_handler = SIG_ERR;
 352           scheme_handlers[i] = SCM_BOOL_F;
 353         }
 354 #else
 355       if (orig_handlers[i] != SIG_ERR)
 356         {
 357           if (signal (i, orig_handlers[i]) == SIG_ERR)
 358             SCM_SYSERROR;
 359           orig_handlers[i] = SIG_ERR;
 360           scheme_handlers[i] = SCM_BOOL_F;
 361         }
 362 #endif
 363     }
 364   return SCM_UNSPECIFIED;
 365 }
 366 #undef FUNC_NAME
 367
 368 SCM_DEFINE (scm_alarm, "alarm", 1, 0, 0,
 369            (SCM i),
 370             "Set a timer to raise a @code{SIGALRM} signal after the specified\n"
 371             "number of seconds (an integer).  It's advisable to install a signal\n"
 372             "handler for\n"
 373             "@code{SIGALRM} beforehand, since the default action is to terminate\n"
 374             "the process.\n\n"
 375             "The return value indicates the time remaining for the previous alarm,\n"
 376             "if any.  The new value replaces the previous alarm.  If there was\n"
 377             "no previous alarm, the return value is zero.")
 378 #define FUNC_NAME s_scm_alarm
 379 {
 380   unsigned int j;
 381   SCM_VALIDATE_INUM (1,i);
 382   j = alarm (SCM_INUM (i));
 383   return SCM_MAKINUM (j);
 384 }
 385 #undef FUNC_NAME
 386
 387 #ifdef HAVE_PAUSE
 388 SCM_DEFINE (scm_pause, "pause", 0, 0, 0,
 389            (),
 390             "Pause the current process (thread?) until a signal arrives whose\n"
 391             "action is to either terminate the current process or invoke a\n"
 392             "handler procedure.  The return value is unspecified.")
 393 #define FUNC_NAME s_scm_pause
 394 {
 395   pause ();
 396   return SCM_UNSPECIFIED;
 397 }
 398 #undef FUNC_NAME
 399 #endif
 400
 401 SCM_DEFINE (scm_sleep, "sleep", 1, 0, 0,
 402            (SCM i),
 403             "Wait for the given number of seconds (an integer) or until a signal\n"
 404             "arrives.  The return value is zero if the time elapses or the number\n"
 405             "of seconds remaining otherwise.")
 406 #define FUNC_NAME s_scm_sleep
 407 {
 408   unsigned long j;
 409   SCM_VALIDATE_INUM_MIN (1,i,0);
 410 #ifdef USE_THREADS
 411   j = scm_thread_sleep (SCM_INUM(i));
 412 #else
 413   j = sleep (SCM_INUM(i));
 414 #endif
 415   return scm_ulong2num (j);
 416 }
 417 #undef FUNC_NAME
 418
 419 #if defined(USE_THREADS) || defined(HAVE_USLEEP)
 420 SCM_DEFINE (scm_usleep, "usleep", 1, 0, 0,
 421            (SCM i),
 422             "Sleep for I microseconds.\n"
 423             "`usleep' is not available on all platforms.")
 424 #define FUNC_NAME s_scm_usleep
 425 {
 426   SCM_VALIDATE_INUM_MIN (1,i,0);
 427
 428 #ifdef USE_THREADS
 429   /* If we have threads, we use the thread system's sleep function.  */
 430   {
 431     unsigned long j = scm_thread_usleep (SCM_INUM (i));
 432     return scm_ulong2num (j);
 433   }
 434 #else
 435 #ifdef USLEEP_RETURNS_VOID
 436   usleep (SCM_INUM (i));
 437   return SCM_INUM0;
 438 #else
 439   {
 440     int j = usleep (SCM_INUM (i));
 441     return SCM_MAKINUM (j);
 442   }
 443 #endif
 444 #endif
 445 }
 446 #undef FUNC_NAME
 447 #endif /* GUILE_ISELECT || HAVE_USLEEP */
 448
 449 SCM_DEFINE (scm_raise, "raise", 1, 0, 0,
 450            (SCM sig),
 451             "\n"
 452             "Sends a specified signal @var{sig} to the current process, where\n"
 453             "@var{sig} is as described for the kill procedure.")
 454 #define FUNC_NAME s_scm_raise
 455 {
 456   SCM_VALIDATE_INUM (1,sig);
 457   SCM_DEFER_INTS;
 458   if (kill (getpid (), (int) SCM_INUM (sig)) != 0)
 459     SCM_SYSERROR;
 460   SCM_ALLOW_INTS;
 461   return SCM_UNSPECIFIED;
 462 }
 463 #undef FUNC_NAME
 464
 465 \f
 466
 467 void
 468 scm_init_scmsigs ()
 469 {
 470   SCM thunk;
 471   int i;
 472
 473   signal_handlers =
 474     SCM_CDRLOC (scm_sysintern ("signal-handlers",
 475                                scm_make_vector (SCM_MAKINUM (NSIG),
 476                                                 SCM_BOOL_F)));
 477   thunk = scm_make_gsubr ("%deliver-signals", 0, 0, 0,
 478                           sys_deliver_signals);
 479   signal_async = scm_system_async (thunk);
 480
 481   for (i = 0; i < NSIG; i++)
 482     {
 483       got_signal[i] = 0;
 484 #ifdef HAVE_SIGACTION
 485       orig_handlers[i].sa_handler = SIG_ERR;
 486
 487 #else
 488       orig_handlers[i] = SIG_ERR;
 489 #endif
 490
 491 #ifdef HAVE_RESTARTABLE_SYSCALLS
 492       /* If HAVE_RESTARTABLE_SYSCALLS is defined, it's important that
 493          signals really are restartable.  don't rely on the same
 494          run-time that configure got: reset the default for every signal.
 495       */
 496 #ifdef HAVE_SIGINTERRUPT
 497       siginterrupt (i, 0);
 498 #elif defined(SA_RESTART)
 499       {
 500         struct sigaction action;
 501
 502         sigaction (i, NULL, &action);
 503         if (!(action.sa_flags & SA_RESTART))
 504           {
 505             action.sa_flags &= SA_RESTART;
 506             sigaction (i, &action, NULL);
 507           }
 508       }
 509 #endif
 510       /* if neither siginterrupt nor SA_RESTART are available we may
 511          as well assume that signals are always restartable.  */
 512 #endif
 513     }
 514
 515   scm_sysintern ("NSIG", scm_long2num (NSIG));
 516   scm_sysintern ("SIG_IGN", scm_long2num ((long) SIG_IGN));
 517   scm_sysintern ("SIG_DFL", scm_long2num ((long) SIG_DFL));
 518 #ifdef SA_NOCLDSTOP
 519   scm_sysintern ("SA_NOCLDSTOP", scm_long2num (SA_NOCLDSTOP));
 520 #endif
 521 #ifdef SA_RESTART
 522   scm_sysintern ("SA_RESTART", scm_long2num (SA_RESTART));
 523 #endif
 524
 525 #include "libguile/scmsigs.x"
 526 }
 527
 528
 529 /*
 530   Local Variables:
 531   c-file-style: "gnu"
 532   End:
 533 */