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