libguile/scmsigs.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007, 2008, 2009, 2011 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19
  20 \f
  21
  22 #ifdef HAVE_CONFIG_H
  23 #  include <config.h>
  24 #endif
  25
  26 #include <fcntl.h>      /* for mingw */
  27 #include <signal.h>
  28 #include <stdio.h>
  29 #include <errno.h>
  30
  31 #include "libguile/_scm.h"
  32
  33 #include "libguile/async.h"
  34 #include "libguile/eval.h"
  35 #include "libguile/root.h"
  36 #include "libguile/vectors.h"
  37 #include "libguile/threads.h"
  38
  39 #include "libguile/validate.h"
  40 #include "libguile/scmsigs.h"
  41
  42 #ifdef HAVE_PROCESS_H
  43 #include <process.h>    /* for mingw */
  44 #endif
  45
  46 #ifdef HAVE_UNISTD_H
  47 #include <unistd.h>
  48 #endif
  49
  50 #ifdef HAVE_SYS_TIME_H
  51 #include <sys/time.h>
  52 #endif
  53
  54 #ifdef __MINGW32__
  55 #include <windows.h>
  56 #define alarm(sec) (0)
  57 /* This weird comma expression is because Sleep is void under Windows. */
  58 #define sleep(sec) (Sleep ((sec) * 1000), 0)
  59 #define usleep(usec) (Sleep ((usec) / 1000), 0)
  60 #endif
  61
  62 #include <full-write.h>
  63
  64
  65 \f
  66
  67 /* SIGRETTYPE is the type that signal handlers return.  See <signal.h> */
  68
  69 #ifdef RETSIGTYPE
  70 # define SIGRETTYPE RETSIGTYPE
  71 #else
  72 # ifdef STDC_HEADERS
  73 #  define SIGRETTYPE void
  74 # else
  75 #  define SIGRETTYPE int
  76 # endif
  77 #endif
  78
  79 \f
  80
  81 /* take_signal is installed as the C signal handler whenever a Scheme
  82    handler is set.  When a signal arrives, take_signal will write a
  83    byte into the 'signal pipe'.  The 'signal delivery thread' will
  84    read this pipe and queue the appropriate asyncs.
  85
  86    When Guile is built without threads, the signal handler will
  87    install the async directly.
  88 */
  89
  90
  91 /* Scheme vectors with information about a signal.  signal_handlers
  92    contains the handler procedure or #f, signal_handler_asyncs
  93    contains the thunk to be marked as an async when the signal arrives
  94    (or the cell with the thunk in a singlethreaded Guile), and
  95    signal_handler_threads points to the thread that a signal should be
  96    delivered to.
  97 */
  98 static SCM *signal_handlers;
  99 static SCM signal_handler_asyncs;
 100 static SCM signal_handler_threads;
 101
 102 /* The signal delivery thread.  */
 103 scm_i_thread *scm_i_signal_delivery_thread = NULL;
 104
 105 /* The mutex held when launching the signal delivery thread.  */
 106 static scm_i_pthread_mutex_t signal_delivery_thread_mutex =
 107   SCM_I_PTHREAD_MUTEX_INITIALIZER;
 108
 109
 110 /* saves the original C handlers, when a new handler is installed.
 111    set to SIG_ERR if the original handler is installed.  */
 112 #ifdef HAVE_SIGACTION
 113 static struct sigaction orig_handlers[NSIG];
 114 #else
 115 static SIGRETTYPE (*orig_handlers[NSIG])(int);
 116 #endif
 117
 118 static SCM
 119 close_1 (SCM proc, SCM arg)
 120 {
 121   return scm_primitive_eval_x (scm_list_3 (scm_sym_lambda, SCM_EOL,
 122                                            scm_list_2 (proc, arg)));
 123 }
 124
 125 #if SCM_USE_PTHREAD_THREADS
 126 /* On mingw there's no notion of inter-process signals, only a raise()
 127    within the process itself which apparently invokes the registered handler
 128    immediately.  Not sure how well the following code will cope in this
 129    case.  It builds but it may not offer quite the same scheme-level
 130    semantics as on a proper system.  If you're relying on much in the way of
 131    signal handling on mingw you probably lose anyway.  */
 132
 133 static int signal_pipe[2];
 134
 135 static SIGRETTYPE
 136 take_signal (int signum)
 137 {
 138   char sigbyte = signum;
 139   full_write (signal_pipe[1], &sigbyte, 1);
 140
 141 #ifndef HAVE_SIGACTION
 142   signal (signum, take_signal);
 143 #endif
 144 }
 145
 146 struct signal_pipe_data
 147 {
 148   char sigbyte;
 149   ssize_t n;
 150   int err;
 151 };
 152
 153 #ifndef HAVE_GC_GET_SUSPEND_SIGNAL
 154 static int
 155 GC_get_suspend_signal (void)
 156 {
 157 #if defined SIG_SUSPEND
 158   return SIG_SUSPEND;
 159 #elif defined SIGPWR
 160   return SIGPWR;
 161 #elif defined SIGLOST
 162   return SIGLOST;
 163 #elif defined _SIGRTMIN
 164   return _SIGRTMIN + 6;
 165 #elif defined SIGRTMIN
 166   return SIGRTMIN + 6;
 167 #elif defined __GLIBC__
 168   return 32+6;
 169 #else
 170   return SIGUSR1;
 171 #endif
 172 }
 173 #endif /* HAVE_GC_GET_SUSPEND_SIGNAL */
 174
 175 static void*
 176 read_signal_pipe_data (void * data)
 177 {
 178   struct signal_pipe_data *sdata = data;
 179
 180   sdata->n = read (signal_pipe[0], &sdata->sigbyte, 1);
 181   sdata->err = errno;
 182
 183   return NULL;
 184 }
 185
 186 static SCM
 187 signal_delivery_thread (void *data)
 188 {
 189   int sig;
 190 #if HAVE_PTHREAD_SIGMASK  /* not on mingw, see notes above */
 191   sigset_t all_sigs;
 192   sigfillset (&all_sigs);
 193   /* On libgc 7.1 and earlier, GC_do_blocking doesn't actually do
 194      anything.  So in that case, libgc will want to suspend the signal
 195      delivery thread, so we need to allow it to do so by unmasking the
 196      suspend signal.  */
 197   sigdelset (&all_sigs, GC_get_suspend_signal ());
 198   scm_i_pthread_sigmask (SIG_SETMASK, &all_sigs, NULL);
 199 #endif
 200
 201   while (1)
 202     {
 203       struct signal_pipe_data sigdata;
 204
 205       scm_without_guile (read_signal_pipe_data, &sigdata);
 206
 207       sig = sigdata.sigbyte;
 208       if (sigdata.n == 1 && sig >= 0 && sig < NSIG)
 209         {
 210           SCM h, t;
 211
 212           h = SCM_SIMPLE_VECTOR_REF (signal_handler_asyncs, sig);
 213           t = SCM_SIMPLE_VECTOR_REF (signal_handler_threads, sig);
 214           if (scm_is_true (h))
 215             scm_system_async_mark_for_thread (h, t);
 216         }
 217       else if (sigdata.n == 0)
 218         break; /* the signal pipe was closed. */
 219       else if (sigdata.n < 0 && sigdata.err != EINTR)
 220         perror ("error in signal delivery thread");
 221     }
 222
 223   return SCM_UNSPECIFIED; /* not reached unless all other threads exited */
 224 }
 225
 226 static void
 227 start_signal_delivery_thread (void)
 228 {
 229   SCM signal_thread;
 230
 231   scm_i_pthread_mutex_lock (&signal_delivery_thread_mutex);
 232
 233   if (pipe2 (signal_pipe, O_CLOEXEC) != 0)
 234     scm_syserror (NULL);
 235   signal_thread = scm_spawn_thread (signal_delivery_thread, NULL,
 236                                     scm_handle_by_message,
 237                                     "signal delivery thread");
 238   scm_i_signal_delivery_thread = SCM_I_THREAD_DATA (signal_thread);
 239
 240   scm_i_pthread_mutex_unlock (&signal_delivery_thread_mutex);
 241 }
 242
 243 void
 244 scm_i_ensure_signal_delivery_thread ()
 245 {
 246   static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
 247   scm_i_pthread_once (&once, start_signal_delivery_thread);
 248 }
 249
 250 #else /* !SCM_USE_PTHREAD_THREADS */
 251
 252 static SIGRETTYPE
 253 take_signal (int signum)
 254 {
 255   SCM cell = SCM_SIMPLE_VECTOR_REF (signal_handler_asyncs, signum);
 256   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 257
 258   if (scm_is_false (SCM_CDR (cell)))
 259     {
 260       SCM_SETCDR (cell, t->active_asyncs);
 261       t->active_asyncs = cell;
 262       t->pending_asyncs = 1;
 263     }
 264
 265 #ifndef HAVE_SIGACTION
 266   signal (signum, take_signal);
 267 #endif
 268 }
 269
 270 void
 271 scm_i_ensure_signal_delivery_thread ()
 272 {
 273   return;
 274 }
 275
 276 #endif /* !SCM_USE_PTHREAD_THREADS */
 277
 278 static void
 279 install_handler (int signum, SCM thread, SCM handler)
 280 {
 281   if (scm_is_false (handler))
 282     {
 283       SCM_SIMPLE_VECTOR_SET (*signal_handlers, signum, SCM_BOOL_F);
 284       SCM_SIMPLE_VECTOR_SET (signal_handler_asyncs, signum, SCM_BOOL_F);
 285     }
 286   else
 287     {
 288       SCM async = close_1 (handler, scm_from_int (signum));
 289 #if !SCM_USE_PTHREAD_THREADS
 290       async = scm_cons (async, SCM_BOOL_F);
 291 #endif
 292       SCM_SIMPLE_VECTOR_SET (*signal_handlers, signum, handler);
 293       SCM_SIMPLE_VECTOR_SET (signal_handler_asyncs, signum, async);
 294     }
 295
 296   SCM_SIMPLE_VECTOR_SET (signal_handler_threads, signum, thread);
 297 }
 298
 299 SCM
 300 scm_sigaction (SCM signum, SCM handler, SCM flags)
 301 {
 302   return scm_sigaction_for_thread (signum, handler, flags, SCM_UNDEFINED);
 303 }
 304
 305 /* user interface for installation of signal handlers.  */
 306 SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
 307            (SCM signum, SCM handler, SCM flags, SCM thread),
 308             "Install or report the signal handler for a specified signal.\n\n"
 309             "@var{signum} is the signal number, which can be specified using the value\n"
 310             "of variables such as @code{SIGINT}.\n\n"
 311             "If @var{handler} is omitted, @code{sigaction} returns a pair: the\n"
 312             "CAR is the current\n"
 313             "signal hander, which will be either an integer with the value @code{SIG_DFL}\n"
 314             "(default action) or @code{SIG_IGN} (ignore), or the Scheme procedure which\n"
 315             "handles the signal, or @code{#f} if a non-Scheme procedure handles the\n"
 316             "signal.  The CDR contains the current @code{sigaction} flags for the handler.\n\n"
 317             "If @var{handler} is provided, it is installed as the new handler for\n"
 318             "@var{signum}.  @var{handler} can be a Scheme procedure taking one\n"
 319             "argument, or the value of @code{SIG_DFL} (default action) or\n"
 320             "@code{SIG_IGN} (ignore), or @code{#f} to restore whatever signal handler\n"
 321             "was installed before @code{sigaction} was first used.  When\n"
 322             "a scheme procedure has been specified, that procedure will run\n"
 323             "in the given @var{thread}.   When no thread has been given, the\n"
 324             "thread that made this call to @code{sigaction} is used.\n"
 325             "Flags can optionally be specified for the new handler.\n"
 326             "The return value is a pair with information about the\n"
 327             "old handler as described above.\n\n"
 328             "This interface does not provide access to the \"signal blocking\"\n"
 329             "facility.  Maybe this is not needed, since the thread support may\n"
 330             "provide solutions to the problem of consistent access to data\n"
 331             "structures.")
 332 #define FUNC_NAME s_scm_sigaction_for_thread
 333 {
 334   int csig;
 335 #ifdef HAVE_SIGACTION
 336   struct sigaction action;
 337   struct sigaction old_action;
 338 #else
 339   SIGRETTYPE (* chandler) (int) = SIG_DFL;
 340   SIGRETTYPE (* old_chandler) (int);
 341 #endif
 342   int query_only = 0;
 343   int save_handler = 0;
 344
 345   SCM old_handler;
 346
 347   csig = scm_to_signed_integer (signum, 0, NSIG-1);
 348
 349 #if defined(HAVE_SIGACTION)
 350   action.sa_flags = 0;
 351   if (!SCM_UNBNDP (flags))
 352     action.sa_flags |= scm_to_int (flags);
 353   sigemptyset (&action.sa_mask);
 354 #endif
 355
 356   if (SCM_UNBNDP (thread))
 357     thread = scm_current_thread ();
 358   else
 359     {
 360       SCM_VALIDATE_THREAD (4, thread);
 361       if (scm_c_thread_exited_p (thread))
 362         SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
 363     }
 364
 365   scm_i_ensure_signal_delivery_thread ();
 366
 367   SCM_CRITICAL_SECTION_START;
 368   old_handler = SCM_SIMPLE_VECTOR_REF (*signal_handlers, csig);
 369   if (SCM_UNBNDP (handler))
 370     query_only = 1;
 371   else if (scm_is_integer (handler))
 372     {
 373       long handler_int = scm_to_long (handler);
 374
 375       if (handler_int == (long) SIG_DFL || handler_int == (long) SIG_IGN)
 376         {
 377 #ifdef HAVE_SIGACTION
 378           action.sa_handler = (SIGRETTYPE (*) (int)) handler_int;
 379 #else
 380           chandler = (SIGRETTYPE (*) (int)) handler_int;
 381 #endif
 382           install_handler (csig, SCM_BOOL_F, SCM_BOOL_F);
 383         }
 384       else
 385         {
 386           SCM_CRITICAL_SECTION_END;
 387           SCM_OUT_OF_RANGE (2, handler);
 388         }
 389     }
 390   else if (scm_is_false (handler))
 391     {
 392       /* restore the default handler.  */
 393 #ifdef HAVE_SIGACTION
 394       if (orig_handlers[csig].sa_handler == SIG_ERR)
 395         query_only = 1;
 396       else
 397         {
 398           action = orig_handlers[csig];
 399           orig_handlers[csig].sa_handler = SIG_ERR;
 400           install_handler (csig, SCM_BOOL_F, SCM_BOOL_F);
 401         }
 402 #else
 403       if (orig_handlers[csig] == SIG_ERR)
 404         query_only = 1;
 405       else
 406         {
 407           chandler = orig_handlers[csig];
 408           orig_handlers[csig] = SIG_ERR;
 409           install_handler (csig, SCM_BOOL_F, SCM_BOOL_F);
 410         }
 411 #endif
 412     }
 413   else
 414     {
 415       SCM_VALIDATE_PROC (2, handler);
 416 #ifdef HAVE_SIGACTION
 417       action.sa_handler = take_signal;
 418       if (orig_handlers[csig].sa_handler == SIG_ERR)
 419         save_handler = 1;
 420 #else
 421       chandler = take_signal;
 422       if (orig_handlers[csig] == SIG_ERR)
 423         save_handler = 1;
 424 #endif
 425       install_handler (csig, thread, handler);
 426     }
 427
 428   /* XXX - Silently ignore setting handlers for `program error signals'
 429      because they can't currently be handled by Scheme code.
 430   */
 431
 432   switch (csig)
 433     {
 434       /* This list of program error signals is from the GNU Libc
 435          Reference Manual */
 436     case SIGFPE:
 437     case SIGILL:
 438     case SIGSEGV:
 439 #ifdef SIGBUS
 440     case SIGBUS:
 441 #endif
 442     case SIGABRT:
 443 #if defined(SIGIOT) && (SIGIOT != SIGABRT)
 444     case SIGIOT:
 445 #endif
 446 #ifdef SIGTRAP
 447     case SIGTRAP:
 448 #endif
 449 #ifdef SIGEMT
 450     case SIGEMT:
 451 #endif
 452 #ifdef SIGSYS
 453     case SIGSYS:
 454 #endif
 455       query_only = 1;
 456     }
 457
 458 #ifdef HAVE_SIGACTION
 459   if (query_only)
 460     {
 461       if (sigaction (csig, 0, &old_action) == -1)
 462         SCM_SYSERROR;
 463     }
 464   else
 465     {
 466       if (sigaction (csig, &action , &old_action) == -1)
 467         SCM_SYSERROR;
 468       if (save_handler)
 469         orig_handlers[csig] = old_action;
 470     }
 471   if (old_action.sa_handler == SIG_DFL || old_action.sa_handler == SIG_IGN)
 472     old_handler = scm_from_long ((long) old_action.sa_handler);
 473   SCM_CRITICAL_SECTION_END;
 474   return scm_cons (old_handler, scm_from_int (old_action.sa_flags));
 475 #else
 476   if (query_only)
 477     {
 478       if ((old_chandler = signal (csig, SIG_IGN)) == SIG_ERR)
 479         SCM_SYSERROR;
 480       if (signal (csig, old_chandler) == SIG_ERR)
 481         SCM_SYSERROR;
 482     }
 483   else
 484     {
 485       if ((old_chandler = signal (csig, chandler)) == SIG_ERR)
 486         SCM_SYSERROR;
 487       if (save_handler)
 488         orig_handlers[csig] = old_chandler;
 489     }
 490   if (old_chandler == SIG_DFL || old_chandler == SIG_IGN)
 491     old_handler = scm_from_long ((long) old_chandler);
 492   SCM_CRITICAL_SECTION_END;
 493   return scm_cons (old_handler, scm_from_int (0));
 494 #endif
 495 }
 496 #undef FUNC_NAME
 497
 498 SCM_DEFINE (scm_restore_signals, "restore-signals", 0, 0, 0,
 499             (void),
 500             "Return all signal handlers to the values they had before any call to\n"
 501             "@code{sigaction} was made.  The return value is unspecified.")
 502 #define FUNC_NAME s_scm_restore_signals
 503 {
 504   int i;
 505   for (i = 0; i < NSIG; i++)
 506     {
 507 #ifdef HAVE_SIGACTION
 508       if (orig_handlers[i].sa_handler != SIG_ERR)
 509         {
 510           if (sigaction (i, &orig_handlers[i], NULL) == -1)
 511             SCM_SYSERROR;
 512           orig_handlers[i].sa_handler = SIG_ERR;
 513           SCM_SIMPLE_VECTOR_SET (*signal_handlers, i, SCM_BOOL_F);
 514         }
 515 #else
 516       if (orig_handlers[i] != SIG_ERR)
 517         {
 518           if (signal (i, orig_handlers[i]) == SIG_ERR)
 519             SCM_SYSERROR;
 520           orig_handlers[i] = SIG_ERR;
 521           SCM_SIMPLE_VECTOR_SET (*signal_handlers, i, SCM_BOOL_F);
 522         }
 523 #endif
 524     }
 525   return SCM_UNSPECIFIED;
 526 }
 527 #undef FUNC_NAME
 528
 529 SCM_DEFINE (scm_alarm, "alarm", 1, 0, 0,
 530            (SCM i),
 531             "Set a timer to raise a @code{SIGALRM} signal after the specified\n"
 532             "number of seconds (an integer).  It's advisable to install a signal\n"
 533             "handler for\n"
 534             "@code{SIGALRM} beforehand, since the default action is to terminate\n"
 535             "the process.\n\n"
 536             "The return value indicates the time remaining for the previous alarm,\n"
 537             "if any.  The new value replaces the previous alarm.  If there was\n"
 538             "no previous alarm, the return value is zero.")
 539 #define FUNC_NAME s_scm_alarm
 540 {
 541   return scm_from_uint (alarm (scm_to_uint (i)));
 542 }
 543 #undef FUNC_NAME
 544
 545 #ifdef HAVE_SETITIMER
 546 SCM_DEFINE (scm_setitimer, "setitimer", 5, 0, 0,
 547            (SCM which_timer,
 548             SCM interval_seconds, SCM interval_microseconds,
 549             SCM value_seconds, SCM value_microseconds),
 550             "Set the timer specified by @var{which_timer} according to the given\n"
 551             "@var{interval_seconds}, @var{interval_microseconds},\n"
 552             "@var{value_seconds}, and @var{value_microseconds} values.\n"
 553             "\n"
 554             "Return information about the timer's previous setting."
 555             "\n"
 556             "Errors are handled as described in the guile info pages under ``POSIX\n"
 557             "Interface Conventions''.\n"
 558             "\n"
 559             "The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL},\n"
 560             "and @code{ITIMER_PROF}.\n"
 561             "\n"
 562             "The return value will be a list of two cons pairs representing the\n"
 563             "current state of the given timer.  The first pair is the seconds and\n"
 564             "microseconds of the timer @code{it_interval}, and the second pair is\n"
 565             "the seconds and microseconds of the timer @code{it_value}.")
 566 #define FUNC_NAME s_scm_setitimer
 567 {
 568   int rv;
 569   int c_which_timer;
 570   struct itimerval new_timer;
 571   struct itimerval old_timer;
 572
 573   c_which_timer = SCM_NUM2INT(1, which_timer);
 574   new_timer.it_interval.tv_sec = SCM_NUM2LONG(2, interval_seconds);
 575   new_timer.it_interval.tv_usec = SCM_NUM2LONG(3, interval_microseconds);
 576   new_timer.it_value.tv_sec = SCM_NUM2LONG(4, value_seconds);
 577   new_timer.it_value.tv_usec = SCM_NUM2LONG(5, value_microseconds);
 578
 579   SCM_SYSCALL(rv = setitimer(c_which_timer, &new_timer, &old_timer));
 580
 581   if(rv != 0)
 582     SCM_SYSERROR;
 583
 584   return scm_list_2 (scm_cons (scm_from_long (old_timer.it_interval.tv_sec),
 585                                scm_from_long (old_timer.it_interval.tv_usec)),
 586                      scm_cons (scm_from_long (old_timer.it_value.tv_sec),
 587                                scm_from_long (old_timer.it_value.tv_usec)));
 588 }
 589 #undef FUNC_NAME
 590 #endif /* HAVE_SETITIMER */
 591
 592 #ifdef HAVE_GETITIMER
 593 SCM_DEFINE (scm_getitimer, "getitimer", 1, 0, 0,
 594   (SCM which_timer),
 595             "Return information about the timer specified by @var{which_timer}"
 596             "\n"
 597             "Errors are handled as described in the guile info pages under ``POSIX\n"
 598             "Interface Conventions''.\n"
 599             "\n"
 600             "The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL},\n"
 601             "and @code{ITIMER_PROF}.\n"
 602             "\n"
 603             "The return value will be a list of two cons pairs representing the\n"
 604             "current state of the given timer.  The first pair is the seconds and\n"
 605             "microseconds of the timer @code{it_interval}, and the second pair is\n"
 606             "the seconds and microseconds of the timer @code{it_value}.")
 607 #define FUNC_NAME s_scm_getitimer
 608 {
 609   int rv;
 610   int c_which_timer;
 611   struct itimerval old_timer;
 612
 613   c_which_timer = SCM_NUM2INT(1, which_timer);
 614
 615   SCM_SYSCALL(rv = getitimer(c_which_timer, &old_timer));
 616
 617   if(rv != 0)
 618     SCM_SYSERROR;
 619
 620   return scm_list_2 (scm_cons (scm_from_long (old_timer.it_interval.tv_sec),
 621                                scm_from_long (old_timer.it_interval.tv_usec)),
 622                      scm_cons (scm_from_long (old_timer.it_value.tv_sec),
 623                                scm_from_long (old_timer.it_value.tv_usec)));
 624 }
 625 #undef FUNC_NAME
 626 #endif /* HAVE_GETITIMER */
 627
 628 #ifdef HAVE_PAUSE
 629 SCM_DEFINE (scm_pause, "pause", 0, 0, 0,
 630            (),
 631             "Pause the current process (thread?) until a signal arrives whose\n"
 632             "action is to either terminate the current process or invoke a\n"
 633             "handler procedure.  The return value is unspecified.")
 634 #define FUNC_NAME s_scm_pause
 635 {
 636   pause ();
 637   return SCM_UNSPECIFIED;
 638 }
 639 #undef FUNC_NAME
 640 #endif
 641
 642 SCM_DEFINE (scm_sleep, "sleep", 1, 0, 0,
 643            (SCM i),
 644             "Wait for the given number of seconds (an integer) or until a signal\n"
 645             "arrives.  The return value is zero if the time elapses or the number\n"
 646             "of seconds remaining otherwise.\n"
 647             "\n"
 648             "See also @code{usleep}.")
 649 #define FUNC_NAME s_scm_sleep
 650 {
 651   return scm_from_uint (scm_std_sleep (scm_to_uint (i)));
 652 }
 653 #undef FUNC_NAME
 654
 655 SCM_DEFINE (scm_usleep, "usleep", 1, 0, 0,
 656            (SCM i),
 657             "Wait the given period @var{usecs} microseconds (an integer).\n"
 658             "If a signal arrives the wait stops and the return value is the\n"
 659             "time remaining, in microseconds.  If the period elapses with no\n"
 660             "signal the return is zero.\n"
 661             "\n"
 662             "On most systems the process scheduler is not microsecond accurate and\n"
 663             "the actual period slept by @code{usleep} may be rounded to a system\n"
 664             "clock tick boundary.  Traditionally such ticks were 10 milliseconds\n"
 665             "apart, and that interval is often still used.\n"
 666             "\n"
 667             "See also @code{sleep}.")
 668 #define FUNC_NAME s_scm_usleep
 669 {
 670   return scm_from_ulong (scm_std_usleep (scm_to_ulong (i)));
 671 }
 672 #undef FUNC_NAME
 673
 674 SCM_DEFINE (scm_raise, "raise", 1, 0, 0,
 675            (SCM sig),
 676             "Sends a specified signal @var{sig} to the current process, where\n"
 677             "@var{sig} is as described for the kill procedure.")
 678 #define FUNC_NAME s_scm_raise
 679 {
 680   if (raise (scm_to_int (sig)) != 0)
 681     SCM_SYSERROR;
 682   return SCM_UNSPECIFIED;
 683 }
 684 #undef FUNC_NAME
 685
 686 \f
 687
 688 void
 689 scm_i_close_signal_pipe()
 690 {
 691   /* SIGNAL_DELIVERY_THREAD_MUTEX is only locked while the signal delivery
 692      thread is being launched.  The thread that calls this function is
 693      already holding the thread admin mutex, so if the delivery thread hasn't
 694      been launched at this point, it never will be before shutdown.  */
 695   scm_i_pthread_mutex_lock (&signal_delivery_thread_mutex);
 696
 697 #if SCM_USE_PTHREAD_THREADS
 698   if (scm_i_signal_delivery_thread != NULL)
 699     close (signal_pipe[1]);
 700 #endif
 701
 702   scm_i_pthread_mutex_unlock (&signal_delivery_thread_mutex);
 703 }
 704
 705 void
 706 scm_init_scmsigs ()
 707 {
 708   int i;
 709
 710   signal_handlers =
 711     SCM_VARIABLE_LOC (scm_c_define ("signal-handlers",
 712                                   scm_c_make_vector (NSIG, SCM_BOOL_F)));
 713   signal_handler_asyncs = scm_c_make_vector (NSIG, SCM_BOOL_F);
 714   signal_handler_threads = scm_c_make_vector (NSIG, SCM_BOOL_F);
 715
 716   for (i = 0; i < NSIG; i++)
 717     {
 718 #ifdef HAVE_SIGACTION
 719       orig_handlers[i].sa_handler = SIG_ERR;
 720
 721 #else
 722       orig_handlers[i] = SIG_ERR;
 723 #endif
 724     }
 725
 726   scm_c_define ("NSIG", scm_from_long (NSIG));
 727   scm_c_define ("SIG_IGN", scm_from_long ((long) SIG_IGN));
 728   scm_c_define ("SIG_DFL", scm_from_long ((long) SIG_DFL));
 729 #ifdef SA_NOCLDSTOP
 730   scm_c_define ("SA_NOCLDSTOP", scm_from_long (SA_NOCLDSTOP));
 731 #endif
 732 #ifdef SA_RESTART
 733   scm_c_define ("SA_RESTART", scm_from_long (SA_RESTART));
 734 #endif
 735
 736 #if defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER)
 737   /* Stuff needed by setitimer and getitimer. */
 738   scm_c_define ("ITIMER_REAL", scm_from_int (ITIMER_REAL));
 739   scm_c_define ("ITIMER_VIRTUAL", scm_from_int (ITIMER_VIRTUAL));
 740   scm_c_define ("ITIMER_PROF", scm_from_int (ITIMER_PROF));
 741 #endif /* defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER) */
 742
 743 #include "libguile/scmsigs.x"
 744 }
 745
 746
 747 /*
 748   Local Variables:
 749   c-file-style: "gnu"
 750   End:
 751 */