libguile/scmsigs.c

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