libguile/scmsigs.c

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