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